Tezos

These are the sources Tezos imported to Coq by the current development version of coq-of-ocaml. Tezos is a crypto-currency with smart-contracts and an upgradable protocol. The market cap of Tezos is more than US $500 millions at the time of writting. Write at web [at] clarus [dot] me for more information. Work currently made at Nomadic Labs.



src/bin_attacker/attacker_main.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () = Attacker_minimal.main ()
src/bin_attacker/attacker_main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/bin_attacker/attacker_minimal.ml 142 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Format

include Logging.Make (struct
  let name = "attacker"
end)

module Proto = Client_embedded_proto_alpha

(* the genesis block and network *)
let genesis_block_hashed =
  Block_hash.of_b58check "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let network = Store.Net genesis_block_hashed

let network = Store.Chain_id.Id genesis_block_hashed

(* the bootstrap accounts and actions like signing to do with them *)
let source_account = List.nth Proto.Bootstrap_storage.accounts 4

let destination_account = List.nth Proto.Bootstrap_storage.accounts 0

let wrong_account = List.nth Proto.Bootstrap_storage.accounts 1

let another_account = List.nth Proto.Bootstrap_storage.accounts 2

let signed = Ed25519.append_signature source_account.secret_key

let signed_wrong = Ed25519.append_signature wrong_account.secret_key

(* forge a block from a list of operations *)
let block_forged ?prev ops =
  let from_int64 x =
    [ Bytes.of_string Proto.Constants_repr.version_number;
      Proto.Fitness_repr.int64_to_bytes x ]
  in
  let pred = match prev with None -> genesis_block_hashed | Some x -> x in
  let block ops =
    Store.Block_header.
      {
        chain_id = network;
        predecessor = pred;
        timestamp = Systime_os.now ();
        fitness = from_int64 1L;
        operations = ops;
      }
  in
  let open Proto in
  let generate_proof_of_work_nonce () =
    Rand.generate Proto.Alpha_context.Constants.proof_of_work_nonce_size
  in
  let generate_seed_nonce () =
    match
      Proto.Nonce_storage.of_bytes
      @@ Rand.generate Proto.Alpha_context.Constants.nonce_length
    with
    | Error _ ->
        assert false
    | Ok nonce ->
        nonce
  in
  Block_repr.forge_header
    (block ops)
    Block_repr.
      {
        baking_slot = {level = Raw_level_repr.of_int32_exn 1l; priority = 0l};
        seed_nonce_hash = Proto.Nonce_storage.hash (generate_seed_nonce ());
        proof_of_work_nonce = generate_proof_of_work_nonce ();
      }

(* forge a transaction *)
let tx_forged ?dest amount fee =
  let open Proto.Operation_repr in
  let open Proto.Tez_repr in
  let open Proto.Contract_repr in
  let trgt =
    match dest with None -> destination_account | Some dest -> dest
  in
  let src = source_account in
  let tx =
    Transaction
      {
        amount = of_cents_exn amount;
        parameters = None;
        destination = default_contract trgt.public_key_hash;
      }
  in
  let op =
    Sourced_operations
      (Manager_operations
         {
           source = default_contract src.public_key_hash;
           public_key = Some src.public_key;
           fee = of_cents_exn fee;
           counter = 1l;
           operations = [tx];
         })
  in
  forge {chain_id = network} op

(* forge a list of proposals, california eat your heart out *)
let props_forged period props =
  let open Proto.Operation_repr in
  let src = source_account in
  let props = Proposals {period; proposals = props} in
  let op =
    Sourced_operations
      (Delegate_operations {source = src.public_key; operations = [props]})
  in
  forge {chain_id = network} op

(* "forge" a ballot *)
let ballot_forged period prop vote =
  let open Proto.Operation_repr in
  let src = source_account in
  let ballot = Ballot {period; proposal = prop; ballot = vote} in
  let op =
    Sourced_operations
      (Delegate_operations {source = src.public_key; operations = [ballot]})
  in
  forge {chain_id = network} op

let identity = P2p_identity.generate Crypto_box.default_target

(* connect to the network, run an action and then disconnect *)
let try_action addr port action =
  let socket = Lwt_unix.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
  Lwt_unix.connect socket (Lwt_unix.ADDR_INET (uaddr, port))
  >>= fun () ->
  let io_sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 14) () in
  let conn = P2p_io_scheduler.register io_sched socket in
  P2p_connection.authenticate
    ~proof_of_work_target:Crypto_box.default_target
    ~incoming:false
    conn
    (addr, port)
    identity
    Distributed_db.Raw.supported_versions
  >>=? fun (_, auth_fd) ->
  P2p_connection.accept auth_fd Distributed_db.Raw.encoding
  >>= function
  | Error _ ->
      failwith "Connection rejected by peer."
  | Ok conn ->
      action conn
      >>=? fun () -> P2p_connection.close conn >>= fun () -> return_unit

let replicate n x =
  let rec replicate_acc acc n x =
    if n <= 0 then acc else replicate_acc (x :: acc) (n - 1) x
  in
  replicate_acc [] n x

let send conn (msg : Distributed_db.Message.t) =
  P2p_connection.write conn (P2p.Raw.Message msg)

let request_block_times block_hash n conn =
  let open Block_hash in
  lwt_log_notice "requesting %a block %d times" pp_short block_hash n
  >>= fun () ->
  let block_hashes = replicate n block_hash in
  send conn (Get_block_headers (network, block_hashes))

let request_op_times op_signed n conn =
  let open Operation_hash in
  let op_hash = hash_bytes [op_signed] in
  lwt_log_notice "sending %a transaction" pp_short op_hash
  >>= fun () ->
  send conn (Operation op_signed)
  >>=? fun () ->
  lwt_log_notice "requesting %a transaction %d times" pp_short op_hash n
  >>= fun () ->
  let op_hashes = replicate n op_hash in
  send conn (Get_operations op_hashes)

let send_block_size n conn =
  let bytes = Bytes.create n in
  let open Block_hash in
  lwt_log_notice
    "propagating fake %d byte block %a"
    n
    pp_short
    (hash_bytes [bytes])
  >>= fun () -> send conn (Block bytes)

let send_protocol_size n conn =
  let bytes = Bytes.create n in
  let open Protocol_hash in
  lwt_log_notice
    "propagating fake %d byte protocol %a"
    n
    pp_short
    (hash_bytes [bytes])
  >>= fun () -> send conn (Protocol bytes)

let send_operation_size n conn =
  let op_faked = Bytes.create n in
  let op_hashed = Operation_hash.hash_bytes [op_faked] in
  lwt_log_notice
    "propagating fake %d byte operation %a"
    n
    Operation_hash.pp_short
    op_hashed
  >>= fun () ->
  send conn (Operation op_faked)
  >>=? fun () ->
  let block = signed (block_forged [op_hashed]) in
  let block_hashed = Block_hash.hash_bytes [block] in
  lwt_log_notice
    "propagating block %a with operation"
    Block_hash.pp_short
    block_hashed
  >>= fun () -> send conn (Block block)

let send_operation_bad_signature () conn =
  let open Operation_hash in
  let signed_wrong_op = signed_wrong (tx_forged 5L 1L) in
  let hashed_wrong_op = hash_bytes [signed_wrong_op] in
  lwt_log_notice
    "propagating operation %a with wrong signature"
    pp_short
    hashed_wrong_op
  >>= fun () ->
  send conn (Operation signed_wrong_op)
  >>=? fun () ->
  let block = signed (block_forged [hashed_wrong_op]) in
  let block_hashed = Block_hash.hash_bytes [block] in
  lwt_log_notice
    "propagating block %a with operation"
    Block_hash.pp_short
    block_hashed
  >>= fun () -> send conn (Block block)

let send_block_bad_signature () conn =
  let open Block_hash in
  let signed_wrong_block = signed_wrong (block_forged []) in
  lwt_log_notice
    "propagating block %a with wrong signature"
    pp_short
    (hash_bytes [signed_wrong_block])
  >>= fun () -> send conn (Block signed_wrong_block)

let double_spend () conn =
  let spend account =
    let op_signed = signed (tx_forged ~dest:account 199999999L 1L) in
    let op_hashed = Operation_hash.hash_bytes [op_signed] in
    let block_signed = signed (block_forged [op_hashed]) in
    let block_hashed = Block_hash.hash_bytes [block_signed] in
    lwt_log_notice "propagating operation %a" Operation_hash.pp_short op_hashed
    >>= fun () ->
    send conn (Operation op_signed)
    >>=? fun () ->
    lwt_log_notice "propagating block %a" Block_hash.pp_short block_hashed
    >>= fun () -> send conn (Block block_signed)
  in
  spend destination_account >>=? fun () -> spend another_account

let long_chain n conn =
  lwt_log_notice "propogating %d blocks" n
  >>= fun () ->
  let prev_ref = ref genesis_block_hashed in
  let rec loop k =
    if k < 1 then return_unit
    else
      let block = signed (block_forged ~prev:!prev_ref []) in
      prev_ref := Block_hash.hash_bytes [block] ;
      send conn (Block block) >>=? fun () -> loop (k - 1)
  in
  loop n

let lots_transactions amount fee n conn =
  let signed_op = signed (tx_forged amount fee) in
  let rec loop k =
    if k < 1 then return_unit
    else send conn (Operation signed_op) >>=? fun () -> loop (k - 1)
  in
  let ops = replicate n (Operation_hash.hash_bytes [signed_op]) in
  let signed_block = signed (block_forged ops) in
  lwt_log_notice "propogating %d transactions" n
  >>= fun () ->
  loop n
  >>=? fun () ->
  lwt_log_notice
    "propagating block %a with wrong signature"
    Block_hash.pp_short
    (Block_hash.hash_bytes [signed_block])
  >>= fun () -> send conn (Block signed_block)

let main () =
  let addr = Ipaddr.V6.localhost in
  let port = 9732 in
  let run_action action = try_action addr port action in
  let run_cmd_unit lwt =
    Arg.Unit
      (fun () ->
        Lwt_main.run
          ( lwt ()
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error err ->
              lwt_log_error "Error: %a" pp_print_error err
              >>= fun () -> Lwt.return_unit ))
  in
  let run_cmd_int_suffix lwt =
    Arg.String
      (fun str ->
        let last = str.[String.length str - 1] in
        let init = String.sub str 0 (String.length str - 1) in
        let n =
          if last == 'k' || last == 'K' then int_of_string init * (1 lsl 10)
          else if last == 'm' || last == 'M' then
            int_of_string init * (1 lsl 20)
          else if last == 'g' || last == 'G' then
            int_of_string init * (1 lsl 30)
          else int_of_string str
        in
        Lwt_main.run
          ( lwt n
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error err ->
              lwt_log_error "Error: %a" pp_print_error err
              >>= fun () -> Lwt.return_unit ))
  in
  let cmds =
    [ ( "-1",
        run_cmd_int_suffix
          (run_action << request_block_times genesis_block_hashed),
        "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
      );
      ( "-2",
        run_cmd_int_suffix
          (run_action << request_op_times (signed (tx_forged 5L 1L))),
        "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
      );
      ( "-3",
        run_cmd_int_suffix (run_action << send_block_size),
        "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
         block." );
      ( "-4",
        run_cmd_int_suffix (run_action << send_operation_size),
        "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
         operation." );
      ( "-5",
        run_cmd_int_suffix (run_action << send_protocol_size),
        "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake \
         protocol." );
      ( "-6",
        run_cmd_unit (run_action << send_operation_bad_signature),
        "Attempt to propagate a transaction with a bad signature." );
      ( "-7",
        run_cmd_unit (run_action << send_block_bad_signature),
        "Attempt to propagate a block with a bad signature." );
      ( "-8",
        run_cmd_unit (run_action << double_spend),
        "Attempt to send the same transaction in two blocks" );
      ( "-9",
        run_cmd_int_suffix (run_action << long_chain),
        "[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks" );
      ( "-10",
        run_cmd_int_suffix (run_action << lots_transactions 0L 0L),
        "[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops" ) ]
  in
  Arg.parse cmds print_endline "Tezos Evil Client"
src/bin_attacker/attacker_minimal.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Format.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition genesis_block_hashed {A : Type} : A :=
  op_startypeminuserrorstar
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition network {A : Type} : A := op_startypeminuserrorstar.

Definition network {A : Type} : A := op_startypeminuserrorstar.

Definition source_account {A : Type} : A :=
  Stdlib.List.nth op_startypeminuserrorstar 4.

Definition destination_account {A : Type} : A :=
  Stdlib.List.nth op_startypeminuserrorstar 0.

Definition wrong_account {A : Type} : A :=
  Stdlib.List.nth op_startypeminuserrorstar 1.

Definition another_account {A : Type} : A :=
  Stdlib.List.nth op_startypeminuserrorstar 2.

Definition signed {A : Type} : A :=
  op_startypeminuserrorstar (secret_key source_account).

Definition signed_wrong {A : Type} : A :=
  op_startypeminuserrorstar (secret_key wrong_account).

Definition block_forged {A B C : Type} (prev : option A) (ops : B) : C :=
  let from_int64 {D : Type} (x : D) : list string :=
    cons (Stdlib.Bytes.of_string op_startypeminuserrorstar)
      (cons (op_startypeminuserrorstar x) []) in
  let pred :=
    match prev with
    | None => genesis_block_hashed
    | Some x => x
    end in
  let block {D E : Type} (ops : D) : E :=
    op_startypeminuserrorstar in
  let generate_proof_of_work_nonce {D : Type} (function_parameter : unit) : D :=
    let 'tt := function_parameter in
    op_startypeminuserrorstar op_startypeminuserrorstar in
  let generate_seed_nonce {D : Type} (function_parameter : unit) : D :=
    let 'tt := function_parameter in
    match
      apply op_startypeminuserrorstar
        (op_startypeminuserrorstar op_startypeminuserrorstar) with
    | Stdlib.Error _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Stdlib.Ok nonce => nonce
    end in
  op_startypeminuserrorstar (block ops) op_startypeminuserrorstar.

Definition tx_forged {A B C D : Type} (dest : option A) (amount : B) (fee : C)
  : D := op_startypeminuserrorstar.

Definition props_forged {A B C : Type} (period : A) (props : B) : C :=
  op_startypeminuserrorstar.

Definition ballot_forged {A B C D : Type} (period : A) (prop : B) (vote : C)
  : D := op_startypeminuserrorstar.

Definition identity {A : Type} : A :=
  op_startypeminuserrorstar op_startypeminuserrorstar.

Definition try_action {A B C D E : Type} (addr : A) (port : B) (action : C -> D)
  : E :=
  let socket :=
    op_startypeminuserrorstar op_startypeminuserrorstar
      op_startypeminuserrorstar 0 in
  let uaddr := op_startypeminuserrorstar addr in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar socket op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let io_sched := op_startypeminuserrorstar (Z.shiftl 1 14) tt in
      let conn := op_startypeminuserrorstar io_sched socket in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar op_startypeminuserrorstar false conn
          (addr, port) identity op_startypeminuserrorstar)
        (fun function_parameter =>
          let '(_, auth_fd) := function_parameter in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar auth_fd op_startypeminuserrorstar)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Error _ =>
                OCaml.Stdlib.failwith "Connection rejected by peer." % string
              | Stdlib.Ok conn =>
                op_startypeminuserrorstar (action conn)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_startypeminuserrorstar (op_startypeminuserrorstar conn)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar))
              end))).

Definition replicate {A : Type} (n : Z) (x : A) : list A :=
  let fix replicate_acc {B : Type} (acc : list B) (n : Z) (x : B) : list B :=
    if OCaml.Stdlib.le n 0 then
      acc
    else
      replicate_acc (cons x acc) (Z.sub n 1) x in
  replicate_acc [] n x.

Definition send {A B C : Type} (conn : A) (function_parameter : B) : C :=
  let '_ := function_parameter in
  op_startypeminuserrorstar conn op_startypeminuserrorstar.

Definition request_block_times {A B C D : Type}
  (block_hash : A) (n : B) (conn : C) : D := op_startypeminuserrorstar.

Definition request_op_times {A B C D : Type} (op_signed : A) (n : B) (conn : C)
  : D := op_startypeminuserrorstar.

Definition send_block_size {A B : Type} (n : Z) (conn : A) : B :=
  let bytes := Stdlib.Bytes.create n in
  op_startypeminuserrorstar.

Definition send_protocol_size {A B : Type} (n : Z) (conn : A) : B :=
  let bytes := Stdlib.Bytes.create n in
  op_startypeminuserrorstar.

Definition send_operation_size {A B : Type} (n : Z) (conn : A) : B :=
  let op_faked := Stdlib.Bytes.create n in
  let op_hashed := op_startypeminuserrorstar (cons op_faked []) in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar "propagating fake %d byte operation %a" % string
      n op_startypeminuserrorstar op_hashed)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let block := signed (block_forged None (cons op_hashed [])) in
          let block_hashed := op_startypeminuserrorstar (cons block []) in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar
              "propagating block %a with operation" % string
              op_startypeminuserrorstar block_hashed)
            (fun function_parameter =>
              let 'tt := function_parameter in
              send conn op_startypeminuserrorstar))).

Definition send_operation_bad_signature {A B : Type} (function_parameter : unit)
  : A -> B :=
  let 'tt := function_parameter in
  fun conn => op_startypeminuserrorstar.

Definition send_block_bad_signature {A B : Type} (function_parameter : unit)
  : A -> B :=
  let 'tt := function_parameter in
  fun conn => op_startypeminuserrorstar.

Definition double_spend {A B : Type} (function_parameter : unit) : A -> B :=
  let 'tt := function_parameter in
  fun conn =>
    let spend {C D : Type} (account : C) : D :=
      let op_signed :=
        signed
          (tx_forged (Some account)
            (* ❌ Constant of type int64 is converted to int *)
            199999999
            (* ❌ Constant of type int64 is converted to int *)
            1) in
      let op_hashed := op_startypeminuserrorstar (cons op_signed []) in
      let block_signed := signed (block_forged None (cons op_hashed [])) in
      let block_hashed := op_startypeminuserrorstar (cons block_signed []) in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar "propagating operation %a" % string
          op_startypeminuserrorstar op_hashed)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar "propagating block %a" % string
                  op_startypeminuserrorstar block_hashed)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  send conn op_startypeminuserrorstar))) in
    op_startypeminuserrorstar (spend destination_account)
      (fun function_parameter =>
        let 'tt := function_parameter in
        spend another_account).

Definition long_chain {A B : Type} (n : Z) (conn : A) : B :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar "propogating %d blocks" % string n)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let prev_ref := Stdlib.ref genesis_block_hashed in
      let fix loop {C : Type} (k : Z) : C :=
        if OCaml.Stdlib.lt k 1 then
          op_startypeminuserrorstar
        else
          let block :=
            signed (block_forged (Some (Stdlib.op_exclamation prev_ref)) []) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.op_coloneq prev_ref
              (op_startypeminuserrorstar (cons block [])) in
          op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              loop (Z.sub k 1)) in
      loop n).

Definition lots_transactions {A B C D : Type}
  (amount : A) (fee : B) (n : Z) (conn : C) : D :=
  let signed_op := signed (tx_forged None amount fee) in
  let fix loop {E : Type} (k : Z) : E :=
    if OCaml.Stdlib.lt k 1 then
      op_startypeminuserrorstar
    else
      op_startypeminuserrorstar (send conn op_startypeminuserrorstar)
        (fun function_parameter =>
          let 'tt := function_parameter in
          loop (Z.sub k 1)) in
  let ops := replicate n (op_startypeminuserrorstar (cons signed_op [])) in
  let signed_block := signed (block_forged None ops) in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar "propogating %d transactions" % string n)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar (loop n)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar
              "propagating block %a with wrong signature" % string
              op_startypeminuserrorstar
              (op_startypeminuserrorstar (cons signed_block [])))
            (fun function_parameter =>
              let 'tt := function_parameter in
              send conn op_startypeminuserrorstar))).

Definition main (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let addr := op_startypeminuserrorstar in
  let port := 9732 in
  let run_action {A B C : Type} (action : A -> B) : C :=
    try_action addr port action in
  let run_cmd_unit {A : Type} (lwt : unit -> A) : Stdlib.Arg.spec :=
    Stdlib.Arg.Unit
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_startypeminuserrorstar
          (op_startypeminuserrorstar (lwt tt)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok tt => op_startypeminuserrorstar
              | Stdlib.Error err =>
                op_startypeminuserrorstar
                  (op_startypeminuserrorstar "Error: %a" % string
                    op_startypeminuserrorstar err)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_startypeminuserrorstar)
              end))) in
  let run_cmd_int_suffix {A : Type} (lwt : Z -> A) : Stdlib.Arg.spec :=
    Stdlib.Arg.String
      (fun str =>
        let last := Stdlib.String.get str (Z.sub (OCaml.String.length str) 1) in
        let init := Stdlib.String.sub str 0 (Z.sub (OCaml.String.length str) 1)
          in
        let n :=
          if
            orb (Stdlib.op_eqeq last "k" % char)
              (Stdlib.op_eqeq last "K" % char) then
            Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 10)
          else
            if
              orb (Stdlib.op_eqeq last "m" % char)
                (Stdlib.op_eqeq last "M" % char) then
              Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 20)
            else
              if
                orb (Stdlib.op_eqeq last "g" % char)
                  (Stdlib.op_eqeq last "G" % char) then
                Z.mul (OCaml.Stdlib.int_of_string init) (Z.shiftl 1 30)
              else
                OCaml.Stdlib.int_of_string str in
        op_startypeminuserrorstar
          (op_startypeminuserrorstar (lwt n)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok tt => op_startypeminuserrorstar
              | Stdlib.Error err =>
                op_startypeminuserrorstar
                  (op_startypeminuserrorstar "Error: %a" % string
                    op_startypeminuserrorstar err)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_startypeminuserrorstar)
              end))) in
  let cmds :=
    cons
      ("-1" % string,
        (run_cmd_int_suffix
          (op_startypeminuserrorstar run_action
            (request_block_times genesis_block_hashed))),
        "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}blocks."
          % string)
      (cons
        ("-2" % string,
          (run_cmd_int_suffix
            (op_startypeminuserrorstar run_action
              (request_op_times
                (signed
                  (tx_forged None
                    (* ❌ Constant of type int64 is converted to int *)
                    5
                    (* ❌ Constant of type int64 is converted to int *)
                    1))))),
          "[N {,K,M,G}] Attempt to request to download N {,kilo,mega,giga}ops."
            % string)
        (cons
          ("-3" % string,
            (run_cmd_int_suffix
              (op_startypeminuserrorstar run_action send_block_size)),
            "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake block."
              % string)
          (cons
            ("-4" % string,
              (run_cmd_int_suffix
                (op_startypeminuserrorstar run_action send_operation_size)),
              "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake operation."
                % string)
            (cons
              ("-5" % string,
                (run_cmd_int_suffix
                  (op_startypeminuserrorstar run_action send_protocol_size)),
                "[N {,K,M,G}] Attempt to propagate an N {,kilo,mega,giga}byte fake protocol."
                  % string)
              (cons
                ("-6" % string,
                  (run_cmd_unit
                    (op_startypeminuserrorstar run_action
                      send_operation_bad_signature)),
                  "Attempt to propagate a transaction with a bad signature." %
                    string)
                (cons
                  ("-7" % string,
                    (run_cmd_unit
                      (op_startypeminuserrorstar run_action
                        send_block_bad_signature)),
                    "Attempt to propagate a block with a bad signature." %
                      string)
                  (cons
                    ("-8" % string,
                      (run_cmd_unit
                        (op_startypeminuserrorstar run_action double_spend)),
                      "Attempt to send the same transaction in two blocks" %
                        string)
                    (cons
                      ("-9" % string,
                        (run_cmd_int_suffix
                          (op_startypeminuserrorstar run_action long_chain)),
                        "[N {,K,M,G}] Attempt to send a chain of N {,kilo,mega,giga}blocks"
                          % string)
                      (cons
                        ("-10" % string,
                          (run_cmd_int_suffix
                            (op_startypeminuserrorstar run_action
                              (lots_transactions
                                (* ❌ Constant of type int64 is converted to int *)
                                0
                                (* ❌ Constant of type int64 is converted to int *)
                                0))),
                          "[N {,K,M,G}] Attempt to send N {,kilo,mega,giga}ops"
                            % string) []))))))))) in
  Arg.parse cmds OCaml.Stdlib.print_endline "Tezos Evil Client" % string.

src/bin_client/client_protocols_commands.ml 43 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let group =
  {Clic.name = "protocols"; title = "Commands for managing protocols"}

let proto_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
    t

let commands () =
  let open Clic in
  let check_dir _ dn =
    if Sys.is_directory dn then return dn
    else failwith "%s is not a directory" dn
  in
  let check_dir_parameter = parameter check_dir in
  [ command
      ~group
      ~desc:"List protocols known by the node."
      no_options
      (prefixes ["list"; "protocols"] stop)
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.Protocol.list cctxt
        >>=? fun protos ->
        Lwt_list.iter_s
          (fun ph -> cctxt#message "%a" Protocol_hash.pp ph)
          protos
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Inject a new protocol into the node."
      no_options
      ( prefixes ["inject"; "protocol"]
      @@ param
           ~name:"dir"
           ~desc:"directory containing the sources of a protocol"
           check_dir_parameter
      @@ stop )
      (fun () dirname (cctxt : #Client_context.full) ->
        Lwt.catch
          (fun () ->
            Tezos_base_unix.Protocol_files.read_dir dirname
            >>=? fun (_hash, proto) ->
            Shell_services.Injection.protocol cctxt proto
            >>= function
            | Ok hash ->
                cctxt#message
                  "Injected protocol %a successfully"
                  Protocol_hash.pp
                  hash
                >>= fun () -> return_unit
            | Error err ->
                cctxt#error
                  "Error while injecting protocol from %s: %a"
                  dirname
                  Error_monad.pp_print_error
                  err
                >>= fun () -> return_unit)
          (fun exn ->
            cctxt#error
              "Error while injecting protocol from %s: %a"
              dirname
              Error_monad.pp_print_error
              [Error_monad.Exn exn]
            >>= fun () -> return_unit));
    command
      ~group
      ~desc:"Dump a protocol from the node's record of protocol."
      no_options
      ( prefixes ["dump"; "protocol"]
      @@ proto_param ~name:"protocol hash" ~desc:""
      @@ stop )
      (fun () ph (cctxt : #Client_context.full) ->
        Shell_services.Protocol.contents cctxt ph
        >>=? fun proto ->
        Tezos_base_unix.Protocol_files.write_dir
          (Protocol_hash.to_short_b58check ph)
          ~hash:ph
          proto
        >>=? fun () ->
        cctxt#message "Extracted protocol %a" Protocol_hash.pp_short ph
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Fetch a protocol from the network."
      no_options
      ( prefixes ["fetch"; "protocol"]
      @@ proto_param ~name:"protocol hash" ~desc:""
      @@ stop )
      (fun () hash (cctxt : #Client_context.full) ->
        Shell_services.Protocol.fetch cctxt hash
        >>= function
        | Ok () ->
            cctxt#message
              "Protocol %a successfully fetched."
              Protocol_hash.pp_short
              hash
            >>= fun () -> return_unit
        | Error err ->
            cctxt#error
              "Error while fetching protocol: %a"
              Error_monad.pp_print_error
              err
            >>= fun () -> return_unit) ]
src/bin_client/client_protocols_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "protocols" % string;
    Clic.title := "Commands for managing protocols" % string |}.

Definition proto_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
  Clic.param name desc
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun str => Lwt._return (Protocol_hash.of_b58check str))) t.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let 'tt := function_parameter in
  let check_dir {J : Type} (function_parameter : J)
    : string -> Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let '_ := function_parameter in
    fun dn =>
      if Sys.is_directory dn then
        _return dn
      else
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " is not a directory" % string
                CamlinternalFormatBasics.End_of_format))
            "%s is not a directory" % string) dn in
  let check_dir_parameter := parameter None check_dir in
  cons
    (command (Some group) "List protocols known by the node." % string
      no_options
      (prefixes (cons "list" % string (cons "protocols" % string [])) stop)
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          op_gtgteqquestion (Shell_services.Protocol.list cctxt)
            (fun protos =>
              op_gtgteq
                (Lwt_list.iter_s
                  (fun ph =>
                    (* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      Protocol_hash.pp ph) protos)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit))))
    (cons
      (command (Some group) "Inject a new protocol into the node." % string
        no_options
        (apply (prefixes (cons "inject" % string (cons "protocol" % string [])))
          (apply
            (param "dir" % string
              "directory containing the sources of a protocol" % string
              check_dir_parameter) stop))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun dirname =>
            fun cctxt =>
              Lwt.catch
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (Tezos_base_unix.Protocol_files.read_dir dirname)
                    (fun function_parameter =>
                      let '(_hash, proto) := function_parameter in
                      op_gtgteq
                        (Shell_services.Injection.protocol cctxt None proto)
                        (fun function_parameter =>
                          match function_parameter with
                          | Stdlib.Ok hash =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Injected protocol " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " successfully" % string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "Injected protocol %a successfully" % string)
                                Protocol_hash.pp hash)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit)
                          | Stdlib.Error err =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Error while injecting protocol from " %
                                      string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.String_literal
                                        ": " % string
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format))))
                                  "Error while injecting protocol from %s: %a" %
                                    string) dirname Error_monad.pp_print_error
                                err)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit)
                          end)))
                (fun exn =>
                  op_gtgteq
                    ((* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Error while injecting protocol from " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              ": " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))
                        "Error while injecting protocol from %s: %a" % string)
                      dirname Error_monad.pp_print_error
                      (cons (Tezos_base__TzPervasives.Error_monad.Exn exn) []))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit))))
      (cons
        (command (Some group)
          "Dump a protocol from the node's record of protocol." % string
          no_options
          (apply (prefixes (cons "dump" % string (cons "protocol" % string [])))
            (apply (proto_param "protocol hash" % string "" % string) stop))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun ph =>
              fun cctxt =>
                op_gtgteqquestion (Shell_services.Protocol.contents cctxt ph)
                  (fun proto =>
                    op_gtgteqquestion
                      (Tezos_base_unix.Protocol_files.write_dir
                        (Protocol_hash.to_short_b58check ph) (Some ph) proto)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Extracted protocol " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))
                              "Extracted protocol %a" % string)
                            Protocol_hash.pp_short ph)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)))))
        (cons
          (command (Some group) "Fetch a protocol from the network." % string
            no_options
            (apply
              (prefixes (cons "fetch" % string (cons "protocol" % string [])))
              (apply (proto_param "protocol hash" % string "" % string) stop))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun hash =>
                fun cctxt =>
                  op_gtgteq (Shell_services.Protocol.fetch cctxt hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | Stdlib.Ok tt =>
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Protocol " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " successfully fetched." % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Protocol %a successfully fetched." % string)
                            Protocol_hash.pp_short hash)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)
                      | Stdlib.Error err =>
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Error while fetching protocol: " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))
                              "Error while fetching protocol: %a" % string)
                            Error_monad.pp_print_error err)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)
                      end))) []))).

src/bin_client/client_rpc_commands.ml 367 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Generic JSON RPC interface *)

open Lwt.Infix
open Clic
open Json_schema

(*-- Assisted, schema directed input fill in --------------------------------*)

exception Unsupported_construct

type input = {
  int : int -> int -> string option -> string list -> int Lwt.t;
  float : string option -> string list -> float Lwt.t;
  string : string option -> string list -> string Lwt.t;
  bool : string option -> string list -> bool Lwt.t;
  continue : string option -> string list -> bool Lwt.t;
  display : string -> unit Lwt.t;
}

(* generic JSON generation from a schema with callback for random or
   interactive filling *)
let fill_in ?(show_optionals = true) input schema =
  let rec element path {title; kind; _} =
    match kind with
    | Integer {minimum; maximum; _} ->
        let minimum =
          match minimum with
          | None ->
              min_int
          | Some (m, `Inclusive) ->
              int_of_float m
          | Some (m, `Exclusive) ->
              int_of_float m + 1
        in
        let maximum =
          match maximum with
          | None ->
              max_int
          | Some (m, `Inclusive) ->
              int_of_float m
          | Some (m, `Exclusive) ->
              int_of_float m - 1
        in
        input.int minimum maximum title path
        >>= fun i -> Lwt.return (`Float (float i))
    | Number _ ->
        input.float title path >>= fun f -> Lwt.return (`Float f)
    | Boolean ->
        input.bool title path >>= fun f -> Lwt.return (`Bool f)
    | String _ ->
        input.string title path >>= fun f -> Lwt.return (`String f)
    | Combine ((One_of | Any_of), elts) ->
        let nb = List.length elts in
        input.int 0 (nb - 1) (Some "Select the schema to follow") path
        >>= fun n -> element path (List.nth elts n)
    | Combine ((All_of | Not), _) ->
        Lwt.fail Unsupported_construct
    | Def_ref name ->
        Lwt.return (`String (Json_query.json_pointer_of_path name))
    | Id_ref _ | Ext_ref _ ->
        Lwt.fail Unsupported_construct
    | Array (elts, _) ->
        let rec fill_loop acc n ls =
          match ls with
          | [] ->
              Lwt.return acc
          | elt :: elts ->
              element (string_of_int n :: path) elt
              >>= fun json -> fill_loop (json :: acc) (succ n) elts
        in
        fill_loop [] 0 elts >>= fun acc -> Lwt.return (`A (List.rev acc))
    | Object {properties; _} ->
        let properties =
          if show_optionals then properties
          else List.filter (fun (_, _, b, _) -> b) properties
        in
        let rec fill_loop acc ls =
          match ls with
          | [] ->
              Lwt.return acc
          | (n, elt, _, _) :: elts ->
              element (n :: path) elt
              >>= fun json -> fill_loop ((n, json) :: acc) elts
        in
        fill_loop [] properties >>= fun acc -> Lwt.return (`O (List.rev acc))
    | Monomorphic_array (elt, specs) ->
        let rec fill_loop acc min n max =
          if n > max then Lwt.return acc
          else
            element (string_of_int n :: path) elt
            >>= fun json ->
            (if n < min then Lwt.return_true else input.continue title path)
            >>= function
            | true ->
                fill_loop (json :: acc) min (succ n) max
            | false ->
                Lwt.return (json :: acc)
        in
        let max = match specs.max_items with None -> max_int | Some m -> m in
        fill_loop [] specs.min_items 0 max
        >>= fun acc -> Lwt.return (`A (List.rev acc))
    | Any ->
        Lwt.fail Unsupported_construct
    | Dummy ->
        Lwt.fail Unsupported_construct
    | Null ->
        Lwt.return `Null
  in
  element [] (Json_schema.root schema)

let random_fill_in ?(show_optionals = true) schema =
  let display _ = Lwt.return_unit in
  let int min max _ _ =
    let max = Int64.of_int max and min = Int64.of_int min in
    let range = Int64.sub max min in
    let random_int64 = Int64.add (Random.int64 range) min in
    Lwt.return (Int64.to_int random_int64)
  in
  let string _title _ = Lwt.return "" in
  let float _ _ = Lwt.return (Random.float infinity) in
  let bool _ _ = Lwt.return (Random.int 2 = 0) in
  let continue _ _ = Lwt.return (Random.int 4 = 0) in
  Lwt.catch
    (fun () ->
      fill_in
        ~show_optionals
        {int; float; string; bool; display; continue}
        schema
      >>= fun json -> Lwt.return_ok json)
    (fun e ->
      let msg =
        Printf.sprintf "Fill-in failed %s\n%!" (Printexc.to_string e)
      in
      Lwt.return_error msg)

let editor_fill_in ?(show_optionals = true) schema =
  let tmp = Filename.temp_file "tezos_rpc_call_" ".json" in
  let rec init () =
    (* write a temp file with instructions *)
    random_fill_in ~show_optionals schema
    >>= function
    | Error msg ->
        Lwt.return_error msg
    | Ok json ->
        Lwt_io.(
          with_file ~mode:Output tmp (fun fp ->
              write_line fp (Data_encoding.Json.to_string json)))
        >>= fun () -> edit ()
  and edit () =
    (* launch the user's editor on it *)
    let editor_cmd =
      let ed =
        match (Sys.getenv_opt "EDITOR", Sys.getenv_opt "VISUAL") with
        | (Some ed, _) ->
            ed
        | (None, Some ed) ->
            ed
        | (None, None) when Sys.win32 ->
            (* TODO: I have no idea what I'm doing here *)
            "notepad.exe"
        | _ ->
            (* TODO: vi on MacOSX ? *)
            "nano"
      in
      Lwt_process.shell (ed ^ " " ^ tmp)
    in
    (Lwt_process.open_process_none editor_cmd)#status
    >>= function
    | Unix.WEXITED 0 ->
        reread () >>= fun json -> delete () >>= fun () -> Lwt.return json
    | Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x ->
        let msg = Printf.sprintf "FAILED %d \n%!" x in
        delete () >>= fun () -> Lwt.return_error msg
  and reread () =
    (* finally reread the file *)
    Lwt_io.(with_file ~mode:Input tmp (fun fp -> read fp))
    >>= fun text ->
    match Data_encoding.Json.from_string text with
    | Ok r ->
        Lwt.return_ok r
    | Error msg ->
        Lwt.return_error (Format.asprintf "bad input: %s" msg)
  and delete () =
    (* and delete the temp file *)
    Lwt_unix.unlink tmp
  in
  init ()

(*-- Nice list display ------------------------------------------------------*)

let rec count =
  let open RPC_description in
  function
  | Empty ->
      0
  | Dynamic _ ->
      1
  | Static {services; subdirs} ->
      let service = RPC_service.MethMap.cardinal services in
      let subdirs =
        match subdirs with
        | None ->
            0
        | Some (Suffixes subdirs) ->
            Resto.StringMap.fold (fun _ t r -> r + count t) subdirs 0
        | Some (Arg (_, subdir)) ->
            count subdir
      in
      service + subdirs

(*-- Commands ---------------------------------------------------------------*)

let list url (cctxt : #Client_context.full) =
  let args = String.split '/' url in
  RPC_description.describe cctxt ~recurse:true args
  >>=? fun tree ->
  let open RPC_description in
  let collected_args = ref [] in
  let collect arg =
    if not (arg.RPC_arg.descr <> None && List.mem arg !collected_args) then
      collected_args := arg :: !collected_args
  in
  let display_paragraph ppf description =
    Format.fprintf
      ppf
      "@,    @[%a@]"
      (fun ppf words -> List.iter (Format.fprintf ppf "%s@ ") words)
      (String.split ' ' description)
  in
  let display_arg ppf arg =
    match arg.RPC_arg.descr with
    | None ->
        Format.fprintf ppf "%s" arg.RPC_arg.name
    | Some descr ->
        Format.fprintf ppf "<%s>%a" arg.RPC_arg.name display_paragraph descr
  in
  let display_service ppf (_path, tpath, service) =
    Format.fprintf
      ppf
      "- %s /%s"
      (RPC_service.string_of_meth service.meth)
      (String.concat "/" tpath) ;
    match service.description with
    | None | Some "" ->
        ()
    | Some description ->
        display_paragraph ppf description
  in
  let display_services ppf (_path, tpath, services) =
    Format.pp_print_list
      (fun ppf (_, s) -> display_service ppf (_path, tpath, s))
      ppf
      (RPC_service.MethMap.bindings services)
  in
  let rec display ppf (path, tpath, tree) =
    match tree with
    | Dynamic description -> (
        Format.fprintf ppf "- /%s <dynamic>" (String.concat "/" tpath) ;
        match description with
        | None | Some "" ->
            ()
        | Some description ->
            display_paragraph ppf description )
    | Empty ->
        ()
    | Static {services; subdirs = None} ->
        display_services ppf (path, tpath, services)
    | Static {services; subdirs = Some (Suffixes subdirs)} -> (
      match
        ( RPC_service.MethMap.cardinal services,
          Resto.StringMap.bindings subdirs )
      with
      | (0, []) ->
          ()
      | (0, [(n, solo)]) ->
          display ppf (path @ [n], tpath @ [n], solo)
      | (_, items) when count tree >= 3 && path <> [] ->
          Format.fprintf
            ppf
            "@[<v 2>+ %s/@,%a@]"
            (String.concat "/" path)
            (display_list tpath)
            items
      | (_, items) when count tree >= 3 && path <> [] ->
          Format.fprintf
            ppf
            "@[<v 2>+ %s@,%a@,%a@]"
            (String.concat "/" path)
            display_services
            (path, tpath, services)
            (display_list tpath)
            items
      | (0, (n, t) :: items) ->
          Format.fprintf ppf "%a" display (path @ [n], tpath @ [n], t) ;
          List.iter
            (fun (n, t) ->
              Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
            items
      | (_, items) ->
          display_services ppf (path, tpath, services) ;
          List.iter
            (fun (n, t) ->
              Format.fprintf ppf "@,%a" display (path @ [n], tpath @ [n], t))
            items )
    | Static {services; subdirs = Some (Arg (arg, solo))}
      when RPC_service.MethMap.cardinal services = 0 ->
        collect arg ;
        let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
        display ppf (path @ [name], tpath @ [name], solo)
    | Static {services; subdirs = Some (Arg (arg, solo))} ->
        collect arg ;
        display_services ppf (path, tpath, services) ;
        Format.fprintf ppf "@," ;
        let name = Printf.sprintf "<%s>" arg.RPC_arg.name in
        display ppf (path @ [name], tpath @ [name], solo)
  and display_list tpath =
    Format.pp_print_list (fun ppf (n, t) -> display ppf ([n], tpath @ [n], t))
  in
  cctxt#message
    "@ @[<v 2>Available services:@ @ %a@]@."
    display
    (args, args, tree)
  >>= fun () ->
  if !collected_args <> [] then
    cctxt#message
      "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
      (Format.pp_print_list display_arg)
      !collected_args
    >>= fun () -> return_unit
  else return_unit

let schema meth url (cctxt : #Client_context.full) =
  let args = String.split '/' url in
  let open RPC_description in
  RPC_description.describe cctxt ~recurse:false args
  >>=? function
  | Static {services; _} -> (
    match RPC_service.MethMap.find_opt meth services with
    | None ->
        cctxt#message
          "No service found at this URL (but this is a valid prefix)\n%!"
        >>= fun () -> return_unit
    | Some {input = Some input; output; _} ->
        let json =
          `O
            [ ("input", Json_schema.to_json (fst input));
              ("output", Json_schema.to_json (fst output)) ]
        in
        cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
        >>= fun () -> return_unit
    | Some {input = None; output; _} ->
        let json = `O [("output", Json_schema.to_json (fst output))] in
        cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
        >>= fun () -> return_unit )
  | _ ->
      cctxt#message
        "No service found at this URL (but this is a valid prefix)\n%!"
      >>= fun () -> return_unit

let format binary meth url (cctxt : #Client_context.io_rpcs) =
  let args = String.split '/' url in
  let open RPC_description in
  let pp =
    if binary then fun ppf (_, schema) ->
      Data_encoding.Binary_schema.pp ppf schema
    else fun ppf (schema, _) -> Json_schema.pp ppf schema
  in
  RPC_description.describe cctxt ~recurse:false args
  >>=? function
  | Static {services; _} -> (
    match RPC_service.MethMap.find_opt meth services with
    | None ->
        cctxt#message
          "No service found at this URL (but this is a valid prefix)\n%!"
        >>= fun () -> return_unit
    | Some {input = Some input; output; _} ->
        cctxt#message
          "@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
          pp
          input
          pp
          output
        >>= fun () -> return_unit
    | Some {input = None; output; _} ->
        cctxt#message "@[<v 0>@[<v 2>Output format:@,%a@]@,@]" pp output
        >>= fun () -> return_unit )
  | _ ->
      cctxt#message
        "No service found at this URL (but this is a valid prefix)\n%!"
      >>= fun () -> return_unit

let fill_in ?(show_optionals = true) schema =
  let open Json_schema in
  match (root schema).kind with
  | Null ->
      Lwt.return_ok `Null
  | Any | Object {properties = []; _} ->
      Lwt.return_ok (`O [])
  | _ ->
      editor_fill_in ~show_optionals schema

let display_answer (cctxt : #Client_context.full) = function
  | `Ok json ->
      cctxt#message "%a" Json_repr.(pp (module Ezjsonm)) json
      >>= fun () -> return_unit
  | `Not_found _ ->
      cctxt#message "No service found at this URL\n%!"
      >>= fun () -> return_unit
  | `Error (Some json) ->
      cctxt#message
        "@[<v 2>Command failed :@[ %a@]@]@."
        (Format.pp_print_list Error_monad.pp)
        (Data_encoding.Json.destruct
           (Data_encoding.list Error_monad.error_encoding)
           json)
      >>= fun () -> return_unit
  | `Error None | `Unauthorized _ | `Forbidden _ | `Conflict _ ->
      cctxt#message "Unexpected server answer\n%!" >>= fun () -> return_unit

let call meth raw_url (cctxt : #Client_context.full) =
  let uri = Uri.of_string raw_url in
  let args = String.split_path (Uri.path uri) in
  RPC_description.describe cctxt ~recurse:false args
  >>=? function
  | Static {services; _} -> (
    match RPC_service.MethMap.find_opt meth services with
    | None ->
        cctxt#message
          "No service found at this URL with this method (but this is a valid \
           prefix)\n\
           %!"
        >>= fun () -> return_unit
    | Some {input = None; _} ->
        cctxt#generic_json_call meth uri >>=? display_answer cctxt
    | Some {input = Some input; _} -> (
        fill_in ~show_optionals:false (fst input)
        >>= function
        | Error msg ->
            cctxt#error "%s" msg >>= fun () -> return_unit
        | Ok json ->
            cctxt#generic_json_call meth ~body:json uri
            >>=? display_answer cctxt ) )
  | _ ->
      cctxt#message "No service found at this URL\n%!"
      >>= fun () -> return_unit

let call_with_json meth raw_url json (cctxt : #Client_context.full) =
  let uri = Uri.of_string raw_url in
  match Data_encoding.Json.from_string json with
  | exception Assert_failure _ ->
      (* Ref : https://github.com/mirage/ezjsonm/issues/31 *)
      cctxt#error
        "Failed to parse the provided json: unwrapped JSON value.\n%!"
  | Error err ->
      cctxt#error "Failed to parse the provided json: %s\n%!" err
  | Ok body ->
      cctxt#generic_json_call meth ~body uri >>=? display_answer cctxt

let call_with_file_or_json meth url maybe_file (cctxt : #Client_context.full) =
  ( match TzString.split ':' ~limit:1 maybe_file with
  | ["file"; filename] ->
      (* Mostly copied from src/client/client_aliases.ml *)
      Lwt.catch
        (fun () ->
          Lwt_io.(with_file ~mode:Input filename read)
          >>= fun content -> return content)
        (fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))
  | _ ->
      return maybe_file )
  >>=? fun json -> call_with_json meth url json cctxt

let meth_params ?(name = "HTTP method") ?(desc = "") params =
  param
    ~name
    ~desc
    (parameter
       ~autocomplete:(fun _ ->
         return
         @@ List.map String.lowercase_ascii
         @@ List.map Resto.string_of_meth
         @@ [`GET; `POST; `DELETE; `PUT; `PATCH])
       (fun _ name ->
         match Resto.meth_of_string (String.uppercase_ascii name) with
         | None ->
             failwith "Unknown HTTP method: %s" name
         | Some meth ->
             return meth))
    params

let group = {Clic.name = "rpc"; title = "Commands for the low level RPC layer"}

let commands =
  [ command
      ~group
      ~desc:
        "List RPCs under a given URL prefix.\n\
         Some parts of the RPC service hierarchy depend on parameters,\n\
         they are marked by a suffix `<dynamic>`.\n\
         You can list these sub-hierarchies by providing a concrete URL \
         prefix whose arguments are set to a valid value."
      no_options
      ( prefixes ["rpc"; "list"]
      @@ string ~name:"url" ~desc:"the URL prefix"
      @@ stop )
      (fun () -> list);
    command
      ~group
      ~desc:"Alias to `rpc list /`."
      no_options
      (prefixes ["rpc"; "list"] @@ stop)
      (fun () -> list "/");
    command
      ~group
      ~desc:"Get the input and output JSON schemas of an RPC."
      no_options
      ( prefixes ["rpc"; "schema"]
      @@ meth_params
      @@ string ~name:"url" ~desc:"the RPC url"
      @@ stop )
      (fun () -> schema);
    command
      ~group
      ~desc:"Get the humanoid readable input and output formats of an RPC."
      (args1 (switch ~doc:"Binary format" ~short:'b' ~long:"binary" ()))
      ( prefixes ["rpc"; "format"]
      @@ meth_params
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      format;
    command
      ~group
      ~desc:"Call an RPC with the GET method."
      no_options
      ( prefixes ["rpc"; "get"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `GET);
    command
      ~group
      ~desc:
        "Call an RPC with the POST method.\n\
         It invokes $EDITOR if input data is needed."
      no_options
      ( prefixes ["rpc"; "post"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `POST);
    command
      ~group
      ~desc:
        "Call an RPC with the POST method,  providing input data via the \
         command line."
      no_options
      ( prefixes ["rpc"; "post"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ prefix "with"
      @@ string
           ~name:"input"
           ~desc:
             "the raw JSON input to the RPC\n\
              For instance, use `{}` to send the empty document.\n\
              Alternatively, use `file:path` to read the JSON data from a file."
      @@ stop )
      (fun () -> call_with_file_or_json `POST);
    command
      ~group
      ~desc:
        "Call an RPC with the PUT method.\n\
         It invokes $EDITOR if input data is needed."
      no_options
      ( prefixes ["rpc"; "put"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `PUT);
    command
      ~group
      ~desc:
        "Call an RPC with the PUT method,  providing input data via the \
         command line."
      no_options
      ( prefixes ["rpc"; "put"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ prefix "with"
      @@ string
           ~name:"input"
           ~desc:
             "the raw JSON input to the RPC\n\
              For instance, use `{}` to send the empty document.\n\
              Alternatively, use `file:path` to read the JSON data from a file."
      @@ stop )
      (fun () -> call_with_file_or_json `PUT);
    command
      ~group
      ~desc:"Call an RPC with the DELETE method."
      no_options
      ( prefixes ["rpc"; "delete"]
      @@ string ~name:"url" ~desc:"the RPC URL"
      @@ stop )
      (fun () -> call `DELETE) ]
src/bin_client/client_rpc_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Clic.

Import Json_schema.

(* ❌ The definition of exceptions is not handled. *)
exception

Record input := {
  int : Z -> Z -> (option string) -> (list string) -> Lwt.t Z;
  float : (option string) -> (list string) -> Lwt.t Z;
  string : (option string) -> (list string) -> Lwt.t string;
  bool : (option string) -> (list string) -> Lwt.t bool;
  continue : (option string) -> (list string) -> Lwt.t bool;
  display : string -> Lwt.t unit }.

Definition fill_in (op_staroptstar : option bool)
  : input -> Json_schema.schema -> Lwt.t variant :=
  let show_optionals :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun input =>
    fun schema =>
      let fix element
        (path : list string) (function_parameter : Json_schema.element)
        : Lwt.t variant :=
        let '{| title := title; kind := kind |} := function_parameter in
        match kind with
        | Json_schema.Integer {| minimum := minimum; maximum := maximum |} =>
          let minimum :=
            match minimum with
            | None => Stdlib.min_int
            | Some (m, Inclusive) => Stdlib.int_of_float m
            | Some (m, Exclusive) => Z.add (Stdlib.int_of_float m) 1
            end in
          let maximum :=
            match maximum with
            | None => Stdlib.max_int
            | Some (m, Inclusive) => Stdlib.int_of_float m
            | Some (m, Exclusive) => Z.sub (Stdlib.int_of_float m) 1
            end in
          op_gtgteq ((int input) minimum maximum title path)
            (fun i =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.Number _ =>
          op_gtgteq ((float input) title path)
            (fun f =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.Boolean =>
          op_gtgteq ((bool input) title path)
            (fun f =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.String _ =>
          op_gtgteq ((string input) title path)
            (fun f =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.Combine (Json_schema.One_of | Json_schema.Any_of) elts =>
          let nb := List.length elts in
          op_gtgteq
            ((int input) 0 (Z.sub nb 1)
              (Some "Select the schema to follow" % string) path)
            (fun n => element path (List.nth elts n))
        | Json_schema.Combine (Json_schema.All_of | Json_schema.Not) _ =>
          Lwt.fail Unsupported_construct
        | Json_schema.Def_ref name =>
          Lwt._return
            (* ❌ Variants not supported *)
            variant
        | Json_schema.Id_ref _ | Json_schema.Ext_ref _ =>
          Lwt.fail Unsupported_construct
        | Json_schema.Array elts _ =>
          let fix fill_loop
            (acc : list variant) (n : Z) (ls : list Json_schema.element)
            : Lwt.t (list variant) :=
            match ls with
            | [] => Lwt._return acc
            | cons elt elts =>
              op_gtgteq (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
                (fun json => fill_loop (cons json acc) (Z.succ n) elts)
            end in
          op_gtgteq (fill_loop [] 0 elts)
            (fun acc =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.Object {| properties := properties |} =>
          let properties :=
            if show_optionals then
              properties
            else
              List.filter
                (fun function_parameter =>
                  let '(_, _, b, _) := function_parameter in
                  b) properties in
          let fix fill_loop {A B : Type}
            (acc : list (string * variant)) (ls :
            list (string * Json_schema.element * A * B))
            : Lwt.t (list (string * variant)) :=
            match ls with
            | [] => Lwt._return acc
            | cons (n, elt, _, _) elts =>
              op_gtgteq (element (cons n path) elt)
                (fun json => fill_loop (cons (n, json) acc) elts)
            end in
          op_gtgteq (fill_loop [] properties)
            (fun acc =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.Monomorphic_array elt specs =>
          let fix fill_loop (acc : list variant) (min : Z) (n : Z) (max : Z)
            : Lwt.t (list variant) :=
            if OCaml.Stdlib.gt n max then
              Lwt._return acc
            else
              op_gtgteq (element (cons (OCaml.Stdlib.string_of_int n) path) elt)
                (fun json =>
                  op_gtgteq
                    (if OCaml.Stdlib.lt n min then
                      Lwt.return_true
                    else
                      (continue input) title path)
                    (fun function_parameter =>
                      match function_parameter with
                      | true => fill_loop (cons json acc) min (Z.succ n) max
                      | false => Lwt._return (cons json acc)
                      end)) in
          let max :=
            match max_items specs with
            | None => Stdlib.max_int
            | Some m => m
            end in
          op_gtgteq (fill_loop [] (min_items specs) 0 max)
            (fun acc =>
              Lwt._return
                (* ❌ Variants not supported *)
                variant)
        | Json_schema.Any => Lwt.fail Unsupported_construct
        | Json_schema.Dummy => Lwt.fail Unsupported_construct
        | Json_schema.Null =>
          Lwt._return
            (* ❌ Variants not supported *)
            variant
        end in
      element [] (Json_schema.root schema).

Definition random_fill_in (op_staroptstar : option bool)
  : Json_schema.schema -> Lwt.t (Result.result variant string) :=
  let show_optionals :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun schema =>
    let display {A : Type} (function_parameter : A) : Lwt.t unit :=
      let '_ := function_parameter in
      Lwt.return_unit in
    let int {A B : Type} (min : Z) (max : Z) (function_parameter : A)
      : B -> Lwt.t Z :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        let max : int64 :=
          Int64.of_int max
        with min : int64 :=
          Int64.of_int min in
        let range := Int64.sub max min in
        let random_int64 := Int64.add (Random.int64 range) min in
        Lwt._return (Int64.to_int random_int64) in
    let string {A B : Type} (_title : A) (function_parameter : B)
      : Lwt.t string :=
      let '_ := function_parameter in
      Lwt._return "" % string in
    let float {A B : Type} (function_parameter : A) : B -> Lwt.t Z :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Lwt._return (Random.float Stdlib.infinity) in
    let bool {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Lwt._return (equiv_decb (Random.int 2) 0) in
    let continue {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        Lwt._return (equiv_decb (Random.int 4) 0) in
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (fill_in (Some show_optionals)
            {| int := Z; float := Z; string := string; bool := bool;
              continue := continue; display := display |} schema)
          (fun json => Lwt.return_ok json))
      (fun e =>
        let msg :=
          Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Fill-in failed " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal "010" % char
                    (CamlinternalFormatBasics.Flush
                      CamlinternalFormatBasics.End_of_format))))
              "Fill-in failed %s
%!" % string) (Printexc.to_string e) in
        Lwt.return_error msg).

Definition editor_fill_in (op_staroptstar : option bool)
  : Json_schema.schema ->
    Lwt.t
      (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
  let show_optionals :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun schema =>
    let tmp :=
      Filename.temp_file None "tezos_rpc_call_" % string ".json" % string in
    let fix init (function_parameter : unit)
      : Lwt.t
        (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
      let 'tt := function_parameter in
      op_gtgteq (random_fill_in (Some show_optionals) schema)
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Error msg => Lwt.return_error msg
          | Stdlib.Ok json =>
            op_gtgteq
              (with_file None None None Lwt_io.Output tmp
                (fun fp =>
                  write_line fp (Data_encoding.Json.to_string None None json)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                edit tt)
          end)
    with edit (function_parameter : unit)
      : Lwt.t
        (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
      let 'tt := function_parameter in
      let editor_cmd :=
        let ed :=
          match
            ((Sys.getenv_opt "EDITOR" % string),
              (Sys.getenv_opt "VISUAL" % string)) with
          | (Some ed, _) => ed
          | (None, Some ed) => ed
          | (None, None) => "notepad.exe" % string
          | _ => "nano" % string
          end in
        Lwt_process.shell (String.append ed (String.append " " % string tmp)) in
      op_gtgteq
        (* ❌ Sending method message is not handled *)
        send
        (fun function_parameter =>
          match function_parameter with
          | Unix.WEXITED 0 =>
            op_gtgteq (reread tt)
              (fun json =>
                op_gtgteq (delete tt)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt._return json))
          | Unix.WSIGNALED x | Unix.WSTOPPED x | Unix.WEXITED x =>
            let msg :=
              Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "FAILED " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal " 
" % string
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format))))
                  "FAILED %d 
%!" % string) x in
            op_gtgteq (delete tt)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.return_error msg)
          end)
    with reread (function_parameter : unit)
      : Lwt.t
        (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
      let 'tt := function_parameter in
      op_gtgteq
        (with_file None None None Lwt_io.Input tmp (fun fp => read None fp))
        (fun text =>
          match Data_encoding.Json.from_string text with
          | Stdlib.Ok r => Lwt.return_ok r
          | Stdlib.Error msg =>
            Lwt.return_error
              (Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "bad input: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "bad input: %s" % string) msg)
          end)
    with delete (function_parameter : unit) : Lwt.t unit :=
      let 'tt := function_parameter in
      Lwt_unix.unlink tmp in
    init tt.

Fixpoint count {A : Type}
  (function_parameter : Tezos_base__TzPervasives.RPC_description.directory A)
  : Z :=
  match function_parameter with
  | Tezos_base__TzPervasives.RPC_description.Empty => 0
  | Tezos_base__TzPervasives.RPC_description.Dynamic _ => 1
  |
    Tezos_base__TzPervasives.RPC_description.Static {|
      services := services; subdirs := subdirs |} =>
    let service := RPC_service.MethMap.cardinal services in
    let subdirs :=
      match subdirs with
      | None => 0
      | Some (Tezos_base__TzPervasives.RPC_description.Suffixes subdirs) =>
        Resto.StringMap.(Stdlib__map.S.fold)
          (fun function_parameter =>
            let '_ := function_parameter in
            fun t => fun r => Z.add r (count t)) subdirs 0
      | Some (Tezos_base__TzPervasives.RPC_description.Arg _ subdir) =>
        count subdir
      end in
    Z.add service subdirs
  end.

Definition list {F G I a b i o p q : Type}
  (url : string)
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let args := String.split "/" % char None None url in
  op_gtgteqquestion (RPC_description.describe cctxt (Some true) args)
    (fun tree =>
      let collected_args := Stdlib.ref [] in
      let collect (arg : Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
        if
          negb
            (andb (nequiv_decb (RPC_arg.descr arg) None)
              (List.mem arg (Stdlib.op_exclamation collected_args))) then
          Stdlib.op_coloneq collected_args
            (cons arg (Stdlib.op_exclamation collected_args))
        else
          tt in
      let display_paragraph
        (ppf : Stdlib.Format.formatter) (description : string) : unit :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "    " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@,    @[%a@]" % string)
          (fun ppf =>
            fun words =>
              List.iter
                (Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format)) "%s@ " % string))
                words) (String.split " " % char None None description) in
      let display_arg
        (ppf : Stdlib.Format.formatter) (arg :
        Tezos_base__TzPervasives.RPC_arg.descr) : unit :=
        match RPC_arg.descr arg with
        | None =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string)
            (RPC_arg.name arg)
        | Some descr =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Char_literal "<" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ">" % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "<%s>%a" % string) (RPC_arg.name arg) display_paragraph descr
        end in
      let display_service {J K : Type}
        (ppf : Stdlib.Format.formatter) (function_parameter :
        J * (list string) * (Tezos_base__TzPervasives.RPC_description.service K))
        : unit :=
        let '(_path, tpath, service) := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "- " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " /" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))))
              "- %s /%s" % string) (RPC_service.string_of_meth (meth service))
            (String.concat "/" % string tpath) in
        match description service with
        | None | Some "" % string => tt
        | Some description => display_paragraph ppf description
        end in
      let display_services {J K : Type}
        (ppf : Stdlib.Format.formatter) (function_parameter :
        J * (list string) *
          (Tezos_base__TzPervasives.RPC_service.MethMap.t
            (Tezos_base__TzPervasives.RPC_description.service K))) : unit :=
        let '(_path, tpath, services) := function_parameter in
        Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              let '(_, s) := function_parameter in
              display_service ppf (_path, tpath, s)) ppf
          (RPC_service.MethMap.bindings services) in
      let fix display {J : Type}
        (ppf : Stdlib.Format.formatter) (function_parameter :
        (list Resto.StringMap.(Stdlib__map.S.key)) *
          (list Resto.StringMap.(Stdlib__map.S.key)) *
          (Tezos_base__TzPervasives.RPC_description.directory J)) : unit :=
        let '(path, tpath, tree) := function_parameter in
        match tree with
        | Tezos_base__TzPervasives.RPC_description.Dynamic description =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "- /" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " <dynamic>" % string
                      CamlinternalFormatBasics.End_of_format)))
                "- /%s <dynamic>" % string) (String.concat "/" % string tpath)
            in
          match description with
          | None | Some "" % string => tt
          | Some description => display_paragraph ppf description
          end
        | Tezos_base__TzPervasives.RPC_description.Empty => tt
        |
          Tezos_base__TzPervasives.RPC_description.Static {|
            services := services; subdirs := None |} =>
          display_services ppf (path, tpath, services)
        |
          Tezos_base__TzPervasives.RPC_description.Static {|
            services := services;
              subdirs :=
                Some
                  (Tezos_base__TzPervasives.RPC_description.Suffixes
                    subdirs)
              |} =>
          match
            ((RPC_service.MethMap.cardinal services),
              (Resto.StringMap.(Stdlib__map.S.bindings) subdirs)) with
          | (0, []) => tt
          | (0, cons (n, solo) []) =>
            display ppf
              ((OCaml.Stdlib.app path (cons n [])),
                (OCaml.Stdlib.app tpath (cons n [])), solo)
          | (_, items) =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal "+ " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "/" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))))
                "@[<v 2>+ %s/@,%a@]" % string) (String.concat "/" % string path)
              (display_list tpath) items
          | (_, items) =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal "+ " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[<v 2>+ %s@,%a@,%a@]" % string)
              (String.concat "/" % string path) display_services
              (path, tpath, services) (display_list tpath) items
          | (0, cons (n, t) items) =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                display
                ((OCaml.Stdlib.app path (cons n [])),
                  (OCaml.Stdlib.app tpath (cons n [])), t) in
            List.iter
              (fun function_parameter =>
                let '(n, t) := function_parameter in
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
                  display
                  ((OCaml.Stdlib.app path (cons n [])),
                    (OCaml.Stdlib.app tpath (cons n [])), t)) items
          | (_, items) =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := display_services ppf (path, tpath, services) in
            List.iter
              (fun function_parameter =>
                let '(n, t) := function_parameter in
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)) "@,%a" % string)
                  display
                  ((OCaml.Stdlib.app path (cons n [])),
                    (OCaml.Stdlib.app tpath (cons n [])), t)) items
          end
        |
          Tezos_base__TzPervasives.RPC_description.Static {|
            services := services;
              subdirs :=
                Some
                  (Tezos_base__TzPervasives.RPC_description.Arg
                    arg solo)
              |} =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := collect arg in
          let name :=
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Char_literal "<" % char
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal ">" % char
                      CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
              (RPC_arg.name arg) in
          display ppf
            ((OCaml.Stdlib.app path (cons name [])),
              (OCaml.Stdlib.app tpath (cons name [])), solo)
        |
          Tezos_base__TzPervasives.RPC_description.Static {|
            services := services;
              subdirs :=
                Some
                  (Tezos_base__TzPervasives.RPC_description.Arg
                    arg solo)
              |} =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := collect arg in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := display_services ppf (path, tpath, services) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  CamlinternalFormatBasics.End_of_format) "@," % string) in
          let name :=
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Char_literal "<" % char
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Char_literal ">" % char
                      CamlinternalFormatBasics.End_of_format))) "<%s>" % string)
              (RPC_arg.name arg) in
          display ppf
            ((OCaml.Stdlib.app path (cons name [])),
              (OCaml.Stdlib.app tpath (cons name [])), solo)
        end
      with display_list {J : Type}
        (tpath : list Resto.StringMap.(Stdlib__map.S.key))
        : Stdlib.Format.formatter ->
          (list
            (Resto.StringMap.(Stdlib__map.S.key) *
              (Tezos_base__TzPervasives.RPC_description.directory J))) -> unit :=
        Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              let '(n, t) := function_parameter in
              display ppf ((cons n []), (OCaml.Stdlib.app tpath (cons n [])), t))
        in
      op_gtgteq
        ((* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Available services:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))))
            "@ @[<v 2>Available services:@ @ %a@]@." % string) display
          (args, args, tree))
        (fun function_parameter =>
          let 'tt := function_parameter in
          if nequiv_decb (Stdlib.op_exclamation collected_args) [] then
            op_gtgteq
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Dynamic parameter description:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format))))))))
                  "@,@[<v 2>Dynamic parameter description:@ @ %a@]@." % string)
                (Format.pp_print_list None display_arg)
                (Stdlib.op_exclamation collected_args))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)
          else
            return_unit)).

Definition schema {F G I a b i o p q : Type}
  (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (url : string)
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let args := String.split "/" % char None None url in
  op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_base__TzPervasives.RPC_description.Static {|
          services := services |} =>
        match RPC_service.MethMap.find_opt meth services with
        | None =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No service found at this URL (but this is a valid prefix)
" %
                    string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))
                "No service found at this URL (but this is a valid prefix)
%!" %
                  string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        | Some {| input := Some input; output := output |} =>
          let json :=
            (* ❌ Variants not supported *)
            variant in
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (pp None None Ezjsonm) json)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        | Some {| input := None; output := output |} =>
          let json :=
            (* ❌ Variants not supported *)
            variant in
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (pp None None Ezjsonm) json)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        end
      | _ =>
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "No service found at this URL (but this is a valid prefix)
" %
                  string
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format))
              "No service found at this URL (but this is a valid prefix)
%!" %
                string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_unit)
      end).

Definition format {E F I a b i o p q : Type}
  (binary : bool) (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key)
  (url : string)
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) *
        ((Tezos_rpc.RPC_service.meth ->
          (option Tezos_data_encoding.Data_encoding.json) ->
            Uri.t ->
              Lwt.t
                (Tezos_rpc.RPC_context.rest_result
                  Tezos_data_encoding.Data_encoding.json
                  (option Tezos_data_encoding.Data_encoding.json))) *
          (Uri.t *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                (a * b)) *
                (((string ->
                  (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                    * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a
                      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) *
                        (a)) *
                        ((((Tezos_client_base.Client_context.lwt_format a unit)
                          -> a) * (a)) * I))))))))))) * I)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let args := String.split "/" % char None None url in
  let pp :=
    if binary then
      fun ppf =>
        fun function_parameter =>
          let '(_, schema) := function_parameter in
          Data_encoding.Binary_schema.pp ppf schema
    else
      fun ppf =>
        fun function_parameter =>
          let '(schema, _) := function_parameter in
          Json_schema.pp ppf schema in
  op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_base__TzPervasives.RPC_description.Static {|
          services := services |} =>
        match RPC_service.MethMap.find_opt meth services with
        | None =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No service found at this URL (but this is a valid prefix)
" %
                    string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))
                "No service found at this URL (but this is a valid prefix)
%!" %
                  string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        | Some {| input := Some input; output := output |} =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 0>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Input format:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Output format:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format))))))))))))))
                "@[<v 0>@[<v 2>Input format:@,%a@]@,@[<v 2>Output format:@,%a@]@,@]"
                  % string) pp input pp output)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        | Some {| input := None; output := output |} =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 0>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Output format:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[<v 0>@[<v 2>Output format:@,%a@]@,@]" % string) pp output)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        end
      | _ =>
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "No service found at this URL (but this is a valid prefix)
" %
                  string
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format))
              "No service found at this URL (but this is a valid prefix)
%!" %
                string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_unit)
      end).

Definition fill_in (op_staroptstar : option bool)
  : Json_schema.schema ->
    Lwt.t
      (Result.result Tezos_base__TzPervasives.Data_encoding.Json.json string) :=
  let show_optionals :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun schema =>
    match kind (root schema) with
    | Json_schema.Null =>
      Lwt.return_ok
        (* ❌ Variants not supported *)
        variant
    | Json_schema.Any | Json_schema.Object {| properties := [] |} =>
      Lwt.return_ok
        (* ❌ Variants not supported *)
        variant
    | _ => editor_fill_in (Some show_optionals) schema
    end.

Definition display_answer {F G I a b i o p q : Type}
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (function_parameter : variant)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | Ok json =>
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) (pp None None Ezjsonm) json)
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  | Not_found _ =>
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "No service found at this URL
" % string
            (CamlinternalFormatBasics.Flush
              CamlinternalFormatBasics.End_of_format))
          "No service found at this URL
%!" % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  | Error (Some json) =>
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal "Command failed :" % string
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))))
          "@[<v 2>Command failed :@[ %a@]@]@." % string)
        (Format.pp_print_list None Error_monad.pp)
        (Data_encoding.Json.destruct
          (Data_encoding.list None Error_monad.error_encoding) json))
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  | Error None | Unauthorized _ | Forbidden _ | Conflict _ =>
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Unexpected server answer
" % string
            (CamlinternalFormatBasics.Flush
              CamlinternalFormatBasics.End_of_format))
          "Unexpected server answer
%!" % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  end.

Definition call {F G I a b i o p q : Type}
  (meth : Tezos_base__TzPervasives.RPC_service.MethMap.key) (raw_url : string)
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let uri := Uri.of_string raw_url in
  let args := String.split_path (Uri.path uri) in
  op_gtgteqquestion (RPC_description.describe cctxt (Some false) args)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_base__TzPervasives.RPC_description.Static {|
          services := services |} =>
        match RPC_service.MethMap.find_opt meth services with
        | None =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No service found at this URL with this method (but this is a valid prefix)
"
                    % string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))
                "No service found at this URL with this method (but this is a valid prefix)
%!"
                  % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        | Some {| input := None |} =>
          op_gtgteqquestion
            ((* ❌ Sending method message is not handled *)
            send meth None uri) (display_answer cctxt)
        | Some {| input := Some input |} =>
          op_gtgteq (fill_in (Some false) (fst input))
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Error msg =>
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format) "%s" % string)
                    msg)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)
              | Stdlib.Ok json =>
                op_gtgteqquestion
                  ((* ❌ Sending method message is not handled *)
                  send meth (Some json) uri) (display_answer cctxt)
              end)
        end
      | _ =>
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "No service found at this URL
" % string
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format))
              "No service found at this URL
%!" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_unit)
      end).

Definition call_with_json {F G I a b i o p q : Type}
  (meth : Tezos_rpc.RPC_service.meth) (raw_url : string) (json : string)
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let uri := Uri.of_string raw_url in
  match Data_encoding.Json.from_string json with
  | Stdlib.Error err =>
    (* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the provided json: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              (CamlinternalFormatBasics.Flush
                CamlinternalFormatBasics.End_of_format))))
        "Failed to parse the provided json: %s
%!" % string) err
  | Stdlib.Ok body =>
    op_gtgteqquestion
      ((* ❌ Sending method message is not handled *)
      send meth (Some body) uri) (display_answer cctxt)
  end.

Definition call_with_file_or_json {F G I a b i o p q : Type}
  (meth : Tezos_rpc.RPC_service.meth) (url : string) (maybe_file : string)
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    match TzString.split ":" % char None (Some 1) maybe_file with
    | cons "file" % string (cons filename []) =>
      Lwt.catch
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (with_file None None None Lwt_io.Input filename
              (let arg := read in
              fun eta => arg None eta)) (fun content => _return content))
        (fun exn =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "cannot read file (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "cannot read file (%s)" % string) (Printexc.to_string exn))
    | _ => _return maybe_file
    end (fun json => call_with_json meth url json cctxt).

Definition meth_params {A B : Type} (op_staroptstar : option string)
  : (option string) ->
    (Tezos_base__TzPervasives.Clic.params A B) ->
      Tezos_base__TzPervasives.Clic.params (variant -> A) B :=
  let name :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "HTTP method" % string
    end in
  fun op_staroptstar =>
    let desc :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => "" % string
      end in
    fun params =>
      param name desc
        (parameter
          (Some
            (fun function_parameter =>
              let '_ := function_parameter in
              apply _return
                (apply (List.map String.lowercase_ascii)
                  (apply (List.map Resto.string_of_meth)
                    (cons
                      (* ❌ Variants not supported *)
                      variant
                      (cons
                        (* ❌ Variants not supported *)
                        variant
                        (cons
                          (* ❌ Variants not supported *)
                          variant
                          (cons
                            (* ❌ Variants not supported *)
                            variant
                            (cons
                              (* ❌ Variants not supported *)
                              variant [])))))))))
          (fun function_parameter =>
            let '_ := function_parameter in
            fun name =>
              match Resto.meth_of_string (String.uppercase_ascii name) with
              | None =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Unknown HTTP method: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "Unknown HTTP method: %s" % string) name
              | Some meth => _return meth
              end)) params.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "rpc" % string;
    Clic.title := "Commands for the low level RPC layer" % string |}.

Definition commands {F G I a b i o p q : Type}
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  cons
    (command (Some group)
      "List RPCs under a given URL prefix.
Some parts of the RPC service hierarchy depend on parameters,
they are marked by a suffix `<dynamic>`.
You can list these sub-hierarchies by providing a concrete URL prefix whose arguments are set to a valid value."
        % string no_options
      (apply (prefixes (cons "rpc" % string (cons "list" % string [])))
        (apply (string "url" % string "the URL prefix" % string) stop))
      (fun function_parameter =>
        let 'tt := function_parameter in
        list))
    (cons
      (command (Some group) "Alias to `rpc list /`." % string no_options
        (apply (prefixes (cons "rpc" % string (cons "list" % string []))) stop)
        (fun function_parameter =>
          let 'tt := function_parameter in
          list "/" % string))
      (cons
        (command (Some group)
          "Get the input and output JSON schemas of an RPC." % string no_options
          (apply (prefixes (cons "rpc" % string (cons "schema" % string [])))
            (apply
              (let arg := meth_params in
              fun eta => arg None None eta)
              (apply (string "url" % string "the RPC url" % string) stop)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            schema))
        (cons
          (command (Some group)
            "Get the humanoid readable input and output formats of an RPC." %
              string
            (args1
              (switch "Binary format" % string (Some "b" % char)
                "binary" % string tt))
            (apply (prefixes (cons "rpc" % string (cons "format" % string [])))
              (apply
                (let arg := meth_params in
                fun eta => arg None None eta)
                (apply (string "url" % string "the RPC URL" % string) stop)))
            format)
          (cons
            (command (Some group) "Call an RPC with the GET method." % string
              no_options
              (apply (prefixes (cons "rpc" % string (cons "get" % string [])))
                (apply (string "url" % string "the RPC URL" % string) stop))
              (fun function_parameter =>
                let 'tt := function_parameter in
                call
                  (* ❌ Variants not supported *)
                  variant))
            (cons
              (command (Some group)
                "Call an RPC with the POST method.
It invokes $EDITOR if input data is needed."
                  % string no_options
                (apply
                  (prefixes (cons "rpc" % string (cons "post" % string [])))
                  (apply (string "url" % string "the RPC URL" % string) stop))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  call
                    (* ❌ Variants not supported *)
                    variant))
              (cons
                (command (Some group)
                  "Call an RPC with the POST method,  providing input data via the command line."
                    % string no_options
                  (apply
                    (prefixes (cons "rpc" % string (cons "post" % string [])))
                    (apply (string "url" % string "the RPC URL" % string)
                      (apply (prefix "with" % string)
                        (apply
                          (string "input" % string
                            "the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
                              % string) stop))))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    call_with_file_or_json
                      (* ❌ Variants not supported *)
                      variant))
                (cons
                  (command (Some group)
                    "Call an RPC with the PUT method.
It invokes $EDITOR if input data is needed."
                      % string no_options
                    (apply
                      (prefixes (cons "rpc" % string (cons "put" % string [])))
                      (apply (string "url" % string "the RPC URL" % string) stop))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      call
                        (* ❌ Variants not supported *)
                        variant))
                  (cons
                    (command (Some group)
                      "Call an RPC with the PUT method,  providing input data via the command line."
                        % string no_options
                      (apply
                        (prefixes (cons "rpc" % string (cons "put" % string [])))
                        (apply (string "url" % string "the RPC URL" % string)
                          (apply (prefix "with" % string)
                            (apply
                              (string "input" % string
                                "the raw JSON input to the RPC
For instance, use `{}` to send the empty document.
Alternatively, use `file:path` to read the JSON data from a file."
                                  % string) stop))))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        call_with_file_or_json
                          (* ❌ Variants not supported *)
                          variant))
                    (cons
                      (command (Some group)
                        "Call an RPC with the DELETE method." % string
                        no_options
                        (apply
                          (prefixes
                            (cons "rpc" % string (cons "delete" % string [])))
                          (apply (string "url" % string "the RPC URL" % string)
                            stop))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          call
                            (* ❌ Variants not supported *)
                            variant)) []))))))))).

src/bin_client/main_admin.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "admin-client.main"
end)

let select_commands _ _ =
  return
    (List.flatten
       [ Client_report_commands.commands ();
         Client_admin_commands.commands ();
         Client_p2p_commands.commands ();
         Client_protocols_commands.commands ();
         Client_rpc_commands.commands;
         Client_event_logging_commands.commands () ])

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/bin_client/main_admin.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    _return
      (List.flatten
        (cons (Client_report_commands.commands tt)
          (cons (Client_admin_commands.commands tt)
            (cons (Client_p2p_commands.commands tt)
              (cons (Client_protocols_commands.commands tt)
                (cons Client_rpc_commands.commands
                  (cons (Client_event_logging_commands.commands tt) []))))))).



src/bin_client/main_client.ml 25 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "client.main"
end)

open Client_config

let disable_disclaimer =
  match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" with
  | Some ("yes" | "y" | "YES" | "Y") ->
      true
  | _ ->
      false

let zeronet () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
       @,\
      \               This is @{<warning>NOT@} the Tezos Mainnet.@,\
       @,\
      \    The node you are connecting to claims to be running on the@,\
      \               @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,\
      \         Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
       Zeronet is a testing network, with free tokens and frequent resets.@]@\n\
       @."

let alphanet () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
       @,\
      \               This is @{<warning>NOT@} the Tezos Mainnet.@,\
       @,\
      \   The node you are connecting to claims to be running on the@,\
      \             @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,\
      \        Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
      \        Alphanet is a testing network, with free tokens.@]@\n\
       @."

let mainnet () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,\
       The  Tezos  network  is  a  new  blockchain technology.@,\
       Users are  solely responsible  for any risks associated@,\
       with usage of the Tezos network.  Users should do their@,\
       own  research to determine  if Tezos is the appropriate@,\
       platform for their needs and should apply judgement and@,\
       care in their network interactions.@]@\n\
       @."

let sandbox () =
  if not disable_disclaimer then
    Format.eprintf
      "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
       @,\
      \ The node you are connecting to claims to be running in a@,\
      \                  @{<warning>Tezos TEST SANDBOX@}.@,\
      \    Do @{<warning>NOT@} use your fundraiser keys on this network.@,\
       You should not see this message if you are not a developer.@]@\n\
       @."

let check_network ctxt =
  Shell_services.P2p.version ctxt
  >>= function
  | Error _ ->
      Lwt.return_none
  | Ok version ->
      let has_prefix prefix =
        String.has_prefix ~prefix (version.chain_name :> string)
      in
      if has_prefix "SANDBOXED" then (
        sandbox () ;
        Lwt.return_some `Sandbox )
      else if has_prefix "TEZOS_ZERONET" then (
        zeronet () ;
        Lwt.return_some `Zeronet )
      else if has_prefix "TEZOS_ALPHANET" then (
        alphanet () ;
        Lwt.return_some `Alphanet )
      else if has_prefix "TEZOS_BETANET" || has_prefix "TEZOS_MAINNET" then (
        mainnet () ;
        Lwt.return_some `Mainnet )
      else Lwt.return_none

let get_commands_for_version ctxt network chain block protocol =
  Shell_services.Blocks.protocols ctxt ~chain ~block ()
  >>= function
  | Ok {next_protocol = version; _} -> (
    match protocol with
    | None ->
        return
          (Some version, Client_commands.commands_for_version version network)
    | Some given_version ->
        if not (Protocol_hash.equal version given_version) then
          Format.eprintf
            "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
             The protocol provided via `--protocol` (%a)@,\
             is not the one retrieved from the node (%a).@]@\n\
             @."
            Protocol_hash.pp_short
            given_version
            Protocol_hash.pp_short
            version ;
        return
          ( Some version,
            Client_commands.commands_for_version given_version network ) )
  | Error errs -> (
    match protocol with
    | None ->
        Format.eprintf
          "@[<v 2>@{<warning>@{<title>Warning@}@}@,\
           Failed to acquire the protocol version from the node@,\
           %a@]@\n\
           @."
          (Format.pp_print_list pp)
          errs ;
        return (None, [])
    | Some version ->
        return
          (Some version, Client_commands.commands_for_version version network)
    )

let select_commands ctxt {chain; block; protocol; _} =
  check_network ctxt
  >>= fun network ->
  get_commands_for_version ctxt network chain block protocol
  >>|? fun (_, commands_for_version) ->
  Client_rpc_commands.commands
  @ Tezos_signer_backends_unix.Ledger.commands ()
  @ Client_keys_commands.commands network
  @ Client_helpers_commands.commands ()
  @ commands_for_version

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/bin_client/main_client.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

Import Client_config.

Definition disable_disclaimer : bool :=
  match Sys.getenv_opt "TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" % string with
  | Some ("yes" % string | "y" % string | "YES" % string | "Y" % string) => true
  | _ => false
  end.

Definition zeronet (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  if negb disable_disclaimer then
    Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<warning>" % string
                  CamlinternalFormatBasics.End_of_format) "<warning>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<title>" % string
                    CamlinternalFormatBasics.End_of_format) "<title>" % string))
              (CamlinternalFormatBasics.String_literal "Warning" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "               This is " % string
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<warning>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<warning>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "NOT" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.String_literal
                                  " the Tezos Mainnet." % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "    The node you are connecting to claims to be running on the"
                                          % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "               " % string
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_tag
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<warning>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<warning>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "Tezos Zeronet DEVELOPMENT NETWORK"
                                                  % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_tag
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "." % char
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@," % string 0 0)
                                                      (CamlinternalFormatBasics.String_literal
                                                        "         Do " % string
                                                        (CamlinternalFormatBasics.Formatting_gen
                                                          (CamlinternalFormatBasics.Open_tag
                                                            (CamlinternalFormatBasics.Format
                                                              (CamlinternalFormatBasics.String_literal
                                                                "<warning>" %
                                                                  string
                                                                CamlinternalFormatBasics.End_of_format)
                                                              "<warning>" %
                                                                string))
                                                          (CamlinternalFormatBasics.String_literal
                                                            "NOT" % string
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Close_tag
                                                              (CamlinternalFormatBasics.String_literal
                                                                " use your fundraiser keys on this network."
                                                                  % string
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  (CamlinternalFormatBasics.Break
                                                                    "@," %
                                                                      string 0 0)
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Zeronet is a testing network, with free tokens and frequent resets."
                                                                      % string
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Close_box
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Force_newline
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          CamlinternalFormatBasics.Flush_newline
                                                                          CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))))
        "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,               This is @{<warning>NOT@} the Tezos Mainnet.@,@,    The node you are connecting to claims to be running on the@,               @{<warning>Tezos Zeronet DEVELOPMENT NETWORK@}.@,         Do @{<warning>NOT@} use your fundraiser keys on this network.@,Zeronet is a testing network, with free tokens and frequent resets.@]@
@."
          % string)
  else
    tt.

Definition alphanet (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  if negb disable_disclaimer then
    Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<warning>" % string
                  CamlinternalFormatBasics.End_of_format) "<warning>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<title>" % string
                    CamlinternalFormatBasics.End_of_format) "<title>" % string))
              (CamlinternalFormatBasics.String_literal "Warning" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "               This is " % string
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_tag
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<warning>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<warning>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "NOT" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.String_literal
                                  " the Tezos Mainnet." % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "   The node you are connecting to claims to be running on the"
                                          % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "             " % string
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_tag
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<warning>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<warning>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "Tezos Alphanet DEVELOPMENT NETWORK."
                                                  % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_tag
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@," % string 0 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "        Do " % string
                                                      (CamlinternalFormatBasics.Formatting_gen
                                                        (CamlinternalFormatBasics.Open_tag
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "<warning>" %
                                                                string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "<warning>" % string))
                                                        (CamlinternalFormatBasics.String_literal
                                                          "NOT" % string
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_tag
                                                            (CamlinternalFormatBasics.String_literal
                                                              " use your fundraiser keys on this network."
                                                                % string
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@," % string
                                                                  0 0)
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "        Alphanet is a testing network, with free tokens."
                                                                    % string
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    CamlinternalFormatBasics.Close_box
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Force_newline
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Flush_newline
                                                                        CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))))))))
        "@[<v 2>@{<warning>@{<title>Warning@}@}@,@,               This is @{<warning>NOT@} the Tezos Mainnet.@,@,   The node you are connecting to claims to be running on the@,             @{<warning>Tezos Alphanet DEVELOPMENT NETWORK.@}@,        Do @{<warning>NOT@} use your fundraiser keys on this network.@,        Alphanet is a testing network, with free tokens.@]@
@."
          % string)
  else
    tt.

Definition mainnet (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  if negb disable_disclaimer then
    Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<warning>" % string
                  CamlinternalFormatBasics.End_of_format) "<warning>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<title>" % string
                    CamlinternalFormatBasics.End_of_format) "<title>" % string))
              (CamlinternalFormatBasics.String_literal "Disclaimer" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal
                        "The  Tezos  network  is  a  new  blockchain technology."
                          % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Users are  solely responsible  for any risks associated"
                              % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "with usage of the Tezos network.  Users should do their"
                                  % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "own  research to determine  if Tezos is the appropriate"
                                      % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "platform for their needs and should apply judgement and"
                                          % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "care in their network interactions."
                                              % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Force_newline
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Flush_newline
                                                  CamlinternalFormatBasics.End_of_format)))))))))))))))))))))
        "@[<v 2>@{<warning>@{<title>Disclaimer@}@}@,The  Tezos  network  is  a  new  blockchain technology.@,Users are  solely responsible  for any risks associated@,with usage of the Tezos network.  Users should do their@,own  research to determine  if Tezos is the appropriate@,platform for their needs and should apply judgement and@,care in their network interactions.@]@
@."
          % string)
  else
    tt.

Definition sandbox (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  if negb disable_disclaimer then
    Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_tag
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<warning>" % string
                  CamlinternalFormatBasics.End_of_format) "<warning>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<title>" % string
                    CamlinternalFormatBasics.End_of_format) "<title>" % string))
              (CamlinternalFormatBasics.String_literal "Warning" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_tag
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          " The node you are connecting to claims to be running in a"
                            % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "                  " % string
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_tag
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<warning>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<warning>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Tezos TEST SANDBOX" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_tag
                                    (CamlinternalFormatBasics.Char_literal
                                      "." % char
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@," % string 0 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "    Do " % string
                                          (CamlinternalFormatBasics.Formatting_gen
                                            (CamlinternalFormatBasics.Open_tag
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "<warning>" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "<warning>" % string))
                                            (CamlinternalFormatBasics.String_literal
                                              "NOT" % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_tag
                                                (CamlinternalFormatBasics.String_literal
                                                  " use your fundraiser keys on this network."
                                                    % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@," % string 0 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "You should not see this message if you are not a developer."
                                                        % string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Force_newline
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Flush_newline
                                                            CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
        "@[<v 2>@{<warning>@{<title>Warning@}@}@,@, The node you are connecting to claims to be running in a@,                  @{<warning>Tezos TEST SANDBOX@}.@,    Do @{<warning>NOT@} use your fundraiser keys on this network.@,You should not see this message if you are not a developer.@]@
@."
          % string)
  else
    tt.

Definition check_network {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) : Lwt.t (option variant) :=
  op_gtgteq (Shell_services.P2p.version ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error _ => Lwt.return_none
      | Stdlib.Ok version =>
        let has_prefix (prefix : string) : bool :=
          String.has_prefix prefix (chain_name version) in
        if has_prefix "SANDBOXED" % string then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := sandbox tt in
          Lwt.return_some
            (* ❌ Variants not supported *)
            variant
        else
          if has_prefix "TEZOS_ZERONET" % string then
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := zeronet tt in
            Lwt.return_some
              (* ❌ Variants not supported *)
              variant
          else
            if has_prefix "TEZOS_ALPHANET" % string then
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := alphanet tt in
              Lwt.return_some
                (* ❌ Variants not supported *)
                variant
            else
              if
                orb (has_prefix "TEZOS_BETANET" % string)
                  (has_prefix "TEZOS_MAINNET" % string) then
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := mainnet tt in
                Lwt.return_some
                  (* ❌ Variants not supported *)
                  variant
              else
                Lwt.return_none
      end).

Definition get_commands_for_version {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (network : option Tezos_client_commands.Client_commands.network)
  (chain : Tezos_shell_services__Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (protocol : option Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((option Tezos_base__TzPervasives.Protocol_hash.t) *
        (list Tezos_client_commands.Client_commands.command))) :=
  op_gtgteq (Shell_services.Blocks.protocols ctxt (Some chain) (Some block) tt)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok {| next_protocol := version |} =>
        match protocol with
        | None =>
          _return
            ((Some version),
              (Client_commands.commands_for_version version network))
        | Some given_version =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if negb (Protocol_hash.equal version given_version) then
              Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_tag
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<warning>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<warning>" % string))
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<title>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<title>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Warning" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_tag
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_tag
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "The protocol provided via `--protocol` (" %
                                    string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@," % string 0 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "is not the one retrieved from the node ("
                                            % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              ")." % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Force_newline
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    CamlinternalFormatBasics.End_of_format)))))))))))))))))
                  "@[<v 2>@{<warning>@{<title>Warning@}@}@,The protocol provided via `--protocol` (%a)@,is not the one retrieved from the node (%a).@]@
@."
                    % string) Protocol_hash.pp_short given_version
                Protocol_hash.pp_short version
            else
              tt in
          _return
            ((Some version),
              (Client_commands.commands_for_version given_version network))
        end
      | Stdlib.Error errs =>
        match protocol with
        | None =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_tag
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<warning>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<warning>" % string))
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_tag
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<title>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<title>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Warning" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_tag
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_tag
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "Failed to acquire the protocol version from the node"
                                  % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Force_newline
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          CamlinternalFormatBasics.End_of_format)))))))))))))
                "@[<v 2>@{<warning>@{<title>Warning@}@}@,Failed to acquire the protocol version from the node@,%a@]@
@."
                  % string) (Format.pp_print_list None pp) errs in
          _return (None, [])
        | Some version =>
          _return
            ((Some version),
              (Client_commands.commands_for_version version network))
        end
      end).

Definition select_commands {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (function_parameter : Tezos_client_base_unix.Client_config.cli_args)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_client_commands.Client_commands.command)) :=
  let '{| chain := chain; block := block; protocol := protocol |} :=
    function_parameter in
  op_gtgteq (check_network ctxt)
    (fun network =>
      op_gtgtpipequestion
        (get_commands_for_version ctxt network chain block protocol)
        (fun function_parameter =>
          let '(_, commands_for_version) := function_parameter in
          OCaml.Stdlib.app Client_rpc_commands.commands
            (OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
              (OCaml.Stdlib.app (Client_keys_commands.commands network)
                (OCaml.Stdlib.app (Client_helpers_commands.commands tt)
                  commands_for_version))))).



src/bin_client/test/proto_test_injection/main.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type block_header_data = MBytes.t

type block_header = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

let block_header_data_encoding =
  Data_encoding.(obj1 (req "random_data" Variable.bytes))

type block_header_metadata = unit

let block_header_metadata_encoding = Data_encoding.unit

type operation_data = unit

let operation_data_encoding = Data_encoding.unit

type operation_receipt = unit

let operation_receipt_encoding = Data_encoding.unit

let operation_data_and_receipt_encoding =
  Data_encoding.conv
    (function ((), ()) -> ())
    (fun () -> ((), ()))
    Data_encoding.unit

type operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let max_block_length = 42

let max_operation_data_length = 42

let validation_passes = []

let acceptable_passes _op = []

let compare_operations _ _ = 0

type validation_state = {context : Context.t; fitness : Int64.t}

let current_context {context} = return context

module Fitness = struct
  type error += Invalid_fitness

  type error += Invalid_fitness2

  let int64_to_bytes i =
    let b = MBytes.create 8 in
    MBytes.set_int64 b 0 i ; b

  let int64_of_bytes b =
    if Compare.Int.(MBytes.length b <> 8) then fail Invalid_fitness2
    else return (MBytes.get_int64 b 0)

  let from_int64 fitness = [int64_to_bytes fitness]

  let to_int64 = function
    | [fitness] ->
        int64_of_bytes fitness
    | [] ->
        return 0L
    | _ ->
        fail Invalid_fitness

  let get {fitness} = fitness
end

let begin_application ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_fitness:_ (raw_block : block_header)
    =
  Fitness.to_int64 raw_block.shell.fitness
  >>=? fun fitness -> return {context; fitness}

let begin_partial_application ~chain_id ~ancestor_context
    ~predecessor_timestamp ~predecessor_fitness raw_block =
  begin_application
    ~chain_id
    ~predecessor_context:ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    raw_block

let begin_construction ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_level:_
    ~predecessor_fitness:pred_fitness ~predecessor:_ ~timestamp:_
    ?protocol_data:_ () =
  Fitness.to_int64 pred_fitness
  >>=? fun pred_fitness ->
  let fitness = Int64.succ pred_fitness in
  return {context; fitness}

let apply_operation ctxt _ = return (ctxt, ())

let finalize_block ctxt =
  let fitness = Fitness.get ctxt in
  let message = Some (Format.asprintf "fitness <- %Ld" fitness) in
  let fitness = Fitness.from_int64 fitness in
  return
    ( {
        Updater.message;
        context = ctxt.context;
        fitness;
        max_operations_ttl = 0;
        last_allowed_fork_level = 0l;
      },
      () )

let rpc_services = RPC_directory.empty

let init ctxt block_header =
  let fitness = block_header.Block_header.fitness in
  let message = None in
  return
    {
      Updater.message;
      context = ctxt;
      fitness;
      max_operations_ttl = 0;
      last_allowed_fork_level = 0l;
    }
src/bin_client/test/proto_test_injection/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition block_header_data := Tezos_base__TzPervasives.MBytes.t.

Record block_header := {
  shell : Tezos_base__TzPervasives.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
  obj1 (req None None "random_data" % string Variable.bytes).

Definition block_header_metadata := unit.

Definition block_header_metadata_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.

Definition operation_data := unit.

Definition operation_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.

Definition operation_receipt := unit.

Definition operation_receipt_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unit := Data_encoding.unit.

Definition operation_data_and_receipt_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
  Data_encoding.conv
    (fun function_parameter =>
      let '(tt, tt) := function_parameter in
      tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      (tt, tt)) None Data_encoding.unit.

Record operation := {
  shell : Tezos_base__TzPervasives.Operation.shell_header;
  protocol_data : operation_data }.

Definition max_block_length : Z := 42.

Definition max_operation_data_length : Z := 42.

Definition validation_passes {A : Type} : list A := [].

Definition acceptable_passes {A B : Type} (_op : A) : list B := [].

Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    0.

Definition current_context {A B : Type} (function_parameter : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  let '_ := function_parameter in
  _return op_startypeminuserrorstar.

Module Fitness.
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition int64_to_bytes (i : int64) : Tezos_base__TzPervasives.MBytes.t :=
    let b := MBytes.create 8 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := MBytes.set_int64 b 0 i in
    b.
  
  Definition int64_of_bytes (b : Tezos_base__TzPervasives.MBytes.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
    if op_ltgt (MBytes.length b) 8 then
      fail Tezos_base__TzPervasives.Invalid_fitness2
    else
      _return (MBytes.get_int64 b 0).
  
  Definition from_int64 (fitness : int64)
    : list Tezos_base__TzPervasives.MBytes.t := cons (int64_to_bytes fitness) [].
  
  Definition to_int64
    (function_parameter : list Tezos_base__TzPervasives.MBytes.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int64) :=
    match function_parameter with
    | cons fitness [] => int64_of_bytes fitness
    | [] =>
      _return
        (* ❌ Constant of type int64 is converted to int *)
        0
    | _ => fail Tezos_base__TzPervasives.Invalid_fitness
    end.
  
  Definition get {A B : Type} (function_parameter : A) : B :=
    let '_ := function_parameter in
    op_startypeminuserrorstar.
End Fitness.

Definition begin_application {A B C D E : Type} (function_parameter : A)
  : B -> C -> D -> block_header -> Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
  let '_ := function_parameter in
  fun context =>
    fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        fun raw_block =>
          op_gtgteqquestion (Fitness.to_int64 (fitness (shell raw_block)))
            (fun fitness => _return op_startypeminuserrorstar).

Definition begin_partial_application {A B C D E : Type}
  (chain_id : A) (ancestor_context : B) (predecessor_timestamp : C)
  (predecessor_fitness : D) (raw_block : block_header)
  : Lwt.t (Tezos_base__TzPervasives.tzresult E) :=
  begin_application chain_id ancestor_context predecessor_timestamp
    predecessor_fitness raw_block.

Definition begin_construction {A B C D E F G H : Type} (function_parameter : A)
  : B ->
    C ->
      D ->
        (list Tezos_base__TzPervasives.MBytes.t) ->
          E ->
            F ->
              (option G) -> unit -> Lwt.t (Tezos_base__TzPervasives.tzresult H) :=
  let '_ := function_parameter in
  fun context =>
    fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        fun pred_fitness =>
          fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '_ := function_parameter in
              fun function_parameter =>
                let '_ := function_parameter in
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion (Fitness.to_int64 pred_fitness)
                    (fun pred_fitness =>
                      let fitness := Int64.succ pred_fitness in
                      _return op_startypeminuserrorstar).

Definition apply_operation {A B : Type} (ctxt : A) (function_parameter : B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (A * unit)) :=
  let '_ := function_parameter in
  _return (ctxt, tt).

Definition finalize_block {A B : Type} (ctxt : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (B * unit)) :=
  let fitness := Fitness.get ctxt in
  let message :=
    Some
      (Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "fitness <- " % string
            (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format)) "fitness <- %Ld" % string)
        fitness) in
  let fitness := Fitness.from_int64 fitness in
  _return (op_startypeminuserrorstar, tt).

Definition rpc_services {A : Type}
  : Tezos_base__TzPervasives.RPC_directory.directory A := RPC_directory.empty.

Definition init {A B : Type}
  (ctxt : A) (block_header : Tezos_base__TzPervasives.Block_header.shell_header)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  let fitness := Block_header.fitness block_header in
  let message := None in
  _return op_startypeminuserrorstar.

src/bin_codec/codec.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let commands = Commands.commands ()

let home = try Sys.getenv "HOME" with Not_found -> "/tmp"

let default_base_dir = Filename.concat home ".tezos-client"

let base_dir_arg =
  let open Clic in
  arg
    ~long:"base-dir"
    ~short:'d'
    ~placeholder:"path"
    ~doc:
      ( "data directory\n\
         The directory where the Tezos codec will output logs.\n\
         By default: '" ^ default_base_dir ^ "'." )
    (parameter (fun _ctxt x -> return x))

let global_options = Clic.args1 base_dir_arg

let parse_config_args argv =
  (* The context used during argument parsing. We switch to a real context
     that is created based on some of the parsed arguments. *)
  let ctxt = Client_context.null_printer in
  Clic.parse_global_options global_options ctxt argv
  >>=? fun (base_dir, argv) ->
  ( match base_dir with
  | None ->
      let base_dir = default_base_dir in
      ( if Sys.file_exists base_dir then Lwt.return_unit
      else Lwt_utils_unix.create_dir base_dir )
      >>= fun () -> return base_dir
  | Some dir ->
      if not (Sys.file_exists dir) then
        failwith
          "Specified -base-dir does not exist. Please create the directory \
           and try again."
      else if not (Sys.is_directory dir) then
        failwith "Specified -base-dir must be a directory"
      else return dir )
  >>=? fun base_dir -> return (base_dir, argv)

(* Main (lwt) entry *)
let main commands =
  let executable_name = Filename.basename Sys.executable_name in
  let run () =
    let (argv, autocomplete) =
      (* for shell aliases *)
      let rec move_autocomplete_token_upfront acc = function
        | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
            let args = List.rev acc @ args in
            (args, Some (prev_arg, cur_arg, script))
        | x :: rest ->
            move_autocomplete_token_upfront (x :: acc) rest
        | [] ->
            (List.rev acc, None)
      in
      match Array.to_list Sys.argv with
      | _ :: args ->
          move_autocomplete_token_upfront [] args
      | [] ->
          ([], None)
    in
    Random.self_init () ;
    ignore
      Clic.(
        setup_formatter
          Format.std_formatter
          (if Unix.isatty Unix.stdout then Ansi else Plain)
          Short) ;
    ignore
      Clic.(
        setup_formatter
          Format.err_formatter
          (if Unix.isatty Unix.stderr then Ansi else Plain)
          Short) ;
    Internal_event_unix.init ()
    >>= fun () ->
    parse_config_args argv
    >>=? fun (base_dir, argv) ->
    let ctxt = new Client_context_unix.unix_logger ~base_dir in
    let commands =
      Clic.add_manual
        ~executable_name
        ~global_options
        (if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
        Format.std_formatter
        commands
    in
    match autocomplete with
    | Some (prev_arg, cur_arg, script) ->
        Clic.autocompletion
          ~script
          ~cur_arg
          ~prev_arg
          ~args:argv
          ~global_options
          commands
          ctxt
        >>=? fun completions ->
        List.iter print_endline completions ;
        return_unit
    | None ->
        Clic.dispatch commands ctxt argv
  in
  Pervasives.exit
    (Lwt_main.run
       ( Lwt.catch run (function
             | Failure msg ->
                 failwith "%s" msg
             | exn ->
                 failwith "%s" (Printexc.to_string exn))
       >>= (function
             | Ok () ->
                 Lwt.return 0
             | Error [Clic.Help command] ->
                 Clic.usage
                   Format.std_formatter
                   ~executable_name
                   ~global_options
                   (match command with None -> [] | Some c -> [c]) ;
                 Lwt.return 0
             | Error errs ->
                 Clic.pp_cli_errors
                   Format.err_formatter
                   ~executable_name
                   ~global_options
                   ~default:Error_monad.pp
                   errs ;
                 Lwt.return 1)
       >>= fun retcode ->
       Format.pp_print_flush Format.err_formatter () ;
       Format.pp_print_flush Format.std_formatter () ;
       Lwt.return retcode ))

let () = main commands
src/bin_codec/codec.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition commands
  : list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer) :=
  Commands.commands tt.

Definition home : string :=
  (* ❌ Try-with are not handled *)
  try (Sys.getenv "HOME" % string).

Definition default_base_dir : string :=
  Filename.concat home ".tezos-client" % string.

Definition base_dir_arg
  : Tezos_clic.Clic.arg (option string) Tezos_client_base.Client_context.printer :=
  arg
    (String.append
      "data directory
The directory where the Tezos codec will output logs.
By default: '"
        % string (String.append default_base_dir "'." % string))
    (Some "d" % char) "base-dir" % string "path" % string
    (parameter None (fun _ctxt => fun x => _return x)).

Definition global_options
  : Tezos_clic.Clic.options (option string)
    Tezos_client_base.Client_context.printer := Clic.args1 base_dir_arg.

Definition parse_config_args (argv : list string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (string * (list string))) :=
  let ctxt := Client_context.null_printer in
  op_gtgteqquestion (Clic.parse_global_options global_options ctxt argv)
    (fun function_parameter =>
      let '(base_dir, argv) := function_parameter in
      op_gtgteqquestion
        match base_dir with
        | None =>
          let base_dir := default_base_dir in
          op_gtgteq
            (if Sys.file_exists base_dir then
              Lwt.return_unit
            else
              Lwt_utils_unix.create_dir None base_dir)
            (fun function_parameter =>
              let 'tt := function_parameter in
              _return base_dir)
        | Some dir =>
          if negb (Sys.file_exists dir) then
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Specified -base-dir does not exist. Please create the directory and try again."
                    % string CamlinternalFormatBasics.End_of_format)
                "Specified -base-dir does not exist. Please create the directory and try again."
                  % string)
          else
            if negb (Sys.is_directory dir) then
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Specified -base-dir must be a directory" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Specified -base-dir must be a directory" % string)
            else
              _return dir
        end (fun base_dir => _return (base_dir, argv))).

Definition main {A : Type}
  (commands :
    list (Tezos_clic.Clic.command Tezos_client_base.Client_context.printer))
  : A :=
  let executable_name := Filename.basename Sys.executable_name in
  let run (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let 'tt := function_parameter in
    let '(argv, autocomplete) :=
      let fix move_autocomplete_token_upfront
        (acc : list string) (function_parameter : list string)
        : (list string) * (option (string * string * string)) :=
        match function_parameter with
        |
          cons "bash_autocomplete" % string
            (cons prev_arg (cons cur_arg (cons script args))) =>
          let args := OCaml.Stdlib.app (List.rev acc) args in
          (args, (Some (prev_arg, cur_arg, script)))
        | cons x rest => move_autocomplete_token_upfront (cons x acc) rest
        | [] => ((List.rev acc), None)
        end in
      match Array.to_list Sys.argv with
      | cons _ args => move_autocomplete_token_upfront [] args
      | [] => ([], None)
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Random.self_init tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      OCaml.Stdlib.ignore
        (setup_formatter Format.std_formatter
          (if Unix.isatty Unix.stdout then
            Tezos_clic.Clic.Ansi
          else
            Tezos_clic.Clic.Plain) Tezos_clic.Clic.Short) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      OCaml.Stdlib.ignore
        (setup_formatter Format.err_formatter
          (if Unix.isatty Unix.stderr then
            Tezos_clic.Clic.Ansi
          else
            Tezos_clic.Clic.Plain) Tezos_clic.Clic.Short) in
    op_gtgteq (Internal_event_unix.init None None tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion (parse_config_args argv)
          (fun function_parameter =>
            let '(base_dir, argv) := function_parameter in
            let ctxt :=
              (* ❌ Creation of new objects is not handled *)
              new base_dir in
            let commands :=
              Clic.add_manual executable_name global_options
                (if Unix.isatty Unix.stdout then
                  Tezos_clic.Clic.Ansi
                else
                  Tezos_clic.Clic.Plain) Format.std_formatter commands in
            match autocomplete with
            | Some (prev_arg, cur_arg, script) =>
              op_gtgteqquestion
                (Clic.autocompletion script cur_arg prev_arg argv global_options
                  commands ctxt)
                (fun completions =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := List.iter OCaml.Stdlib.print_endline completions in
                  return_unit)
            | None => Clic.dispatch commands ctxt argv
            end)) in
  Pervasives.exit
    (Lwt_main.run
      (op_gtgteq
        (op_gtgteq
          (Lwt.catch run
            (fun function_parameter =>
              match function_parameter with
              | OCaml.Failure msg =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format) "%s" % string) msg
              | exn =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format) "%s" % string)
                  (Printexc.to_string exn)
              end))
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok tt => Lwt._return 0
            |
              Stdlib.Error
                (cons (Tezos_error_monad.Error_monad.Help command) []) =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Clic.usage Format.std_formatter executable_name global_options
                  match command with
                  | None => []
                  | Some c => cons c []
                  end in
              Lwt._return 0
            | Stdlib.Error errs =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Clic.pp_cli_errors Format.err_formatter executable_name
                  global_options Error_monad.pp errs in
              Lwt._return 1
            end))
        (fun retcode =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Format.pp_print_flush Format.err_formatter tt in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Format.pp_print_flush Format.std_formatter tt in
          Lwt._return retcode))).



src/bin_codec/commands.ml 69 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix
open Clic

let group = {name = "encoding"; title = "Commands to handle encodings"}

let id_parameter =
  parameter (fun (cctxt : #Client_context.printer) id ->
      match Data_encoding.Registration.find id with
      | Some record ->
          return record
      | None ->
          cctxt#error "Unkown encoding id: %s" id)

let json_parameter =
  parameter (fun (cctxt : #Client_context.printer) file_or_data ->
      Lwt_unix.file_exists file_or_data
      >>= (function
            | true ->
                Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
            | false ->
                Lwt.return file_or_data)
      >>= fun data ->
      match Json.from_string data with
      | Ok json ->
          return json
      | Error err ->
          cctxt#error "%s" err)

let bytes_parameter = parameter (fun _ hex -> return (Hex.to_bytes (`Hex hex)))

let commands () =
  [ command
      ~group
      ~desc:"List the registered encoding in Tezos."
      no_options
      (fixed ["list"; "encodings"])
      (fun () (cctxt : #Client_context.printer) ->
        let bindings =
          Data_encoding.Registration.list ()
          |> List.map (fun (id, elem) ->
                 (id, Data_encoding.Registration.description elem))
        in
        cctxt#message
          "@[<v>%a@]@."
          (Format.pp_print_list
             ~pp_sep:Format.pp_print_cut
             (fun ppf (id, desc) ->
               let desc =
                 Option.unopt ~default:"No description available." desc
               in
               Format.fprintf
                 ppf
                 "@[<v 2>%s:@ @[%a@]@]"
                 id
                 Format.pp_print_text
                 desc))
          bindings
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Dump a json description of all registered encodings."
      ( args1
      @@ switch
           ~doc:
             "Output json descriptions without extraneous whitespace characters"
           ~long:"compact"
           () )
      (fixed ["dump"; "encodings"])
      (fun minify (cctxt : #Client_context.printer) ->
        cctxt#message
          "%s"
          (Json.to_string
             ~minify
             (`A
               ( Registration.list ()
               |> List.map (fun (id, enc) ->
                      `O
                        [ ("id", `String id);
                          ( "json",
                            Json.construct
                              Json.schema_encoding
                              (Registration.json_schema enc) );
                          ( "binary",
                            Json.construct
                              Binary_schema.encoding
                              (Registration.binary_schema enc) ) ]) )))
        >>= fun () -> return_unit);
    (* JSON -> Binary *)
    command
      ~group
      ~desc:
        "Encode the given JSON data into binary using the provided encoding \
         identifier."
      no_options
      ( prefix "encode"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefix "from"
      @@ param ~name:"json" ~desc:"JSON file or data" json_parameter
      @@ stop )
      (fun () registered_encoding json (cctxt : #Client_context.printer) ->
        match
          Data_encoding.Registration.bytes_of_json registered_encoding json
        with
        | exception exn ->
            cctxt#error "%a" (fun ppf exn -> Json.print_error ppf exn) exn
        | None ->
            cctxt#error
              "Impossible to the JSON convert to binary.@,\
               This error should not happen."
        | Some bytes ->
            cctxt#message "%a" Hex.pp (Hex.of_bytes bytes)
            >>= fun () -> return_unit);
    (* Binary -> JSON *)
    command
      ~group
      ~desc:
        "Decode the binary encoded data into JSON using the provided encoding \
         identifier."
      no_options
      ( prefix "decode"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefix "from"
      @@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
      @@ stop )
      (fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
        match
          Data_encoding.Registration.json_of_bytes registered_encoding bytes
        with
        | None ->
            cctxt#error "Cannot parse the binary with the given encoding"
        | Some bytes ->
            cctxt#message "%a" Json.pp bytes >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Display the binary encoded data using the provided encoding \
         identifier."
      no_options
      ( prefix "display"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["from"; "binary"]
      @@ param ~name:"hex" ~desc:"Binary encoded data" bytes_parameter
      @@ stop )
      (fun () registered_encoding bytes (cctxt : #Client_context.printer) ->
        let pp_bytes fmt bytes =
          Data_encoding.Registration.binary_pretty_printer
            registered_encoding
            fmt
            bytes
        in
        cctxt#message "%a" pp_bytes bytes >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Display the JSON encoded data using the provided encoding identifier."
      no_options
      ( prefix "display"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["from"; "json"]
      @@ param ~name:"json" ~desc:"JSON file or data" json_parameter
      @@ stop )
      (fun () registered_encoding json (cctxt : #Client_context.printer) ->
        let pp_json fmt json =
          Data_encoding.Registration.json_pretty_printer
            registered_encoding
            fmt
            json
        in
        cctxt#message "%a" pp_json json >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Describe the binary schema associated to the provided encoding \
         identifier."
      no_options
      ( prefix "describe"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["binary"; "schema"]
      @@ stop )
      (fun () registered_encoding (cctxt : #Client_context.printer) ->
        let schema =
          Data_encoding.Registration.binary_schema registered_encoding
        in
        cctxt#message "%a" Binary_schema.pp schema >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Describe the JSON schema associated to the provided encoding \
         identifier."
      no_options
      ( prefix "describe"
      @@ param ~name:"id" ~desc:"Encoding identifier" id_parameter
      @@ prefixes ["json"; "schema"]
      @@ stop )
      (fun () registered_encoding cctxt ->
        let schema =
          Data_encoding.Registration.json_schema registered_encoding
        in
        cctxt#message "%a" Json_schema.pp schema >>= fun () -> return_unit) ]
src/bin_codec/commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Clic.

Definition group : Tezos_clic.Clic.group :=
  {| name := "encoding" % string;
    title := "Commands to handle encodings" % string |}.

Definition id_parameter {C a b : Type}
  : Tezos_clic.Clic.parameter
    Tezos_base__TzPervasives.Data_encoding.Registration.t
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) :=
  parameter None
    (fun cctxt =>
      fun id =>
        match Data_encoding.Registration.find id with
        | Some record => _return record
        | None =>
          (* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Unkown encoding id: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))
              "Unkown encoding id: %s" % string) id
        end).

Definition json_parameter {C a b : Type}
  : Tezos_clic.Clic.parameter Tezos_data_encoding.Json.json
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) :=
  parameter None
    (fun cctxt =>
      fun file_or_data =>
        op_gtgteq
          (op_gtgteq (Lwt_unix.file_exists file_or_data)
            (fun function_parameter =>
              match function_parameter with
              | true => Tezos_stdlib_unix.Lwt_utils_unix.read_file file_or_data
              | false => Lwt._return file_or_data
              end))
          (fun data =>
            match Json.from_string data with
            | Stdlib.Ok json => _return json
            | Stdlib.Error err =>
              (* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format) "%s" % string) err
            end)).

Definition bytes_parameter {C a b : Type}
  : Tezos_clic.Clic.parameter string
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) :=
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun hex =>
        _return
          (Hex.to_bytes
            (* ❌ Variants not supported *)
            variant)).

Definition commands {C a b : Type} (function_parameter : unit)
  : list
    (Tezos_clic.Clic.command
      (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (((string ->
                (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
                * C))))) * C)) :=
  let 'tt := function_parameter in
  cons
    (command (Some group) "List the registered encoding in Tezos." % string
      no_options (fixed (cons "list" % string (cons "encodings" % string [])))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          let bindings :=
            OCaml.Stdlib.reverse_apply (Data_encoding.Registration.list tt)
              (List.map
                (fun function_parameter =>
                  let '(id, elem) := function_parameter in
                  (id, (Data_encoding.Registration.description elem)))) in
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v>" % string
                        CamlinternalFormatBasics.End_of_format) "<v>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format))))
                "@[<v>%a@]@." % string)
              (Format.pp_print_list (Some Format.pp_print_cut)
                (fun ppf =>
                  fun function_parameter =>
                    let '(id, desc) := function_parameter in
                    let desc :=
                      Option.unopt "No description available." % string desc in
                    Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.Char_literal ":" % char
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      CamlinternalFormatBasics.End_of_format
                                      "" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))
                        "@[<v 2>%s:@ @[%a@]@]" % string) id Format.pp_print_text
                      desc)) bindings)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)))
    (cons
      (command (Some group)
        "Dump a json description of all registered encodings." % string
        (apply args1
          (switch
            "Output json descriptions without extraneous whitespace characters"
              % string None "compact" % string tt))
        (fixed (cons "dump" % string (cons "encodings" % string [])))
        (fun minify =>
          fun cctxt =>
            op_gtgteq
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format) "%s" % string)
                (Json.to_string None (Some minify)
                  (* ❌ Variants not supported *)
                  variant))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)))
      (cons
        (command (Some group)
          "Encode the given JSON data into binary using the provided encoding identifier."
            % string no_options
          (apply (prefix "encode" % string)
            (apply
              (param "id" % string "Encoding identifier" % string id_parameter)
              (apply (prefix "from" % string)
                (apply
                  (param "json" % string "JSON file or data" % string
                    json_parameter) stop))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun registered_encoding =>
              fun json =>
                fun cctxt =>
                  match
                    Data_encoding.Registration.bytes_of_json registered_encoding
                      json with
                  | None =>
                    (* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Impossible to the JSON convert to binary." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "This error should not happen." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Impossible to the JSON convert to binary.@,This error should not happen."
                          % string)
                  | Some bytes =>
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)
                          "%a" % string) Hex.pp (Hex.of_bytes None string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)
                  end))
        (cons
          (command (Some group)
            "Decode the binary encoded data into JSON using the provided encoding identifier."
              % string no_options
            (apply (prefix "decode" % string)
              (apply
                (param "id" % string "Encoding identifier" % string id_parameter)
                (apply (prefix "from" % string)
                  (apply
                    (param "hex" % string "Binary encoded data" % string
                      bytes_parameter) stop))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun registered_encoding =>
                fun bytes =>
                  fun cctxt =>
                    match
                      Data_encoding.Registration.json_of_bytes
                        registered_encoding string with
                    | None =>
                      (* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Cannot parse the binary with the given encoding" %
                              string CamlinternalFormatBasics.End_of_format)
                          "Cannot parse the binary with the given encoding" %
                            string)
                    | Some bytes =>
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string) Json.pp string)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit)
                    end))
          (cons
            (command (Some group)
              "Display the binary encoded data using the provided encoding identifier."
                % string no_options
              (apply (prefix "display" % string)
                (apply
                  (param "id" % string "Encoding identifier" % string
                    id_parameter)
                  (apply
                    (prefixes (cons "from" % string (cons "binary" % string [])))
                    (apply
                      (param "hex" % string "Binary encoded data" % string
                        bytes_parameter) stop))))
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun registered_encoding =>
                  fun bytes =>
                    fun cctxt =>
                      let pp_bytes
                        (fmt : Stdlib.Format.formatter) (bytes : Stdlib.Bytes.t)
                        : unit :=
                        Data_encoding.Registration.binary_pretty_printer
                          registered_encoding fmt string in
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string) pp_bytes string)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit)))
            (cons
              (command (Some group)
                "Display the JSON encoded data using the provided encoding identifier."
                  % string no_options
                (apply (prefix "display" % string)
                  (apply
                    (param "id" % string "Encoding identifier" % string
                      id_parameter)
                    (apply
                      (prefixes (cons "from" % string (cons "json" % string [])))
                      (apply
                        (param "json" % string "JSON file or data" % string
                          json_parameter) stop))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  fun registered_encoding =>
                    fun json =>
                      fun cctxt =>
                        let pp_json
                          (fmt : Stdlib.Format.formatter) (json :
                          Tezos_data_encoding.Json.t) : unit :=
                          Data_encoding.Registration.json_pretty_printer
                            registered_encoding fmt json in
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format)
                              "%a" % string) pp_json json)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)))
              (cons
                (command (Some group)
                  "Describe the binary schema associated to the provided encoding identifier."
                    % string no_options
                  (apply (prefix "describe" % string)
                    (apply
                      (param "id" % string "Encoding identifier" % string
                        id_parameter)
                      (apply
                        (prefixes
                          (cons "binary" % string (cons "schema" % string [])))
                        stop)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    fun registered_encoding =>
                      fun cctxt =>
                        let schema :=
                          Data_encoding.Registration.binary_schema
                            registered_encoding in
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format)
                              "%a" % string) Binary_schema.pp schema)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)))
                (cons
                  (command (Some group)
                    "Describe the JSON schema associated to the provided encoding identifier."
                      % string no_options
                    (apply (prefix "describe" % string)
                      (apply
                        (param "id" % string "Encoding identifier" % string
                          id_parameter)
                        (apply
                          (prefixes
                            (cons "json" % string (cons "schema" % string [])))
                          stop)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      fun registered_encoding =>
                        fun cctxt =>
                          let schema :=
                            Data_encoding.Registration.json_schema
                              registered_encoding in
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string) Json_schema.pp schema)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit))) []))))))).

src/bin_node/genesis_chain.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018-2019 Nomadic Labs. <nomadic@tezcore.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let genesis : State.Chain.genesis =
  {
    time = Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z";
    block =
      Block_hash.of_b58check_exn
        "BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2";
    protocol =
      Protocol_hash.of_b58check_exn
        "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im";
  }
src/bin_node/genesis_chain.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition genesis : Tezos_shell.State.Chain.genesis :=
  {| time := Time.Protocol.of_notation_exn "2018-06-30T16:07:32Z" % string;
    block :=
      Block_hash.of_b58check_exn
        "BLockGenesisGenesisGenesisGenesisGenesisf79b5d1CoW2" % string;
    protocol :=
      Protocol_hash.of_b58check_exn
        "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string |}.

src/bin_node/main.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  let log s = Node_logging.fatal_error "%s" s in
  Lwt_exit.exit_on ~log Sys.sigint ;
  Lwt_exit.exit_on ~log Sys.sigterm

let () =
  if Filename.basename Sys.argv.(0) = Updater.compiler_name then (
    try
      Tezos_protocol_compiler.Compiler.main
        Tezos_protocol_compiler_native.Native.driver ;
      Pervasives.exit 0
    with exn ->
      Format.eprintf "%a\n%!" Opterrors.report_error exn ;
      Pervasives.exit 1 )

let () =
  if Filename.basename Sys.argv.(0) = "tezos-validator" then (
    try Pervasives.exit (Lwt_main.run @@ Validator.main ())
    with exn ->
      Format.eprintf "%a\n%!" Opterrors.report_error exn ;
      Pervasives.exit 1 )

let term =
  let open Cmdliner.Term in
  ret (const (`Help (`Pager, None)))

let description =
  [ `S "DESCRIPTION";
    `P "Entry point for initializing, configuring and running a Tezos node.";
    `P Node_identity_command.Manpage.command_description;
    `P Node_run_command.Manpage.command_description;
    `P Node_config_command.Manpage.command_description;
    `P Node_snapshot_command.Manpage.command_description ]

let man = description @ Node_run_command.Manpage.examples

let info =
  let version =
    Tezos_version.Current_git_info.abbreviated_commit_hash ^ " ("
    ^ Tezos_version.Current_git_info.committer_date ^ ")"
  in
  Cmdliner.Term.info ~doc:"The Tezos node" ~man ~version "tezos-node"

let commands =
  [ Node_run_command.cmd;
    Node_config_command.cmd;
    Node_identity_command.cmd;
    Node_snapshot_command.cmd ]

let () =
  Random.self_init () ;
  match Cmdliner.Term.eval_choice (term, info) commands with
  | `Error _ ->
      exit 1
  | `Help ->
      exit 0
  | `Version ->
      exit 1
  | `Ok () ->
      exit 0
src/bin_node/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.







Definition term {A : Type} : Cmdliner.Term.t A :=
  ret
    (const
      (* ❌ Variants not supported *)
      variant).

Definition description : list variant :=
  cons
    (* ❌ Variants not supported *)
    variant
    (cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant
          (cons
            (* ❌ Variants not supported *)
            variant
            (cons
              (* ❌ Variants not supported *)
              variant []))))).

Definition man : list Cmdliner.Manpage.block :=
  OCaml.Stdlib.app description Node_run_command.Manpage.examples.

Definition info : Cmdliner.Term.info :=
  let version :=
    String.append Tezos_version.Current_git_info.abbreviated_commit_hash
      (String.append " (" % string
        (String.append Tezos_version.Current_git_info.committer_date
          ")" % string)) in
  Cmdliner.Term.info None (Some man) None None None None
    (Some "The Tezos node" % string) (Some version) "tezos-node" % string.

Definition commands : list ((Cmdliner.Term.t unit) * Cmdliner.Term.info) :=
  cons Node_run_command.cmd
    (cons Node_config_command.cmd
      (cons Node_identity_command.cmd (cons Node_snapshot_command.cmd []))).



src/bin_node/node_config_command.ml 24 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Commands *)

let show (args : Node_shared_arg.t) =
  if not @@ Sys.file_exists args.config_file then
    Format.eprintf
      "\n\
       Warning: no config file at %s,\n\
      \         displaying the default configuration.\n\
       @."
      args.config_file ;
  Node_shared_arg.read_and_patch_config_file args
  >>=? fun cfg ->
  Node_config_file.check cfg
  >>= fun () ->
  print_endline @@ Node_config_file.to_string cfg ;
  return_unit

let reset (args : Node_shared_arg.t) =
  if Sys.file_exists args.config_file then
    Format.eprintf
      "Ignoring previous configuration file: %s.@."
      args.config_file ;
  Node_shared_arg.read_and_patch_config_file args
  >>=? fun cfg ->
  Node_config_file.check cfg
  >>= fun () -> Node_config_file.write args.config_file cfg

let init (args : Node_shared_arg.t) =
  if Sys.file_exists args.config_file then
    failwith "Pre-existing config file at %s, use `reset`." args.config_file
  else
    Node_shared_arg.read_and_patch_config_file args
    >>=? fun cfg ->
    Node_config_file.check cfg
    >>= fun () -> Node_config_file.write args.config_file cfg

let update (args : Node_shared_arg.t) =
  if not (Sys.file_exists args.config_file) then
    failwith
      "Missing configuration file at %s. Use `%s config init [options]` to \
       generate a new file"
      args.config_file
      Sys.argv.(0)
  else
    Node_shared_arg.read_and_patch_config_file args
    >>=? fun cfg ->
    Node_config_file.check cfg
    >>= fun () -> Node_config_file.write args.config_file cfg

(** Main *)

module Term = struct
  type subcommand = Show | Reset | Init | Update

  let process subcommand args =
    let res =
      match subcommand with
      | Show ->
          show args
      | Reset ->
          reset args
      | Init ->
          init args
      | Update ->
          update args
    in
    match Lwt_main.run res with
    | Ok () ->
        `Ok ()
    | Error err ->
        `Error (false, Format.asprintf "%a" pp_print_error err)

  let subcommand_arg =
    let parser = function
      | "show" ->
          `Ok Show
      | "reset" ->
          `Ok Reset
      | "init" ->
          `Ok Init
      | "update" ->
          `Ok Update
      | s ->
          `Error ("invalid argument: " ^ s)
    and printer ppf = function
      | Show ->
          Format.fprintf ppf "show"
      | Reset ->
          Format.fprintf ppf "reset"
      | Init ->
          Format.fprintf ppf "init"
      | Update ->
          Format.fprintf ppf "update"
    in
    let open Cmdliner.Arg in
    let doc =
      "Operation to perform. Possible values: $(b,show), $(b,reset), \
       $(b,init), $(b,update)."
    in
    value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc

  let term =
    let open Cmdliner.Term in
    ret (const process $ subcommand_arg $ Node_shared_arg.Term.args)
end

module Manpage = struct
  let command_description =
    "The $(b,config) command is meant to inspect and amend the configuration \
     of the Tezos node. This command is complementary to manually editing the \
     tezos node configuration file. Its arguments are a subset of the \
     $(i,run) command ones."

  let description =
    [ `S "DESCRIPTION";
      `P (command_description ^ " Several operations are possible: ");
      `P
        "$(b,show) reads, parses and displays Tezos current config file. Use \
         this command to see exactly what config file will be used by Tezos. \
         If additional command-line arguments are provided, the displayed \
         configuration will be amended accordingly. This is the default \
         operation.";
      `P
        "$(b,reset) will overwrite the current configuration file with a \
         factory default one. If additional command-line arguments are \
         provided, they will amend the generated file. It assumes that a \
         configuration file already exists and will abort otherwise.";
      `P
        "$(b,init) is like reset but assumes that no configuration file is \
         present and will abort otherwise.";
      `P
        "$(b,update) is the main option to edit the configuration file of \
         Tezos. It will parse command line arguments and add or replace \
         corresponding entries in the Tezos configuration file." ]

  let options =
    let schema = Data_encoding.Json.schema Node_config_file.encoding in
    let schema = Format.asprintf "@[%a@]" Json_schema.pp schema in
    let schema = String.concat "\\$" (String.split '$' schema) in
    [`S "OPTIONS"; `P "All options available in the config file"; `Pre schema]

  let man =
    description @ Node_shared_arg.Manpage.args @ options
    @ Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Manage node configuration" ~man "config"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_config_command.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition show (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if apply negb (Sys.file_exists (config_file args)) then
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "
Warning: no config file at " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                ",
         displaying the default configuration.
" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "
Warning: no config file at %s,
         displaying the default configuration.
@."
            % string) (config_file args)
    else
      tt in
  op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
    (fun cfg =>
      op_gtgteq (Node_config_file.check cfg)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply OCaml.Stdlib.print_endline (Node_config_file.to_string cfg) in
          return_unit)).

Definition reset (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if Sys.file_exists (config_file args) then
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Ignoring previous configuration file: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "Ignoring previous configuration file: %s.@." % string)
        (config_file args)
    else
      tt in
  op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
    (fun cfg =>
      op_gtgteq (Node_config_file.check cfg)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Node_config_file.write (config_file args) cfg)).

Definition init (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Sys.file_exists (config_file args) then
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Pre-existing config file at " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ", use `reset`." % string
              CamlinternalFormatBasics.End_of_format)))
        "Pre-existing config file at %s, use `reset`." % string)
      (config_file args)
  else
    op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
      (fun cfg =>
        op_gtgteq (Node_config_file.check cfg)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Node_config_file.write (config_file args) cfg)).

Definition update (args : Node_shared_arg.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if negb (Sys.file_exists (config_file args)) then
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Missing configuration file at " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ". Use `" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " config init [options]` to generate a new file" % string
                  CamlinternalFormatBasics.End_of_format)))))
        "Missing configuration file at %s. Use `%s config init [options]` to generate a new file"
          % string) (config_file args) (Array.get Sys.argv 0)
  else
    op_gtgteqquestion (Node_shared_arg.read_and_patch_config_file None args)
      (fun cfg =>
        op_gtgteq (Node_config_file.check cfg)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Node_config_file.write (config_file args) cfg)).

Module Term.
  Inductive subcommand : Type :=
  | Show : subcommand
  | Reset : subcommand
  | Init : subcommand
  | Update : subcommand.
  
  Definition process (subcommand : subcommand) (args : Node_shared_arg.t)
    : variant :=
    let res :=
      match subcommand with
      | Show => show args
      | Reset => reset args
      | Init => init args
      | Update => update args
      end in
    match Lwt_main.run res with
    | Stdlib.Ok tt =>
      (* ❌ Variants not supported *)
      variant
    | Stdlib.Error err =>
      (* ❌ Variants not supported *)
      variant
    end.
  
  Definition subcommand_arg : Cmdliner.Term.t subcommand :=
    let parser (function_parameter : string) : variant :=
      match function_parameter with
      | "show" % string =>
        (* ❌ Variants not supported *)
        variant
      | "reset" % string =>
        (* ❌ Variants not supported *)
        variant
      | "init" % string =>
        (* ❌ Variants not supported *)
        variant
      | "update" % string =>
        (* ❌ Variants not supported *)
        variant
      | s =>
        (* ❌ Variants not supported *)
        variant
      end
    with printer
      (ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
      : unit :=
      match function_parameter with
      | Show =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "show" % string
              CamlinternalFormatBasics.End_of_format) "show" % string)
      | Reset =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "reset" % string
              CamlinternalFormatBasics.End_of_format) "reset" % string)
      | Init =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "init" % string
              CamlinternalFormatBasics.End_of_format) "init" % string)
      | Update =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "update" % string
              CamlinternalFormatBasics.End_of_format) "update" % string)
      end in
    let doc :=
      "Operation to perform. Possible values: $(b,show), $(b,reset), $(b,init), $(b,update)."
        % string in
    op_and value
      (op_and (pos None 0 (parser, printer) Show)
        (info None (Some "OPERATION" % string) (Some doc) None [])).
  
  Definition term : Cmdliner.Term.t unit :=
    ret
      (op_dollar (op_dollar (const process) subcommand_arg)
        Node_shared_arg.Term.args).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,config) command is meant to inspect and amend the configuration of the Tezos node. This command is complementary to manually editing the tezos node configuration file. Its arguments are a subset of the $(i,run) command ones."
      % string.
  
  Definition description : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant
          (cons
            (* ❌ Variants not supported *)
            variant
            (cons
              (* ❌ Variants not supported *)
              variant
              (cons
                (* ❌ Variants not supported *)
                variant []))))).
  
  Definition options : list variant :=
    let schema := Data_encoding.Json.schema None Node_config_file.encoding in
    let schema :=
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
        Json_schema.pp schema in
    let schema :=
      String.concat "\$" % string (String.split "$" % char None None schema) in
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant [])).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description
      (OCaml.Stdlib.app Node_shared_arg.Manpage.args
        (OCaml.Stdlib.app options Node_shared_arg.Manpage.bugs)).
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Manage node configuration" % string) None "config" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).

src/bin_node/node_config_file.ml 66 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

let ( // ) = Filename.concat

let home = try Sys.getenv "HOME" with Not_found -> "/root"

let default_data_dir = home // ".tezos-node"

let default_rpc_port = 8732

let default_p2p_port = 9732

let default_discovery_port = 10732

type t = {
  data_dir : string;
  p2p : p2p;
  rpc : rpc;
  log : Lwt_log_sink_unix.cfg;
  internal_events : Internal_event_unix.Configuration.t;
  shell : shell;
}

and p2p = {
  expected_pow : float;
  bootstrap_peers : string list;
  listen_addr : string option;
  discovery_addr : string option;
  private_mode : bool;
  limits : P2p.limits;
  disable_mempool : bool;
  disable_testchain : bool;
  greylisting_config : P2p_point_state.Info.greylisting_config;
}

and rpc = {
  listen_addrs : string list;
  cors_origins : string list;
  cors_headers : string list;
  tls : tls option;
}

and tls = {cert : string; key : string}

and shell = {
  block_validator_limits : Node.block_validator_limits;
  prevalidator_limits : Node.prevalidator_limits;
  peer_validator_limits : Node.peer_validator_limits;
  chain_validator_limits : Node.chain_validator_limits;
  history_mode : History_mode.t option;
}

let default_p2p_limits : P2p.limits =
  {
    connection_timeout = Time.System.Span.of_seconds_exn 10.;
    authentication_timeout = Time.System.Span.of_seconds_exn 5.;
    greylist_timeout = Time.System.Span.of_seconds_exn 86400. (* one day *);
    maintenance_idle_time =
      Time.System.Span.of_seconds_exn 120. (* two minutes *);
    min_connections = 10;
    expected_connections = 50;
    max_connections = 100;
    backlog = 20;
    max_incoming_connections = 20;
    max_download_speed = None;
    max_upload_speed = None;
    read_buffer_size = 1 lsl 14;
    read_queue_size = None;
    write_queue_size = None;
    incoming_app_message_queue_size = None;
    incoming_message_queue_size = None;
    outgoing_message_queue_size = None;
    known_points_history_size = 500;
    known_peer_ids_history_size = 500;
    max_known_points = Some (400, 300);
    max_known_peer_ids = Some (400, 300);
    swap_linger = Time.System.Span.of_seconds_exn 30.;
    binary_chunks_size = None;
  }

let default_p2p =
  {
    expected_pow = 26.;
    bootstrap_peers = [];
    listen_addr = Some ("[::]:" ^ string_of_int default_p2p_port);
    discovery_addr = None;
    private_mode = false;
    limits = default_p2p_limits;
    disable_mempool = false;
    disable_testchain = false;
    greylisting_config = P2p_point_state.Info.default_greylisting_config;
  }

let default_rpc =
  {listen_addrs = []; cors_origins = []; cors_headers = []; tls = None}

let default_shell =
  {
    block_validator_limits = Node.default_block_validator_limits;
    prevalidator_limits = Node.default_prevalidator_limits;
    peer_validator_limits = Node.default_peer_validator_limits;
    chain_validator_limits = Node.default_chain_validator_limits;
    history_mode = None;
  }

let default_config =
  {
    data_dir = default_data_dir;
    p2p = default_p2p;
    rpc = default_rpc;
    log = Lwt_log_sink_unix.default_cfg;
    internal_events = Internal_event_unix.Configuration.default;
    shell = default_shell;
  }

let limit : P2p.limits Data_encoding.t =
  let open Data_encoding in
  conv
    (fun { P2p.connection_timeout;
           authentication_timeout;
           greylist_timeout;
           maintenance_idle_time;
           min_connections;
           expected_connections;
           max_connections;
           backlog;
           max_incoming_connections;
           max_download_speed;
           max_upload_speed;
           read_buffer_size;
           read_queue_size;
           write_queue_size;
           incoming_app_message_queue_size;
           incoming_message_queue_size;
           outgoing_message_queue_size;
           known_points_history_size;
           known_peer_ids_history_size;
           max_known_points;
           max_known_peer_ids;
           swap_linger;
           binary_chunks_size } ->
      ( ( ( connection_timeout,
            authentication_timeout,
            min_connections,
            expected_connections,
            max_connections,
            backlog,
            max_incoming_connections,
            max_download_speed,
            max_upload_speed,
            swap_linger ),
          ( binary_chunks_size,
            read_buffer_size,
            read_queue_size,
            write_queue_size,
            incoming_app_message_queue_size,
            incoming_message_queue_size,
            outgoing_message_queue_size,
            known_points_history_size,
            known_peer_ids_history_size,
            max_known_points ) ),
        (max_known_peer_ids, greylist_timeout, maintenance_idle_time) ))
    (fun ( ( ( connection_timeout,
               authentication_timeout,
               min_connections,
               expected_connections,
               max_connections,
               backlog,
               max_incoming_connections,
               max_download_speed,
               max_upload_speed,
               swap_linger ),
             ( binary_chunks_size,
               read_buffer_size,
               read_queue_size,
               write_queue_size,
               incoming_app_message_queue_size,
               incoming_message_queue_size,
               outgoing_message_queue_size,
               known_points_history_size,
               known_peer_ids_history_size,
               max_known_points ) ),
           (max_known_peer_ids, greylist_timeout, maintenance_idle_time) ) ->
      {
        connection_timeout;
        authentication_timeout;
        greylist_timeout;
        maintenance_idle_time;
        min_connections;
        expected_connections;
        max_connections;
        backlog;
        max_incoming_connections;
        max_download_speed;
        max_upload_speed;
        read_buffer_size;
        read_queue_size;
        write_queue_size;
        incoming_app_message_queue_size;
        incoming_message_queue_size;
        outgoing_message_queue_size;
        known_points_history_size;
        known_peer_ids_history_size;
        max_known_points;
        max_known_peer_ids;
        swap_linger;
        binary_chunks_size;
      })
    (merge_objs
       (merge_objs
          (obj10
             (dft
                "connection-timeout"
                ~description:
                  "Delay acceptable when initiating a connection to a new \
                   peer, in seconds."
                Time.System.Span.encoding
                default_p2p_limits.authentication_timeout)
             (dft
                "authentication-timeout"
                ~description:
                  "Delay granted to a peer to perform authentication, in \
                   seconds."
                Time.System.Span.encoding
                default_p2p_limits.authentication_timeout)
             (dft
                "min-connections"
                ~description:
                  "Strict minimum number of connections (triggers an urgent \
                   maintenance)."
                uint16
                default_p2p_limits.min_connections)
             (dft
                "expected-connections"
                ~description:
                  "Targeted number of connections to reach when bootstrapping \
                   / maintaining."
                uint16
                default_p2p_limits.expected_connections)
             (dft
                "max-connections"
                ~description:
                  "Maximum number of connections (exceeding peers are \
                   disconnected)."
                uint16
                default_p2p_limits.max_connections)
             (dft
                "backlog"
                ~description:
                  "Number above which pending incoming connections are \
                   immediately rejected."
                uint8
                default_p2p_limits.backlog)
             (dft
                "max-incoming-connections"
                ~description:
                  "Number above which pending incoming connections are \
                   immediately rejected."
                uint8
                default_p2p_limits.max_incoming_connections)
             (opt
                "max-download-speed"
                ~description:"Max download speeds in KiB/s."
                int31)
             (opt
                "max-upload-speed"
                ~description:"Max upload speeds in KiB/s."
                int31)
             (dft
                "swap-linger"
                Time.System.Span.encoding
                default_p2p_limits.swap_linger))
          (obj10
             (opt "binary-chunks-size" uint8)
             (dft
                "read-buffer-size"
                ~description:"Size of the buffer passed to read(2)."
                int31
                default_p2p_limits.read_buffer_size)
             (opt "read-queue-size" int31)
             (opt "write-queue-size" int31)
             (opt "incoming-app-message-queue-size" int31)
             (opt "incoming-message-queue-size" int31)
             (opt "outgoing-message-queue-size" int31)
             (dft
                "known_points_history_size"
                uint16
                default_p2p_limits.known_points_history_size)
             (dft
                "known_peer_ids_history_size"
                uint16
                default_p2p_limits.known_points_history_size)
             (opt "max_known_points" (tup2 uint16 uint16))))
       (obj3
          (opt "max_known_peer_ids" (tup2 uint16 uint16))
          (dft
             "greylist-timeout"
             ~description:"GC delay for the greylists tables, in seconds."
             Time.System.Span.encoding
             default_p2p_limits.greylist_timeout)
          (dft
             "maintenance-idle-time"
             ~description:
               "How long to wait at most, in seconds, before running a \
                maintenance loop."
             Time.System.Span.encoding
             default_p2p_limits.maintenance_idle_time)))

let p2p =
  let open Data_encoding in
  conv
    (fun { expected_pow;
           bootstrap_peers;
           listen_addr;
           discovery_addr;
           private_mode;
           limits;
           disable_mempool;
           disable_testchain;
           greylisting_config } ->
      ( expected_pow,
        bootstrap_peers,
        listen_addr,
        discovery_addr,
        private_mode,
        limits,
        disable_mempool,
        disable_testchain,
        greylisting_config ))
    (fun ( expected_pow,
           bootstrap_peers,
           listen_addr,
           discovery_addr,
           private_mode,
           limits,
           disable_mempool,
           disable_testchain,
           greylisting_config ) ->
      {
        expected_pow;
        bootstrap_peers;
        listen_addr;
        discovery_addr;
        private_mode;
        limits;
        disable_mempool;
        disable_testchain;
        greylisting_config;
      })
    (obj9
       (dft
          "expected-proof-of-work"
          ~description:
            "Floating point number between 0 and 256 that represents a \
             difficulty, 24 signifies for example that at least 24 leading \
             zeroes are expected in the hash."
          float
          default_p2p.expected_pow)
       (dft
          "bootstrap-peers"
          ~description:
            "List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If \
             the port is not specified, default port 9732 will be assumed."
          (list string)
          default_p2p.bootstrap_peers)
       (opt
          "listen-addr"
          ~description:
            "Host to listen to. If the port is not specified, the default \
             port 8732 will be assumed."
          string)
       (dft
          "discovery-addr"
          ~description:
            "Host for local peer discovery. If the port is not specified, the \
             default port 10732 will be assumed."
          (option string)
          default_p2p.discovery_addr)
       (dft
          "private-mode"
          ~description:
            "Specify if the node is in private mode or not. A node in private \
             mode rejects incoming connections from untrusted peers and only \
             opens outgoing connections to peers listed in 'bootstrap-peers' \
             or provided with '--peer' option. Moreover, these peers will \
             keep the identity and the address of the private node secret."
          bool
          false)
       (dft "limits" ~description:"Network limits" limit default_p2p_limits)
       (dft
          "disable_mempool"
          ~description:
            "If set to [true], the node will not participate in the \
             propagation of pending operations (mempool). Default value is \
             [false]. It can be used to decrease the memory and computation \
             footprints of the node."
          bool
          false)
       (dft
          "disable_testchain"
          ~description:
            "If set to [true], the node will not spawn a testchain during the \
             protocol's testing voting period. Default value is [false]. It \
             may be used used to decrease the node storage usage and \
             computation by droping the validation of the test network blocks."
          bool
          false)
       (let open P2p_point_state.Info in
       dft
         "greylisting_config"
         ~description:"The greylisting policy."
         greylisting_config_encoding
         default_greylisting_config))

let rpc : rpc Data_encoding.t =
  let open Data_encoding in
  conv
    (fun {cors_origins; cors_headers; listen_addrs; tls} ->
      let (cert, key) =
        match tls with
        | None ->
            (None, None)
        | Some {cert; key} ->
            (Some cert, Some key)
      in
      (Some listen_addrs, None, cors_origins, cors_headers, cert, key))
    (fun ( listen_addrs,
           legacy_listen_addr,
           cors_origins,
           cors_headers,
           cert,
           key ) ->
      let tls =
        match (cert, key) with
        | (None, _) | (_, None) ->
            None
        | (Some cert, Some key) ->
            Some {cert; key}
      in
      let listen_addrs =
        match (listen_addrs, legacy_listen_addr) with
        | (Some addrs, None) ->
            addrs
        | (None, Some addr) ->
            [addr]
        | (None, None) ->
            default_rpc.listen_addrs
        | (Some _, Some _) ->
            Pervasives.failwith
              "Config file: Use only \"listen-addrs\" and not (legacy) \
               \"listen-addr\"."
      in
      {listen_addrs; cors_origins; cors_headers; tls})
    (obj6
       (opt
          "listen-addrs"
          ~description:
            "Hosts to listen to. If the port is not specified, the default \
             port 8732 will be assumed."
          (list string))
       (opt "listen-addr" ~description:"Legacy value: Host to listen to" string)
       (dft
          "cors-origin"
          ~description:
            "Cross Origin Resource Sharing parameters, see \
             https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
          (list string)
          default_rpc.cors_origins)
       (dft
          "cors-headers"
          ~description:
            "Cross Origin Resource Sharing parameters, see \
             https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
          (list string)
          default_rpc.cors_headers)
       (opt
          "crt"
          ~description:"Certificate file (necessary when TLS is used)."
          string)
       (opt "key" ~description:"Key file (necessary when TLS is used)." string))

let worker_limits_encoding default_size default_level =
  let open Data_encoding in
  conv
    (fun {Worker_types.backlog_size; backlog_level} ->
      (backlog_size, backlog_level))
    (fun (backlog_size, backlog_level) -> {backlog_size; backlog_level})
    (obj2
       (dft "worker_backlog_size" uint16 default_size)
       (dft "worker_backlog_level" Internal_event.Level.encoding default_level))

let timeout_encoding = Time.System.Span.encoding

let block_validator_limits_encoding =
  let open Data_encoding in
  conv
    (fun {Node.protocol_timeout; worker_limits} ->
      (protocol_timeout, worker_limits))
    (fun (protocol_timeout, worker_limits) ->
      {protocol_timeout; worker_limits})
    (merge_objs
       (obj1
          (dft
             "protocol_request_timeout"
             timeout_encoding
             default_shell.block_validator_limits.protocol_timeout))
       (worker_limits_encoding
          default_shell.block_validator_limits.worker_limits.backlog_size
          default_shell.block_validator_limits.worker_limits.backlog_level))

let prevalidator_limits_encoding =
  let open Data_encoding in
  conv
    (fun { Node.operation_timeout;
           max_refused_operations;
           operations_batch_size;
           worker_limits } ->
      ( (operation_timeout, max_refused_operations, operations_batch_size),
        worker_limits ))
    (fun ( (operation_timeout, max_refused_operations, operations_batch_size),
           worker_limits ) ->
      {
        operation_timeout;
        max_refused_operations;
        operations_batch_size;
        worker_limits;
      })
    (merge_objs
       (obj3
          (dft
             "operations_request_timeout"
             timeout_encoding
             default_shell.prevalidator_limits.operation_timeout)
          (dft
             "max_refused_operations"
             uint16
             default_shell.prevalidator_limits.max_refused_operations)
          (dft
             "operations_batch_size"
             int31
             default_shell.prevalidator_limits.operations_batch_size))
       (worker_limits_encoding
          default_shell.prevalidator_limits.worker_limits.backlog_size
          default_shell.prevalidator_limits.worker_limits.backlog_level))

let peer_validator_limits_encoding =
  let open Data_encoding in
  let default_limits = default_shell.peer_validator_limits in
  conv
    (fun { Node.block_header_timeout;
           block_operations_timeout;
           protocol_timeout;
           new_head_request_timeout;
           worker_limits } ->
      ( ( block_header_timeout,
          block_operations_timeout,
          protocol_timeout,
          new_head_request_timeout ),
        worker_limits ))
    (fun ( ( block_header_timeout,
             block_operations_timeout,
             protocol_timeout,
             new_head_request_timeout ),
           worker_limits ) ->
      {
        block_header_timeout;
        block_operations_timeout;
        protocol_timeout;
        new_head_request_timeout;
        worker_limits;
      })
    (merge_objs
       (obj4
          (dft
             "block_header_request_timeout"
             timeout_encoding
             default_limits.block_header_timeout)
          (dft
             "block_operations_request_timeout"
             timeout_encoding
             default_limits.block_operations_timeout)
          (dft
             "protocol_request_timeout"
             timeout_encoding
             default_limits.protocol_timeout)
          (dft
             "new_head_request_timeout"
             timeout_encoding
             default_limits.new_head_request_timeout))
       (worker_limits_encoding
          default_limits.worker_limits.backlog_size
          default_limits.worker_limits.backlog_level))

let chain_validator_limits_encoding =
  let open Data_encoding in
  conv
    (fun {Node.bootstrap_threshold; worker_limits} ->
      (bootstrap_threshold, worker_limits))
    (fun (bootstrap_threshold, worker_limits) ->
      {bootstrap_threshold; worker_limits})
    (merge_objs
       (obj1
          (dft
             "bootstrap_threshold"
             ~description:
               "Set the number of peers with whom a chain synchronization \
                must be completed to bootstrap the node."
             uint8
             default_shell.chain_validator_limits.bootstrap_threshold))
       (worker_limits_encoding
          default_shell.chain_validator_limits.worker_limits.backlog_size
          default_shell.chain_validator_limits.worker_limits.backlog_level))

let shell =
  let open Data_encoding in
  conv
    (fun { peer_validator_limits;
           block_validator_limits;
           prevalidator_limits;
           chain_validator_limits;
           history_mode } ->
      ( peer_validator_limits,
        block_validator_limits,
        prevalidator_limits,
        chain_validator_limits,
        history_mode ))
    (fun ( peer_validator_limits,
           block_validator_limits,
           prevalidator_limits,
           chain_validator_limits,
           history_mode ) ->
      {
        peer_validator_limits;
        block_validator_limits;
        prevalidator_limits;
        chain_validator_limits;
        history_mode;
      })
    (obj5
       (dft
          "peer_validator"
          peer_validator_limits_encoding
          default_shell.peer_validator_limits)
       (dft
          "block_validator"
          block_validator_limits_encoding
          default_shell.block_validator_limits)
       (dft
          "prevalidator"
          prevalidator_limits_encoding
          default_shell.prevalidator_limits)
       (dft
          "chain_validator"
          chain_validator_limits_encoding
          default_shell.chain_validator_limits)
       (opt "history_mode" History_mode.encoding))

let encoding =
  let open Data_encoding in
  conv
    (fun {data_dir; rpc; p2p; log; internal_events; shell} ->
      (data_dir, rpc, p2p, log, internal_events, shell))
    (fun (data_dir, rpc, p2p, log, internal_events, shell) ->
      {data_dir; rpc; p2p; log; internal_events; shell})
    (obj6
       (dft
          "data-dir"
          ~description:"Location of the data dir on disk."
          string
          default_data_dir)
       (dft
          "rpc"
          ~description:"Configuration of rpc parameters"
          rpc
          default_rpc)
       (req "p2p" ~description:"Configuration of network parameters" p2p)
       (dft
          "log"
          ~description:
            "Configuration of the Lwt-log sink (part of the logging framework)"
          Lwt_log_sink_unix.cfg_encoding
          Lwt_log_sink_unix.default_cfg)
       (dft
          "internal-events"
          ~description:"Configuration of the structured logging framework"
          Internal_event_unix.Configuration.encoding
          Internal_event_unix.Configuration.default)
       (dft
          "shell"
          ~description:"Configuration of network parameters"
          shell
          default_shell))

let read fp =
  if Sys.file_exists fp then
    Lwt_utils_unix.Json.read_file fp
    >>=? fun json ->
    try return (Data_encoding.Json.destruct encoding json)
    with exn -> fail (Exn exn)
  else return default_config

let write fp cfg =
  Node_data_version.ensure_data_dir (Filename.dirname fp)
  >>=? fun () ->
  Lwt_utils_unix.Json.write_file fp (Data_encoding.Json.construct encoding cfg)

let to_string cfg =
  Data_encoding.Json.to_string (Data_encoding.Json.construct encoding cfg)

let update ?data_dir ?min_connections ?expected_connections ?max_connections
    ?max_download_speed ?max_upload_speed ?binary_chunks_size ?peer_table_size
    ?expected_pow ?bootstrap_peers ?listen_addr ?discovery_addr
    ?(rpc_listen_addrs = []) ?(private_mode = false) ?(disable_mempool = false)
    ?(disable_testchain = false) ?(cors_origins = []) ?(cors_headers = [])
    ?rpc_tls ?log_output ?bootstrap_threshold ?history_mode cfg =
  let data_dir = Option.unopt ~default:cfg.data_dir data_dir in
  Node_data_version.ensure_data_dir data_dir
  >>=? fun () ->
  let peer_table_size =
    Option.map peer_table_size ~f:(fun i -> (i, i / 4 * 3))
  in
  let unopt_list ~default = function [] -> default | l -> l in
  let limits : P2p.limits =
    {
      cfg.p2p.limits with
      min_connections =
        Option.unopt ~default:cfg.p2p.limits.min_connections min_connections;
      expected_connections =
        Option.unopt
          ~default:cfg.p2p.limits.expected_connections
          expected_connections;
      max_connections =
        Option.unopt ~default:cfg.p2p.limits.max_connections max_connections;
      max_download_speed =
        Option.first_some max_download_speed cfg.p2p.limits.max_download_speed;
      max_upload_speed =
        Option.first_some max_upload_speed cfg.p2p.limits.max_upload_speed;
      max_known_points =
        Option.first_some peer_table_size cfg.p2p.limits.max_known_points;
      max_known_peer_ids =
        Option.first_some peer_table_size cfg.p2p.limits.max_known_peer_ids;
      binary_chunks_size = Option.map ~f:(fun x -> x lsl 10) binary_chunks_size;
    }
  in
  let p2p : p2p =
    {
      expected_pow = Option.unopt ~default:cfg.p2p.expected_pow expected_pow;
      bootstrap_peers =
        Option.unopt ~default:cfg.p2p.bootstrap_peers bootstrap_peers;
      listen_addr = Option.first_some listen_addr cfg.p2p.listen_addr;
      discovery_addr = Option.first_some discovery_addr cfg.p2p.discovery_addr;
      private_mode = cfg.p2p.private_mode || private_mode;
      limits;
      disable_mempool = cfg.p2p.disable_mempool || disable_mempool;
      disable_testchain = cfg.p2p.disable_testchain || disable_testchain;
      greylisting_config = cfg.p2p.greylisting_config;
    }
  and rpc : rpc =
    {
      listen_addrs = unopt_list ~default:cfg.rpc.listen_addrs rpc_listen_addrs;
      cors_origins = unopt_list ~default:cfg.rpc.cors_origins cors_origins;
      cors_headers = unopt_list ~default:cfg.rpc.cors_headers cors_headers;
      tls = Option.first_some rpc_tls cfg.rpc.tls;
    }
  and log : Lwt_log_sink_unix.cfg =
    {cfg.log with output = Option.unopt ~default:cfg.log.output log_output}
  and shell : shell =
    {
      peer_validator_limits = cfg.shell.peer_validator_limits;
      block_validator_limits = cfg.shell.block_validator_limits;
      prevalidator_limits = cfg.shell.prevalidator_limits;
      chain_validator_limits =
        Option.unopt_map
          ~default:cfg.shell.chain_validator_limits
          ~f:(fun bootstrap_threshold ->
            {cfg.shell.chain_validator_limits with bootstrap_threshold})
          bootstrap_threshold;
      history_mode = Option.first_some history_mode cfg.shell.history_mode;
    }
  in
  let internal_events = cfg.internal_events in
  return {data_dir; p2p; rpc; log; internal_events; shell}

let resolve_addr ~default_addr ?default_port ?(passive = false) peer =
  let (addr, port) = P2p_point.Id.parse_addr_port peer in
  let node = if addr = "" || addr = "_" then default_addr else addr
  and service =
    match (port, default_port) with
    | ("", None) ->
        invalid_arg ""
    | ("", Some default_port) ->
        string_of_int default_port
    | (port, _) ->
        port
  in
  Lwt_utils_unix.getaddrinfo ~passive ~node ~service

let resolve_addrs ~default_addr ?default_port ?passive peers =
  Lwt_list.fold_left_s
    (fun a peer ->
      resolve_addr ~default_addr ?default_port ?passive peer
      >>= fun points -> Lwt.return (List.rev_append points a))
    []
    peers

let resolve_discovery_addrs discovery_addr =
  resolve_addr
    ~default_addr:Ipaddr.V4.(to_string broadcast)
    ~default_port:default_discovery_port
    ~passive:true
    discovery_addr
  >>= fun addrs ->
  let rec to_ipv4 acc = function
    | [] ->
        Lwt.return (List.rev acc)
    | (ip, port) :: xs -> (
      match Ipaddr.v4_of_v6 ip with
      | Some v ->
          to_ipv4 ((v, port) :: acc) xs
      | None ->
          Format.eprintf
            "Warning: failed to convert %S to an ipv4 address@."
            (Ipaddr.V6.to_string ip) ;
          to_ipv4 acc xs )
  in
  to_ipv4 [] addrs

let resolve_listening_addrs listen_addr =
  resolve_addr
    ~default_addr:"::"
    ~default_port:default_p2p_port
    ~passive:true
    listen_addr

let resolve_rpc_listening_addrs listen_addr =
  resolve_addr
    ~default_addr:"::"
    ~default_port:default_rpc_port
    ~passive:true
    listen_addr

let resolve_bootstrap_addrs peers =
  resolve_addrs ~default_addr:"::" ~default_port:default_p2p_port peers

let check_listening_addrs config =
  match config.p2p.listen_addr with
  | None ->
      Lwt.return_unit
  | Some addr ->
      Lwt.catch
        (fun () ->
          resolve_listening_addrs addr
          >>= function
          | [] ->
              Format.eprintf "Warning: failed to resolve %S\n@." addr ;
              Lwt.return_unit
          | _ :: _ ->
              Lwt.return_unit)
        (function
          | Invalid_argument msg ->
              Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
              Lwt.return_unit
          | exn ->
              Lwt.fail exn)

let check_discovery_addr config =
  match config.p2p.discovery_addr with
  | None ->
      Lwt.return_unit
  | Some addr ->
      Lwt.catch
        (fun () ->
          resolve_discovery_addrs addr
          >>= function
          | [] ->
              Format.eprintf "Warning: failed to resolve %S\n@." addr ;
              Lwt.return_unit
          | _ :: _ ->
              Lwt.return_unit)
        (function
          | Invalid_argument msg ->
              Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
              Lwt.return_unit
          | exn ->
              Lwt.fail exn)

let check_rpc_listening_addr config =
  Lwt_list.iter_p
    (fun addr ->
      Lwt.catch
        (fun () ->
          resolve_rpc_listening_addrs addr
          >>= function
          | [] ->
              Format.eprintf "Warning: failed to resolve %S\n@." addr ;
              Lwt.return_unit
          | _ :: _ ->
              Lwt.return_unit)
        (function
          | Invalid_argument msg ->
              Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
              Lwt.return_unit
          | exn ->
              Lwt.fail exn))
    config.rpc.listen_addrs

let check_bootstrap_peer addr =
  Lwt.catch
    (fun () ->
      resolve_bootstrap_addrs [addr]
      >>= function
      | [] ->
          Format.eprintf "Warning: cannot resolve %S\n@." addr ;
          Lwt.return_unit
      | _ :: _ ->
          Lwt.return_unit)
    (function
      | Invalid_argument msg ->
          Format.eprintf "Warning: failed to parse %S:   %s\n@." addr msg ;
          Lwt.return_unit
      | exn ->
          Lwt.fail exn)

let check_bootstrap_peers config =
  Lwt_list.iter_p check_bootstrap_peer config.p2p.bootstrap_peers

let fail fmt = Format.kasprintf (fun s -> prerr_endline s ; exit 1) fmt

let check_connections config =
  if config.p2p.limits.min_connections > config.p2p.limits.expected_connections
  then
    fail
      "Error: The minumum number of connections is greater than the expected \
       number of connections"
      config.p2p.limits.min_connections
      config.p2p.limits.expected_connections ;
  if config.p2p.limits.expected_connections > config.p2p.limits.max_connections
  then
    fail
      "Error: The expected number of connections is greater than the maximum \
       number of connections"
      config.p2p.limits.expected_connections
      config.p2p.limits.max_connections ;
  ( match config.p2p.limits.max_known_peer_ids with
  | None ->
      ()
  | Some (max_known_peer_ids, target_known_peer_ids) ->
      if target_known_peer_ids > max_known_peer_ids then
        fail
          "Error: The target number of known peer ids is greater than the \
           maximum number of known peer ids."
          target_known_peer_ids
          max_known_peer_ids ;
      if config.p2p.limits.max_connections > target_known_peer_ids then
        fail
          "Error: The target number of known peer ids is lower than the \
           maximum number of connections."
          target_known_peer_ids
          max_known_peer_ids ) ;
  match config.p2p.limits.max_known_points with
  | None ->
      ()
  | Some (max_known_points, target_known_points) ->
      if target_known_points > max_known_points then
        fail
          "Error: The target number of known points is greater than the \
           maximum number of known points."
          target_known_points
          max_known_points ;
      if config.p2p.limits.max_connections > target_known_points then
        fail
          "Error: The target number of known points is lower than the maximum \
           number of connections."
          target_known_points
          max_known_points

let check config =
  check_listening_addrs config
  >>= fun () ->
  check_rpc_listening_addr config
  >>= fun () ->
  check_discovery_addr config
  >>= fun () ->
  check_bootstrap_peers config
  >>= fun () -> check_connections config ; Lwt.return_unit
src/bin_node/node_config_file.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition home : string :=
  (* ❌ Try-with are not handled *)
  try (Sys.getenv "HOME" % string).

Definition default_data_dir : string := op_divdiv home ".tezos-node" % string.

Definition default_rpc_port : Z := 8732.

Definition default_p2p_port : Z := 9732.

Definition default_discovery_port : Z := 10732.

.

Definition default_p2p_limits : Tezos_p2p.P2p.limits :=
  {|
    connection_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 10. is approximated by the integer 10 *)
        10;
    authentication_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 5. is approximated by the integer 5 *)
        5;
    greylist_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 86400. is approximated by the integer 86400 *)
        86400;
    maintenance_idle_time :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 120. is approximated by the integer 120 *)
        120; min_connections := 10; expected_connections := 50;
    max_connections := 100; backlog := 20; max_incoming_connections := 20;
    max_download_speed := None; max_upload_speed := None;
    read_buffer_size := Z.shiftl 1 14; read_queue_size := None;
    write_queue_size := None; incoming_app_message_queue_size := None;
    incoming_message_queue_size := None; outgoing_message_queue_size := None;
    known_peer_ids_history_size := 500; known_points_history_size := 500;
    max_known_peer_ids := Some (400, 300); max_known_points := Some (400, 300);
    swap_linger :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 30. is approximated by the integer 30 *)
        30; binary_chunks_size := None |}.

Definition default_p2p : p2p :=
  {|
    expected_pow :=
      (* ❌ Float constant 26. is approximated by the integer 26 *)
      26; bootstrap_peers := [];
    listen_addr :=
      Some
        (String.append "[::]:" % string
          (OCaml.Stdlib.string_of_int default_p2p_port));
    discovery_addr := None; private_mode := false; limits := default_p2p_limits;
    disable_mempool := false; disable_testchain := false;
    greylisting_config := P2p_point_state.Info.default_greylisting_config |}.

Definition default_rpc : rpc :=
  {| listen_addrs := []; cors_origins := []; cors_headers := []; tls := None |}.

Definition default_shell : shell :=
  {| block_validator_limits := Node.default_block_validator_limits;
    prevalidator_limits := Node.default_prevalidator_limits;
    peer_validator_limits := Node.default_peer_validator_limits;
    chain_validator_limits := Node.default_chain_validator_limits;
    history_mode := None |}.

Definition default_config : t :=
  {| data_dir := default_data_dir; p2p := default_p2p; rpc := default_rpc;
    log := Lwt_log_sink_unix.default_cfg;
    internal_events := Internal_event_unix.Configuration.default;
    shell := default_shell |}.

Definition limit
  : Tezos_base__TzPervasives.Data_encoding.t Tezos_p2p.P2p.limits :=
  conv
    (fun function_parameter =>
      let '{|
        P2p.connection_timeout := connection_timeout;
          P2p.authentication_timeout := authentication_timeout;
          P2p.greylist_timeout := greylist_timeout;
          P2p.maintenance_idle_time := maintenance_idle_time;
          P2p.min_connections := min_connections;
          P2p.expected_connections := expected_connections;
          P2p.max_connections := max_connections;
          P2p.backlog := backlog;
          P2p.max_incoming_connections := max_incoming_connections;
          P2p.max_download_speed := max_download_speed;
          P2p.max_upload_speed := max_upload_speed;
          P2p.read_buffer_size := read_buffer_size;
          P2p.read_queue_size := read_queue_size;
          P2p.write_queue_size := write_queue_size;
          P2p.incoming_app_message_queue_size := incoming_app_message_queue_size;
          P2p.incoming_message_queue_size := incoming_message_queue_size;
          P2p.outgoing_message_queue_size := outgoing_message_queue_size;
          P2p.known_peer_ids_history_size := known_peer_ids_history_size;
          P2p.known_points_history_size := known_points_history_size;
          P2p.max_known_peer_ids := max_known_peer_ids;
          P2p.max_known_points := max_known_points;
          P2p.swap_linger := swap_linger;
          P2p.binary_chunks_size := binary_chunks_size
          |} := function_parameter in
      (((connection_timeout, authentication_timeout, min_connections,
        expected_connections, max_connections, backlog,
        max_incoming_connections, max_download_speed, max_upload_speed,
        swap_linger),
        (binary_chunks_size, read_buffer_size, read_queue_size,
          write_queue_size, incoming_app_message_queue_size,
          incoming_message_queue_size, outgoing_message_queue_size,
          known_points_history_size, known_peer_ids_history_size,
          max_known_points)),
        (max_known_peer_ids, greylist_timeout, maintenance_idle_time)))
    (fun function_parameter =>
      let
        '(((connection_timeout, authentication_timeout, min_connections,
          expected_connections, max_connections, backlog,
          max_incoming_connections, max_download_speed, max_upload_speed,
          swap_linger),
          (binary_chunks_size, read_buffer_size, read_queue_size,
            write_queue_size, incoming_app_message_queue_size,
            incoming_message_queue_size, outgoing_message_queue_size,
            known_points_history_size, known_peer_ids_history_size,
            max_known_points)),
          (max_known_peer_ids, greylist_timeout, maintenance_idle_time)) :=
        function_parameter in
      {| connection_timeout := connection_timeout;
        authentication_timeout := authentication_timeout;
        greylist_timeout := greylist_timeout;
        maintenance_idle_time := maintenance_idle_time;
        min_connections := min_connections;
        expected_connections := expected_connections;
        max_connections := max_connections; backlog := backlog;
        max_incoming_connections := max_incoming_connections;
        max_download_speed := max_download_speed;
        max_upload_speed := max_upload_speed;
        read_buffer_size := read_buffer_size;
        read_queue_size := read_queue_size;
        write_queue_size := write_queue_size;
        incoming_app_message_queue_size := incoming_app_message_queue_size;
        incoming_message_queue_size := incoming_message_queue_size;
        outgoing_message_queue_size := outgoing_message_queue_size;
        known_peer_ids_history_size := known_peer_ids_history_size;
        known_points_history_size := known_points_history_size;
        max_known_peer_ids := max_known_peer_ids;
        max_known_points := max_known_points; swap_linger := swap_linger;
        binary_chunks_size := binary_chunks_size |}) None
    (merge_objs
      (merge_objs
        (obj10
          (dft None
            (Some
              "Delay acceptable when initiating a connection to a new peer, in seconds."
                % string) "connection-timeout" % string
            Time.System.Span.encoding
            (authentication_timeout default_p2p_limits))
          (dft None
            (Some
              "Delay granted to a peer to perform authentication, in seconds." %
                string) "authentication-timeout" % string
            Time.System.Span.encoding
            (authentication_timeout default_p2p_limits))
          (dft None
            (Some
              "Strict minimum number of connections (triggers an urgent maintenance)."
                % string) "min-connections" % string uint16
            (min_connections default_p2p_limits))
          (dft None
            (Some
              "Targeted number of connections to reach when bootstrapping / maintaining."
                % string) "expected-connections" % string uint16
            (expected_connections default_p2p_limits))
          (dft None
            (Some
              "Maximum number of connections (exceeding peers are disconnected)."
                % string) "max-connections" % string uint16
            (max_connections default_p2p_limits))
          (dft None
            (Some
              "Number above which pending incoming connections are immediately rejected."
                % string) "backlog" % string uint8 (backlog default_p2p_limits))
          (dft None
            (Some
              "Number above which pending incoming connections are immediately rejected."
                % string) "max-incoming-connections" % string uint8
            (max_incoming_connections default_p2p_limits))
          (opt None (Some "Max download speeds in KiB/s." % string)
            "max-download-speed" % string int31)
          (opt None (Some "Max upload speeds in KiB/s." % string)
            "max-upload-speed" % string int31)
          (dft None None "swap-linger" % string Time.System.Span.encoding
            (swap_linger default_p2p_limits)))
        (obj10 (opt None None "binary-chunks-size" % string uint8)
          (dft None (Some "Size of the buffer passed to read(2)." % string)
            "read-buffer-size" % string int31
            (read_buffer_size default_p2p_limits))
          (opt None None "read-queue-size" % string int31)
          (opt None None "write-queue-size" % string int31)
          (opt None None "incoming-app-message-queue-size" % string int31)
          (opt None None "incoming-message-queue-size" % string int31)
          (opt None None "outgoing-message-queue-size" % string int31)
          (dft None None "known_points_history_size" % string uint16
            (known_points_history_size default_p2p_limits))
          (dft None None "known_peer_ids_history_size" % string uint16
            (known_points_history_size default_p2p_limits))
          (opt None None "max_known_points" % string (tup2 uint16 uint16))))
      (obj3 (opt None None "max_known_peer_ids" % string (tup2 uint16 uint16))
        (dft None
          (Some "GC delay for the greylists tables, in seconds." % string)
          "greylist-timeout" % string Time.System.Span.encoding
          (greylist_timeout default_p2p_limits))
        (dft None
          (Some
            "How long to wait at most, in seconds, before running a maintenance loop."
              % string) "maintenance-idle-time" % string
          Time.System.Span.encoding (maintenance_idle_time default_p2p_limits)))).

Definition p2p : Tezos_base__TzPervasives.Data_encoding.encoding p2p :=
  conv
    (fun function_parameter =>
      let '{|
        expected_pow := expected_pow;
          bootstrap_peers := bootstrap_peers;
          listen_addr := listen_addr;
          discovery_addr := discovery_addr;
          private_mode := private_mode;
          limits := limits;
          disable_mempool := disable_mempool;
          disable_testchain := disable_testchain;
          greylisting_config := greylisting_config
          |} := function_parameter in
      (expected_pow, bootstrap_peers, listen_addr, discovery_addr, private_mode,
        limits, disable_mempool, disable_testchain, greylisting_config))
    (fun function_parameter =>
      let
        '(expected_pow, bootstrap_peers, listen_addr, discovery_addr,
          private_mode, limits, disable_mempool, disable_testchain,
          greylisting_config) := function_parameter in
      {| expected_pow := expected_pow; bootstrap_peers := bootstrap_peers;
        listen_addr := listen_addr; discovery_addr := discovery_addr;
        private_mode := private_mode; limits := limits;
        disable_mempool := disable_mempool;
        disable_testchain := disable_testchain;
        greylisting_config := greylisting_config |}) None
    (obj9
      (dft None
        (Some
          "Floating point number between 0 and 256 that represents a difficulty, 24 signifies for example that at least 24 leading zeroes are expected in the hash."
            % string) "expected-proof-of-work" % string float
        (expected_pow default_p2p))
      (dft None
        (Some
          "List of hosts. Tezos can connect to both IPv6 and IPv4 hosts. If the port is not specified, default port 9732 will be assumed."
            % string) "bootstrap-peers" % string (list None string)
        (bootstrap_peers default_p2p))
      (opt None
        (Some
          "Host to listen to. If the port is not specified, the default port 8732 will be assumed."
            % string) "listen-addr" % string string)
      (dft None
        (Some
          "Host for local peer discovery. If the port is not specified, the default port 10732 will be assumed."
            % string) "discovery-addr" % string (option string)
        (discovery_addr default_p2p))
      (dft None
        (Some
          "Specify if the node is in private mode or not. A node in private mode rejects incoming connections from untrusted peers and only opens outgoing connections to peers listed in 'bootstrap-peers' or provided with '--peer' option. Moreover, these peers will keep the identity and the address of the private node secret."
            % string) "private-mode" % string bool false)
      (dft None (Some "Network limits" % string) "limits" % string limit
        default_p2p_limits)
      (dft None
        (Some
          "If set to [true], the node will not participate in the propagation of pending operations (mempool). Default value is [false]. It can be used to decrease the memory and computation footprints of the node."
            % string) "disable_mempool" % string bool false)
      (dft None
        (Some
          "If set to [true], the node will not spawn a testchain during the protocol's testing voting period. Default value is [false]. It may be used used to decrease the node storage usage and computation by droping the validation of the test network blocks."
            % string) "disable_testchain" % string bool false)
      (dft None (Some "The greylisting policy." % string)
        "greylisting_config" % string greylisting_config_encoding
        default_greylisting_config)).

Definition rpc : Tezos_base__TzPervasives.Data_encoding.t rpc :=
  conv
    (fun function_parameter =>
      let '{|
        listen_addrs := listen_addrs;
          cors_origins := cors_origins;
          cors_headers := cors_headers;
          tls := tls
          |} := function_parameter in
      let '(cert, key) :=
        match tls with
        | None => (None, None)
        | Some {| cert := cert; key := key |} => ((Some cert), (Some key))
        end in
      ((Some listen_addrs), None, cors_origins, cors_headers, cert, key))
    (fun function_parameter =>
      let
        '(listen_addrs, legacy_listen_addr, cors_origins, cors_headers, cert,
          key) := function_parameter in
      let tls :=
        match (cert, key) with
        | (None, _) | (_, None) => None
        | (Some cert, Some key) => Some {| cert := cert; key := key |}
        end in
      let listen_addrs :=
        match (listen_addrs, legacy_listen_addr) with
        | (Some addrs, None) => addrs
        | (None, Some addr) => cons addr []
        | (None, None) => listen_addrs default_rpc
        | (Some _, Some _) =>
          Pervasives.failwith
            "Config file: Use only ""listen-addrs"" and not (legacy) ""listen-addr""."
              % string
        end in
      {| listen_addrs := listen_addrs; cors_origins := cors_origins;
        cors_headers := cors_headers; tls := tls |}) None
    (obj6
      (opt None
        (Some
          "Hosts to listen to. If the port is not specified, the default port 8732 will be assumed."
            % string) "listen-addrs" % string (list None string))
      (opt None (Some "Legacy value: Host to listen to" % string)
        "listen-addr" % string string)
      (dft None
        (Some
          "Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
            % string) "cors-origin" % string (list None string)
        (cors_origins default_rpc))
      (dft None
        (Some
          "Cross Origin Resource Sharing parameters, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing."
            % string) "cors-headers" % string (list None string)
        (cors_headers default_rpc))
      (opt None (Some "Certificate file (necessary when TLS is used)." % string)
        "crt" % string string)
      (opt None (Some "Key file (necessary when TLS is used)." % string)
        "key" % string string)).

Definition worker_limits_encoding
  (default_size : Z)
  (default_level : Tezos_base__TzPervasives.Internal_event.Level.t)
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell_services.Worker_types.limits :=
  conv
    (fun function_parameter =>
      let '{|
        Worker_types.backlog_size := backlog_size;
          Worker_types.backlog_level := backlog_level
          |} := function_parameter in
      (backlog_size, backlog_level))
    (fun function_parameter =>
      let '(backlog_size, backlog_level) := function_parameter in
      {| backlog_size := backlog_size; backlog_level := backlog_level |}) None
    (obj2 (dft None None "worker_backlog_size" % string uint16 default_size)
      (dft None None "worker_backlog_level" % string
        Internal_event.Level.encoding default_level)).

Definition timeout_encoding
  : Tezos_data_encoding.Data_encoding.t
    Tezos_base__TzPervasives.Time.System.Span.t := Time.System.Span.encoding.

Definition block_validator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.block_validator_limits :=
  conv
    (fun function_parameter =>
      let '{|
        Node.protocol_timeout := protocol_timeout;
          Node.worker_limits := worker_limits
          |} := function_parameter in
      (protocol_timeout, worker_limits))
    (fun function_parameter =>
      let '(protocol_timeout, worker_limits) := function_parameter in
      {| protocol_timeout := protocol_timeout; worker_limits := worker_limits |})
    None
    (merge_objs
      (obj1
        (dft None None "protocol_request_timeout" % string timeout_encoding
          (protocol_timeout (block_validator_limits default_shell))))
      (worker_limits_encoding
        (backlog_size (worker_limits (block_validator_limits default_shell)))
        (backlog_level (worker_limits (block_validator_limits default_shell))))).

Definition prevalidator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.prevalidator_limits :=
  conv
    (fun function_parameter =>
      let '{|
        Node.max_refused_operations := max_refused_operations;
          Node.operation_timeout := operation_timeout;
          Node.worker_limits := worker_limits;
          Node.operations_batch_size := operations_batch_size
          |} := function_parameter in
      ((operation_timeout, max_refused_operations, operations_batch_size),
        worker_limits))
    (fun function_parameter =>
      let
        '((operation_timeout, max_refused_operations, operations_batch_size),
          worker_limits) := function_parameter in
      {| max_refused_operations := max_refused_operations;
        operation_timeout := operation_timeout; worker_limits := worker_limits;
        operations_batch_size := operations_batch_size |}) None
    (merge_objs
      (obj3
        (dft None None "operations_request_timeout" % string timeout_encoding
          (operation_timeout (prevalidator_limits default_shell)))
        (dft None None "max_refused_operations" % string uint16
          (max_refused_operations (prevalidator_limits default_shell)))
        (dft None None "operations_batch_size" % string int31
          (operations_batch_size (prevalidator_limits default_shell))))
      (worker_limits_encoding
        (backlog_size (worker_limits (prevalidator_limits default_shell)))
        (backlog_level (worker_limits (prevalidator_limits default_shell))))).

Definition peer_validator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.peer_validator_limits :=
  let default_limits := peer_validator_limits default_shell in
  conv
    (fun function_parameter =>
      let '{|
        Node.new_head_request_timeout := new_head_request_timeout;
          Node.block_header_timeout := block_header_timeout;
          Node.block_operations_timeout := block_operations_timeout;
          Node.protocol_timeout := protocol_timeout;
          Node.worker_limits := worker_limits
          |} := function_parameter in
      ((block_header_timeout, block_operations_timeout, protocol_timeout,
        new_head_request_timeout), worker_limits))
    (fun function_parameter =>
      let
        '((block_header_timeout, block_operations_timeout, protocol_timeout,
          new_head_request_timeout), worker_limits) := function_parameter in
      {| new_head_request_timeout := new_head_request_timeout;
        block_header_timeout := block_header_timeout;
        block_operations_timeout := block_operations_timeout;
        protocol_timeout := protocol_timeout; worker_limits := worker_limits |})
    None
    (merge_objs
      (obj4
        (dft None None "block_header_request_timeout" % string timeout_encoding
          (block_header_timeout default_limits))
        (dft None None "block_operations_request_timeout" % string
          timeout_encoding (block_operations_timeout default_limits))
        (dft None None "protocol_request_timeout" % string timeout_encoding
          (protocol_timeout default_limits))
        (dft None None "new_head_request_timeout" % string timeout_encoding
          (new_head_request_timeout default_limits)))
      (worker_limits_encoding (backlog_size (worker_limits default_limits))
        (backlog_level (worker_limits default_limits)))).

Definition chain_validator_limits_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_shell.Node.chain_validator_limits :=
  conv
    (fun function_parameter =>
      let '{|
        Node.bootstrap_threshold := bootstrap_threshold;
          Node.worker_limits := worker_limits
          |} := function_parameter in
      (bootstrap_threshold, worker_limits))
    (fun function_parameter =>
      let '(bootstrap_threshold, worker_limits) := function_parameter in
      {| bootstrap_threshold := bootstrap_threshold;
        worker_limits := worker_limits |}) None
    (merge_objs
      (obj1
        (dft None
          (Some
            "Set the number of peers with whom a chain synchronization must be completed to bootstrap the node."
              % string) "bootstrap_threshold" % string uint8
          (bootstrap_threshold (chain_validator_limits default_shell))))
      (worker_limits_encoding
        (backlog_size (worker_limits (chain_validator_limits default_shell)))
        (backlog_level (worker_limits (chain_validator_limits default_shell))))).

Definition shell : Tezos_base__TzPervasives.Data_encoding.encoding shell :=
  conv
    (fun function_parameter =>
      let '{|
        block_validator_limits := block_validator_limits;
          prevalidator_limits := prevalidator_limits;
          peer_validator_limits := peer_validator_limits;
          chain_validator_limits := chain_validator_limits;
          history_mode := history_mode
          |} := function_parameter in
      (peer_validator_limits, block_validator_limits, prevalidator_limits,
        chain_validator_limits, history_mode))
    (fun function_parameter =>
      let
        '(peer_validator_limits, block_validator_limits, prevalidator_limits,
          chain_validator_limits, history_mode) := function_parameter in
      {| block_validator_limits := block_validator_limits;
        prevalidator_limits := prevalidator_limits;
        peer_validator_limits := peer_validator_limits;
        chain_validator_limits := chain_validator_limits;
        history_mode := history_mode |}) None
    (obj5
      (dft None None "peer_validator" % string peer_validator_limits_encoding
        (peer_validator_limits default_shell))
      (dft None None "block_validator" % string block_validator_limits_encoding
        (block_validator_limits default_shell))
      (dft None None "prevalidator" % string prevalidator_limits_encoding
        (prevalidator_limits default_shell))
      (dft None None "chain_validator" % string chain_validator_limits_encoding
        (chain_validator_limits default_shell))
      (opt None None "history_mode" % string History_mode.encoding)).

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  conv
    (fun function_parameter =>
      let '{|
        data_dir := data_dir;
          p2p := p2p;
          rpc := rpc;
          log := log;
          internal_events := internal_events;
          shell := shell
          |} := function_parameter in
      (data_dir, rpc, p2p, log, internal_events, shell))
    (fun function_parameter =>
      let '(data_dir, rpc, p2p, log, internal_events, shell) :=
        function_parameter in
      {| data_dir := data_dir; p2p := p2p; rpc := rpc; log := log;
        internal_events := internal_events; shell := shell |}) None
    (obj6
      (dft None (Some "Location of the data dir on disk." % string)
        "data-dir" % string string default_data_dir)
      (dft None (Some "Configuration of rpc parameters" % string) "rpc" % string
        rpc default_rpc)
      (req None (Some "Configuration of network parameters" % string)
        "p2p" % string p2p)
      (dft None
        (Some
          "Configuration of the Lwt-log sink (part of the logging framework)" %
            string) "log" % string Lwt_log_sink_unix.cfg_encoding
        Lwt_log_sink_unix.default_cfg)
      (dft None
        (Some "Configuration of the structured logging framework" % string)
        "internal-events" % string Internal_event_unix.Configuration.encoding
        Internal_event_unix.Configuration.default)
      (dft None (Some "Configuration of network parameters" % string)
        "shell" % string shell default_shell)).

Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  if Sys.file_exists fp then
    op_gtgteqquestion (Lwt_utils_unix.Json.read_file fp)
      (fun json =>
        (* ❌ Try-with are not handled *)
        try (_return (Data_encoding.Json.destruct encoding json)))
  else
    _return default_config.

Definition write (fp : string) (cfg : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (Node_data_version.ensure_data_dir None (Filename.dirname fp))
    (fun function_parameter =>
      let 'tt := function_parameter in
      Lwt_utils_unix.Json.write_file fp
        (Data_encoding.Json.construct encoding cfg)).

Definition to_string (cfg : t) : string :=
  Data_encoding.Json.to_string None None
    (Data_encoding.Json.construct encoding cfg).

Definition update
  (data_dir : option string) (min_connections : option Z)
  (expected_connections : option Z) (max_connections : option Z)
  (max_download_speed : option Z) (max_upload_speed : option Z)
  (binary_chunks_size : option Z) (peer_table_size : option Z)
  (expected_pow : option Z) (bootstrap_peers : option (list string))
  (listen_addr : option string) (discovery_addr : option string)
  (op_staroptstar : option (list string))
  : (option bool) ->
    (option bool) ->
      (option bool) ->
        (option (list string)) ->
          (option (list string)) ->
            (option tls) ->
              (option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t) ->
                (option Z) ->
                  (option Tezos_shell_services.History_mode.t) ->
                    t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let rpc_listen_addrs :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun op_staroptstar =>
    let private_mode :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun op_staroptstar =>
      let disable_mempool :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => false
        end in
      fun op_staroptstar =>
        let disable_testchain :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => false
          end in
        fun op_staroptstar =>
          let cors_origins :=
            match op_staroptstar with
            | Some op_starsthstar => op_starsthstar
            | None => []
            end in
          fun op_staroptstar =>
            let cors_headers :=
              match op_staroptstar with
              | Some op_starsthstar => op_starsthstar
              | None => []
              end in
            fun rpc_tls =>
              fun log_output =>
                fun bootstrap_threshold =>
                  fun history_mode =>
                    fun cfg =>
                      let data_dir := Option.unopt (data_dir cfg) data_dir in
                      op_gtgteqquestion
                        (Node_data_version.ensure_data_dir None data_dir)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          let peer_table_size :=
                            Option.map (fun i => (i, (Z.mul (Z.div i 4) 3)))
                              peer_table_size in
                          let unopt_list {A : Type}
                            (default : list A) (function_parameter : list A)
                            : list A :=
                            match function_parameter with
                            | [] => default
                            | l => l
                            end in
                          let limits :=
                            (* ❌ Record substitution not handled *)
                            record_substitution in
                          let p2p : p2p :=
                            {|
                              expected_pow :=
                                Option.unopt (expected_pow (p2p cfg))
                                  expected_pow;
                              bootstrap_peers :=
                                Option.unopt (bootstrap_peers (p2p cfg))
                                  bootstrap_peers;
                              listen_addr :=
                                Option.first_some listen_addr
                                  (listen_addr (p2p cfg));
                              discovery_addr :=
                                Option.first_some discovery_addr
                                  (discovery_addr (p2p cfg));
                              private_mode :=
                                orb (private_mode (p2p cfg)) private_mode;
                              limits := limits;
                              disable_mempool :=
                                orb (disable_mempool (p2p cfg)) disable_mempool;
                              disable_testchain :=
                                orb (disable_testchain (p2p cfg))
                                  disable_testchain;
                              greylisting_config := greylisting_config (p2p cfg)
                              |}
                          with rpc : rpc :=
                            {|
                              listen_addrs :=
                                unopt_list (listen_addrs (rpc cfg))
                                  rpc_listen_addrs;
                              cors_origins :=
                                unopt_list (cors_origins (rpc cfg)) cors_origins;
                              cors_headers :=
                                unopt_list (cors_headers (rpc cfg)) cors_headers;
                              tls := Option.first_some rpc_tls (tls (rpc cfg))
                              |}
                          with log : Tezos_stdlib_unix.Lwt_log_sink_unix.cfg :=
                            (* ❌ Record substitution not handled *)
                            record_substitution
                          with shell : shell :=
                            {|
                              block_validator_limits :=
                                block_validator_limits (shell cfg);
                              prevalidator_limits :=
                                prevalidator_limits (shell cfg);
                              peer_validator_limits :=
                                peer_validator_limits (shell cfg);
                              chain_validator_limits :=
                                Option.unopt_map
                                  (fun bootstrap_threshold =>
                                    (* ❌ Record substitution not handled *)
                                    record_substitution)
                                  (chain_validator_limits (shell cfg))
                                  bootstrap_threshold;
                              history_mode :=
                                Option.first_some history_mode
                                  (history_mode (shell cfg)) |} in
                          let internal_events := internal_events cfg in
                          _return
                            {| data_dir := data_dir; p2p := p2p; rpc := rpc;
                              log := log; internal_events := internal_events;
                              shell := shell |}).

Definition resolve_addr
  (default_addr : string) (default_port : option Z)
  (op_staroptstar : option bool) : string -> Lwt.t (list (Ipaddr.V6.t * Z)) :=
  let passive :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun peer =>
    let '(addr, port) := P2p_point.Id.parse_addr_port peer in
    let node : string :=
      if orb (equiv_decb addr "" % string) (equiv_decb addr "_" % string) then
        default_addr
      else
        addr
    with service : string :=
      match (port, default_port) with
      | ("" % string, None) => OCaml.Stdlib.invalid_arg "" % string
      | ("" % string, Some default_port) =>
        OCaml.Stdlib.string_of_int default_port
      | (port, _) => port
      end in
    Lwt_utils_unix.getaddrinfo passive node service.

Definition resolve_addrs
  (default_addr : string) (default_port : option Z) (passive : option bool)
  (peers : list string) : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  Lwt_list.fold_left_s
    (fun a =>
      fun peer =>
        op_gtgteq (resolve_addr default_addr default_port passive peer)
          (fun points => Lwt._return (List.rev_append points a))) [] peers.

Definition resolve_discovery_addrs (discovery_addr : string)
  : Lwt.t (list (Ipaddr.V4.t * Z)) :=
  op_gtgteq
    (resolve_addr (to_string broadcast) (Some default_discovery_port)
      (Some true) discovery_addr)
    (fun addrs =>
      let fix to_ipv4 {A : Type}
        (acc : list (Ipaddr.V4.t * A)) (function_parameter :
        list (Ipaddr.V6.t * A)) : Lwt.t (list (Ipaddr.V4.t * A)) :=
        match function_parameter with
        | [] => Lwt._return (List.rev acc)
        | cons (ip, port) xs =>
          match Ipaddr.v4_of_v6 ip with
          | Some v => to_ipv4 (cons (v, port) acc) xs
          | None =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Warning: failed to convert " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " to an ipv4 address" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))
                  "Warning: failed to convert %S to an ipv4 address@." % string)
                (Ipaddr.V6.to_string ip) in
            to_ipv4 acc xs
          end
        end in
      to_ipv4 [] addrs).

Definition resolve_listening_addrs (listen_addr : string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  resolve_addr "::" % string (Some default_p2p_port) (Some true) listen_addr.

Definition resolve_rpc_listening_addrs (listen_addr : string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  resolve_addr "::" % string (Some default_rpc_port) (Some true) listen_addr.

Definition resolve_bootstrap_addrs (peers : list string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  resolve_addrs "::" % string (Some default_p2p_port) None peers.

Definition check_listening_addrs (config : t) : Lwt.t unit :=
  match listen_addr (p2p config) with
  | None => Lwt.return_unit
  | Some addr =>
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (resolve_listening_addrs addr)
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Format.eprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Warning: failed to resolve " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "Warning: failed to resolve %S
@." % string) addr in
              Lwt.return_unit
            | cons _ _ => Lwt.return_unit
            end))
      (fun function_parameter =>
        match function_parameter with
        | OCaml.Invalid_argument msg =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Warning: failed to parse " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal ":   " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))
                "Warning: failed to parse %S:   %s
@." % string) addr msg in
          Lwt.return_unit
        | exn => Lwt.fail exn
        end)
  end.

Definition check_discovery_addr (config : t) : Lwt.t unit :=
  match discovery_addr (p2p config) with
  | None => Lwt.return_unit
  | Some addr =>
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (resolve_discovery_addrs addr)
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Format.eprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Warning: failed to resolve " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "Warning: failed to resolve %S
@." % string) addr in
              Lwt.return_unit
            | cons _ _ => Lwt.return_unit
            end))
      (fun function_parameter =>
        match function_parameter with
        | OCaml.Invalid_argument msg =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Warning: failed to parse " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal ":   " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))
                "Warning: failed to parse %S:   %s
@." % string) addr msg in
          Lwt.return_unit
        | exn => Lwt.fail exn
        end)
  end.

Definition check_rpc_listening_addr (config : t) : Lwt.t unit :=
  Lwt_list.iter_p
    (fun addr =>
      Lwt.catch
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (resolve_rpc_listening_addrs addr)
            (fun function_parameter =>
              match function_parameter with
              | [] =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Format.eprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Warning: failed to resolve " % string
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "010" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))
                      "Warning: failed to resolve %S
@." % string) addr in
                Lwt.return_unit
              | cons _ _ => Lwt.return_unit
              end))
        (fun function_parameter =>
          match function_parameter with
          | OCaml.Invalid_argument msg =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Warning: failed to parse " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal ":   " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "010" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))))
                  "Warning: failed to parse %S:   %s
@." % string) addr msg in
            Lwt.return_unit
          | exn => Lwt.fail exn
          end)) (listen_addrs (rpc config)).

Definition check_bootstrap_peer (addr : string) : Lwt.t unit :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (resolve_bootstrap_addrs (cons addr []))
        (fun function_parameter =>
          match function_parameter with
          | [] =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Format.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Warning: cannot resolve " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))
                  "Warning: cannot resolve %S
@." % string) addr in
            Lwt.return_unit
          | cons _ _ => Lwt.return_unit
          end))
    (fun function_parameter =>
      match function_parameter with
      | OCaml.Invalid_argument msg =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Warning: failed to parse " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ":   " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))
              "Warning: failed to parse %S:   %s
@." % string) addr msg in
        Lwt.return_unit
      | exn => Lwt.fail exn
      end).

Definition check_bootstrap_peers (config : t) : Lwt.t unit :=
  Lwt_list.iter_p check_bootstrap_peer (bootstrap_peers (p2p config)).

Definition fail {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Format.kasprintf
    (fun s =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := OCaml.Stdlib.prerr_endline s in
      Stdlib.exit 1) fmt.

Definition check_connections (config : t) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      OCaml.Stdlib.gt (min_connections (limits (p2p config)))
        (expected_connections (limits (p2p config))) then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The minumum number of connections is greater than the expected number of connections"
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The minumum number of connections is greater than the expected number of connections"
            % string) (min_connections (limits (p2p config)))
        (expected_connections (limits (p2p config)))
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      OCaml.Stdlib.gt (expected_connections (limits (p2p config)))
        (max_connections (limits (p2p config))) then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The expected number of connections is greater than the maximum number of connections"
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The expected number of connections is greater than the maximum number of connections"
            % string) (expected_connections (limits (p2p config)))
        (max_connections (limits (p2p config)))
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    match max_known_peer_ids (limits (p2p config)) with
    | None => tt
    | Some (max_known_peer_ids, target_known_peer_ids) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if OCaml.Stdlib.gt target_known_peer_ids max_known_peer_ids then
          fail
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Error: The target number of known peer ids is greater than the maximum number of known peer ids."
                  % string CamlinternalFormatBasics.End_of_format)
              "Error: The target number of known peer ids is greater than the maximum number of known peer ids."
                % string) target_known_peer_ids max_known_peer_ids
        else
          tt in
      if
        OCaml.Stdlib.gt (max_connections (limits (p2p config)))
          target_known_peer_ids then
        fail
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Error: The target number of known peer ids is lower than the maximum number of connections."
                % string CamlinternalFormatBasics.End_of_format)
            "Error: The target number of known peer ids is lower than the maximum number of connections."
              % string) target_known_peer_ids max_known_peer_ids
      else
        tt
    end in
  match max_known_points (limits (p2p config)) with
  | None => tt
  | Some (max_known_points, target_known_points) =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.gt target_known_points max_known_points then
        fail
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Error: The target number of known points is greater than the maximum number of known points."
                % string CamlinternalFormatBasics.End_of_format)
            "Error: The target number of known points is greater than the maximum number of known points."
              % string) target_known_points max_known_points
      else
        tt in
    if
      OCaml.Stdlib.gt (max_connections (limits (p2p config)))
        target_known_points then
      fail
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Error: The target number of known points is lower than the maximum number of connections."
              % string CamlinternalFormatBasics.End_of_format)
          "Error: The target number of known points is lower than the maximum number of connections."
            % string) target_known_points max_known_points
    else
      tt
  end.

Definition check (config : t) : Lwt.t unit :=
  op_gtgteq (check_listening_addrs config)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (check_rpc_listening_addr config)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (check_discovery_addr config)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (check_bootstrap_peers config)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := check_connections config in
                  Lwt.return_unit)))).

src/bin_node/node_data_version.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

type t = string

(* Data_version hitory:
 *  - 0.0.1 : original storage
 *  - 0.0.2 : never released
 *  - 0.0.3 : store upgrade (introducing history mode)
 *  - 0.0.4 : context upgrade (switching from LMDB to IRMIN v2) *)
let data_version = "0.0.4"

(* List of upgrade functions from each still supported previous
   version to the current [data_version] above. If this list grows too
   much, an idea would be to have triples (version, version,
   converter), and to sequence them dynamically instead of
   statically. *)
let upgradable_data_version = []

let store_dir data_dir = data_dir // "store"

let context_dir data_dir = data_dir // "context"

let protocol_dir data_dir = data_dir // "protocol"

let lock_file data_dir = data_dir // "lock"

let default_identity_file_name = "identity.json"

let default_peers_file_name = "peers.json"

let default_config_file_name = "config.json"

let version_file_name = "version.json"

let version_encoding = Data_encoding.(obj1 (req "version" string))

type error += Invalid_data_dir_version of t * t

type error += Invalid_data_dir of string

type error += Could_not_read_data_dir_version of string

type error += Data_dir_needs_upgrade of {expected : t; actual : t}

let () =
  register_error_kind
    `Permanent
    ~id:"invalidDataDir"
    ~title:"Invalid data directory"
    ~description:"The data directory cannot be accessed or created"
    ~pp:(fun ppf path ->
      Format.fprintf ppf "Invalid data directory '%s'." path)
    Data_encoding.(obj1 (req "datadir_path" string))
    (function Invalid_data_dir path -> Some path | _ -> None)
    (fun path -> Invalid_data_dir path) ;
  register_error_kind
    `Permanent
    ~id:"invalidDataDirVersion"
    ~title:"Invalid data directory version"
    ~description:"The data directory version was not the one that was expected"
    ~pp:(fun ppf (exp, got) ->
      Format.fprintf
        ppf
        "Invalid data directory version '%s' (expected '%s')."
        got
        exp)
    Data_encoding.(
      obj2 (req "expected_version" string) (req "actual_version" string))
    (function
      | Invalid_data_dir_version (expected, actual) ->
          Some (expected, actual)
      | _ ->
          None)
    (fun (expected, actual) -> Invalid_data_dir_version (expected, actual)) ;
  register_error_kind
    `Permanent
    ~id:"couldNotReadDataDirVersion"
    ~title:"Could not read data directory version file"
    ~description:"Data directory version file was invalid."
    Data_encoding.(obj1 (req "version_path" string))
    ~pp:(fun ppf path ->
      Format.fprintf
        ppf
        "Tried to read version file at '%s',  but the file could not be parsed."
        path)
    (function Could_not_read_data_dir_version path -> Some path | _ -> None)
    (fun path -> Could_not_read_data_dir_version path) ;
  register_error_kind
    `Permanent
    ~id:"dataDirNeedsUpgrade"
    ~title:"The data directory needs to be upgraded"
    ~description:"The data directory needs to be upgraded"
    ~pp:(fun ppf (exp, got) ->
      Format.fprintf
        ppf
        "The data directory version is too old.@,\
         Found '%s', expected '%s'.@,\
         It needs to be upgraded with `tezos-node upgrade_storage`."
        got
        exp)
    Data_encoding.(
      obj2 (req "expected_version" string) (req "actual_version" string))
    (function
      | Data_dir_needs_upgrade {expected; actual} ->
          Some (expected, actual)
      | _ ->
          None)
    (fun (expected, actual) -> Data_dir_needs_upgrade {expected; actual})

let version_file data_dir = Filename.concat data_dir version_file_name

let clean_directory files =
  let to_delete =
    Format.asprintf
      "@[<v>%a@]"
      (Format.pp_print_list ~pp_sep:Format.pp_print_cut Format.pp_print_string)
      files
  in
  Format.sprintf "Please provide a clean directory by removing:@ %s" to_delete

let write_version data_dir =
  Lwt_utils_unix.Json.write_file
    (version_file data_dir)
    (Data_encoding.Json.construct version_encoding data_version)

let check_data_dir_version files data_dir =
  let version_file = version_file data_dir in
  Lwt_unix.file_exists version_file
  >>= function
  | false ->
      fail (Invalid_data_dir (clean_directory files))
  | true -> (
      Lwt_utils_unix.Json.read_file version_file
      |> trace (Could_not_read_data_dir_version version_file)
      >>=? fun json ->
      ( try return (Data_encoding.Json.destruct version_encoding json)
        with
        | Data_encoding.Json.Cannot_destruct _
        | Data_encoding.Json.Unexpected _
        | Data_encoding.Json.No_case_matched _
        | Data_encoding.Json.Bad_array_size _
        | Data_encoding.Json.Missing_field _
        | Data_encoding.Json.Unexpected_field _
        ->
          fail (Could_not_read_data_dir_version version_file) )
      >>=? fun version ->
      if String.equal version data_version then return_none
      else
        match
          List.find_opt
            (fun (v, _) -> String.equal v version)
            upgradable_data_version
        with
        | Some f ->
            return_some f
        | None ->
            fail (Invalid_data_dir_version (data_version, version)) )

let ensure_data_dir bare data_dir =
  let write_version () = write_version data_dir >>=? fun () -> return_none in
  Lwt.catch
    (fun () ->
      Lwt_unix.file_exists data_dir
      >>= function
      | true -> (
          Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir)
          >|= List.filter (fun s ->
                  s <> "." && s <> ".." && s <> version_file_name
                  && s <> default_identity_file_name
                  && s <> default_config_file_name
                  && s <> default_peers_file_name)
          >>= function
          | [] ->
              write_version ()
          | files when bare ->
              fail (Invalid_data_dir (clean_directory files))
          | files ->
              check_data_dir_version files data_dir )
      | false ->
          Lwt_utils_unix.create_dir ~perm:0o700 data_dir
          >>= fun () -> write_version ())
    (function
      | Unix.Unix_error _ ->
          fail (Invalid_data_dir data_dir)
      | exc ->
          raise exc)

let ensure_data_dir ?(bare = false) data_dir =
  ensure_data_dir bare data_dir
  >>=? function
  | None ->
      return_unit
  | Some (version, _) ->
      fail (Data_dir_needs_upgrade {expected = data_version; actual = version})
src/bin_node/node_data_version.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition t := string.

Definition data_version : string := "0.0.4" % string.

Definition upgradable_data_version {A : Type} : list A := [].

Definition store_dir (data_dir : string) : string :=
  op_divdiv data_dir "store" % string.

Definition context_dir (data_dir : string) : string :=
  op_divdiv data_dir "context" % string.

Definition protocol_dir (data_dir : string) : string :=
  op_divdiv data_dir "protocol" % string.

Definition lock_file (data_dir : string) : string :=
  op_divdiv data_dir "lock" % string.

Definition default_identity_file_name : string := "identity.json" % string.

Definition default_peers_file_name : string := "peers.json" % string.

Definition default_config_file_name : string := "config.json" % string.

Definition version_file_name : string := "version.json" % string.

Definition version_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  obj1 (req None None "version" % string string).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition version_file (data_dir : string) : string :=
  Filename.concat data_dir version_file_name.

Definition clean_directory (files : list string) : string :=
  let to_delete :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v>" % string
                CamlinternalFormatBasics.End_of_format) "<v>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
      (Format.pp_print_list (Some Format.pp_print_cut) Format.pp_print_string)
      files in
  Format.sprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "Please provide a clean directory by removing:" % string
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@ " % string 1 0)
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)))
      "Please provide a clean directory by removing:@ %s" % string) to_delete.

Definition write_version (data_dir : string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  Lwt_utils_unix.Json.write_file (version_file data_dir)
    (Data_encoding.Json.construct version_encoding data_version).

Definition check_data_dir_version {A : Type}
  (files : list string) (data_dir : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.String.t * A))) :=
  let version_file := version_file data_dir in
  op_gtgteq (Lwt_unix.file_exists version_file)
    (fun function_parameter =>
      match function_parameter with
      | false =>
        fail (Tezos_base__TzPervasives.Invalid_data_dir (clean_directory files))
      | true =>
        op_gtgteqquestion
          (OCaml.Stdlib.reverse_apply
            (Lwt_utils_unix.Json.read_file version_file)
            (trace
              (Tezos_base__TzPervasives.Could_not_read_data_dir_version
                version_file)))
          (fun json =>
            op_gtgteqquestion
              (* ❌ Try-with are not handled *)
              (try (_return (Data_encoding.Json.destruct version_encoding json)))
              (fun version =>
                if String.equal version data_version then
                  return_none
                else
                  match
                    List.find_opt
                      (fun function_parameter =>
                        let '(v, _) := function_parameter in
                        String.equal v version) upgradable_data_version with
                  | Some f => return_some f
                  | None =>
                    fail
                      (Tezos_base__TzPervasives.Invalid_data_dir_version
                        data_version version)
                  end))
      end).

Definition ensure_data_dir {A : Type} (bare : bool) (data_dir : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.String.t * A))) :=
  let write_version {B : Type} (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
    let 'tt := function_parameter in
    op_gtgteqquestion (write_version data_dir)
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_none) in
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_unix.file_exists data_dir)
        (fun function_parameter =>
          match function_parameter with
          | true =>
            op_gtgteq
              (op_gtpipeeq
                (Lwt_stream.to_list (Lwt_unix.files_of_directory data_dir))
                (List.filter
                  (fun s =>
                    andb (nequiv_decb s "." % string)
                      (andb (nequiv_decb s ".." % string)
                        (andb (nequiv_decb s version_file_name)
                          (andb (nequiv_decb s default_identity_file_name)
                            (andb (nequiv_decb s default_config_file_name)
                              (nequiv_decb s default_peers_file_name))))))))
              (fun function_parameter =>
                match function_parameter with
                | [] => write_version tt
                | files =>
                  fail
                    (Tezos_base__TzPervasives.Invalid_data_dir
                      (clean_directory files))
                | files => check_data_dir_version files data_dir
                end)
          | false =>
            op_gtgteq (Lwt_utils_unix.create_dir (Some 448) data_dir)
              (fun function_parameter =>
                let 'tt := function_parameter in
                write_version tt)
          end))
    (fun function_parameter =>
      match function_parameter with
      | Unix_error _ _ _ =>
        fail (Tezos_base__TzPervasives.Invalid_data_dir data_dir)
      | exc => Stdlib.raise exc
      end).

Definition ensure_data_dir (op_staroptstar : option bool)
  : string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let bare :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun data_dir =>
    op_gtgteqquestion (ensure_data_dir bare data_dir)
      (fun function_parameter =>
        match function_parameter with
        | None => return_unit
        | Some (version, _) =>
          fail
            (Tezos_base__TzPervasives.Data_dir_needs_upgrade
              {| expected := data_version; actual := version |})
        end).

src/bin_node/node_identity_command.ml 21 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Commands *)

let identity_file data_dir =
  data_dir // Node_data_version.default_identity_file_name

let show {Node_config_file.data_dir; _} =
  Node_identity_file.read (identity_file data_dir)
  >>=? fun id ->
  Format.printf "Peer_id: %a.@." P2p_peer.Id.pp id.peer_id ;
  return_unit

let generate_with_animation ppf target =
  let duration = 1200 / Animation.number_of_frames in
  Animation.make_with_animation
    ppf
    ~make:(fun count ->
      try Ok (P2p_identity.generate_with_bound ~max:count target)
      with Not_found -> Error count)
    ~on_retry:(fun time count ->
      let ms = int_of_float (Mtime.Span.to_ms time) in
      if ms <= 1 then max 10 (count * 10) else count * duration / ms)
    10000

let generate {Node_config_file.data_dir; p2p; _} =
  let identity_file = identity_file data_dir in
  if Sys.file_exists identity_file then
    fail (Node_identity_file.Existent_identity_file identity_file)
  else
    let target = Crypto_box.make_target p2p.expected_pow in
    Format.eprintf
      "Generating a new identity... (level: %.2f) "
      p2p.expected_pow ;
    let id = generate_with_animation Format.err_formatter target in
    Node_identity_file.write identity_file id
    >>=? fun () ->
    Format.eprintf
      "Stored the new identity (%a) into '%s'.@."
      P2p_peer.Id.pp
      id.peer_id
      identity_file ;
    return_unit

let check {Node_config_file.data_dir; p2p = {expected_pow; _}; _} =
  Node_identity_file.read ~expected_pow (identity_file data_dir)
  >>=? fun id ->
  Format.printf
    "Peer_id: %a. Proof of work is higher than %.2f.@."
    P2p_peer.Id.pp
    id.peer_id
    expected_pow ;
  return_unit

(** Main *)

module Term = struct
  type subcommand = Show | Generate | Check

  let process subcommand data_dir config_file expected_pow =
    let res =
      ( match (data_dir, config_file) with
      | (None, None) ->
          let default_config =
            Node_config_file.default_data_dir
            // Node_data_version.default_config_file_name
          in
          if Sys.file_exists default_config then
            Node_config_file.read default_config
          else return Node_config_file.default_config
      | (None, Some config_file) ->
          Node_config_file.read config_file
      | (Some data_dir, None) ->
          Node_config_file.read
            (data_dir // Node_data_version.default_config_file_name)
          >>=? fun cfg -> return {cfg with data_dir}
      | (Some data_dir, Some config_file) ->
          Node_config_file.read config_file
          >>=? fun cfg -> return {cfg with data_dir} )
      >>=? fun cfg ->
      Node_config_file.update ?expected_pow cfg
      >>=? fun cfg ->
      match subcommand with
      | Show ->
          show cfg
      | Generate ->
          generate cfg
      | Check ->
          check cfg
    in
    match Lwt_main.run res with
    | Ok () ->
        `Ok ()
    | Error err ->
        `Error (false, Format.asprintf "%a" pp_print_error err)

  let subcommand_arg =
    let parser = function
      | "show" ->
          `Ok Show
      | "generate" ->
          `Ok Generate
      | "check" ->
          `Ok Check
      | s ->
          `Error ("invalid argument: " ^ s)
    and printer fmt = function
      | Show ->
          Format.fprintf fmt "show"
      | Generate ->
          Format.fprintf fmt "generate"
      | Check ->
          Format.fprintf fmt "check"
    in
    let doc =
      "Operation to perform. Possible values: $(b,show), $(b,generate), \
       $(b,check)."
    in
    let open Cmdliner.Arg in
    value & pos 0 (parser, printer) Show & info [] ~docv:"OPERATION" ~doc

  let expected_pow =
    let open Cmdliner in
    let doc =
      "Expected amount of proof-of-work for the node identity. The optional \
       parameter should be a float between 0 and 256, where\n\
      \       0 disables the proof-of-work mechanism."
    in
    Arg.(value & pos 1 (some float) None & info [] ~docv:"DIFFICULTY" ~doc)

  let term =
    Cmdliner.Term.(
      ret
        ( const process $ subcommand_arg $ Node_shared_arg.Term.data_dir
        $ Node_shared_arg.Term.config_file $ expected_pow ))
end

module Manpage = struct
  let command_description =
    "The $(b,identity) command is meant to create and manage node identities. \
     An $(i,identity) uniquely identifies a peer on the network and consists \
     of a cryptographic key pair as well as a proof-of-work stamp that \
     certifies that enough CPU time has been dedicated to produce the \
     identity, to avoid sybil attacks. An identity with enough proof-of-work \
     is required to participate in the Tezos network, therefore this command \
     is necessary to launch Tezos the first time."

  let description =
    [ `S "DESCRIPTION";
      `P (command_description ^ " Several options are possible:");
      `P
        "$(b,show) reads, parses and displays the current identity of the \
         node. Use this command to see what identity will be used by Tezos. \
         This is the default operation.";
      `P
        "$(b,generate [difficulty]) generates an identity whose proof of work \
         stamp difficulty is at least equal to $(i,difficulty). The value \
         provided must be a floating point number between 0 and 256. It \
         roughly reflects the numbers of expected leading zeroes in the hash \
         of the identity data-structure. Therefore, a value of 0 means no \
         proof-of-work, and the difficulty doubles for each increment of 1 in \
         the difficulty value.";
      `P
        "$(b,check [difficulty]) checks that an identity is valid and that \
         its proof of work stamp difficulty is at least equal to \
         $(i,difficulty)." ]

  let man = description @ (* [ `S misc_docs ] @ *)
                          Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Manage node identities" ~man "identity"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_identity_command.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition identity_file (data_dir : string) : string :=
  op_divdiv data_dir Node_data_version.default_identity_file_name.

Definition show (function_parameter : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{| Node_config_file.data_dir := data_dir |} := function_parameter in
  op_gtgteqquestion (Node_identity_file.read None (identity_file data_dir))
    (fun id =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Peer_id: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Flush_newline
                    CamlinternalFormatBasics.End_of_format))))
            "Peer_id: %a.@." % string) P2p_peer.Id.pp (peer_id id) in
      return_unit).

Definition generate_with_animation
  (ppf : Stdlib.Format.formatter) (target : Tezos_crypto.Crypto_box.target)
  : Tezos_base__TzPervasives.P2p_identity.t :=
  let duration := Z.div 1200 Animation.number_of_frames in
  Animation.make_with_animation ppf
    (fun count =>
      (* ❌ Try-with are not handled *)
      try (Stdlib.Ok (P2p_identity.generate_with_bound (Some count) target)))
    (fun time =>
      fun count =>
        let ms := Stdlib.int_of_float (Mtime.Span.to_ms time) in
        if OCaml.Stdlib.le ms 1 then
          OCaml.Stdlib.max 10 (Z.mul count 10)
        else
          Z.div (Z.mul count duration) ms) 10000.

Definition generate (function_parameter : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    Node_config_file.data_dir := data_dir; Node_config_file.p2p := p2p |} :=
    function_parameter in
  let identity_file := identity_file data_dir in
  if Sys.file_exists identity_file then
    fail (Tezos_base__TzPervasives.Existent_identity_file identity_file)
  else
    let target := Crypto_box.make_target (expected_pow p2p) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Generating a new identity... (level: " % string
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Lit_precision 2)
              (CamlinternalFormatBasics.String_literal ") " % string
                CamlinternalFormatBasics.End_of_format)))
          "Generating a new identity... (level: %.2f) " % string)
        (expected_pow p2p) in
    let id := generate_with_animation Format.err_formatter target in
    op_gtgteqquestion (Node_identity_file.write identity_file id)
      (fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Stored the new identity (" % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal ") into '" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal "'." % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))
              "Stored the new identity (%a) into '%s'.@." % string)
            P2p_peer.Id.pp (peer_id id) identity_file in
        return_unit).

Definition check (function_parameter : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    Node_config_file.data_dir := data_dir;
      Node_config_file.p2p := {| expected_pow := expected_pow |}
      |} := function_parameter in
  op_gtgteqquestion
    (Node_identity_file.read (Some expected_pow) (identity_file data_dir))
    (fun id =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Peer_id: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  ". Proof of work is higher than " % string
                  (CamlinternalFormatBasics.Float
                    CamlinternalFormatBasics.Float_f
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Lit_precision 2)
                    (CamlinternalFormatBasics.Char_literal "." % char
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format))))))
            "Peer_id: %a. Proof of work is higher than %.2f.@." % string)
          P2p_peer.Id.pp (peer_id id) expected_pow in
      return_unit).

Module Term.
  Inductive subcommand : Type :=
  | Show : subcommand
  | Generate : subcommand
  | Check : subcommand.
  
  Definition process
    (subcommand : subcommand) (data_dir : option string)
    (config_file : option string) (expected_pow : option Z) : variant :=
    let res :=
      op_gtgteqquestion
        match (data_dir, config_file) with
        | (None, None) =>
          let default_config :=
            op_divdiv Node_config_file.default_data_dir
              Node_data_version.default_config_file_name in
          if Sys.file_exists default_config then
            Node_config_file.read default_config
          else
            _return Node_config_file.default_config
        | (None, Some config_file) => Node_config_file.read config_file
        | (Some data_dir, None) =>
          op_gtgteqquestion
            (Node_config_file.read
              (op_divdiv data_dir Node_data_version.default_config_file_name))
            (fun cfg =>
              _return
                (* ❌ Record substitution not handled *)
                record_substitution)
        | (Some data_dir, Some config_file) =>
          op_gtgteqquestion (Node_config_file.read config_file)
            (fun cfg =>
              _return
                (* ❌ Record substitution not handled *)
                record_substitution)
        end
        (fun cfg =>
          op_gtgteqquestion
            (Node_config_file.update None None None None None None None None
              expected_pow None None None None None None None None None None
              None None None cfg)
            (fun cfg =>
              match subcommand with
              | Show => show cfg
              | Generate => generate cfg
              | Check => check cfg
              end)) in
    match Lwt_main.run res with
    | Stdlib.Ok tt =>
      (* ❌ Variants not supported *)
      variant
    | Stdlib.Error err =>
      (* ❌ Variants not supported *)
      variant
    end.
  
  Definition subcommand_arg : Cmdliner.Term.t subcommand :=
    let parser (function_parameter : string) : variant :=
      match function_parameter with
      | "show" % string =>
        (* ❌ Variants not supported *)
        variant
      | "generate" % string =>
        (* ❌ Variants not supported *)
        variant
      | "check" % string =>
        (* ❌ Variants not supported *)
        variant
      | s =>
        (* ❌ Variants not supported *)
        variant
      end
    with printer
      (fmt : Stdlib.Format.formatter) (function_parameter : subcommand)
      : unit :=
      match function_parameter with
      | Show =>
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "show" % string
              CamlinternalFormatBasics.End_of_format) "show" % string)
      | Generate =>
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "generate" % string
              CamlinternalFormatBasics.End_of_format) "generate" % string)
      | Check =>
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "check" % string
              CamlinternalFormatBasics.End_of_format) "check" % string)
      end in
    let doc :=
      "Operation to perform. Possible values: $(b,show), $(b,generate), $(b,check)."
        % string in
    op_and value
      (op_and (pos None 0 (parser, printer) Show)
        (info None (Some "OPERATION" % string) (Some doc) None [])).
  
  Definition expected_pow : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Expected amount of proof-of-work for the node identity. The optional parameter should be a float between 0 and 256, where
       0 disables the proof-of-work mechanism."
        % string in
    op_and value
      (op_and (pos None 1 (some None float) None)
        (info None (Some "DIFFICULTY" % string) (Some doc) None [])).
  
  Definition term : Cmdliner.Term.t unit :=
    ret
      (op_dollar
        (op_dollar
          (op_dollar (op_dollar (const process) subcommand_arg)
            Node_shared_arg.Term.data_dir) Node_shared_arg.Term.config_file)
        expected_pow).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,identity) command is meant to create and manage node identities. An $(i,identity) uniquely identifies a peer on the network and consists of a cryptographic key pair as well as a proof-of-work stamp that certifies that enough CPU time has been dedicated to produce the identity, to avoid sybil attacks. An identity with enough proof-of-work is required to participate in the Tezos network, therefore this command is necessary to launch Tezos the first time."
      % string.
  
  Definition description : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant
          (cons
            (* ❌ Variants not supported *)
            variant
            (cons
              (* ❌ Variants not supported *)
              variant [])))).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description Node_shared_arg.Manpage.bugs.
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Manage node identities" % string) None "identity" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).

src/bin_node/node_identity_file.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += No_identity_file of string

type error += Insufficient_proof_of_work of {expected : float}

type error +=
  | Identity_mismatch of {
      filename : string;
      peer_id : Crypto_box.Public_key_hash.t;
    }

type error +=
  | Identity_keys_mismatch of {
      filename : string;
      expected_key : Crypto_box.public_key;
    }

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.no_file"
    ~title:"No identity file"
    ~description:"The node identity file cannot be found"
    ~pp:(fun ppf file ->
      Format.fprintf
        ppf
        "Cannot read the identity file: `%s`. See `%s identity --help` on how \
         to generate an identity."
        file
        Sys.argv.(0))
    Data_encoding.(obj1 (req "file" string))
    (function No_identity_file file -> Some file | _ -> None)
    (fun file -> No_identity_file file)

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.insufficient_proof_of_work"
    ~title:"Insufficient proof of work"
    ~description:
      "The proof of work embeded by the current identity is not sufficient"
    ~pp:(fun ppf expected ->
      Format.fprintf
        ppf
        "The current identity does not embed a sufficient stamp of \
         proof-of-work. (expected level: %.2f). See `%s identity --help` on \
         how to generate a new identity."
        expected
        Sys.argv.(0))
    Data_encoding.(obj1 (req "expected" float))
    (function
      | Insufficient_proof_of_work {expected} -> Some expected | _ -> None)
    (fun expected -> Insufficient_proof_of_work {expected})

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.identity_mismatch"
    ~title:"Identity mismatch"
    ~description:
      "The identity (public key hash) does not match the keys provided with it"
    ~pp:(fun ppf (file, public_key_hash) ->
      Format.fprintf
        ppf
        "The current identity (public key hash) does not match the keys in %s.\n\
        \           Expected identity %a."
        file
        Crypto_box.Public_key_hash.pp
        public_key_hash)
    Data_encoding.(
      obj2
        (req "file" string)
        (req "public_key_hash" Crypto_box.Public_key_hash.encoding))
    (function
      | Identity_mismatch {filename; peer_id} ->
          Some (filename, peer_id)
      | _ ->
          None)
    (fun (filename, peer_id) -> Identity_mismatch {filename; peer_id})

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.identity_keys_mismatch"
    ~title:"Identity keys mismatch"
    ~description:
      "The current identity file has non-matching keys (secret key/ public \
       key pair is not valid)"
    ~pp:(fun ppf (file, public_key) ->
      Format.fprintf
        ppf
        "The current identity file %s has non-matching keys (secret key/ \
         public key pair is not valid).\n\
        \           Expected public key %a."
        file
        Crypto_box.pp_pk
        public_key)
    Data_encoding.(
      obj2
        (req "file" string)
        (req "public_key" Crypto_box.public_key_encoding))
    (function
      | Identity_keys_mismatch {filename; expected_key} ->
          Some (filename, expected_key)
      | _ ->
          None)
    (fun (filename, expected_key) ->
      Identity_keys_mismatch {filename; expected_key})

let read ?expected_pow filename =
  Lwt_unix.file_exists filename
  >>= function
  | false ->
      fail (No_identity_file filename)
  | true -> (
      Lwt_utils_unix.Json.read_file filename
      >>=? fun json ->
      let id = Data_encoding.Json.destruct P2p_identity.encoding json in
      let pkh = Crypto_box.hash id.public_key in
      (* check public_key hash *)
      if not (Crypto_box.Public_key_hash.equal pkh id.peer_id) then
        fail (Identity_mismatch {filename; peer_id = pkh})
        (* check public/private keys correspondance *)
      else if not Crypto_box.(equal (neuterize id.secret_key) id.public_key)
      then
        fail (Identity_keys_mismatch {filename; expected_key = id.public_key})
      else
        (* check PoW level *)
        match expected_pow with
        | None ->
            return id
        | Some expected ->
            let target = Crypto_box.make_target expected in
            if
              not
                (Crypto_box.check_proof_of_work
                   id.public_key
                   id.proof_of_work_stamp
                   target)
            then fail (Insufficient_proof_of_work {expected})
            else return id )

type error += Existent_identity_file of string

let () =
  register_error_kind
    `Permanent
    ~id:"main.identity.existent_file"
    ~title:"Cannot overwrite identity file"
    ~description:"Cannot implicitely overwrite the current identity file"
    ~pp:(fun ppf file ->
      Format.fprintf
        ppf
        "Cannot implicitely overwrite the current identity file: '%s'. See \
         `%s identity --help` on how to generate a new identity."
        file
        Sys.argv.(0))
    Data_encoding.(obj1 (req "file" string))
    (function Existent_identity_file file -> Some file | _ -> None)
    (fun file -> Existent_identity_file file)

let write file identity =
  if Sys.file_exists file then fail (Existent_identity_file file)
  else
    Node_data_version.ensure_data_dir (Filename.dirname file)
    >>=? fun () ->
    Lwt_utils_unix.Json.write_file
      file
      (Data_encoding.Json.construct P2p_identity.encoding identity)
src/bin_node/node_identity_file.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension









Definition read (expected_pow : option Z) (filename : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.P2p_identity.t) :=
  op_gtgteq (Lwt_unix.file_exists filename)
    (fun function_parameter =>
      match function_parameter with
      | false => fail (Tezos_base__TzPervasives.No_identity_file filename)
      | true =>
        op_gtgteqquestion (Lwt_utils_unix.Json.read_file filename)
          (fun json =>
            let id := Data_encoding.Json.destruct P2p_identity.encoding json in
            let pkh := Crypto_box.hash (public_key id) in
            if negb (Crypto_box.Public_key_hash.equal pkh (peer_id id)) then
              fail
                (Tezos_base__TzPervasives.Identity_mismatch
                  {| filename := filename; peer_id := pkh |})
            else
              if negb (equal (neuterize (secret_key id)) (public_key id)) then
                fail
                  (Tezos_base__TzPervasives.Identity_keys_mismatch
                    {| filename := filename; expected_key := public_key id |})
              else
                match expected_pow with
                | None => _return id
                | Some expected =>
                  let target := Crypto_box.make_target expected in
                  if
                    negb
                      (Crypto_box.check_proof_of_work (public_key id)
                        (proof_of_work_stamp id) target) then
                    fail
                      (Tezos_base__TzPervasives.Insufficient_proof_of_work
                        {| expected := expected |})
                  else
                    _return id
                end)
      end).

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition write
  (file : string) (identity : Tezos_base__TzPervasives.P2p_identity.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Sys.file_exists file then
    fail (Tezos_base__TzPervasives.Existent_identity_file file)
  else
    op_gtgteqquestion
      (Node_data_version.ensure_data_dir None (Filename.dirname file))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_utils_unix.Json.write_file file
          (Data_encoding.Json.construct P2p_identity.encoding identity)).

src/bin_node/node_logging.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "node.main"
end)
src/bin_node/node_logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/bin_node/node_run_command.ml 25 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Node_logging
open Genesis_chain

type error += Non_private_sandbox of P2p_addr.t

type error += RPC_Port_already_in_use of P2p_point.Id.t list

let () =
  register_error_kind
    `Permanent
    ~id:"main.run.non_private_sandbox"
    ~title:"Forbidden public sandbox"
    ~description:"A sandboxed node should not listen on a public address."
    ~pp:(fun ppf addr ->
      Format.fprintf
        ppf
        "The node is configured to listen on a public address (%a), while \
         only 'private' networks are authorised with `--sandbox`.\n\
        \           See `%s run --help` on how to change the listening address."
        Ipaddr.V6.pp
        addr
        Sys.argv.(0))
    Data_encoding.(obj1 (req "addr" P2p_addr.encoding))
    (function Non_private_sandbox addr -> Some addr | _ -> None)
    (fun addr -> Non_private_sandbox addr) ;
  register_error_kind
    `Permanent
    ~id:"main.run.port_already_in_use"
    ~title:"Cannot start node: RPC port already in use"
    ~description:"Another tezos node is probably running on the same RPC port."
    ~pp:(fun ppf addrlist ->
      Format.fprintf
        ppf
        "Another tezos node is probably running on one of these addresses \
         (%a). Please choose another RPC port."
        (Format.pp_print_list P2p_point.Id.pp)
        addrlist)
    Data_encoding.(obj1 (req "addrlist" (list P2p_point.Id.encoding)))
    (function RPC_Port_already_in_use addrlist -> Some addrlist | _ -> None)
    (fun addrlist -> RPC_Port_already_in_use addrlist)

let ( // ) = Filename.concat

let init_node ?sandbox ?checkpoint ~singleprocess (config : Node_config_file.t)
    =
  ( match sandbox with
  | None ->
      Lwt.return_none
  | Some sandbox_param -> (
    match sandbox_param with
    | None ->
        Lwt.return_none
    | Some file -> (
        Lwt_utils_unix.Json.read_file file
        >>= function
        | Error err ->
            lwt_warn "Cannot parse sandbox parameters: %s" file
            >>= fun () ->
            lwt_debug "%a" pp_print_error err >>= fun () -> Lwt.return_none
        | Ok json ->
            Lwt.return_some json ) ) )
  >>= fun sandbox_param ->
  (* TODO "WARN" when pow is below our expectation. *)
  ( match config.p2p.discovery_addr with
  | None ->
      lwt_log_notice "No local peer discovery."
      >>= fun () -> return (None, None)
  | Some addr -> (
      Node_config_file.resolve_discovery_addrs addr
      >>= function
      | [] ->
          failwith "Cannot resolve P2P discovery address: %S" addr
      | (addr, port) :: _ ->
          return (Some addr, Some port) ) )
  >>=? fun (discovery_addr, discovery_port) ->
  ( match config.p2p.listen_addr with
  | None ->
      lwt_log_notice "Not listening to P2P calls."
      >>= fun () -> return (None, None)
  | Some addr -> (
      Node_config_file.resolve_listening_addrs addr
      >>= function
      | [] ->
          failwith "Cannot resolve P2P listening address: %S" addr
      | (addr, port) :: _ ->
          return (Some addr, Some port) ) )
  >>=? fun (listening_addr, listening_port) ->
  ( match (listening_addr, sandbox) with
  | (Some addr, Some _) when Ipaddr.V6.(compare addr unspecified) = 0 ->
      return_none
  | (Some addr, Some _) when not (Ipaddr.V6.is_private addr) ->
      fail (Non_private_sandbox addr)
  | (None, Some _) ->
      return_none
  | _ ->
      Node_config_file.resolve_bootstrap_addrs config.p2p.bootstrap_peers
      >>= fun trusted_points ->
      Node_identity_file.read
        (config.data_dir // Node_data_version.default_identity_file_name)
      >>=? fun identity ->
      lwt_log_notice "Peer's global id: %a" P2p_peer.Id.pp identity.peer_id
      >>= fun () ->
      let p2p_config : P2p.config =
        {
          listening_addr;
          listening_port;
          discovery_addr;
          discovery_port;
          trusted_points;
          peers_file =
            config.data_dir // Node_data_version.default_peers_file_name;
          private_mode = config.p2p.private_mode;
          greylisting_config = config.p2p.greylisting_config;
          identity;
          proof_of_work_target = Crypto_box.make_target config.p2p.expected_pow;
          disable_mempool = config.p2p.disable_mempool;
          trust_discovered_peers = sandbox_param <> None;
          disable_testchain = config.p2p.disable_testchain;
        }
      in
      return_some (p2p_config, config.p2p.limits) )
  >>=? fun p2p_config ->
  let sandbox_parameters = sandbox_param in
  let sandbox_param =
    Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_param
  in
  let node_config : Node.config =
    {
      genesis;
      patch_context = Some (Patch_context.patch_context sandbox_param);
      store_root = Node_data_version.store_dir config.data_dir;
      context_root = Node_data_version.context_dir config.data_dir;
      protocol_root = Node_data_version.protocol_dir config.data_dir;
      p2p = p2p_config;
      checkpoint;
    }
  in
  Node.create
    ~sandboxed:(sandbox <> None)
    ?sandbox_parameters
    ~singleprocess
    node_config
    config.shell.peer_validator_limits
    config.shell.block_validator_limits
    config.shell.prevalidator_limits
    config.shell.chain_validator_limits
    config.shell.history_mode

(* Add default accepted CORS headers *)
let sanitize_cors_headers ~default headers =
  List.map String.lowercase_ascii headers
  |> String.Set.of_list
  |> String.Set.(union (of_list default))
  |> String.Set.elements

let launch_rpc_server (rpc_config : Node_config_file.rpc) node (addr, port) =
  let host = Ipaddr.V6.to_string addr in
  let dir = Node.build_rpc_directory node in
  let mode =
    match rpc_config.tls with
    | None ->
        `TCP (`Port port)
    | Some {cert; key} ->
        `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
  in
  lwt_log_notice
    "Starting a RPC server listening on %s:%d%s."
    host
    port
    (if rpc_config.tls = None then "" else " (TLS enabled)")
  >>= fun () ->
  let cors_headers =
    sanitize_cors_headers ~default:["Content-Type"] rpc_config.cors_headers
  in
  Lwt.catch
    (fun () ->
      RPC_server.launch
        ~host
        mode
        dir
        ~media_types:Media_type.all_media_types
        ~cors:
          {
            allowed_origins = rpc_config.cors_origins;
            allowed_headers = cors_headers;
          }
      >>= return)
    (function
      | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
          fail (RPC_Port_already_in_use [(addr, port)])
      | exn ->
          Lwt.return (error_exn exn))

let init_rpc (rpc_config : Node_config_file.rpc) node =
  fold_right_s
    (fun addr acc ->
      Node_config_file.resolve_rpc_listening_addrs addr
      >>= function
      | [] ->
          failwith "Cannot resolve listening address: %S" addr
      | addrs ->
          fold_right_s
            (fun x a ->
              launch_rpc_server rpc_config node x >>=? fun o -> return (o :: a))
            addrs
            acc)
    rpc_config.listen_addrs
    []

let run ?verbosity ?sandbox ?checkpoint ~singleprocess
    (config : Node_config_file.t) =
  Node_data_version.ensure_data_dir config.data_dir
  >>=? fun () ->
  Lwt_lock_file.create
    ~unlink_on_exit:true
    (Node_data_version.lock_file config.data_dir)
  >>=? fun () ->
  (* Main loop *)
  let log_cfg =
    match verbosity with
    | None ->
        config.log
    | Some default_level ->
        {config.log with default_level}
  in
  Internal_event_unix.init
    ~lwt_log_sink:log_cfg
    ~configuration:config.internal_events
    ()
  >>= fun () ->
  Updater.init (Node_data_version.protocol_dir config.data_dir) ;
  lwt_log_notice "Starting the Tezos node..."
  >>= fun () ->
  init_node ?sandbox ?checkpoint ~singleprocess config
  >>= (function
        | Ok node ->
            return node
        | Error
            (State.Incorrect_history_mode_switch {previous_mode; next_mode}
            :: _) ->
            failwith
              "@[Cannot switch from history mode '%a' to '%a'. Import a \
               context from a corresponding snapshot or re-synchronize a node \
               with an empty tezos node directory.@]"
              History_mode.pp
              previous_mode
              History_mode.pp
              next_mode
        | Error _ as err ->
            Lwt.return err)
  >>=? fun node ->
  init_rpc config.rpc node
  >>=? fun rpc ->
  lwt_log_notice "The Tezos node is now running!"
  >>= fun () ->
  Lwt_exit.(
    wrap_promise @@ retcode_of_unit_result_lwt @@ Lwt_utils.never_ending ())
  >>= fun retcode ->
  (* Clean-shutdown code *)
  Lwt_exit.termination_thread
  >>= fun x ->
  lwt_log_notice "Shutting down the Tezos node..."
  >>= fun () ->
  Node.shutdown node
  >>= fun () ->
  lwt_log_notice "Shutting down the RPC server..."
  >>= fun () ->
  Lwt_list.iter_p RPC_server.shutdown rpc
  >>= fun () ->
  lwt_log_notice "BYE (%d)" x
  >>= fun () -> Internal_event_unix.close () >>= fun () -> return retcode

let process sandbox verbosity checkpoint singleprocess args =
  let verbosity =
    let open Internal_event in
    match verbosity with [] -> None | [_] -> Some Info | _ -> Some Debug
  in
  let run =
    Node_shared_arg.read_and_patch_config_file
      ~ignore_bootstrap_peers:
        (match sandbox with Some _ -> true | None -> false)
      args
    >>=? fun config ->
    ( match sandbox with
    | Some _ ->
        if config.data_dir = Node_config_file.default_data_dir then
          failwith "Cannot use default data directory while in sandbox mode"
        else return_unit
    | None ->
        return_unit )
    >>=? fun () ->
    ( match checkpoint with
    | None ->
        return_none
    | Some s -> (
      match Block_header.of_b58check s with
      | Some b ->
          return_some b
      | None ->
          failwith
            "Failed to parse the provided checkpoint (Base58Check-encoded)." )
    )
    >>=? fun checkpoint ->
    Lwt_lock_file.is_locked (Node_data_version.lock_file config.data_dir)
    >>=? function
    | false ->
        Lwt.catch
          (fun () -> run ?sandbox ?verbosity ?checkpoint ~singleprocess config)
          (function
            | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
                Lwt_list.fold_right_s
                  (fun addr acc ->
                    Node_config_file.resolve_rpc_listening_addrs addr
                    >>= fun x -> Lwt.return (x @ acc))
                  config.rpc.listen_addrs
                  []
                >>= fun addrlist -> fail (RPC_Port_already_in_use addrlist)
            | exn ->
                Lwt.return (error_exn exn))
    | true ->
        failwith "Data directory is locked by another process"
  in
  match Lwt_main.run run with
  | Ok (0 | 2) ->
      (* 2 means that we exit by a signal that was handled *)
      `Ok ()
  | Ok _ ->
      `Error (false, "")
  | Error err ->
      `Error (false, Format.asprintf "%a" pp_print_error err)

module Term = struct
  let verbosity =
    let open Cmdliner in
    let doc =
      "Increase log level. Using $(b,-v) is equivalent to using \
       $(b,TEZOS_LOG='* -> info'), and $(b,-vv) is equivalent to using \
       $(b,TEZOS_LOG='* -> debug')."
    in
    Arg.(
      value & flag_all
      & info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["v"])

  let sandbox =
    let open Cmdliner in
    let doc =
      "Run the daemon in sandbox mode. P2P to non-localhost addresses are \
       disabled, and constants of the economic protocol can be altered with \
       an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the \
       node state and subsequent runs of Tezos node must also use sandbox \
       mode. In order to run the node in normal mode afterwards, a full reset \
       must be performed (by removing the node's data directory)."
    in
    Arg.(
      value
      & opt ~vopt:(Some None) (some (some string)) None
      & info
          ~docs:Node_shared_arg.Manpage.misc_section
          ~doc
          ~docv:"FILE.json"
          ["sandbox"])

  let checkpoint =
    let open Cmdliner in
    let doc =
      "When asked to take a block hash as a checkpoint, the daemon will only \
       accept the chains that contains that block and those that might reach \
       it."
    in
    Arg.(
      value
      & opt (some string) None
      & info
          ~docs:Node_shared_arg.Manpage.misc_section
          ~doc
          ~docv:"<level>,<block_hash>"
          ["checkpoint"])

  let singleprocess =
    let open Cmdliner in
    let doc =
      "When enabled, it deactivates block validation using an external \
       process. Thus, the validation procedure is done in the same process as \
       the node and might not be responding when doing extensive I/Os."
    in
    Arg.(
      value & flag
      & info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["singleprocess"])

  let term =
    Cmdliner.Term.(
      ret
        ( const process $ sandbox $ verbosity $ checkpoint $ singleprocess
        $ Node_shared_arg.Term.args ))
end

module Manpage = struct
  let command_description =
    "The $(b,run) command is meant to run the Tezos node. Most of its command \
     line arguments corresponds to config file entries, and will have \
     priority over the latter if used."

  let description = [`S "DESCRIPTION"; `P command_description]

  let debug =
    let log_sections =
      String.concat " " (List.rev !Internal_event.Legacy_logging.sections)
    in
    [ `S "DEBUG";
      `P
        ( "The environment variable $(b,TEZOS_LOG) is used to fine-tune what \
           is going to be logged. The syntax is \
           $(b,TEZOS_LOG='<section> -> <level> [ ; ...]') where section is \
           one of $(i," ^ log_sections
        ^ ") and level is one of $(i,fatal), $(i,error), $(i,warn), \
           $(i,notice), $(i,info) or $(i,debug). A $(b,*) can be used as a \
           wildcard in sections, i.e. $(b, client* -> debug). The rules are \
           matched left to right, therefore the leftmost rule is highest \
           priority ." ) ]

  let examples =
    [ `S "EXAMPLES";
      `I
        ( "$(b,Run in sandbox mode listening to RPC commands at localhost \
           port 8732)",
          "$(mname) run --sandbox --data-dir /custom/data/dir --rpc-addr \
           localhost:8732" );
      `I ("$(b,Run a node that accepts network connections)", "$(mname) run")
    ]

  let man =
    description @ Node_shared_arg.Manpage.args @ debug @ examples
    @ Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Run the Tezos node" ~man "run"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_run_command.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Node_logging.

Import Genesis_chain.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition op_divdiv : string -> string -> string := Filename.concat.

Definition init_node
  (sandbox : option (option string))
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t)
  (singleprocess : bool) (config : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Node.t) :=
  op_gtgteq
    match sandbox with
    | None => Lwt.return_none
    | Some sandbox_param =>
      match sandbox_param with
      | None => Lwt.return_none
      | Some file =>
        op_gtgteq (Lwt_utils_unix.Json.read_file file)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error err =>
              op_gtgteq
                (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_warn)
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot parse sandbox parameters: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "Cannot parse sandbox parameters: %s" % string) file)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_debug)
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      pp_print_error err)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Lwt.return_none))
            | Stdlib.Ok json => Lwt.return_some json
            end)
      end
    end
    (fun sandbox_param =>
      op_gtgteqquestion
        match discovery_addr (p2p config) with
        | None =>
          op_gtgteq
            (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No local peer discovery." % string
                  CamlinternalFormatBasics.End_of_format)
                "No local peer discovery." % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              _return (None, None))
        | Some addr =>
          op_gtgteq (Node_config_file.resolve_discovery_addrs addr)
            (fun function_parameter =>
              match function_parameter with
              | [] =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot resolve P2P discovery address: " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "Cannot resolve P2P discovery address: %S" % string) addr
              | cons (addr, port) _ => _return ((Some addr), (Some port))
              end)
        end
        (fun function_parameter =>
          let '(discovery_addr, discovery_port) := function_parameter in
          op_gtgteqquestion
            match listen_addr (p2p config) with
            | None =>
              op_gtgteq
                (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Not listening to P2P calls." % string
                      CamlinternalFormatBasics.End_of_format)
                    "Not listening to P2P calls." % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return (None, None))
            | Some addr =>
              op_gtgteq (Node_config_file.resolve_listening_addrs addr)
                (fun function_parameter =>
                  match function_parameter with
                  | [] =>
                    failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Cannot resolve P2P listening address: " % string
                          (CamlinternalFormatBasics.Caml_string
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format))
                        "Cannot resolve P2P listening address: %S" % string)
                      addr
                  | cons (addr, port) _ => _return ((Some addr), (Some port))
                  end)
            end
            (fun function_parameter =>
              let '(listening_addr, listening_port) := function_parameter in
              op_gtgteqquestion
                match (listening_addr, sandbox) with
                | (Some addr, Some _) => return_none
                | (Some addr, Some _) =>
                  fail (Tezos_base__TzPervasives.Non_private_sandbox addr)
                | (None, Some _) => return_none
                | _ =>
                  op_gtgteq
                    (Node_config_file.resolve_bootstrap_addrs
                      (bootstrap_peers (p2p config)))
                    (fun trusted_points =>
                      op_gtgteqquestion
                        (Node_identity_file.read None
                          (op_divdiv (data_dir config)
                            Node_data_version.default_identity_file_name))
                        (fun identity =>
                          op_gtgteq
                            (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Peer's global id: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Peer's global id: %a" % string) P2p_peer.Id.pp
                              (peer_id identity))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              let p2p_config :=
                                {| listening_port := listening_port;
                                  listening_addr := listening_addr;
                                  discovery_port := discovery_port;
                                  discovery_addr := discovery_addr;
                                  trusted_points := trusted_points;
                                  peers_file :=
                                    op_divdiv (data_dir config)
                                      Node_data_version.default_peers_file_name;
                                  private_mode := private_mode (p2p config);
                                  identity := identity;
                                  proof_of_work_target :=
                                    Crypto_box.make_target
                                      (expected_pow (p2p config));
                                  disable_mempool :=
                                    disable_mempool (p2p config);
                                  trust_discovered_peers :=
                                    nequiv_decb sandbox_param None;
                                  disable_testchain :=
                                    disable_testchain (p2p config);
                                  greylisting_config :=
                                    greylisting_config (p2p config) |} in
                              return_some (p2p_config, (limits (p2p config))))))
                end
                (fun p2p_config =>
                  let sandbox_parameters := sandbox_param in
                  let sandbox_param :=
                    Option.map (fun p => ("sandbox_parameter" % string, p))
                      sandbox_param in
                  let node_config :=
                    {| genesis := genesis;
                      store_root :=
                        Node_data_version.store_dir (data_dir config);
                      context_root :=
                        Node_data_version.context_dir (data_dir config);
                      protocol_root :=
                        Node_data_version.protocol_dir (data_dir config);
                      patch_context :=
                        Some (Patch_context.patch_context sandbox_param);
                      p2p := p2p_config; checkpoint := checkpoint |} in
                  Node.create (Some (nequiv_decb sandbox None))
                    sandbox_parameters singleprocess node_config
                    (peer_validator_limits (shell config))
                    (block_validator_limits (shell config))
                    (prevalidator_limits (shell config))
                    (chain_validator_limits (shell config))
                    (history_mode (shell config)))))).

Definition sanitize_cors_headers
  (default : list Tezos_base__TzPervasives.String.Set.elt)
  (headers : list string) : list Tezos_base__TzPervasives.String.Set.elt :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply (List.map String.lowercase_ascii headers)
        String.Set.of_list) (union (of_list default))) String.Set.elements.

Definition launch_rpc_server
  (rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
  (function_parameter : Ipaddr.V6.t * Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_rpc_http_server.RPC_server.server) :=
  let '(addr, port) := function_parameter in
  let host := Ipaddr.V6.to_string addr in
  let dir := Node.build_rpc_directory node in
  let mode :=
    match tls rpc_config with
    | None =>
      (* ❌ Variants not supported *)
      variant
    | Some {| cert := cert; key := key |} =>
      (* ❌ Variants not supported *)
      variant
    end in
  op_gtgteq
    (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Starting a RPC server listening on " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ":" % char
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format))))))
        "Starting a RPC server listening on %s:%d%s." % string) host port
      (if equiv_decb (tls rpc_config) None then
        "" % string
      else
        " (TLS enabled)" % string))
    (fun function_parameter =>
      let 'tt := function_parameter in
      let cors_headers :=
        sanitize_cors_headers (cons "Content-Type" % string [])
          (cors_headers rpc_config) in
      Lwt.catch
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (RPC_server.launch (Some host)
              (Some
                {| allowed_headers := cors_headers;
                  allowed_origins := cors_origins rpc_config |})
              Media_type.all_media_types mode dir) _return)
        (fun function_parameter =>
          match function_parameter with
          | Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
            fail
              (Tezos_base__TzPervasives.RPC_Port_already_in_use
                (cons (addr, port) []))
          | exn => Lwt._return (error_exn exn)
          end)).

Definition init_rpc
  (rpc_config : Node_config_file.rpc) (node : Tezos_shell.Node.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_rpc_http_server.RPC_server.server)) :=
  fold_right_s
    (fun addr =>
      fun acc =>
        op_gtgteq (Node_config_file.resolve_rpc_listening_addrs addr)
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Cannot resolve listening address: " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "Cannot resolve listening address: %S" % string) addr
            | addrs =>
              fold_right_s
                (fun x =>
                  fun a =>
                    op_gtgteqquestion (launch_rpc_server rpc_config node x)
                      (fun o => _return (cons o a))) addrs acc
            end)) (listen_addrs rpc_config) [].

Definition run
  (verbosity : option Tezos_event_logging.Internal_event.level)
  (sandbox : option (option string))
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t)
  (singleprocess : bool) (config : Node_config_file.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
  op_gtgteqquestion (Node_data_version.ensure_data_dir None (data_dir config))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (Lwt_lock_file.create None (Some true)
          (Node_data_version.lock_file (data_dir config)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          let log_cfg :=
            match verbosity with
            | None => log config
            | Some default_level =>
              (* ❌ Record substitution not handled *)
              record_substitution
            end in
          op_gtgteq
            (Internal_event_unix.init (Some log_cfg)
              (Some (internal_events config)) tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Updater.init (Node_data_version.protocol_dir (data_dir config))
                in
              op_gtgteq
                (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Starting the Tezos node..." % string
                      CamlinternalFormatBasics.End_of_format)
                    "Starting the Tezos node..." % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (op_gtgteq
                      (init_node sandbox checkpoint singleprocess config)
                      (fun function_parameter =>
                        match function_parameter with
                        | Stdlib.Ok node => _return node
                        |
                          Stdlib.Error
                            (cons
                              (Tezos_base__TzPervasives.Incorrect_history_mode_switch
                                {|
                                previous_mode := previous_mode;
                                  next_mode := next_mode
                                  |}) _) =>
                          failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    CamlinternalFormatBasics.End_of_format
                                    "" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "Cannot switch from history mode '" % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      "' to '" % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          "'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory."
                                            % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))))
                              "@[Cannot switch from history mode '%a' to '%a'. Import a context from a corresponding snapshot or re-synchronize a node with an empty tezos node directory.@]"
                                % string) History_mode.pp previous_mode
                            History_mode.pp next_mode
                        | (Stdlib.Error _) as err => Lwt._return err
                        end))
                    (fun node =>
                      op_gtgteqquestion (init_rpc (rpc config) node)
                        (fun rpc =>
                          op_gtgteq
                            (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "The Tezos node is now running!" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "The Tezos node is now running!" % string))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (apply wrap_promise
                                  (apply retcode_of_unit_result_lwt
                                    (Lwt_utils.never_ending tt)))
                                (fun retcode =>
                                  op_gtgteq Lwt_exit.termination_thread
                                    (fun x =>
                                      op_gtgteq
                                        (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Shutting down the Tezos node..."
                                                % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "Shutting down the Tezos node..." %
                                              string))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq (Node.shutdown node)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Shutting down the RPC server..."
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "Shutting down the RPC server..."
                                                      % string))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteq
                                                    (Lwt_list.iter_p
                                                      RPC_server.shutdown rpc)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        (Node_logging.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_notice)
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "BYE (" % string
                                                              (CamlinternalFormatBasics.Int
                                                                CamlinternalFormatBasics.Int_d
                                                                CamlinternalFormatBasics.No_padding
                                                                CamlinternalFormatBasics.No_precision
                                                                (CamlinternalFormatBasics.Char_literal
                                                                  ")" % char
                                                                  CamlinternalFormatBasics.End_of_format)))
                                                            "BYE (%d)" % string)
                                                          x)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_gtgteq
                                                            (Internal_event_unix.close
                                                              tt)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              _return retcode))))))))))))))).

Definition process {A : Type}
  (sandbox : option (option string)) (verbosity : list A)
  (checkpoint : option string) (singleprocess : bool) (args : Node_shared_arg.t)
  : variant :=
  let verbosity :=
    match verbosity with
    | [] => None
    | cons _ [] => Some Tezos_base__TzPervasives.Internal_event.Info
    | _ => Some Tezos_base__TzPervasives.Internal_event.Debug
    end in
  let run :=
    op_gtgteqquestion
      (Node_shared_arg.read_and_patch_config_file
        (Some
          match sandbox with
          | Some _ => true
          | None => false
          end) args)
      (fun config =>
        op_gtgteqquestion
          match sandbox with
          | Some _ =>
            if equiv_decb (data_dir config) Node_config_file.default_data_dir
              then
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Cannot use default data directory while in sandbox mode" %
                      string CamlinternalFormatBasics.End_of_format)
                  "Cannot use default data directory while in sandbox mode" %
                    string)
            else
              return_unit
          | None => return_unit
          end
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              match checkpoint with
              | None => return_none
              | Some s =>
                match Block_header.of_b58check s with
                | Some b => return_some b
                | None =>
                  failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Failed to parse the provided checkpoint (Base58Check-encoded)."
                          % string CamlinternalFormatBasics.End_of_format)
                      "Failed to parse the provided checkpoint (Base58Check-encoded)."
                        % string)
                end
              end
              (fun checkpoint =>
                op_gtgteqquestion
                  (Lwt_lock_file.is_locked
                    (Node_data_version.lock_file (data_dir config)))
                  (fun function_parameter =>
                    match function_parameter with
                    | false =>
                      Lwt.catch
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          run verbosity sandbox checkpoint singleprocess config)
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Unix_error Unix.EADDRINUSE "bind" % string
                              "" % string =>
                            op_gtgteq
                              (Lwt_list.fold_right_s
                                (fun addr =>
                                  fun acc =>
                                    op_gtgteq
                                      (Node_config_file.resolve_rpc_listening_addrs
                                        addr)
                                      (fun x =>
                                        Lwt._return (OCaml.Stdlib.app x acc)))
                                (listen_addrs (rpc config)) [])
                              (fun addrlist =>
                                fail
                                  (Tezos_base__TzPervasives.RPC_Port_already_in_use
                                    addrlist))
                          | exn => Lwt._return (error_exn exn)
                          end)
                    | true =>
                      failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Data directory is locked by another process" %
                              string CamlinternalFormatBasics.End_of_format)
                          "Data directory is locked by another process" % string)
                    end)))) in
  match Lwt_main.run run with
  | Stdlib.Ok (0 | 2) =>
    (* ❌ Variants not supported *)
    variant
  | Stdlib.Ok _ =>
    (* ❌ Variants not supported *)
    variant
  | Stdlib.Error err =>
    (* ❌ Variants not supported *)
    variant
  end.

Module Term.
  Definition verbosity : Cmdliner.Term.t (list bool) :=
    let doc :=
      "Increase log level. Using $(b,-v) is equivalent to using $(b,TEZOS_LOG='* -> info'), and $(b,-vv) is equivalent to using $(b,TEZOS_LOG='* -> debug')."
        % string in
    op_and value
      (op_and flag_all
        (info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
          (cons "v" % string []))).
  
  Definition sandbox : Cmdliner.Term.t (option (option string)) :=
    let doc :=
      "Run the daemon in sandbox mode. P2P to non-localhost addresses are disabled, and constants of the economic protocol can be altered with an optional JSON file. $(b,IMPORTANT): Using sandbox mode affects the node state and subsequent runs of Tezos node must also use sandbox mode. In order to run the node in normal mode afterwards, a full reset must be performed (by removing the node's data directory)."
        % string in
    op_and value
      (op_and (opt (Some (Some None)) (some None (some None string)) None)
        (info (Some Node_shared_arg.Manpage.misc_section)
          (Some "FILE.json" % string) (Some doc) None
          (cons "sandbox" % string []))).
  
  Definition checkpoint : Cmdliner.Term.t (option string) :=
    let doc :=
      "When asked to take a block hash as a checkpoint, the daemon will only accept the chains that contains that block and those that might reach it."
        % string in
    op_and value
      (op_and (opt None (some None string) None)
        (info (Some Node_shared_arg.Manpage.misc_section)
          (Some "<level>,<block_hash>" % string) (Some doc) None
          (cons "checkpoint" % string []))).
  
  Definition singleprocess : Cmdliner.Term.t bool :=
    let doc :=
      "When enabled, it deactivates block validation using an external process. Thus, the validation procedure is done in the same process as the node and might not be responding when doing extensive I/Os."
        % string in
    op_and value
      (op_and flag
        (info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
          (cons "singleprocess" % string []))).
  
  Definition term : Cmdliner.Term.t unit :=
    ret
      (op_dollar
        (op_dollar
          (op_dollar (op_dollar (op_dollar (const process) sandbox) verbosity)
            checkpoint) singleprocess) Node_shared_arg.Term.args).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,run) command is meant to run the Tezos node. Most of its command line arguments corresponds to config file entries, and will have priority over the latter if used."
      % string.
  
  Definition description : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant []).
  
  Definition debug : list variant :=
    let log_sections :=
      String.concat " " % string
        (List.rev (Stdlib.op_exclamation Internal_event.Legacy_logging.sections))
      in
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant []).
  
  Definition examples : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant [])).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description
      (OCaml.Stdlib.app Node_shared_arg.Manpage.args
        (OCaml.Stdlib.app debug
          (OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs))).
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Run the Tezos node" % string) None "run" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).

src/bin_node/node_shared_arg.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Cmdliner
open Node_logging

let ( // ) = Filename.concat

type t = {
  data_dir : string option;
  config_file : string;
  min_connections : int option;
  expected_connections : int option;
  max_connections : int option;
  max_download_speed : int option;
  max_upload_speed : int option;
  binary_chunks_size : int option;
  peer_table_size : int option;
  expected_pow : float option;
  peers : string list;
  no_bootstrap_peers : bool;
  listen_addr : string option;
  discovery_addr : string option;
  rpc_listen_addrs : string list;
  private_mode : bool;
  disable_mempool : bool;
  disable_testchain : bool;
  cors_origins : string list;
  cors_headers : string list;
  rpc_tls : Node_config_file.tls option;
  log_output : Lwt_log_sink_unix.Output.t option;
  bootstrap_threshold : int option;
  history_mode : History_mode.t option;
}

let wrap data_dir config_file connections max_download_speed max_upload_speed
    binary_chunks_size peer_table_size listen_addr discovery_addr peers
    no_bootstrap_peers bootstrap_threshold private_mode disable_mempool
    disable_testchain expected_pow rpc_listen_addrs rpc_tls cors_origins
    cors_headers log_output history_mode =
  let actual_data_dir =
    Option.unopt ~default:Node_config_file.default_data_dir data_dir
  in
  let config_file =
    Option.unopt
      ~default:(actual_data_dir // Node_data_version.default_config_file_name)
      config_file
  in
  let rpc_tls =
    Option.map ~f:(fun (cert, key) -> {Node_config_file.cert; key}) rpc_tls
  in
  (* when `--connections` is used,
     override all the bounds defined in the configuration file. *)
  let ( bootstrap_threshold,
        min_connections,
        expected_connections,
        max_connections,
        peer_table_size ) =
    match connections with
    | None ->
        (bootstrap_threshold, None, None, None, peer_table_size)
    | Some x -> (
        let peer_table_size =
          match peer_table_size with
          | None ->
              Some (8 * x)
          | Some _ ->
              peer_table_size
        in
        match bootstrap_threshold with
        | None ->
            ( Some (min (x / 4) 2),
              Some (x / 2),
              Some x,
              Some (3 * x / 2),
              peer_table_size )
        | Some bs ->
            (Some bs, Some (x / 2), Some x, Some (3 * x / 2), peer_table_size)
        )
  in
  {
    data_dir;
    config_file;
    min_connections;
    expected_connections;
    max_connections;
    max_download_speed;
    max_upload_speed;
    binary_chunks_size;
    expected_pow;
    peers;
    no_bootstrap_peers;
    listen_addr;
    discovery_addr;
    rpc_listen_addrs;
    private_mode;
    disable_mempool;
    disable_testchain;
    cors_origins;
    cors_headers;
    rpc_tls;
    log_output;
    peer_table_size;
    bootstrap_threshold;
    history_mode;
  }

module Manpage = struct
  let misc_section = "MISC OPTIONS"

  let p2p_section = "P2P OPTIONS"

  let rpc_section = "RPC OPTIONS"

  let args = [`S p2p_section; `S rpc_section; `S misc_section]

  let bugs =
    [ `S "BUGS";
      `P "Check bug reports at https://gitlab.com/tezos/tezos/issues." ]
end

module Term = struct
  let log_output_converter =
    ( (fun s ->
        match Lwt_log_sink_unix.Output.of_string s with
        | Some res ->
            `Ok res
        | None ->
            `Error s),
      Lwt_log_sink_unix.Output.pp )

  let history_mode_converter =
    let open History_mode in
    ( (function
      | "archive" ->
          `Ok Archive
      | "full" ->
          `Ok Full
      | "experimental-rolling" ->
          `Ok Rolling
      | s ->
          `Error s),
      pp )

  (* misc args *)

  let docs = Manpage.misc_section

  let history_mode =
    let doc =
      "Set the mode for the chain's data history storage. Possible values are \
       $(i,archive), $(i,full) (default), $(i,experimental-rolling). Archive \
       mode retains all data since the genesis block. Full mode only \
       maintains block headers and operations allowing replaying the chain \
       since the genesis if wanted. (Experimental-)Rolling mode retains only \
       the most recent data (i.e. from the 5 last cycles) and deletes the \
       rest."
    in
    Arg.(
      value
      & opt (some history_mode_converter) None
      & info ~docs ~doc ~docv:"<mode>" ["history-mode"])

  let log_output =
    let doc =
      "Log output. Either $(i,stdout), $(i,stderr), $(i,syslog:<facility>) or \
       a file path."
    in
    Arg.(
      value
      & opt (some log_output_converter) None
      & info ~docs ~docv:"OUTPUT" ~doc ["log-output"])

  let data_dir =
    let doc = "The directory where the Tezos node will store all its data." in
    Arg.(
      value & opt (some string) None & info ~docs ~doc ~docv:"DIR" ["data-dir"])

  let config_file =
    let doc = "The main configuration file." in
    Arg.(
      value
      & opt (some string) None
      & info ~docs ~doc ~docv:"FILE" ["config-file"])

  (* P2p args *)

  let docs = Manpage.p2p_section

  let connections =
    let doc =
      "Sets min_connections, expected_connections, max_connections to NUM / \
       2, NUM, (3 * NUM) / 2, respectively. Sets peer_table_size to 8 * NUM \
       unless it is already defined in the configuration file. Sets \
       bootstrap_threshold to min(NUM / 4, 2) unless it is already defined in \
       the configuration file."
    in
    Arg.(
      value & opt (some int) None & info ~docs ~doc ~docv:"NUM" ["connections"])

  let max_download_speed =
    let doc = "The maximum number of bytes read per second." in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["max-download-speed"])

  let max_upload_speed =
    let doc = "The maximum number of bytes sent per second." in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["max-upload-speed"])

  let binary_chunks_size =
    let doc =
      "Size limit (in kB) of binary blocks that are sent to other peers."
    in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["binary-chunks-size"])

  let peer_table_size =
    let doc =
      "Maximum size of internal peer tables, used to store metadata/logs \
       about a peer or about a to-be-authenticated host:port couple."
    in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["peer-table-size"])

  let listen_addr =
    let doc =
      "The TCP address and port at which this instance can be reached."
    in
    Arg.(
      value
      & opt (some string) None
      & info ~docs ~doc ~docv:"ADDR:PORT" ["net-addr"])

  let discovery_addr =
    let doc = "The UDP address and port used for local peer discovery." in
    Arg.(
      value
      & opt (some string) None
      & info ~docs ~doc ~docv:"ADDR:PORT" ["discovery-addr"])

  let no_bootstrap_peers =
    let doc =
      "Ignore the peers found in the config file (or the hard-coded bootstrap \
       peers in the absence of config file)."
    in
    Arg.(value & flag & info ~docs ~doc ["no-bootstrap-peers"])

  let bootstrap_threshold =
    let doc =
      "Set the number of peers with whom a chain synchronization must be \
       completed to bootstrap the node"
    in
    Arg.(
      value
      & opt (some int) None
      & info ~docs ~doc ~docv:"NUM" ["bootstrap-threshold"])

  let peers =
    let doc =
      "A peer to bootstrap the network from. Can be used several times to add \
       several peers."
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"ADDR:PORT" ["peer"])

  let expected_pow =
    let doc = "Expected level of proof-of-work for peers identity." in
    Arg.(
      value
      & opt (some float) None
      & info ~docs ~doc ~docv:"FLOAT" ["expected-pow"])

  let private_mode =
    let doc =
      "Only open outgoing/accept incoming connections to/from peers listed in \
       'bootstrap-peers' or provided with '--peer' option."
    in
    Arg.(value & flag & info ~docs ~doc ["private-mode"])

  let disable_mempool =
    let doc =
      "If set to [true], the node will not participate in the propagation of \
       pending operations (mempool). Default value is [false]. It can be used \
       to decrease the memory and computation footprints of the node."
    in
    Arg.(value & flag & info ~docs ~doc ["disable-mempool"])

  let disable_testchain =
    let doc =
      "If set to [true], the node will not spawn a testchain during the \
       protocol's testing voting period. Default value is [false]. It may be \
       used used to decrease the node storage usage and computation by \
       droping the validation of the test network blocks."
    in
    Arg.(value & flag & info ~docs ~doc ["disable-testchain"])

  (* rpc args *)
  let docs = Manpage.rpc_section

  let rpc_listen_addrs =
    let doc =
      "The TCP socket address at which this RPC server instance can be reached."
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"ADDR:PORT" ["rpc-addr"])

  let rpc_tls =
    let doc =
      "Enable TLS for this RPC server with the provided certificate and key."
    in
    Arg.(
      value
      & opt (some (pair string string)) None
      & info ~docs ~doc ~docv:"crt,key" ["rpc-tls"])

  let cors_origins =
    let doc =
      "CORS origin allowed by the RPC server via Access-Control-Allow-Origin; \
       may be used multiple times"
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"ORIGIN" ["cors-origin"])

  let cors_headers =
    let doc =
      "Header reported by Access-Control-Allow-Headers reported during CORS \
       preflighting; may be used multiple times"
    in
    Arg.(
      value & opt_all string [] & info ~docs ~doc ~docv:"HEADER" ["cors-header"])

  (* Args. *)

  let args =
    let open Term in
    const wrap $ data_dir $ config_file $ connections $ max_download_speed
    $ max_upload_speed $ binary_chunks_size $ peer_table_size $ listen_addr
    $ discovery_addr $ peers $ no_bootstrap_peers $ bootstrap_threshold
    $ private_mode $ disable_mempool $ disable_testchain $ expected_pow
    $ rpc_listen_addrs $ rpc_tls $ cors_origins $ cors_headers $ log_output
    $ history_mode
end

let read_config_file args =
  if Sys.file_exists args.config_file then
    Node_config_file.read args.config_file
  else return Node_config_file.default_config

let read_data_dir args =
  read_config_file args
  >>=? fun cfg ->
  let {data_dir; _} = args in
  let data_dir = Option.unopt ~default:cfg.data_dir data_dir in
  return data_dir

let read_and_patch_config_file ?(ignore_bootstrap_peers = false) args =
  read_config_file args
  >>=? fun cfg ->
  let { data_dir;
        min_connections;
        expected_connections;
        max_connections;
        max_download_speed;
        max_upload_speed;
        binary_chunks_size;
        peer_table_size;
        expected_pow;
        peers;
        no_bootstrap_peers;
        listen_addr;
        private_mode;
        discovery_addr;
        disable_mempool;
        disable_testchain;
        rpc_listen_addrs;
        rpc_tls;
        cors_origins;
        cors_headers;
        log_output;
        bootstrap_threshold;
        history_mode;
        config_file = _ } =
    args
  in
  let bootstrap_peers =
    if no_bootstrap_peers || ignore_bootstrap_peers then (
      log_info "Ignoring bootstrap peers" ;
      peers )
    else cfg.p2p.bootstrap_peers @ peers
  in
  Node_config_file.update
    ?data_dir
    ?min_connections
    ?expected_connections
    ?max_connections
    ?max_download_speed
    ?max_upload_speed
    ?binary_chunks_size
    ?peer_table_size
    ?expected_pow
    ~bootstrap_peers
    ?listen_addr
    ?discovery_addr
    ~rpc_listen_addrs
    ~private_mode
    ~disable_mempool
    ~disable_testchain
    ~cors_origins
    ~cors_headers
    ?rpc_tls
    ?log_output
    ?bootstrap_threshold
    ?history_mode
    cfg
src/bin_node/node_shared_arg.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Cmdliner.

Import Node_logging.

Definition op_divdiv : string -> string -> string := Filename.concat.

Record t := {
  data_dir : option string;
  config_file : string;
  min_connections : option Z;
  expected_connections : option Z;
  max_connections : option Z;
  max_download_speed : option Z;
  max_upload_speed : option Z;
  binary_chunks_size : option Z;
  peer_table_size : option Z;
  expected_pow : option Z;
  peers : list string;
  no_bootstrap_peers : bool;
  listen_addr : option string;
  discovery_addr : option string;
  rpc_listen_addrs : list string;
  private_mode : bool;
  disable_mempool : bool;
  disable_testchain : bool;
  cors_origins : list string;
  cors_headers : list string;
  rpc_tls : option Node_config_file.tls;
  log_output : option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t;
  bootstrap_threshold : option Z;
  history_mode : option Tezos_shell_services.History_mode.t }.

Definition wrap
  (data_dir : option string) (config_file : option string)
  (connections : option Z) (max_download_speed : option Z)
  (max_upload_speed : option Z) (binary_chunks_size : option Z)
  (peer_table_size : option Z) (listen_addr : option string)
  (discovery_addr : option string) (peers : list string)
  (no_bootstrap_peers : bool) (bootstrap_threshold : option Z)
  (private_mode : bool) (disable_mempool : bool) (disable_testchain : bool)
  (expected_pow : option Z) (rpc_listen_addrs : list string)
  (rpc_tls : option (string * string)) (cors_origins : list string)
  (cors_headers : list string)
  (log_output : option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t)
  (history_mode : option Tezos_shell_services.History_mode.t) : t :=
  let actual_data_dir := Option.unopt Node_config_file.default_data_dir data_dir
    in
  let config_file :=
    Option.unopt
      (op_divdiv actual_data_dir Node_data_version.default_config_file_name)
      config_file in
  let rpc_tls :=
    Option.map
      (fun function_parameter =>
        let '(cert, key) := function_parameter in
        {| Node_config_file.cert := cert; Node_config_file.key := key |})
      rpc_tls in
  let
    '(bootstrap_threshold, min_connections, expected_connections,
      max_connections, peer_table_size) :=
    match connections with
    | None => (bootstrap_threshold, None, None, None, peer_table_size)
    | Some x =>
      let peer_table_size :=
        match peer_table_size with
        | None => Some (Z.mul 8 x)
        | Some _ => peer_table_size
        end in
      match bootstrap_threshold with
      | None =>
        ((Some (OCaml.Stdlib.min (Z.div x 4) 2)), (Some (Z.div x 2)), (Some x),
          (Some (Z.div (Z.mul 3 x) 2)), peer_table_size)
      | Some bs =>
        ((Some bs), (Some (Z.div x 2)), (Some x), (Some (Z.div (Z.mul 3 x) 2)),
          peer_table_size)
      end
    end in
  {| data_dir := data_dir; config_file := config_file;
    min_connections := min_connections;
    expected_connections := expected_connections;
    max_connections := max_connections;
    max_download_speed := max_download_speed;
    max_upload_speed := max_upload_speed;
    binary_chunks_size := binary_chunks_size;
    peer_table_size := peer_table_size; expected_pow := expected_pow;
    peers := peers; no_bootstrap_peers := no_bootstrap_peers;
    listen_addr := listen_addr; discovery_addr := discovery_addr;
    rpc_listen_addrs := rpc_listen_addrs; private_mode := private_mode;
    disable_mempool := disable_mempool; disable_testchain := disable_testchain;
    cors_origins := cors_origins; cors_headers := cors_headers;
    rpc_tls := rpc_tls; log_output := log_output;
    bootstrap_threshold := bootstrap_threshold; history_mode := history_mode |}.

Module Manpage.
  Definition misc_section : string := "MISC OPTIONS" % string.
  
  Definition p2p_section : string := "P2P OPTIONS" % string.
  
  Definition rpc_section : string := "RPC OPTIONS" % string.
  
  Definition args : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant [])).
  
  Definition bugs : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant []).
End Manpage.

Module Term.
  Definition log_output_converter
    : (string -> variant) *
      (Stdlib.Format.formatter ->
        Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t -> unit) :=
    ((fun s =>
      match Lwt_log_sink_unix.Output.of_string s with
      | Some res =>
        (* ❌ Variants not supported *)
        variant
      | None =>
        (* ❌ Variants not supported *)
        variant
      end), Lwt_log_sink_unix.Output.pp).
  
  Definition history_mode_converter
    : (string -> variant) *
      (Stdlib.Format.formatter -> Tezos_shell_services.History_mode.t -> unit) :=
    ((fun function_parameter =>
      match function_parameter with
      | "archive" % string =>
        (* ❌ Variants not supported *)
        variant
      | "full" % string =>
        (* ❌ Variants not supported *)
        variant
      | "experimental-rolling" % string =>
        (* ❌ Variants not supported *)
        variant
      | s =>
        (* ❌ Variants not supported *)
        variant
      end), pp).
  
  Definition docs : string := Manpage.misc_section.
  
  Definition history_mode
    : Cmdliner.Term.t (option Tezos_shell_services.History_mode.t) :=
    let doc :=
      "Set the mode for the chain's data history storage. Possible values are $(i,archive), $(i,full) (default), $(i,experimental-rolling). Archive mode retains all data since the genesis block. Full mode only maintains block headers and operations allowing replaying the chain since the genesis if wanted. (Experimental-)Rolling mode retains only the most recent data (i.e. from the 5 last cycles) and deletes the rest."
        % string in
    op_and value
      (op_and (opt None (some None history_mode_converter) None)
        (info (Some docs) (Some "<mode>" % string) (Some doc) None
          (cons "history-mode" % string []))).
  
  Definition log_output
    : Cmdliner.Term.t (option Tezos_stdlib_unix.Lwt_log_sink_unix.Output.t) :=
    let doc :=
      "Log output. Either $(i,stdout), $(i,stderr), $(i,syslog:<facility>) or a file path."
        % string in
    op_and value
      (op_and (opt None (some None log_output_converter) None)
        (info (Some docs) (Some "OUTPUT" % string) (Some doc) None
          (cons "log-output" % string []))).
  
  Definition data_dir : Cmdliner.Term.t (option string) :=
    let doc :=
      "The directory where the Tezos node will store all its data." % string in
    op_and value
      (op_and (opt None (some None string) None)
        (info (Some docs) (Some "DIR" % string) (Some doc) None
          (cons "data-dir" % string []))).
  
  Definition config_file : Cmdliner.Term.t (option string) :=
    let doc := "The main configuration file." % string in
    op_and value
      (op_and (opt None (some None string) None)
        (info (Some docs) (Some "FILE" % string) (Some doc) None
          (cons "config-file" % string []))).
  
  Definition docs : string := Manpage.p2p_section.
  
  Definition connections : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Sets min_connections, expected_connections, max_connections to NUM / 2, NUM, (3 * NUM) / 2, respectively. Sets peer_table_size to 8 * NUM unless it is already defined in the configuration file. Sets bootstrap_threshold to min(NUM / 4, 2) unless it is already defined in the configuration file."
        % string in
    op_and value
      (op_and (opt None (some None int) None)
        (info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "connections" % string []))).
  
  Definition max_download_speed : Cmdliner.Term.t (option Z) :=
    let doc := "The maximum number of bytes read per second." % string in
    op_and value
      (op_and (opt None (some None int) None)
        (info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "max-download-speed" % string []))).
  
  Definition max_upload_speed : Cmdliner.Term.t (option Z) :=
    let doc := "The maximum number of bytes sent per second." % string in
    op_and value
      (op_and (opt None (some None int) None)
        (info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "max-upload-speed" % string []))).
  
  Definition binary_chunks_size : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Size limit (in kB) of binary blocks that are sent to other peers." %
        string in
    op_and value
      (op_and (opt None (some None int) None)
        (info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "binary-chunks-size" % string []))).
  
  Definition peer_table_size : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Maximum size of internal peer tables, used to store metadata/logs about a peer or about a to-be-authenticated host:port couple."
        % string in
    op_and value
      (op_and (opt None (some None int) None)
        (info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "peer-table-size" % string []))).
  
  Definition listen_addr : Cmdliner.Term.t (option string) :=
    let doc :=
      "The TCP address and port at which this instance can be reached." % string
      in
    op_and value
      (op_and (opt None (some None string) None)
        (info (Some docs) (Some "ADDR:PORT" % string) (Some doc) None
          (cons "net-addr" % string []))).
  
  Definition discovery_addr : Cmdliner.Term.t (option string) :=
    let doc :=
      "The UDP address and port used for local peer discovery." % string in
    op_and value
      (op_and (opt None (some None string) None)
        (info (Some docs) (Some "ADDR:PORT" % string) (Some doc) None
          (cons "discovery-addr" % string []))).
  
  Definition no_bootstrap_peers : Cmdliner.Term.t bool :=
    let doc :=
      "Ignore the peers found in the config file (or the hard-coded bootstrap peers in the absence of config file)."
        % string in
    op_and value
      (op_and flag
        (info (Some docs) None (Some doc) None
          (cons "no-bootstrap-peers" % string []))).
  
  Definition bootstrap_threshold : Cmdliner.Term.t (option Z) :=
    let doc :=
      "Set the number of peers with whom a chain synchronization must be completed to bootstrap the node"
        % string in
    op_and value
      (op_and (opt None (some None int) None)
        (info (Some docs) (Some "NUM" % string) (Some doc) None
          (cons "bootstrap-threshold" % string []))).
  
  Definition peers : Cmdliner.Term.t (list string) :=
    let doc :=
      "A peer to bootstrap the network from. Can be used several times to add several peers."
        % string in
    op_and value
      (op_and (opt_all None string [])
        (info (Some docs) (Some "ADDR:PORT" % string) (Some doc) None
          (cons "peer" % string []))).
  
  Definition expected_pow : Cmdliner.Term.t (option Z) :=
    let doc := "Expected level of proof-of-work for peers identity." % string in
    op_and value
      (op_and (opt None (some None float) None)
        (info (Some docs) (Some "FLOAT" % string) (Some doc) None
          (cons "expected-pow" % string []))).
  
  Definition private_mode : Cmdliner.Term.t bool :=
    let doc :=
      "Only open outgoing/accept incoming connections to/from peers listed in 'bootstrap-peers' or provided with '--peer' option."
        % string in
    op_and value
      (op_and flag
        (info (Some docs) None (Some doc) None (cons "private-mode" % string []))).
  
  Definition disable_mempool : Cmdliner.Term.t bool :=
    let doc :=
      "If set to [true], the node will not participate in the propagation of pending operations (mempool). Default value is [false]. It can be used to decrease the memory and computation footprints of the node."
        % string in
    op_and value
      (op_and flag
        (info (Some docs) None (Some doc) None
          (cons "disable-mempool" % string []))).
  
  Definition disable_testchain : Cmdliner.Term.t bool :=
    let doc :=
      "If set to [true], the node will not spawn a testchain during the protocol's testing voting period. Default value is [false]. It may be used used to decrease the node storage usage and computation by droping the validation of the test network blocks."
        % string in
    op_and value
      (op_and flag
        (info (Some docs) None (Some doc) None
          (cons "disable-testchain" % string []))).
  
  Definition docs : string := Manpage.rpc_section.
  
  Definition rpc_listen_addrs : Cmdliner.Term.t (list string) :=
    let doc :=
      "The TCP socket address at which this RPC server instance can be reached."
        % string in
    op_and value
      (op_and (opt_all None string [])
        (info (Some docs) (Some "ADDR:PORT" % string) (Some doc) None
          (cons "rpc-addr" % string []))).
  
  Definition rpc_tls : Cmdliner.Term.t (option (string * string)) :=
    let doc :=
      "Enable TLS for this RPC server with the provided certificate and key." %
        string in
    op_and value
      (op_and (opt None (some None (pair None string string)) None)
        (info (Some docs) (Some "crt,key" % string) (Some doc) None
          (cons "rpc-tls" % string []))).
  
  Definition cors_origins : Cmdliner.Term.t (list string) :=
    let doc :=
      "CORS origin allowed by the RPC server via Access-Control-Allow-Origin; may be used multiple times"
        % string in
    op_and value
      (op_and (opt_all None string [])
        (info (Some docs) (Some "ORIGIN" % string) (Some doc) None
          (cons "cors-origin" % string []))).
  
  Definition cors_headers : Cmdliner.Term.t (list string) :=
    let doc :=
      "Header reported by Access-Control-Allow-Headers reported during CORS preflighting; may be used multiple times"
        % string in
    op_and value
      (op_and (opt_all None string [])
        (info (Some docs) (Some "HEADER" % string) (Some doc) None
          (cons "cors-header" % string []))).
  
  Definition args : Cmdliner.Term.t t :=
    op_dollar
      (op_dollar
        (op_dollar
          (op_dollar
            (op_dollar
              (op_dollar
                (op_dollar
                  (op_dollar
                    (op_dollar
                      (op_dollar
                        (op_dollar
                          (op_dollar
                            (op_dollar
                              (op_dollar
                                (op_dollar
                                  (op_dollar
                                    (op_dollar
                                      (op_dollar
                                        (op_dollar
                                          (op_dollar
                                            (op_dollar
                                              (op_dollar (const wrap) data_dir)
                                              config_file) connections)
                                          max_download_speed) max_upload_speed)
                                      binary_chunks_size) peer_table_size)
                                  listen_addr) discovery_addr) peers)
                            no_bootstrap_peers) bootstrap_threshold)
                        private_mode) disable_mempool) disable_testchain)
                  expected_pow) rpc_listen_addrs) rpc_tls) cors_origins)
          cors_headers) log_output) history_mode.
End Term.

Definition read_config_file (args : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Node_config_file.t) :=
  if Sys.file_exists (config_file args) then
    Node_config_file.read (config_file args)
  else
    _return Node_config_file.default_config.

Definition read_data_dir (args : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  op_gtgteqquestion (read_config_file args)
    (fun cfg =>
      let '{| data_dir := data_dir |} := args in
      let data_dir := Option.unopt (data_dir cfg) data_dir in
      _return data_dir).

Definition read_and_patch_config_file (op_staroptstar : option bool)
  : t -> Lwt.t (Tezos_base__TzPervasives.tzresult Node_config_file.t) :=
  let ignore_bootstrap_peers :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun args =>
    op_gtgteqquestion (read_config_file args)
      (fun cfg =>
        let '{|
          data_dir := data_dir;
            config_file := _;
            min_connections := min_connections;
            expected_connections := expected_connections;
            max_connections := max_connections;
            max_download_speed := max_download_speed;
            max_upload_speed := max_upload_speed;
            binary_chunks_size := binary_chunks_size;
            peer_table_size := peer_table_size;
            expected_pow := expected_pow;
            peers := peers;
            no_bootstrap_peers := no_bootstrap_peers;
            listen_addr := listen_addr;
            discovery_addr := discovery_addr;
            rpc_listen_addrs := rpc_listen_addrs;
            private_mode := private_mode;
            disable_mempool := disable_mempool;
            disable_testchain := disable_testchain;
            cors_origins := cors_origins;
            cors_headers := cors_headers;
            rpc_tls := rpc_tls;
            log_output := log_output;
            bootstrap_threshold := bootstrap_threshold;
            history_mode := history_mode
            |} := args in
        let bootstrap_peers :=
          if orb no_bootstrap_peers ignore_bootstrap_peers then
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              log_info
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Ignoring bootstrap peers" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Ignoring bootstrap peers" % string) in
            peers
          else
            OCaml.Stdlib.app (bootstrap_peers (p2p cfg)) peers in
        Node_config_file.update data_dir min_connections expected_connections
          max_connections max_download_speed max_upload_speed binary_chunks_size
          peer_table_size expected_pow (Some bootstrap_peers) listen_addr
          discovery_addr (Some rpc_listen_addrs) (Some private_mode)
          (Some disable_mempool) (Some disable_testchain) (Some cors_origins)
          (Some cors_headers) rpc_tls log_output bootstrap_threshold
          history_mode cfg).

src/bin_node/node_snapshot_command.ml 18 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Node_logging

let ( // ) = Filename.concat

let context_dir data_dir = data_dir // "context"

let store_dir data_dir = data_dir // "store"

(** Main *)

module Term = struct
  type subcommand = Export | Import

  let dir_cleaner data_dir =
    lwt_log_notice "Cleaning directory %s because of failure" data_dir
    >>= fun () ->
    Lwt_utils_unix.remove_dir @@ store_dir data_dir
    >>= fun () -> Lwt_utils_unix.remove_dir @@ context_dir data_dir

  let process subcommand args snapshot_file block export_rolling =
    let run =
      Internal_event_unix.init ()
      >>= fun () ->
      Node_shared_arg.read_data_dir args
      >>=? fun data_dir ->
      let genesis = Genesis_chain.genesis in
      match subcommand with
      | Export ->
          Node_data_version.ensure_data_dir data_dir
          >>=? fun () ->
          let context_root = context_dir data_dir in
          let store_root = store_dir data_dir in
          Store.init store_root
          >>=? fun store ->
          Context.init ~readonly:true context_root
          >>= fun context_index ->
          Snapshots.export
            ~export_rolling
            ~context_index
            ~store
            ~genesis:genesis.block
            snapshot_file
            block
          >>=? fun () -> Store.close store |> return
      | Import ->
          Node_data_version.ensure_data_dir ~bare:true data_dir
          >>=? fun () ->
          Lwt_lock_file.create
            ~unlink_on_exit:true
            (Node_data_version.lock_file data_dir)
          >>=? fun () ->
          Snapshots.import
            ~data_dir
            ~dir_cleaner
            ~genesis
            ~patch_context:Patch_context.patch_context
            snapshot_file
            block
    in
    match Lwt_main.run run with
    | Ok () ->
        `Ok ()
    | Error err ->
        `Error (false, Format.asprintf "%a" pp_print_error err)

  let subcommand_arg =
    let parser = function
      | "export" ->
          `Ok Export
      | "import" ->
          `Ok Import
      | s ->
          `Error ("invalid argument: " ^ s)
    and printer ppf = function
      | Export ->
          Format.fprintf ppf "export"
      | Import ->
          Format.fprintf ppf "import"
    in
    let open Cmdliner.Arg in
    let doc =
      "Operation to perform. Possible values: $(b,export), $(b,import)."
    in
    required
    & pos 0 (some (parser, printer)) None
    & info [] ~docv:"OPERATION" ~doc

  let file_arg =
    let open Cmdliner.Arg in
    required & pos 1 (some string) None & info [] ~docv:"FILE"

  let blocks =
    let open Cmdliner.Arg in
    let doc = "Block hash of the block to export/import." in
    value & opt (some string) None & info ~docv:"<block_hash>" ~doc ["block"]

  let export_rolling =
    let open Cmdliner in
    let doc =
      "Force export command to dump a minimal snapshot based on the rolling \
       mode."
    in
    Arg.(
      value & flag
      & info ~docs:Node_shared_arg.Manpage.misc_section ~doc ["rolling"])

  let term =
    let open Cmdliner.Term in
    ret
      ( const process $ subcommand_arg $ Node_shared_arg.Term.args $ file_arg
      $ blocks $ export_rolling )
end

module Manpage = struct
  let command_description =
    "The $(b,snapshot) command is meant to export and import snapshots files."

  let description =
    [ `S "DESCRIPTION";
      `P (command_description ^ " Several operations are possible: ");
      `P
        "$(b,export) allows to export a snapshot of the current node state \
         into a file.";
      `P "$(b,import) allows to import a snapshot from a given file." ]

  let options = [`S "OPTIONS"]

  let examples =
    [ `S "EXAMPLES";
      `I
        ( "$(b,Export a snapshot using the rolling mode)",
          "$(mname) snapshot export latest.rolling --rolling" );
      `I
        ( "$(b,Import a snapshot located in file.full)",
          "$(mname) snapshot import file.full" ) ]

  let man = description @ options @ examples @ Node_shared_arg.Manpage.bugs

  let info = Cmdliner.Term.info ~doc:"Manage snapshots" ~man "snapshot"
end

let cmd = (Term.term, Manpage.info)
src/bin_node/node_snapshot_command.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Node_logging.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition context_dir (data_dir : string) : string :=
  op_divdiv data_dir "context" % string.

Definition store_dir (data_dir : string) : string :=
  op_divdiv data_dir "store" % string.

Module Term.
  Inductive subcommand : Type :=
  | Export : subcommand
  | Import : subcommand.
  
  Definition dir_cleaner (data_dir : string) : Lwt.t unit :=
    op_gtgteq
      (lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cleaning directory " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " because of failure" % string
                CamlinternalFormatBasics.End_of_format)))
          "Cleaning directory %s because of failure" % string) data_dir)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (apply Lwt_utils_unix.remove_dir (store_dir data_dir))
          (fun function_parameter =>
            let 'tt := function_parameter in
            apply Lwt_utils_unix.remove_dir (context_dir data_dir))).
  
  Definition process
    (subcommand : subcommand) (args : Node_shared_arg.t)
    (snapshot_file : string) (block : option string) (export_rolling : bool)
    : variant :=
    let run :=
      op_gtgteq (Internal_event_unix.init None None tt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion (Node_shared_arg.read_data_dir args)
            (fun data_dir =>
              let genesis := Genesis_chain.genesis in
              match subcommand with
              | Export =>
                op_gtgteqquestion
                  (Node_data_version.ensure_data_dir None data_dir)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let context_root := context_dir data_dir in
                    let store_root := store_dir data_dir in
                    op_gtgteqquestion (Store.init None None store_root)
                      (fun store =>
                        op_gtgteq
                          (Context.init None None (Some true) context_root)
                          (fun context_index =>
                            op_gtgteqquestion
                              (Snapshots.export (Some export_rolling)
                                context_index store (block genesis)
                                snapshot_file block)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                OCaml.Stdlib.reverse_apply (Store.close store)
                                  _return))))
              | Import =>
                op_gtgteqquestion
                  (Node_data_version.ensure_data_dir (Some true) data_dir)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion
                      (Lwt_lock_file.create None (Some true)
                        (Node_data_version.lock_file data_dir))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Snapshots.import data_dir dir_cleaner
                          Patch_context.patch_context genesis snapshot_file
                          block))
              end)) in
    match Lwt_main.run run with
    | Stdlib.Ok tt =>
      (* ❌ Variants not supported *)
      variant
    | Stdlib.Error err =>
      (* ❌ Variants not supported *)
      variant
    end.
  
  Definition subcommand_arg : Cmdliner.Term.t subcommand :=
    let parser (function_parameter : string) : variant :=
      match function_parameter with
      | "export" % string =>
        (* ❌ Variants not supported *)
        variant
      | "import" % string =>
        (* ❌ Variants not supported *)
        variant
      | s =>
        (* ❌ Variants not supported *)
        variant
      end
    with printer
      (ppf : Stdlib.Format.formatter) (function_parameter : subcommand)
      : unit :=
      match function_parameter with
      | Export =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "export" % string
              CamlinternalFormatBasics.End_of_format) "export" % string)
      | Import =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "import" % string
              CamlinternalFormatBasics.End_of_format) "import" % string)
      end in
    let doc :=
      "Operation to perform. Possible values: $(b,export), $(b,import)." %
        string in
    op_and required
      (op_and (pos None 0 (some None (parser, printer)) None)
        (info None (Some "OPERATION" % string) (Some doc) None [])).
  
  Definition file_arg : Cmdliner.Term.t string :=
    op_and required
      (op_and (pos None 1 (some None string) None)
        (info None (Some "FILE" % string) None None [])).
  
  Definition blocks : Cmdliner.Term.t (option string) :=
    let doc := "Block hash of the block to export/import." % string in
    op_and value
      (op_and (opt None (some None string) None)
        (info None (Some "<block_hash>" % string) (Some doc) None
          (cons "block" % string []))).
  
  Definition export_rolling : Cmdliner.Term.t bool :=
    let doc :=
      "Force export command to dump a minimal snapshot based on the rolling mode."
        % string in
    op_and value
      (op_and flag
        (info (Some Node_shared_arg.Manpage.misc_section) None (Some doc) None
          (cons "rolling" % string []))).
  
  Definition term : Cmdliner.Term.t unit :=
    ret
      (op_dollar
        (op_dollar
          (op_dollar
            (op_dollar (op_dollar (const process) subcommand_arg)
              Node_shared_arg.Term.args) file_arg) blocks) export_rolling).
End Term.

Module Manpage.
  Definition command_description : string :=
    "The $(b,snapshot) command is meant to export and import snapshots files." %
      string.
  
  Definition description : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant
          (cons
            (* ❌ Variants not supported *)
            variant []))).
  
  Definition options : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant [].
  
  Definition examples : list variant :=
    cons
      (* ❌ Variants not supported *)
      variant
      (cons
        (* ❌ Variants not supported *)
        variant
        (cons
          (* ❌ Variants not supported *)
          variant [])).
  
  Definition man : list Cmdliner.Manpage.block :=
    OCaml.Stdlib.app description
      (OCaml.Stdlib.app options
        (OCaml.Stdlib.app examples Node_shared_arg.Manpage.bugs)).
  
  Definition info : Cmdliner.Term.info :=
    Cmdliner.Term.info None (Some man) None None None None
      (Some "Manage snapshots" % string) None "snapshot" % string.
End Manpage.

Definition cmd : (Cmdliner.Term.t unit) * Cmdliner.Term.info :=
  (Term.term, Manpage.info).

src/bin_node/patch_context.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Genesis_chain

let patch_context key_json ctxt =
  ( match key_json with
  | None ->
      Lwt.return ctxt
  | Some (key, json) ->
      Tezos_storage.Context.set
        ctxt
        [key]
        (Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
  >>= fun ctxt ->
  (* TODO: this code seems to be shared with validator.ml, function run:
     can we share it? *)
  match Registered_protocol.get genesis.protocol with
  | None ->
      assert false (* FIXME error *)
  | Some proto -> (
      let module Proto = (val proto) in
      let ctxt = Shell_context.wrap_disk_context ctxt in
      Proto.init
        ctxt
        {
          level = 0l;
          proto_level = 0;
          predecessor = genesis.block;
          timestamp = genesis.time;
          validation_passes = 0;
          operations_hash = Operation_list_list_hash.empty;
          fitness = [];
          context = Context_hash.zero;
        }
      >>= function
      | Error _ ->
          assert false (* FIXME error *)
      | Ok {context; _} ->
          let context = Shell_context.unwrap_disk_context context in
          Lwt.return context )
src/bin_node/patch_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Genesis_chain.

Definition patch_context
  (key_json : option (string * Tezos_base__TzPervasives.Data_encoding.json))
  (ctxt : Tezos_storage.Context.context) : Lwt.t Tezos_storage.Context.t :=
  op_gtgteq
    match key_json with
    | None => Lwt._return ctxt
    | Some (key, json) =>
      Tezos_storage.Context.set ctxt (cons key [])
        (Data_encoding.Binary.to_bytes_exn Data_encoding.json json)
    end
    (fun ctxt =>
      match Registered_protocol.get (protocol genesis) with
      | None =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      | Some proto =>
        let Proto := projT2 proto in
        let ctxt := Shell_context.wrap_disk_context ctxt in
        op_gtgteq
          (Proto.(Tezos_protocol_updater__Registered_protocol.T.init) ctxt
            {|
              level :=
                (* ❌ Constant of type int32 is converted to int *)
                0; proto_level := 0; predecessor := block genesis;
              timestamp := time genesis; validation_passes := 0;
              operations_hash := Operation_list_list_hash.empty; fitness := [];
              context := Context_hash.zero |})
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error _ =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Stdlib.Ok {| context := context |} =>
              let context := Shell_context.unwrap_disk_context context in
              Lwt._return context
            end)
      end).

src/bin_sandbox/command_accusations.ml 419 errors
open Flextesa
open Internal_pervasives
open Console

let default_attempts = 35

let little_mesh_with_bakers ?base_port ?generate_kiln_config state ~protocol
    ~starting_level ~node_exec ~client_exec ~bakers () =
  Helpers.clear_root state
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let block_interval = 1 in
  let (protocol, baker_list) =
    let d = protocol in
    let open Tezos_protocol in
    let bakers = List.take d.bootstrap_accounts bakers in
    ( {
        d with
        time_between_blocks = [block_interval; 0];
        bootstrap_accounts =
          List.map d.bootstrap_accounts ~f:(fun (n, v) ->
              if List.exists bakers ~f:(fun baker -> n = fst baker) then (n, v)
              else (n, 1_000L));
      },
      bakers )
  in
  let net_size = 3 in
  let topology = Test_scenario.Topology.(mesh "Simple" net_size) in
  let all_nodes =
    Test_scenario.Topology.build ~protocol ~exec:node_exec topology ?base_port
  in
  Helpers.dump_connections state all_nodes
  >>= fun () ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes:all_nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]) ;
  Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
  >>= fun () ->
  let baker nth_node =
    let nth_baker = nth_node mod List.length baker_list in
    let key_name = sprintf "b%d" nth_baker in
    let node = List.nth_exn all_nodes nth_node in
    let client = Tezos_client.of_node node ~exec:client_exec in
    let baker_account = List.nth_exn baker_list nth_baker in
    let bak =
      Tezos_client.Keyed.make
        client
        ~key_name
        ~secret_key:(Tezos_protocol.Account.private_key (fst baker_account))
    in
    Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
  in
  baker 0
  >>= fun (client_0, baker_0) ->
  baker 1
  >>= fun (client_1, baker_1) ->
  baker 2
  >>= fun (client_2, baker_2) ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      arbitrary_commands_for_each_and_all_clients
        state
        ~clients:[client_0; client_1; client_2]) ;
  Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
      Tezos_client.rpc
        state
        ~client:client_0
        `Get
        ~path:"/chains/main/chain_id"
      >>= fun chain_id_json ->
      let network_id =
        match chain_id_json with `String s -> s | _ -> assert false
      in
      Kiln.Configuration_directory.generate
        state
        kiln_config
        ~peers:
          (List.map all_nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
        ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
        ~nodes:
          (List.map all_nodes ~f:(fun {Tezos_node.rpc_port; _} ->
               sprintf "http://localhost:%d" rpc_port))
        ~bakers:
          (List.map
             protocol.Tezos_protocol.bootstrap_accounts
             ~f:(fun (account, _) ->
               Tezos_protocol.Account.(name account, pubkey_hash account)))
        ~network_string:network_id
        ~node_exec
        ~client_exec
      >>= fun () ->
      return EF.(wf "Kiln was configured at `%s`" kiln_config.path))
  >>= fun _ ->
  let bake msg baker = Tezos_client.Keyed.bake state baker msg in
  List.fold
    (List.init (starting_level - 1) ~f:(fun n -> n))
    ~init:(return ()) (* We are already at level 1, we bake 7 times: *)
    ~f:(fun pm n ->
      pm
      >>= fun () ->
      bake
        (sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1))
        baker_0)
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to starting_level)
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Clients ready";
        af "Node 0 baked %d times." (starting_level - 1);
        af "All nodes should be at level %d." starting_level ]
  >>= fun () ->
  return (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2)

let wait_for_operation_in_mempools state ~nodes:all_nodes ~kind ~client_exec
    how =
  let (init, combine) =
    match how with `At_least_one -> (false, ( || )) | `All -> (true, ( && ))
  in
  Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
      List.fold ~init:(return init) all_nodes ~f:(fun prev_m node ->
          prev_m
          >>= fun prev ->
          let client = Tezos_client.of_node node ~exec:client_exec in
          Tezos_client.mempool_has_operation state ~client ~kind
          >>= fun client_result -> return (combine client_result prev))
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf "Waiting for %S to show up in the mempool" kind)))

let simple_double_baking ~starting_level ?generate_kiln_config ~state ~protocol
    ~base_port node_exec client_exec () =
  little_mesh_with_bakers
    ~bakers:1
    ~protocol
    state
    ~node_exec
    ~client_exec
    ()
    ~base_port
    ~starting_level
    ?generate_kiln_config
  >>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
  let kill_nth nth = List.nth_exn all_nodes nth |> Helpers.kill_node state in
  let restart_nth nth =
    List.nth_exn all_nodes nth |> Helpers.restart_node ~client_exec state
  in
  let number_of_lonely_bakes = 1 in
  kill_nth 1
  >>= fun () ->
  kill_nth 2
  >>= fun () ->
  Loop.n_times (number_of_lonely_bakes - 1) (fun _ ->
      Tezos_client.Keyed.bake state baker_0 "Bake-on-0")
  >>= fun () ->
  (* Bake one block less and inject an operation to generate a different
     block's hash *)
  Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
  >>= fun () ->
  Tezos_client.get_block_header state ~client:client_0 `Head
  >>= fun baking_0_header ->
  (* This baking will have better fitness so other nodes will have to fetch it. *)
  Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
  >>= fun () ->
  System.sleep 1.
  >>= fun () ->
  kill_nth 0
  >>= fun () ->
  restart_nth 1
  >>= fun () ->
  restart_nth 2
  >>= fun () ->
  Loop.n_times number_of_lonely_bakes (fun _ ->
      Tezos_client.Keyed.bake state baker_1 "Bake-on-1")
  >>= fun () ->
  Tezos_client.get_block_header state ~client:client_1 `Head
  >>= fun baking_1_header ->
  restart_nth 0
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "Bake-on-0"
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`At_least (starting_level + number_of_lonely_bakes + 1))
  >>= fun () ->
  Tezos_client.rpc
    state
    ~client:client_1
    `Get
    ~path:"/chains/main/blocks/head/hash"
  >>= fun head_hash_json ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "About to forge";
        ef_json "Baking 0" baking_0_header;
        ef_json "Baking 1" baking_1_header;
        ef_json "Head hash" head_hash_json ]
  >>= fun () ->
  Tezos_client.Keyed.forge_and_inject
    state
    baker_1
    ~json:
      (let clean header =
         let open Jqo in
         remove_field header ~name:"hash"
         |> remove_field ~name:"chain_id"
         |> remove_field ~name:"protocol"
       in
       `O
         [ ("branch", head_hash_json);
           ( "contents",
             `A
               [ `O
                   [ ("kind", `String "double_baking_evidence");
                     ("bh1", clean baking_0_header);
                     ("bh2", clean baking_1_header) ] ] ) ])
  >>= fun result ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Waiting for accuser to notice double baking";
        ef_json "Result of injection" result;
        af
          "All nodes reaching level %d"
          (starting_level + number_of_lonely_bakes + 1) ]
  >>= fun () ->
  wait_for_operation_in_mempools
    state
    ~nodes:all_nodes
    ~kind:"double_baking_evidence"
    ~client_exec
    `All
  >>= fun () ->
  Tezos_client.Keyed.bake
    state
    baker_2
    (sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
  >>= fun () ->
  let last_level = starting_level + number_of_lonely_bakes + 2 in
  Interactive_test.Pauser.generic
    state
    EF.[af "Just baked what's the level? Vs %d" last_level]
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to last_level)
  >>= fun () ->
  Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
      Tezos_client.block_has_operation
        state
        ~client:client_2
        ~level:last_level
        ~kind:"double_baking_evidence"
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf
                 "Waiting for accusation to show up in block %d"
                 last_level)))
  >>= fun () -> say state EF.(af "Test done.")

let find_endorsement_in_mempool state ~client =
  Helpers.wait_for state ~attempts:4 ~seconds:2. (fun _ ->
      Tezos_client.find_applied_in_mempool state ~client ~f:(fun o ->
          Jqo.field o ~k:"contents"
          |> Jqo.list_exists ~f:(fun op ->
                 (* Dbg.e EF.(ef_json "op" op) ; *)
                 Jqo.field op ~k:"kind" = `String "endorsement"))
      >>= function
      | None ->
          return (`Not_done (sprintf "No endorsement so far"))
      | Some e ->
          return (`Done e))

let simple_double_endorsement ~starting_level ?generate_kiln_config ~state
    ~protocol ~base_port node_exec client_exec () =
  little_mesh_with_bakers
    ~bakers:2
    ~protocol
    state
    ~node_exec
    ~client_exec
    ()
    ~starting_level
    ~base_port
    ?generate_kiln_config
  >>= fun (all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) ->
  (* 2 bakers ⇒ baker_0 and baker_2 are for the same key on ≠ nodes *)
  assert (
    Tezos_client.Keyed.(
      baker_0.key_name = baker_2.key_name
      && baker_0.secret_key = baker_2.secret_key) ) ;
  let node_0 = List.nth_exn all_nodes 0 in
  let node_1 = List.nth_exn all_nodes 1 in
  let node_2 = List.nth_exn all_nodes 2 in
  let baker_1_n0 =
    let open Tezos_client.Keyed in
    let {key_name; secret_key; _} = baker_1 in
    make client_0 ~key_name ~secret_key
  in
  Tezos_client.Keyed.initialize state baker_1_n0
  >>= fun _ ->
  Helpers.kill_node state node_1
  >>= fun () ->
  Helpers.kill_node state node_2
  >>= fun () ->
  (* Inject an operation to generate a different block's hash *)
  Tezos_client.Keyed.endorse state baker_0 "endorsing lonely bake-on-0"
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "baker-0 baking with node 0"
  >>= fun () ->
  Tezos_client.Keyed.endorse state baker_0 "baker-0 endorsing with node 0"
  >>= fun () ->
  find_endorsement_in_mempool state ~client:client_0
  >>= fun endorsement_0 ->
  Tezos_client.Keyed.endorse state baker_1_n0 "baker-1 endorsing with node 0"
  >>= fun () ->
  Helpers.kill_node state node_0
  >>= fun () ->
  Helpers.restart_node state node_2 ~client_exec
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_2 "baker-0 baking with node 2"
  >>= fun () ->
  Tezos_client.Keyed.endorse state baker_2 "baker-0 endorsing with node 2"
  >>= fun () ->
  find_endorsement_in_mempool state ~client:client_2
  >>= fun endorsement_1 ->
  say
    state
    EF.(
      list
        [ ef_json "Endorsement 0:" endorsement_0;
          ef_json "Endorsement 1:" endorsement_1 ])
  >>= fun () ->
  Helpers.restart_node state node_1 ~client_exec
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    [node_1; node_2]
    (`Equal_to (starting_level + 1))
  >>= fun () ->
  Helpers.restart_node state node_0 ~client_exec
  >>= fun () ->
  (* TODO: understand why this kick in the butt is necessary for node
     2 (seems like the node was not getting to level starting+2 without
     this). *)
  Helpers.kill_node state node_2
  >>= fun () ->
  Helpers.restart_node state node_2 ~client_exec
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to (starting_level + 1))
  >>= fun () ->
  Tezos_client.rpc
    state
    ~client:client_1
    `Get
    ~path:"/chains/main/blocks/head/hash"
  >>= fun head_hash_json ->
  let double_endorsement =
    let transform_endorsement endorsement =
      let branch = Jqo.field ~k:"branch" endorsement in
      let signature = Jqo.field ~k:"signature" endorsement in
      let contents =
        match Jqo.field ~k:"contents" endorsement with
        | `A [one] ->
            one
        | _ ->
            assert false
      in
      `O
        [("branch", branch); ("operations", contents); ("signature", signature)]
    in
    let inlined_endorsement_1 = transform_endorsement endorsement_0 in
    let inlined_endorsement_2 = transform_endorsement endorsement_1 in
    `O
      [ ("branch", head_hash_json);
        ( "contents",
          `A
            [ `O
                [ ("kind", `String "double_endorsement_evidence");
                  ("op1", inlined_endorsement_1);
                  ("op2", inlined_endorsement_2) ] ] ) ]
  in
  Interactive_test.Pauser.generic
    state
    EF.[ef_json "About to forge" double_endorsement]
  >>= fun () ->
  Tezos_client.Keyed.forge_and_inject state baker_1 ~json:double_endorsement
  >>= fun result ->
  Interactive_test.Pauser.generic
    state
    EF.[ef_json "Result of injection" result]
  >>= fun () ->
  wait_for_operation_in_mempools
    state
    ~nodes:[node_1]
    ~kind:"double_endorsement_evidence"
    ~client_exec
    `All
  >>= fun () ->
  let last_level = starting_level + 2 in
  Tezos_client.Keyed.bake state baker_1 (sprintf "level %d" last_level)
  >>= fun () ->
  Tezos_client.Keyed.endorse
    state
    baker_1
    (sprintf "endorse level %d" last_level)
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to last_level)
  >>= fun () ->
  Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
      (* We check that client-2 sees the evidence from baker-1 *)
      Tezos_client.block_has_operation
        state
        ~client:client_2
        ~level:last_level
        ~kind:"double_endorsement_evidence"
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf
                 "Waiting for accusation to show up in block %d"
                 last_level)))
  >>= fun () -> say state EF.(af "Test done.")

let with_accusers ~state ~protocol ~base_port node_exec accuser_exec
    client_exec () =
  Helpers.clear_root state
  >>= fun () ->
  let block_interval = 2 in
  let (protocol, baker_0_account) =
    let d = protocol in
    let open Tezos_protocol in
    let baker = List.hd_exn d.bootstrap_accounts in
    ( {
        d with
        time_between_blocks = [block_interval; block_interval * 2];
        bootstrap_accounts =
          List.map d.bootstrap_accounts ~f:(fun (n, v) ->
              if n = fst baker then (n, v) else (n, 1_000L));
      },
      baker )
  in
  let topology =
    Test_scenario.Topology.(
      net_in_the_middle "AT-" (mesh "Mid" 3) (mesh "Main" 4) (mesh "Acc" 4))
  in
  let (mesh_nodes, intermediary_nodes, accuser_nodes) =
    Test_scenario.Topology.build ~protocol ~exec:node_exec topology ~base_port
  in
  let all_nodes = mesh_nodes @ intermediary_nodes @ accuser_nodes in
  Helpers.dump_connections state all_nodes
  >>= fun () ->
  Test_scenario.Network.(start_up state ~client_exec (make all_nodes))
  >>= fun () ->
  let start_accuser nod =
    let client = Tezos_client.of_node nod ~exec:client_exec in
    let acc = Tezos_daemon.accuser_of_node ~exec:accuser_exec ~client nod in
    Running_processes.start state (Tezos_daemon.process acc ~state)
    >>= fun _ -> return ()
  in
  List_sequential.iter accuser_nodes ~f:start_accuser
  >>= fun () ->
  let key_name = "b0" in
  let baker nth =
    let node = List.nth_exn all_nodes nth in
    let client = Tezos_client.of_node node ~exec:client_exec in
    let bak =
      Tezos_client.Keyed.make
        client
        ~key_name
        ~secret_key:(Tezos_protocol.Account.private_key (fst baker_0_account))
    in
    Tezos_client.Keyed.initialize state bak >>= fun _ -> return (client, bak)
  in
  baker 0
  >>= fun (client_0, baker_0) ->
  baker 1
  >>= fun (client_1, baker_1) ->
  baker 2
  >>= fun (client_2, baker_2) ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes:all_nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~clients:[client_0; client_1; client_2]) ;
  let pause ?force msgs = Interactive_test.Pauser.generic state ?force msgs in
  let starting_level = 10 in
  List.fold
    (List.init (starting_level - 1) ~f:(fun n -> n))
    ~init:(return ()) (* We are already at level 1, we bake 7 times: *)
    ~f:(fun pm n ->
      pm
      >>= fun () ->
      Tezos_client.Keyed.bake
        state
        baker_0
        (sprintf "first bakes: [%d/%d]" (n + 1) (starting_level - 1)))
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`Equal_to starting_level)
  >>= fun () ->
  pause
    EF.
      [ af "Two clients ready";
        af "Node 0 baked %d times." (starting_level - 1);
        af "All nodes should be at level %d." starting_level ]
  >>= fun () ->
  let transfer _msg client =
    let dest =
      List.random_element_exn protocol.Tezos_protocol.bootstrap_accounts
      |> fst |> Tezos_protocol.Account.pubkey_hash
    in
    Tezos_client.successful_client_cmd
      state
      ~client
      [ "--wait";
        "none";
        "transfer";
        "1";
        "from";
        key_name;
        "to";
        dest;
        "--fee";
        "0.05" ]
    >>= fun res ->
    say
      state
      EF.(
        desc
          (af "Successful transfer (%s):" client.Tezos_client.id)
          (ocaml_string_list res#out))
  in
  List_sequential.iter intermediary_nodes ~f:(fun x ->
      Helpers.kill_node state x)
  >>= fun () ->
  let kill_all_but nodes iths =
    List_sequential.iteri nodes ~f:(fun ith n ->
        if List.mem iths ith ~equal:Int.equal then return ()
        else Helpers.kill_node state n)
  in
  let kill_nth_node nodes nth =
    Helpers.kill_node
      state
      (Option.value_exn ~message:"kill_nth_node" (List.nth nodes nth))
  in
  let restart_nth_node nodes nth =
    Helpers.restart_node
      state
      ~client_exec
      (Option.value_exn ~message:"restart_nth_node" (List.nth nodes nth))
  in
  let get_block_header ~client block =
    let path =
      sprintf
        "/chains/main/blocks/%s/header"
        (match block with `Head -> "head" | `Level i -> Int.to_string i)
    in
    Tezos_client.rpc state ~client `Get ~path
  in
  kill_all_but mesh_nodes [0]
  >>= fun () ->
  let number_of_lonely_bakes = 1 in
  pause EF.[af "Node 0 is the only one alive"]
  >>= fun () ->
  transfer "node0 only alive" client_0
  >>= fun () ->
  Loop.n_times number_of_lonely_bakes (fun n ->
      Tezos_client.Keyed.bake state baker_0 (sprintf "n0 only alive: %d" n))
  >>= fun () ->
  get_block_header ~client:client_0 `Head
  >>= fun _baking_0_header ->
  Tezos_client.Keyed.endorse state baker_0 "self-endorsing"
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_0 "baking self-endorsement"
  >>= fun () ->
  kill_nth_node mesh_nodes 0
  >>= fun () ->
  restart_nth_node mesh_nodes 1
  >>= fun () ->
  transfer "node1 only one alive" client_1
  >>= fun () ->
  Loop.n_times number_of_lonely_bakes (fun _ ->
      Tezos_client.Keyed.bake state baker_1 "after transfer")
  >>= fun () ->
  get_block_header ~client:client_1 `Head
  >>= fun _baking_1_header ->
  kill_nth_node mesh_nodes 1
  >>= fun () ->
  pause
    EF.
      [ af "Node 0 was killed";
        af "Node 1 was restarted";
        af "Node 1 transfered";
        af "Node 1 baked";
        af "Node 1 was killed" ]
  >>= fun () ->
  List.fold ~init:(return ()) intermediary_nodes ~f:(fun prev x ->
      prev >>= fun () -> Helpers.restart_node state ~client_exec x)
  >>= fun () ->
  let node_0 = List.nth_exn mesh_nodes 0 in
  let except_0 l = List.filter l ~f:Tezos_node.(fun n -> n.id <> node_0.id) in
  List_sequential.iter
    (except_0 mesh_nodes)
    ~f:(Helpers.restart_node state ~client_exec)
  >>= fun () ->
  pause EF.[af "All nodes restarted Except 0"]
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    (except_0 all_nodes)
    (`At_least (starting_level + number_of_lonely_bakes))
  >>= fun () ->
  Helpers.restart_node state ~client_exec node_0
  >>= fun () ->
  pause EF.[af "Restarted 0"]
  >>= fun () ->
  Helpers.wait_for state ~attempts:default_attempts ~seconds:8. (fun _ ->
      List.fold ~init:(return false) accuser_nodes ~f:(fun prev_m node ->
          prev_m
          >>= fun prev ->
          let client = Tezos_client.of_node node ~exec:client_exec in
          Tezos_client.mempool_has_operation
            state
            ~client
            ~kind:"double_baking_evidence"
          >>= fun client_result -> return (client_result || prev))
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf "Waiting for accusation to show up in the mempool")))
  >>= fun () ->
  Tezos_client.Keyed.bake
    state
    baker_2
    (sprintf "all at lvl %d" (starting_level + number_of_lonely_bakes + 1))
  >>= fun () ->
  Helpers.wait_for state ~attempts:10 ~seconds:4. (fun _ ->
      let level = starting_level + number_of_lonely_bakes + 2 in
      Tezos_client.block_has_operation
        state
        ~client:client_2
        ~level
        ~kind:"double_baking_evidence"
      >>= function
      | true ->
          return (`Done ())
      | false ->
          return
            (`Not_done
              (sprintf "Waiting for accusation to show up in block %d" level)))
  >>= fun () ->
  pause
    EF.
      [ af "One more baking (level should include accusation)";
        af
          "All nodes reaching level %d"
          (starting_level + number_of_lonely_bakes + 2) ]
  >>= fun () ->
  Tezos_client.Keyed.bake state baker_1 "a couple more"
  >>= fun () ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    all_nodes
    (`At_least (starting_level + number_of_lonely_bakes + 1))

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  let pf fmt = ksprintf (fun s -> `P s) fmt in
  let tests =
    let test variant name title man = (variant, name, title, man) in
    [ test
        `With_accusers
        "with-accusers"
        "Network With Accusers"
        (pf
           "This test builds a network with 3 interconnected meshes: Main, \
            Intermediate, and Accuser.");
      test
        `Simple_double_baking
        "simple-double-baking"
        "Simple Network With Manual Double Baking Accusation"
        (pf
           "This test builds a very simple 3-piece network, makes a baker \
            double bake and $(i,manually) inserts a double-baking accusation.");
      test
        `Simple_double_endorsing
        "simple-double-endorsing"
        "Simple Network With Manual Double Endorsing Accusation"
        (pf
           "This test builds a very simple 3-piece network, makes a baker \
            double endorse and $(i,manually) inserts a double-baking \
            accusation.") ]
  in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun test
             base_port
             (`Starting_level starting_level)
             bnod
             bcli
             accex
             generate_kiln_config
             protocol
             state
             ->
          let checks () =
            let acc = if test = `With_accusers then [accex] else [] in
            Helpers.System_dependencies.precheck
              state
              `Or_fail
              ~executables:(acc @ [bnod; bcli])
          in
          let actual_test () =
            match test with
            | `With_accusers ->
                checks ()
                >>= fun () ->
                with_accusers ~state bnod accex bcli ~base_port () ~protocol
            | `Simple_double_baking ->
                checks ()
                >>= fun () ->
                simple_double_baking
                  ~state
                  bnod
                  bcli
                  ~base_port
                  ?generate_kiln_config
                  ~starting_level
                  ~protocol
                  ()
            | `Simple_double_endorsing ->
                checks ()
                >>= fun () ->
                simple_double_endorsement
                  ~state
                  bnod
                  bcli
                  ~base_port
                  ?generate_kiln_config
                  ~starting_level
                  ~protocol
                  ()
          in
          (state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
    $ Arg.(
        required
          (pos
             0
             (some (enum (List.map tests ~f:(fun (v, n, _, _) -> (n, v)))))
             None
             (info [] ~docv:"TEST-NAME" ~doc:"Choose which test to run.")))
    $ Arg.(
        value & opt int 30_000
        & info ["base-port"] ~doc:"Base port number to build upon.")
    $ Arg.(
        pure (fun l -> `Starting_level l)
        $ value
            (opt
               int
               5
               (info
                  ["starting-level"]
                  ~doc:
                    "Initial block-level to reach before actually starting \
                     the test.")))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Accuser "tezos"
    $ Kiln.Configuration_directory.cli_term ()
    $ Tezos_protocol.cli_term ()
    $ Test_command_line.cli_state ~name:"accusing" () )
    (let doc = "Sandbox networks which record double-bakings." in
     let man : Manpage.block list =
       [ `S "ACCUSATION TESTS";
         pf
           "This command provides %d tests which use network sandboxes to \
            make double-bakings and double-endorsements happen."
           (List.length tests);
         `Blocks
           (List.map tests ~f:(fun (_, n, tit, m) ->
                `Blocks [pf "* $(b,`%s`): $(i,%s)." n tit; `Noblank; m])) ]
     in
     info ~man ~doc "accusations")
src/bin_sandbox/command_accusations.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition default_attempts : Z := 35.

Definition little_mesh_with_bakers {A B C D E F G H : Type}
  (base_port : option A) (generate_kiln_config : option B) (state : C)
  (protocol : D) (starting_level : Z) (node_exec : E) (client_exec : F)
  (bakers : G) (function_parameter : unit) : H :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar (op_startypeminuserrorstar state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state op_startypeminuserrorstar)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let block_interval := 1 in
          let '(protocol, baker_list) :=
            let d := protocol in
            op_startypeminuserrorstar in
          let net_size := 3 in
          let topology := op_startypeminuserrorstar in
          let all_nodes :=
            op_startypeminuserrorstar protocol node_exec topology base_port in
          op_startypeminuserrorstar (op_startypeminuserrorstar state all_nodes)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := op_startypeminuserrorstar state op_startypeminuserrorstar
                in
              op_startypeminuserrorstar op_startypeminuserrorstar
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let baker {I : Type} (nth_node : Z) : I :=
                    let nth_baker :=
                      Z.modulo nth_node (OCaml.List.length baker_list) in
                    let key_name :=
                      op_startypeminuserrorstar "b%d" % string nth_baker in
                    let node := op_startypeminuserrorstar all_nodes nth_node in
                    let client := op_startypeminuserrorstar node client_exec in
                    let baker_account :=
                      op_startypeminuserrorstar baker_list nth_baker in
                    let bak :=
                      op_startypeminuserrorstar client key_name
                        (op_startypeminuserrorstar (fst baker_account)) in
                    op_startypeminuserrorstar
                      (op_startypeminuserrorstar state bak)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        op_startypeminuserrorstar (client, bak)) in
                  op_startypeminuserrorstar (baker 0)
                    (fun function_parameter =>
                      let '(client_0, baker_0) := function_parameter in
                      op_startypeminuserrorstar (baker 1)
                        (fun function_parameter =>
                          let '(client_1, baker_1) := function_parameter in
                          op_startypeminuserrorstar (baker 2)
                            (fun function_parameter =>
                              let '(client_2, baker_2) := function_parameter in
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                op_startypeminuserrorstar state
                                  op_startypeminuserrorstar in
                              op_startypeminuserrorstar
                                (op_startypeminuserrorstar generate_kiln_config
                                  (fun kiln_config =>
                                    op_startypeminuserrorstar
                                      (op_startypeminuserrorstar state client_0
                                        (* ❌ Variants not supported *)
                                        variant "/chains/main/chain_id" % string)
                                      (fun chain_id_json =>
                                        let network_id :=
                                          match chain_id_json with
                                          | String s => s
                                          | _ =>
                                            (* ❌ Assert instruction is not handled. *)
                                            assert false
                                          end in
                                        op_startypeminuserrorstar
                                          (op_startypeminuserrorstar state
                                            kiln_config
                                            (List.map all_nodes
                                              (* ❌ expected an argument *)
                                              expected_argument
                                              (fun function_parameter =>
                                                let '_ := function_parameter in
                                                op_startypeminuserrorstar))
                                            (op_startypeminuserrorstar state
                                              protocol)
                                            (List.map all_nodes
                                              (* ❌ expected an argument *)
                                              expected_argument
                                              (fun function_parameter =>
                                                let '_ := function_parameter in
                                                op_startypeminuserrorstar
                                                  "http://localhost:%d" % string
                                                  op_startypeminuserrorstar))
                                            (List.map
                                              (Tezos_protocol.bootstrap_accounts
                                                protocol)
                                              (* ❌ expected an argument *)
                                              expected_argument
                                              (fun function_parameter =>
                                                let '(account, _) :=
                                                  function_parameter in
                                                op_startypeminuserrorstar))
                                            network_id node_exec client_exec)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_startypeminuserrorstar
                                              op_startypeminuserrorstar))))
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  let bake {I J K : Type} (msg : I) (baker : J)
                                    : K :=
                                    op_startypeminuserrorstar state baker msg in
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar
                                      (Stdlib.List.init (Z.sub starting_level 1)
                                        (* ❌ expected an argument *)
                                        expected_argument (fun n => n))
                                      (op_startypeminuserrorstar tt)
                                      (fun pm =>
                                        fun n =>
                                          op_startypeminuserrorstar pm
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              bake
                                                (op_startypeminuserrorstar
                                                  "first bakes: [%d/%d]" %
                                                    string (Z.add n 1)
                                                  (Z.sub starting_level 1))
                                                baker_0)))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar
                                        (op_startypeminuserrorstar state
                                          default_attempts
                                          (* ❌ Float constant 8. is approximated by the integer 8 *)
                                          8 all_nodes
                                          (* ❌ Variants not supported *)
                                          variant)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (op_startypeminuserrorstar state
                                              op_startypeminuserrorstar)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar
                                                (all_nodes, client_0, baker_0,
                                                  client_1, baker_1, client_2,
                                                  baker_2)))))))))))).

Definition wait_for_operation_in_mempools {A B C D E : Type}
  (state : A) (all_nodes : B) (kind : C) (client_exec : D) (how : variant)
  : E :=
  let '(init, combine) :=
    match how with
    | At_least_one => (false, orb)
    | All => (true, andb)
    end in
  op_startypeminuserrorstar state default_attempts
    (* ❌ Float constant 8. is approximated by the integer 8 *)
    8
    (fun function_parameter =>
      let '_ := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar (op_startypeminuserrorstar init) all_nodes
          (fun prev_m =>
            fun node =>
              op_startypeminuserrorstar prev_m
                (fun prev =>
                  let client := op_startypeminuserrorstar node client_exec in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar state client kind)
                    (fun client_result =>
                      op_startypeminuserrorstar (combine client_result prev)))))
        (fun function_parameter =>
          match function_parameter with
          | true =>
            op_startypeminuserrorstar
              (* ❌ Variants not supported *)
              variant
          | false =>
            op_startypeminuserrorstar
              (* ❌ Variants not supported *)
              variant
          end)).

Definition simple_double_baking {A B C D E F G : Type}
  (starting_level : Z) (generate_kiln_config : option A) (state : B)
  (protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
  (function_parameter : unit) : G :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (little_mesh_with_bakers (Some base_port) generate_kiln_config state
      protocol starting_level node_exec client_exec 1 tt)
    (fun function_parameter =>
      let
        '(all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) :=
        function_parameter in
      let kill_nth {H I : Type} (nth : H) : I :=
        OCaml.Stdlib.reverse_apply (op_startypeminuserrorstar all_nodes nth)
          (op_startypeminuserrorstar state) in
      let restart_nth {H I : Type} (nth : H) : I :=
        OCaml.Stdlib.reverse_apply (op_startypeminuserrorstar all_nodes nth)
          (op_startypeminuserrorstar client_exec state) in
      let number_of_lonely_bakes := 1 in
      op_startypeminuserrorstar (kill_nth 1)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar (kill_nth 2)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar (Z.sub number_of_lonely_bakes 1)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    op_startypeminuserrorstar state baker_0 "Bake-on-0" % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar state baker_0
                      "endorsing lonely bake-on-0" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar state baker_0
                          "Bake-on-0" % string)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar
                            (op_startypeminuserrorstar state client_0
                              (* ❌ Variants not supported *)
                              variant)
                            (fun baking_0_header =>
                              op_startypeminuserrorstar
                                (op_startypeminuserrorstar state baker_0
                                  "endorsing lonely bake-on-0" % string)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar
                                      (* ❌ Float constant 1. is approximated by the integer 1 *)
                                      1)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar (kill_nth 0)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (restart_nth 1)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar
                                                (restart_nth 2)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      number_of_lonely_bakes
                                                      (fun function_parameter =>
                                                        let '_ :=
                                                          function_parameter in
                                                        op_startypeminuserrorstar
                                                          state baker_1
                                                          "Bake-on-1" % string))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (op_startypeminuserrorstar
                                                          state client_1
                                                          (* ❌ Variants not supported *)
                                                          variant)
                                                        (fun baking_1_header =>
                                                          op_startypeminuserrorstar
                                                            (restart_nth 0)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  state baker_0
                                                                  "Bake-on-0" %
                                                                    string)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      state
                                                                      default_attempts
                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                      8
                                                                      all_nodes
                                                                      (* ❌ Variants not supported *)
                                                                      variant)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          state
                                                                          client_1
                                                                          (* ❌ Variants not supported *)
                                                                          variant
                                                                          "/chains/main/blocks/head/hash"
                                                                            %
                                                                            string)
                                                                        (fun
                                                                          head_hash_json
                                                                          =>
                                                                          op_startypeminuserrorstar
                                                                            (op_startypeminuserrorstar
                                                                              state
                                                                              op_startypeminuserrorstar)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                (op_startypeminuserrorstar
                                                                                  state
                                                                                  baker_1
                                                                                  (let
                                                                                    clean
                                                                                    {H
                                                                                    I
                                                                                    :
                                                                                    Type}
                                                                                    (header
                                                                                    :
                                                                                    H)
                                                                                    : I :=
                                                                                    op_startypeminuserrorstar
                                                                                    in
                                                                                  (* ❌ Variants not supported *)
                                                                                  variant))
                                                                                (fun
                                                                                  result
                                                                                  =>
                                                                                  op_startypeminuserrorstar
                                                                                    (op_startypeminuserrorstar
                                                                                      state
                                                                                      op_startypeminuserrorstar)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_startypeminuserrorstar
                                                                                        (wait_for_operation_in_mempools
                                                                                          state
                                                                                          all_nodes
                                                                                          "double_baking_evidence"
                                                                                            %
                                                                                            string
                                                                                          client_exec
                                                                                          (* ❌ Variants not supported *)
                                                                                          variant)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            'tt :=
                                                                                            function_parameter
                                                                                            in
                                                                                          op_startypeminuserrorstar
                                                                                            (op_startypeminuserrorstar
                                                                                              state
                                                                                              baker_2
                                                                                              (op_startypeminuserrorstar
                                                                                                "all at lvl %d"
                                                                                                  %
                                                                                                  string
                                                                                                (Z.add
                                                                                                  (Z.add
                                                                                                    starting_level
                                                                                                    number_of_lonely_bakes)
                                                                                                  1)))
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                'tt :=
                                                                                                function_parameter
                                                                                                in
                                                                                              let
                                                                                                last_level :=
                                                                                                Z.add
                                                                                                  (Z.add
                                                                                                    starting_level
                                                                                                    number_of_lonely_bakes)
                                                                                                  2
                                                                                                in
                                                                                              op_startypeminuserrorstar
                                                                                                (op_startypeminuserrorstar
                                                                                                  state
                                                                                                  op_startypeminuserrorstar)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  op_startypeminuserrorstar
                                                                                                    (op_startypeminuserrorstar
                                                                                                      state
                                                                                                      default_attempts
                                                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                      8
                                                                                                      all_nodes
                                                                                                      (* ❌ Variants not supported *)
                                                                                                      variant)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        'tt :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      op_startypeminuserrorstar
                                                                                                        (op_startypeminuserrorstar
                                                                                                          state
                                                                                                          10
                                                                                                          (* ❌ Float constant 4. is approximated by the integer 4 *)
                                                                                                          4
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            let
                                                                                                              '_ :=
                                                                                                              function_parameter
                                                                                                              in
                                                                                                            op_startypeminuserrorstar
                                                                                                              (op_startypeminuserrorstar
                                                                                                                state
                                                                                                                client_2
                                                                                                                last_level
                                                                                                                "double_baking_evidence"
                                                                                                                  %
                                                                                                                  string)
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                match
                                                                                                                  function_parameter
                                                                                                                  with
                                                                                                                |
                                                                                                                  true
                                                                                                                  =>
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                    variant
                                                                                                                |
                                                                                                                  false
                                                                                                                  =>
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                    variant
                                                                                                                end)))
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_startypeminuserrorstar
                                                                                                            state
                                                                                                            op_startypeminuserrorstar)))))))))))))))))))))))))).

Definition find_endorsement_in_mempool {A B C : Type} (state : A) (client : B)
  : C :=
  op_startypeminuserrorstar state 4
    (* ❌ Float constant 2. is approximated by the integer 2 *)
    2
    (fun function_parameter =>
      let '_ := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state client
          (fun o =>
            OCaml.Stdlib.reverse_apply
              (op_startypeminuserrorstar o "contents" % string)
              (op_startypeminuserrorstar
                (fun op =>
                  equiv_decb (op_startypeminuserrorstar op "kind" % string)
                    (* ❌ Variants not supported *)
                    variant))))
        (fun function_parameter =>
          match function_parameter with
          | None =>
            op_startypeminuserrorstar
              (* ❌ Variants not supported *)
              variant
          | Some e =>
            op_startypeminuserrorstar
              (* ❌ Variants not supported *)
              variant
          end)).

Definition simple_double_endorsement {A B C D E F G : Type}
  (starting_level : Z) (generate_kiln_config : option A) (state : B)
  (protocol : C) (base_port : D) (node_exec : E) (client_exec : F)
  (function_parameter : unit) : G :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (little_mesh_with_bakers (Some base_port) generate_kiln_config state
      protocol starting_level node_exec client_exec 2 tt)
    (fun function_parameter =>
      let
        '(all_nodes, client_0, baker_0, client_1, baker_1, client_2, baker_2) :=
        function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert op_startypeminuserrorstar in
      let node_0 := op_startypeminuserrorstar all_nodes 0 in
      let node_1 := op_startypeminuserrorstar all_nodes 1 in
      let node_2 := op_startypeminuserrorstar all_nodes 2 in
      let baker_1_n0 := op_startypeminuserrorstar in
      op_startypeminuserrorstar (op_startypeminuserrorstar state baker_1_n0)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_startypeminuserrorstar (op_startypeminuserrorstar state node_1)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar (op_startypeminuserrorstar state node_2)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar state baker_0
                      "endorsing lonely bake-on-0" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar state baker_0
                          "baker-0 baking with node 0" % string)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar
                            (op_startypeminuserrorstar state baker_0
                              "baker-0 endorsing with node 0" % string)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar
                                (find_endorsement_in_mempool state client_0)
                                (fun endorsement_0 =>
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state baker_1_n0
                                      "baker-1 endorsing with node 0" % string)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar
                                        (op_startypeminuserrorstar state node_0)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (op_startypeminuserrorstar state
                                              node_2 client_exec)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar
                                                (op_startypeminuserrorstar state
                                                  baker_2
                                                  "baker-0 baking with node 2" %
                                                    string)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      state baker_2
                                                      "baker-0 endorsing with node 2"
                                                        % string)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (find_endorsement_in_mempool
                                                          state client_2)
                                                        (fun endorsement_1 =>
                                                          op_startypeminuserrorstar
                                                            (op_startypeminuserrorstar
                                                              state
                                                              op_startypeminuserrorstar)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  state node_1
                                                                  client_exec)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      state
                                                                      default_attempts
                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                      8
                                                                      (cons
                                                                        node_1
                                                                        (cons
                                                                          node_2
                                                                          []))
                                                                      (* ❌ Variants not supported *)
                                                                      variant)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          state
                                                                          node_0
                                                                          client_exec)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (op_startypeminuserrorstar
                                                                              state
                                                                              node_2)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                (op_startypeminuserrorstar
                                                                                  state
                                                                                  node_2
                                                                                  client_exec)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  op_startypeminuserrorstar
                                                                                    (op_startypeminuserrorstar
                                                                                      state
                                                                                      default_attempts
                                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                      8
                                                                                      all_nodes
                                                                                      (* ❌ Variants not supported *)
                                                                                      variant)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_startypeminuserrorstar
                                                                                        (op_startypeminuserrorstar
                                                                                          state
                                                                                          client_1
                                                                                          (* ❌ Variants not supported *)
                                                                                          variant
                                                                                          "/chains/main/blocks/head/hash"
                                                                                            %
                                                                                            string)
                                                                                        (fun
                                                                                          head_hash_json
                                                                                          =>
                                                                                          let
                                                                                            double_endorsement :=
                                                                                            let
                                                                                              transform_endorsement
                                                                                              {H
                                                                                              :
                                                                                              Type}
                                                                                              (endorsement
                                                                                              :
                                                                                              H)
                                                                                              : variant :=
                                                                                              let
                                                                                                branch :=
                                                                                                op_startypeminuserrorstar
                                                                                                  "branch"
                                                                                                    %
                                                                                                    string
                                                                                                  endorsement
                                                                                                in
                                                                                              let
                                                                                                signature :=
                                                                                                op_startypeminuserrorstar
                                                                                                  "signature"
                                                                                                    %
                                                                                                    string
                                                                                                  endorsement
                                                                                                in
                                                                                              let
                                                                                                contents :=
                                                                                                match
                                                                                                  op_startypeminuserrorstar
                                                                                                    "contents"
                                                                                                      %
                                                                                                      string
                                                                                                    endorsement
                                                                                                  with
                                                                                                |
                                                                                                  A
                                                                                                    (cons
                                                                                                      one
                                                                                                      [])
                                                                                                  =>
                                                                                                  one
                                                                                                |
                                                                                                  _
                                                                                                  =>
                                                                                                  (* ❌ Assert instruction is not handled. *)
                                                                                                  assert
                                                                                                    false
                                                                                                end
                                                                                                in
                                                                                              (* ❌ Variants not supported *)
                                                                                              variant
                                                                                              in
                                                                                            let
                                                                                              inlined_endorsement_1 :=
                                                                                              transform_endorsement
                                                                                                endorsement_0
                                                                                              in
                                                                                            let
                                                                                              inlined_endorsement_2 :=
                                                                                              transform_endorsement
                                                                                                endorsement_1
                                                                                              in
                                                                                            (* ❌ Variants not supported *)
                                                                                            variant
                                                                                            in
                                                                                          op_startypeminuserrorstar
                                                                                            (op_startypeminuserrorstar
                                                                                              state
                                                                                              op_startypeminuserrorstar)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                'tt :=
                                                                                                function_parameter
                                                                                                in
                                                                                              op_startypeminuserrorstar
                                                                                                (op_startypeminuserrorstar
                                                                                                  state
                                                                                                  baker_1
                                                                                                  double_endorsement)
                                                                                                (fun
                                                                                                  result
                                                                                                  =>
                                                                                                  op_startypeminuserrorstar
                                                                                                    (op_startypeminuserrorstar
                                                                                                      state
                                                                                                      op_startypeminuserrorstar)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        'tt :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      op_startypeminuserrorstar
                                                                                                        (wait_for_operation_in_mempools
                                                                                                          state
                                                                                                          (cons
                                                                                                            node_1
                                                                                                            [])
                                                                                                          "double_endorsement_evidence"
                                                                                                            %
                                                                                                            string
                                                                                                          client_exec
                                                                                                          (* ❌ Variants not supported *)
                                                                                                          variant)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          let
                                                                                                            last_level :=
                                                                                                            Z.add
                                                                                                              starting_level
                                                                                                              2
                                                                                                            in
                                                                                                          op_startypeminuserrorstar
                                                                                                            (op_startypeminuserrorstar
                                                                                                              state
                                                                                                              baker_1
                                                                                                              (op_startypeminuserrorstar
                                                                                                                "level %d"
                                                                                                                  %
                                                                                                                  string
                                                                                                                last_level))
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                'tt :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_startypeminuserrorstar
                                                                                                                (op_startypeminuserrorstar
                                                                                                                  state
                                                                                                                  baker_1
                                                                                                                  (op_startypeminuserrorstar
                                                                                                                    "endorse level %d"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    last_level))
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    (op_startypeminuserrorstar
                                                                                                                      state
                                                                                                                      default_attempts
                                                                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                      8
                                                                                                                      all_nodes
                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                      variant)
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        'tt :=
                                                                                                                        function_parameter
                                                                                                                        in
                                                                                                                      op_startypeminuserrorstar
                                                                                                                        (op_startypeminuserrorstar
                                                                                                                          state
                                                                                                                          10
                                                                                                                          (* ❌ Float constant 4. is approximated by the integer 4 *)
                                                                                                                          4
                                                                                                                          (fun
                                                                                                                            function_parameter
                                                                                                                            =>
                                                                                                                            let
                                                                                                                              '_ :=
                                                                                                                              function_parameter
                                                                                                                              in
                                                                                                                            op_startypeminuserrorstar
                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                state
                                                                                                                                client_2
                                                                                                                                last_level
                                                                                                                                "double_endorsement_evidence"
                                                                                                                                  %
                                                                                                                                  string)
                                                                                                                              (fun
                                                                                                                                function_parameter
                                                                                                                                =>
                                                                                                                                match
                                                                                                                                  function_parameter
                                                                                                                                  with
                                                                                                                                |
                                                                                                                                  true
                                                                                                                                  =>
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                    variant
                                                                                                                                |
                                                                                                                                  false
                                                                                                                                  =>
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                    variant
                                                                                                                                end)))
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          let
                                                                                                                            'tt :=
                                                                                                                            function_parameter
                                                                                                                            in
                                                                                                                          op_startypeminuserrorstar
                                                                                                                            state
                                                                                                                            op_startypeminuserrorstar)))))))))))))))))))))))))))))).

Definition with_accusers {A B C D E F G : Type}
  (state : A) (protocol : B) (base_port : C) (node_exec : D) (accuser_exec : E)
  (client_exec : F) (function_parameter : unit) : G :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar (op_startypeminuserrorstar state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let block_interval := 2 in
      let '(protocol, baker_0_account) :=
        let d := protocol in
        op_startypeminuserrorstar in
      let topology := op_startypeminuserrorstar in
      let '(mesh_nodes, intermediary_nodes, accuser_nodes) :=
        op_startypeminuserrorstar protocol node_exec topology base_port in
      let all_nodes :=
        OCaml.Stdlib.app mesh_nodes
          (OCaml.Stdlib.app intermediary_nodes accuser_nodes) in
      op_startypeminuserrorstar (op_startypeminuserrorstar state all_nodes)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar op_startypeminuserrorstar
            (fun function_parameter =>
              let 'tt := function_parameter in
              let start_accuser {H I : Type} (nod : H) : I :=
                let client := op_startypeminuserrorstar nod client_exec in
                let acc := op_startypeminuserrorstar accuser_exec client nod in
                op_startypeminuserrorstar
                  (op_startypeminuserrorstar state
                    (op_startypeminuserrorstar acc state))
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    op_startypeminuserrorstar tt) in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar accuser_nodes start_accuser)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let key_name := "b0" % string in
                  let baker {H I : Type} (nth : H) : I :=
                    let node := op_startypeminuserrorstar all_nodes nth in
                    let client := op_startypeminuserrorstar node client_exec in
                    let bak :=
                      op_startypeminuserrorstar client key_name
                        (op_startypeminuserrorstar (fst baker_0_account)) in
                    op_startypeminuserrorstar
                      (op_startypeminuserrorstar state bak)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        op_startypeminuserrorstar (client, bak)) in
                  op_startypeminuserrorstar (baker 0)
                    (fun function_parameter =>
                      let '(client_0, baker_0) := function_parameter in
                      op_startypeminuserrorstar (baker 1)
                        (fun function_parameter =>
                          let '(client_1, baker_1) := function_parameter in
                          op_startypeminuserrorstar (baker 2)
                            (fun function_parameter =>
                              let '(client_2, baker_2) := function_parameter in
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                op_startypeminuserrorstar state
                                  op_startypeminuserrorstar in
                              let pause {H I J : Type}
                                (force : option H) (msgs : I) : J :=
                                op_startypeminuserrorstar state force msgs in
                              let starting_level := 10 in
                              op_startypeminuserrorstar
                                (op_startypeminuserrorstar
                                  (Stdlib.List.init (Z.sub starting_level 1)
                                    (* ❌ expected an argument *)
                                    expected_argument (fun n => n))
                                  (op_startypeminuserrorstar tt)
                                  (fun pm =>
                                    fun n =>
                                      op_startypeminuserrorstar pm
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar state
                                            baker_0
                                            (op_startypeminuserrorstar
                                              "first bakes: [%d/%d]" % string
                                              (Z.add n 1)
                                              (Z.sub starting_level 1)))))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state
                                      default_attempts
                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                      8 all_nodes
                                      (* ❌ Variants not supported *)
                                      variant)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar
                                        (pause None op_startypeminuserrorstar)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          let transfer {H I J : Type}
                                            (_msg : H) (client : I) : J :=
                                            let dest :=
                                              OCaml.Stdlib.reverse_apply
                                                (OCaml.Stdlib.reverse_apply
                                                  (op_startypeminuserrorstar
                                                    (Tezos_protocol.bootstrap_accounts
                                                      protocol)) fst)
                                                op_startypeminuserrorstar in
                                            op_startypeminuserrorstar
                                              (op_startypeminuserrorstar state
                                                client
                                                (cons "--wait" % string
                                                  (cons "none" % string
                                                    (cons "transfer" % string
                                                      (cons "1" % string
                                                        (cons "from" % string
                                                          (cons key_name
                                                            (cons "to" % string
                                                              (cons dest
                                                                (cons
                                                                  "--fee" %
                                                                    string
                                                                  (cons
                                                                    "0.05" %
                                                                      string [])))))))))))
                                              (fun res =>
                                                op_startypeminuserrorstar state
                                                  op_startypeminuserrorstar) in
                                          op_startypeminuserrorstar
                                            (op_startypeminuserrorstar
                                              intermediary_nodes
                                              (fun x =>
                                                op_startypeminuserrorstar state
                                                  x))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              let kill_all_but {H I J : Type}
                                                (nodes : H) (iths : I) : J :=
                                                op_startypeminuserrorstar nodes
                                                  (fun ith =>
                                                    fun n =>
                                                      if
                                                        Stdlib.List.mem iths ith
                                                          op_startypeminuserrorstar
                                                        then
                                                        op_startypeminuserrorstar
                                                          tt
                                                      else
                                                        op_startypeminuserrorstar
                                                          state n) in
                                              let kill_nth_node {H I : Type}
                                                (nodes : list H) (nth : Z)
                                                : I :=
                                                op_startypeminuserrorstar state
                                                  (op_startypeminuserrorstar
                                                    "kill_nth_node" % string
                                                    (Stdlib.List.nth nodes nth))
                                                in
                                              let restart_nth_node {H I : Type}
                                                (nodes : list H) (nth : Z)
                                                : I :=
                                                op_startypeminuserrorstar state
                                                  client_exec
                                                  (op_startypeminuserrorstar
                                                    "restart_nth_node" % string
                                                    (Stdlib.List.nth nodes nth))
                                                in
                                              let get_block_header {H I : Type}
                                                (client : H) (block : variant)
                                                : I :=
                                                let path :=
                                                  op_startypeminuserrorstar
                                                    "/chains/main/blocks/%s/header"
                                                      % string
                                                    match block with
                                                    | Head => "head" % string
                                                    | Level i =>
                                                      op_startypeminuserrorstar
                                                        i
                                                    end in
                                                op_startypeminuserrorstar state
                                                  client
                                                  (* ❌ Variants not supported *)
                                                  variant path in
                                              op_startypeminuserrorstar
                                                (kill_all_but mesh_nodes
                                                  (cons 0 []))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  let number_of_lonely_bakes :=
                                                    1 in
                                                  op_startypeminuserrorstar
                                                    (pause None
                                                      op_startypeminuserrorstar)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (transfer
                                                          "node0 only alive" %
                                                            string client_0)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_startypeminuserrorstar
                                                            (op_startypeminuserrorstar
                                                              number_of_lonely_bakes
                                                              (fun n =>
                                                                op_startypeminuserrorstar
                                                                  state baker_0
                                                                  (op_startypeminuserrorstar
                                                                    "n0 only alive: %d"
                                                                      % string n)))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (get_block_header
                                                                  client_0
                                                                  (* ❌ Variants not supported *)
                                                                  variant)
                                                                (fun
                                                                  _baking_0_header
                                                                  =>
                                                                  op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      state
                                                                      baker_0
                                                                      "self-endorsing"
                                                                        % string)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          state
                                                                          baker_0
                                                                          "baking self-endorsement"
                                                                            %
                                                                            string)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (kill_nth_node
                                                                              mesh_nodes
                                                                              0)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                (restart_nth_node
                                                                                  mesh_nodes
                                                                                  1)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  op_startypeminuserrorstar
                                                                                    (transfer
                                                                                      "node1 only one alive"
                                                                                        %
                                                                                        string
                                                                                      client_1)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_startypeminuserrorstar
                                                                                        (op_startypeminuserrorstar
                                                                                          number_of_lonely_bakes
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              '_ :=
                                                                                              function_parameter
                                                                                              in
                                                                                            op_startypeminuserrorstar
                                                                                              state
                                                                                              baker_1
                                                                                              "after transfer"
                                                                                                %
                                                                                                string))
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            'tt :=
                                                                                            function_parameter
                                                                                            in
                                                                                          op_startypeminuserrorstar
                                                                                            (get_block_header
                                                                                              client_1
                                                                                              (* ❌ Variants not supported *)
                                                                                              variant)
                                                                                            (fun
                                                                                              _baking_1_header
                                                                                              =>
                                                                                              op_startypeminuserrorstar
                                                                                                (kill_nth_node
                                                                                                  mesh_nodes
                                                                                                  1)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  op_startypeminuserrorstar
                                                                                                    (pause
                                                                                                      None
                                                                                                      op_startypeminuserrorstar)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        'tt :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      op_startypeminuserrorstar
                                                                                                        (op_startypeminuserrorstar
                                                                                                          (op_startypeminuserrorstar
                                                                                                            tt)
                                                                                                          intermediary_nodes
                                                                                                          (fun
                                                                                                            prev
                                                                                                            =>
                                                                                                            fun
                                                                                                              x
                                                                                                              =>
                                                                                                              op_startypeminuserrorstar
                                                                                                                prev
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    state
                                                                                                                    client_exec
                                                                                                                    x)))
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          let
                                                                                                            node_0 :=
                                                                                                            op_startypeminuserrorstar
                                                                                                              mesh_nodes
                                                                                                              0
                                                                                                            in
                                                                                                          let
                                                                                                            except_0
                                                                                                            {H
                                                                                                            :
                                                                                                            Type}
                                                                                                            (l
                                                                                                            :
                                                                                                            H
                                                                                                              ->
                                                                                                              bool)
                                                                                                            : (list
                                                                                                              H)
                                                                                                              ->
                                                                                                              list
                                                                                                                H :=
                                                                                                            Stdlib.List.filter
                                                                                                              l
                                                                                                              (* ❌ expected an argument *)
                                                                                                              expected_argument
                                                                                                              op_startypeminuserrorstar
                                                                                                            in
                                                                                                          op_startypeminuserrorstar
                                                                                                            (op_startypeminuserrorstar
                                                                                                              (except_0
                                                                                                                mesh_nodes)
                                                                                                              (op_startypeminuserrorstar
                                                                                                                state
                                                                                                                client_exec))
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                'tt :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_startypeminuserrorstar
                                                                                                                (pause
                                                                                                                  None
                                                                                                                  op_startypeminuserrorstar)
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    (op_startypeminuserrorstar
                                                                                                                      state
                                                                                                                      default_attempts
                                                                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                      8
                                                                                                                      op_startypeminuserrorstar
                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                      variant)
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        'tt :=
                                                                                                                        function_parameter
                                                                                                                        in
                                                                                                                      op_startypeminuserrorstar
                                                                                                                        (op_startypeminuserrorstar
                                                                                                                          state
                                                                                                                          client_exec
                                                                                                                          node_0)
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          let
                                                                                                                            'tt :=
                                                                                                                            function_parameter
                                                                                                                            in
                                                                                                                          op_startypeminuserrorstar
                                                                                                                            (pause
                                                                                                                              None
                                                                                                                              op_startypeminuserrorstar)
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              let
                                                                                                                                'tt :=
                                                                                                                                function_parameter
                                                                                                                                in
                                                                                                                              op_startypeminuserrorstar
                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                  state
                                                                                                                                  default_attempts
                                                                                                                                  (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                                  8
                                                                                                                                  (fun
                                                                                                                                    function_parameter
                                                                                                                                    =>
                                                                                                                                    let
                                                                                                                                      '_ :=
                                                                                                                                      function_parameter
                                                                                                                                      in
                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                          false)
                                                                                                                                        accuser_nodes
                                                                                                                                        (fun
                                                                                                                                          prev_m
                                                                                                                                          =>
                                                                                                                                          fun
                                                                                                                                            node
                                                                                                                                            =>
                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                              prev_m
                                                                                                                                              (fun
                                                                                                                                                prev
                                                                                                                                                =>
                                                                                                                                                let
                                                                                                                                                  client :=
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                    node
                                                                                                                                                    client_exec
                                                                                                                                                  in
                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                  (op_startypeminuserrorstar
                                                                                                                                                    state
                                                                                                                                                    client
                                                                                                                                                    "double_baking_evidence"
                                                                                                                                                      %
                                                                                                                                                      string)
                                                                                                                                                  (fun
                                                                                                                                                    client_result
                                                                                                                                                    =>
                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                      (orb
                                                                                                                                                        client_result
                                                                                                                                                        prev)))))
                                                                                                                                      (fun
                                                                                                                                        function_parameter
                                                                                                                                        =>
                                                                                                                                        match
                                                                                                                                          function_parameter
                                                                                                                                          with
                                                                                                                                        |
                                                                                                                                          true
                                                                                                                                          =>
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                            (* ❌ Variants not supported *)
                                                                                                                                            variant
                                                                                                                                        |
                                                                                                                                          false
                                                                                                                                          =>
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                            (* ❌ Variants not supported *)
                                                                                                                                            variant
                                                                                                                                        end)))
                                                                                                                                (fun
                                                                                                                                  function_parameter
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    'tt :=
                                                                                                                                    function_parameter
                                                                                                                                    in
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                      state
                                                                                                                                      baker_2
                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                        "all at lvl %d"
                                                                                                                                          %
                                                                                                                                          string
                                                                                                                                        (Z.add
                                                                                                                                          (Z.add
                                                                                                                                            starting_level
                                                                                                                                            number_of_lonely_bakes)
                                                                                                                                          1)))
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      let
                                                                                                                                        'tt :=
                                                                                                                                        function_parameter
                                                                                                                                        in
                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                          state
                                                                                                                                          10
                                                                                                                                          (* ❌ Float constant 4. is approximated by the integer 4 *)
                                                                                                                                          4
                                                                                                                                          (fun
                                                                                                                                            function_parameter
                                                                                                                                            =>
                                                                                                                                            let
                                                                                                                                              '_ :=
                                                                                                                                              function_parameter
                                                                                                                                              in
                                                                                                                                            let
                                                                                                                                              level :=
                                                                                                                                              Z.add
                                                                                                                                                (Z.add
                                                                                                                                                  starting_level
                                                                                                                                                  number_of_lonely_bakes)
                                                                                                                                                2
                                                                                                                                              in
                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                                state
                                                                                                                                                client_2
                                                                                                                                                level
                                                                                                                                                "double_baking_evidence"
                                                                                                                                                  %
                                                                                                                                                  string)
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  true
                                                                                                                                                  =>
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                                    variant
                                                                                                                                                |
                                                                                                                                                  false
                                                                                                                                                  =>
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                                    variant
                                                                                                                                                end)))
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          let
                                                                                                                                            'tt :=
                                                                                                                                            function_parameter
                                                                                                                                            in
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                            (pause
                                                                                                                                              None
                                                                                                                                              op_startypeminuserrorstar)
                                                                                                                                            (fun
                                                                                                                                              function_parameter
                                                                                                                                              =>
                                                                                                                                              let
                                                                                                                                                'tt :=
                                                                                                                                                function_parameter
                                                                                                                                                in
                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                  state
                                                                                                                                                  baker_1
                                                                                                                                                  "a couple more"
                                                                                                                                                    %
                                                                                                                                                    string)
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  let
                                                                                                                                                    'tt :=
                                                                                                                                                    function_parameter
                                                                                                                                                    in
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                    state
                                                                                                                                                    default_attempts
                                                                                                                                                    (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                                                    8
                                                                                                                                                    all_nodes
                                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                                    variant)))))))))))))))))))))))))))))))))))).

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

src/bin_sandbox/command_daemons_protocol_change.ml 230 errors
open Flextesa
open Internal_pervasives
open Console

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let wait_for_voting_period ?level_within_period state ~client ~attempts period
    =
  let period_name = Tezos_protocol.Voting_period.to_string period in
  let message =
    sprintf
      "Waiting for voting period: `%s`%s"
      period_name
      (Option.value_map
         level_within_period
         ~default:""
         ~f:(sprintf " (and level-within-period ≥ %d)"))
  in
  Console.say state EF.(wf "%s" message)
  >>= fun () ->
  Helpers.wait_for state ~attempts ~seconds:10. (fun nth ->
      Asynchronous_result.map_option level_within_period ~f:(fun lvl ->
          Tezos_client.rpc
            state
            ~client
            `Get
            ~path:"/chains/main/blocks/head/metadata"
          >>= fun json ->
          try
            let voting_period_position =
              Jqo.field ~k:"level" json
              |> Jqo.field ~k:"voting_period_position"
              |> Jqo.get_int
            in
            return (voting_period_position >= lvl)
          with e ->
            failf
              "Cannot get level.voting_period_position: %s"
              (Printexc.to_string e))
      >>= fun lvl_ok ->
      Tezos_client.rpc
        state
        ~client
        `Get
        ~path:"/chains/main/blocks/head/votes/current_period_kind"
      >>= function
      | `String p when p = period_name && (lvl_ok = None || lvl_ok = Some true)
        ->
          return (`Done (nth - 1))
      | _ ->
          Tezos_client.successful_client_cmd
            state
            ~client
            ["show"; "voting"; "period"]
          >>= fun res ->
          Console.say
            state
            EF.(
              desc_list
                (wf "Voting period:")
                [markdown_verbatim (String.concat ~sep:"\n" res#out)])
          >>= fun () -> return (`Not_done message))

let run state ~protocol ~size ~base_port ~no_daemons_for ?external_peer_ports
    ?generate_kiln_config ~node_exec ~client_exec ~first_baker_exec
    ~first_endorser_exec ~first_accuser_exec ~second_baker_exec
    ~second_endorser_exec ~second_accuser_exec ~admin_exec ~new_protocol_path
    ~extra_dummy_proposals_batch_size ~extra_dummy_proposals_batch_levels
    ~waiting_attempts test_variant () =
  Helpers.System_dependencies.precheck
    state
    `Or_fail
    ~protocol_paths:[new_protocol_path]
    ~executables:
      [ node_exec;
        client_exec;
        first_baker_exec;
        first_endorser_exec;
        first_accuser_exec;
        second_baker_exec;
        second_endorser_exec;
        second_accuser_exec ]
  >>= fun () ->
  Test_scenario.network_with_protocol
    ?external_peer_ports
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  Tezos_client.rpc
    state
    ~client:(Tezos_client.of_node (List.hd_exn nodes) ~exec:client_exec)
    `Get
    ~path:"/chains/main/chain_id"
  >>= fun chain_id_json ->
  let network_id =
    match chain_id_json with `String s -> s | _ -> assert false
  in
  let accusers =
    List.concat_map nodes ~f:(fun node ->
        let client = Tezos_client.of_node node ~exec:client_exec in
        [ Tezos_daemon.accuser_of_node
            ~exec:first_accuser_exec
            ~client
            node
            ~name_tag:"first";
          Tezos_daemon.accuser_of_node
            ~exec:second_accuser_exec
            ~client
            node
            ~name_tag:"second" ])
  in
  List_sequential.iter accusers ~f:(fun acc ->
      Running_processes.start state (Tezos_daemon.process acc ~state)
      >>= fun _ -> return ())
  >>= fun () ->
  let keys_and_daemons =
    let pick_a_node_and_client idx =
      match List.nth nodes ((1 + idx) mod List.length nodes) with
      | Some node ->
          (node, Tezos_client.of_node node ~exec:client_exec)
      | None ->
          assert false
    in
    Tezos_protocol.bootstrap_accounts protocol
    |> List.filter_mapi ~f:(fun idx acc ->
           let (node, client) = pick_a_node_and_client idx in
           let key = Tezos_protocol.Account.name acc in
           if List.mem ~equal:String.equal no_daemons_for key then None
           else
             Some
               ( acc,
                 client,
                 [ Tezos_daemon.baker_of_node
                     ~exec:first_baker_exec
                     ~client
                     node
                     ~key
                     ~name_tag:"first";
                   Tezos_daemon.baker_of_node
                     ~exec:second_baker_exec
                     ~client
                     ~name_tag:"second"
                     node
                     ~key;
                   Tezos_daemon.endorser_of_node
                     ~exec:first_endorser_exec
                     ~name_tag:"first"
                     ~client
                     node
                     ~key;
                   Tezos_daemon.endorser_of_node
                     ~exec:second_endorser_exec
                     ~name_tag:"second"
                     ~client
                     node
                     ~key ] ))
  in
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, daemons) ->
      Tezos_client.bootstrapped ~state client
      >>= fun () ->
      let (key, priv) = Tezos_protocol.Account.(name acc, private_key acc) in
      Tezos_client.import_secret_key ~state client key priv
      >>= fun () ->
      say
        state
        EF.(
          desc_list
            (haf "Registration-as-delegate:")
            [ desc (af "Client:") (af "%S" client.Tezos_client.id);
              desc (af "Key:") (af "%S" key) ])
      >>= fun () ->
      Tezos_client.register_as_delegate ~state client key
      >>= fun () ->
      say
        state
        EF.(
          desc_list
            (haf "Starting daemons:")
            [ desc (af "Client:") (af "%S" client.Tezos_client.id);
              desc (af "Key:") (af "%S" key) ])
      >>= fun () ->
      List_sequential.iter daemons ~f:(fun daemon ->
          Running_processes.start state (Tezos_daemon.process daemon ~state)
          >>= fun _ -> return ()))
  >>= fun () ->
  let client_0 =
    Tezos_client.of_node (List.nth_exn nodes 0) ~exec:client_exec
  in
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  (* 
     For each node we try to see if the node knows about the protocol,
     if it does we're good, if not we inject it.
     This is because `inject` fails when the node already knows a protocol.
  *)
  List.fold ~init:(return None) nodes ~f:(fun prevm nod ->
      prevm
      >>= fun _ ->
      System.read_file state (new_protocol_path // "TEZOS_PROTOCOL")
      >>= fun protocol ->
      ( try return Jqo.(of_string protocol |> field ~k:"hash" |> get_string)
        with e ->
          failf
            "Cannot parse %s/TEZOS_PROTOCOL: %s"
            new_protocol_path
            (Printexc.to_string e) )
      >>= fun hash ->
      let client = Tezos_client.of_node ~exec:client_exec nod in
      Tezos_client.rpc state ~client `Get ~path:"/protocols"
      >>= fun protocols ->
      match protocols with
      | `A l
        when List.exists l ~f:(function `String h -> h = hash | _ -> false) ->
          Console.say
            state
            EF.(
              wf
                "Node `%s` already knows protocol `%s`."
                nod.Tezos_node.id
                hash)
          >>= fun () -> return (Some hash)
      | _ ->
          let admin = make_admin client in
          Tezos_admin_client.inject_protocol
            admin
            state
            ~path:new_protocol_path
          >>= fun (_, new_protocol_hash) ->
          ( if new_protocol_hash = hash then
            Console.say
              state
              EF.(
                wf
                  "Injected protocol `%s` in `%s`"
                  new_protocol_hash
                  nod.Tezos_node.id)
          else
            failf
              "Injecting protocol %s failed (≠ %s)"
              new_protocol_hash
              hash )
          >>= fun () -> return (Some hash))
  >>= fun prot_opt ->
  ( match prot_opt with
  | Some s ->
      return s
  | None ->
      failf "protocol injection problem?" )
  >>= fun new_protocol_hash ->
  Asynchronous_result.map_option generate_kiln_config ~f:(fun kiln_config ->
      Kiln.Configuration_directory.generate
        state
        kiln_config
        ~peers:(List.map nodes ~f:(fun {Tezos_node.p2p_port; _} -> p2p_port))
        ~sandbox_json:(Tezos_protocol.sandbox_path ~config:state protocol)
        ~nodes:
          (List.map nodes ~f:(fun {Tezos_node.rpc_port; _} ->
               sprintf "http://localhost:%d" rpc_port))
        ~bakers:
          (List.map
             protocol.Tezos_protocol.bootstrap_accounts
             ~f:(fun (account, _) ->
               Tezos_protocol.Account.(name account, pubkey_hash account)))
        ~network_string:network_id
        ~node_exec
        ~client_exec
        ~protocol_execs:
          [ ( protocol.Tezos_protocol.hash,
              first_baker_exec,
              first_endorser_exec );
            (new_protocol_hash, second_baker_exec, second_endorser_exec) ]
      >>= fun () ->
      let msg =
        EF.(
          desc
            (shout "Kiln-Configuration DONE")
            (wf "Kiln was configured at `%s`" kiln_config.path))
      in
      Console.say state msg >>= fun () -> return msg)
  >>= fun kiln_info_opt ->
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:waiting_attempts
    ~seconds:10.
    nodes
    (* TODO: wait for /chains/main/blocks/head/votes/listings to be
       non-empty instead of counting blocks *)
    (`At_least protocol.Tezos_protocol.blocks_per_voting_period)
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ wf "Test becomes interactive.";
        Option.value kiln_info_opt ~default:(wf "");
        wf "Please type `q` to start a voting/protocol-change period." ]
    ~force:true
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Proposal
    ~level_within_period:3
  >>= fun _ ->
  let submit_prop acc client hash =
    Tezos_client.successful_client_cmd
      state
      ~client
      [ "submit";
        "proposals";
        "for";
        Tezos_protocol.Account.name acc;
        hash;
        "--force" ]
    >>= fun _ ->
    Console.sayf
      state
      Fmt.(
        fun ppf () ->
          pf ppf "%s voted for %s" (Tezos_protocol.Account.name acc) hash)
  in
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
      submit_prop acc client new_protocol_hash)
  >>= fun () ->
  let make_dummy_protocol_hashes t tag =
    List.map
      (List.init extra_dummy_proposals_batch_size ~f:(fun s ->
           sprintf "proto-%s-%d" tag s))
      ~f:(fun s ->
        (t, Tezos_crypto.Protocol_hash.(hash_string [s] |> to_b58check)))
  in
  let extra_dummy_protocols =
    List.bind extra_dummy_proposals_batch_levels ~f:(fun l ->
        make_dummy_protocol_hashes l (sprintf "%d" l))
  in
  Console.say
    state
    EF.(
      wf
        "Going to also vote for %s"
        (String.concat ~sep:", " (List.map extra_dummy_protocols ~f:snd)))
  >>= fun () ->
  List_sequential.iteri
    extra_dummy_protocols
    ~f:(fun nth (level, proto_hash) ->
      match List.nth keys_and_daemons (nth / 19) with
      | None ->
          failf "Too many dummy protocols Vs available voting power (%d)" nth
      | Some (acc, client, _) ->
          wait_for_voting_period
            state
            ~client:client_0
            ~attempts:waiting_attempts
            `Proposal
            ~level_within_period:level
          >>= fun _ -> submit_prop acc client proto_hash)
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Testing_vote
  >>= fun _ ->
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
      Tezos_client.successful_client_cmd
        state
        ~client
        [ "submit";
          "ballot";
          "for";
          Tezos_protocol.Account.name acc;
          new_protocol_hash;
          "yea" ]
      >>= fun _ ->
      Console.sayf
        state
        Fmt.(
          fun ppf () ->
            pf
              ppf
              "%s voted Yea to test %s"
              (Tezos_protocol.Account.name acc)
              new_protocol_hash))
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Promotion_vote
  >>= fun _ ->
  let protocol_switch_will_happen =
    match test_variant with
    | `Full_upgrade ->
        true
    | `Nay_for_promotion ->
        false
  in
  List_sequential.iter keys_and_daemons ~f:(fun (acc, client, _) ->
      Tezos_client.successful_client_cmd
        state
        ~client
        [ "submit";
          "ballot";
          "for";
          Tezos_protocol.Account.name acc;
          new_protocol_hash;
          (if protocol_switch_will_happen then "yea" else "nay") ]
      >>= fun _ ->
      Console.sayf
        state
        Fmt.(
          fun ppf () ->
            pf
              ppf
              "%s voted Yea to promote %s"
              (Tezos_protocol.Account.name acc)
              new_protocol_hash))
  >>= fun () ->
  wait_for_voting_period
    state
    ~client:client_0
    ~attempts:waiting_attempts
    `Proposal
  >>= fun _ ->
  Tezos_client.successful_client_cmd
    state
    ~client:client_0
    ["show"; "voting"; "period"]
  >>= fun res ->
  let protocol_to_wait_for =
    if protocol_switch_will_happen then new_protocol_hash
    else protocol.Tezos_protocol.hash
  in
  Helpers.wait_for state ~attempts:waiting_attempts ~seconds:4. (fun _ ->
      Console.say state EF.(wf "Checking actual protocol transition")
      >>= fun () ->
      Tezos_client.rpc
        state
        ~client:client_0
        `Get
        ~path:"/chains/main/blocks/head/metadata"
      >>= fun json ->
      ( try Jqo.field ~k:"protocol" json |> Jqo.get_string |> return
        with e -> failf "Cannot parse metadata: %s" (Printexc.to_string e) )
      >>= fun proto_hash ->
      if proto_hash <> protocol_to_wait_for then
        return
          (`Not_done
            (sprintf
               "Protocol not done: %s Vs %s"
               proto_hash
               protocol_to_wait_for))
      else return (`Done ()))
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ wf
          "Test finished, protocol is now %s, things should keep baking."
          protocol_to_wait_for;
        markdown_verbatim (String.concat ~sep:"\n" res#out) ]
    ~force:true

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  let variants =
    [ ( "full-upgrade",
        `Full_upgrade,
        "Go through the whole voting process and do the protocol change." );
      ( "nay-for-promotion",
        `Nay_for_promotion,
        "Go through the whole voting process but vote Nay at the last period \
         and hence stay on the same protocol." ) ]
  in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun size
             base_port
             (`Attempts waiting_attempts)
             (`External_peers external_peer_ports)
             (`No_daemons_for no_daemons_for)
             protocol
             node_exec
             client_exec
             admin_exec
             first_baker_exec
             first_endorser_exec
             first_accuser_exec
             second_baker_exec
             second_endorser_exec
             second_accuser_exec
             (`Protocol_path new_protocol_path)
             (`Extra_dummy_proposals_batch_size
               extra_dummy_proposals_batch_size)
             (`Extra_dummy_proposals_batch_levels
               extra_dummy_proposals_batch_levels)
             generate_kiln_config
             test_variant
             state
             ->
          let actual_test =
            run
              state
              ~size
              ~base_port
              ~protocol
              ~node_exec
              ~client_exec
              ~first_baker_exec
              ~first_endorser_exec
              ~first_accuser_exec
              ~second_baker_exec
              ~second_endorser_exec
              ~second_accuser_exec
              ~admin_exec
              ?generate_kiln_config
              ~external_peer_ports
              ~no_daemons_for
              ~new_protocol_path
              test_variant
              ~waiting_attempts
              ~extra_dummy_proposals_batch_size
              ~extra_dummy_proposals_batch_levels
          in
          (state, Interactive_test.Pauser.run_test ~pp_error state actual_test))
    $ Arg.(
        value & opt int 5
        & info ["size"; "S"] ~doc:"Set the size of the network.")
    $ Arg.(
        value & opt int 20_000
        & info ["base-port"; "P"] ~doc:"Base port number to build upon.")
    $ Arg.(
        pure (fun n -> `Attempts n)
        $ value
            (opt
               int
               60
               (info
                  ["waiting-attempts"]
                  ~doc:
                    "Number of attempts done while waiting for voting periods")))
    $ Arg.(
        pure (fun l -> `External_peers l)
        $ value
            (opt_all
               int
               []
               (info
                  ["add-external-peer-port"]
                  ~docv:"PORT-NUMBER"
                  ~doc:"Add $(docv) to the peers of the network nodes.")))
    $ Arg.(
        pure (fun l -> `No_daemons_for l)
        $ value
            (opt_all
               string
               []
               (info
                  ["no-daemons-for"]
                  ~docv:"ACCOUNT-NAME"
                  ~doc:"Do not start daemons for $(docv).")))
    $ Tezos_protocol.cli_term ()
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Admin "tezos"
    $ Tezos_executable.cli_term `Baker "first"
    $ Tezos_executable.cli_term `Endorser "first"
    $ Tezos_executable.cli_term `Accuser "first"
    $ Tezos_executable.cli_term `Baker "second"
    $ Tezos_executable.cli_term `Endorser "second"
    $ Tezos_executable.cli_term `Accuser "second"
    $ Arg.(
        pure (fun p -> `Protocol_path p)
        $ required
            (pos
               0
               (some string)
               None
               (info
                  []
                  ~doc:"The protocol to inject and vote on."
                  ~docv:"PROTOCOL-PATH")))
    $ Arg.(
        pure (fun l -> `Extra_dummy_proposals_batch_size l)
        $ value
            (opt
               int
               0
               (info
                  ["extra-dummy-proposals-batch-size"]
                  ~docv:"NUMBER"
                  ~doc:"Submit $(docv) extra proposals per batch.")))
    $ Arg.(
        pure (fun x -> `Extra_dummy_proposals_batch_levels x)
        $ value
            (opt
               (list ~sep:',' int)
               []
               (info
                  ["extra-dummy-proposals-batch-levels"]
                  ~docv:"NUMBER"
                  ~doc:
                    "Set the levels within the proposal period where batches \
                     of extra proposals appear, e.g. `3,5,7`.")))
    $ Kiln.Configuration_directory.cli_term ()
    $ Arg.(
        let doc =
          sprintf
            "Which variant of the test to run (one of {%s})"
            ( List.map ~f:(fun (n, _, _) -> n) variants
            |> String.concat ~sep:", " )
        in
        value
          (opt
             (enum (List.map variants ~f:(fun (n, v, _) -> (n, v))))
             `Full_upgrade
             (info ["test-variant"] ~doc)))
    $ Test_command_line.cli_state ~name:"daemons-upgrade" () )
    (let doc =
       "Vote and Protocol-upgrade with bakers, endorsers, and accusers."
     in
     let man : Manpage.block list =
       [ `S "DAEMONS-UPGRADE TEST";
         `P
           "This test builds and runs a sandbox network to do a full voting \
            round followed by a protocol change while all the daemons.";
         `P
           (sprintf
              "There are for now %d variants (see option `--test-variant`):"
              (List.length variants));
         `Blocks
           (List.concat_map variants ~f:(fun (n, _, desc) ->
                [`Noblank; `P (sprintf "* `%s`: %s" n desc)]));
         `P "The test is interactive-only:";
         `Blocks
           (List.concat_mapi
              ~f:(fun i s -> [`Noblank; `P (sprintf "%d) %s" (i + 1) s)])
              [ "It starts a sandbox assuming the protocol of the `--first-*` \
                 executables (use the `--protocol-hash` option to make sure \
                 it matches).";
                "An interactive pause is done to let the user play with the \
                 `first` protocol.";
                "Once the user quits the prompt (`q` or `quit` command), a \
                 full voting round happens with a single proposal: the one at \
                 `PROTOCOL-PATH` (which should be the one understood by the \
                 `--second-*` executables).";
                "Once the potential protocol switch has happened (and been \
                 verified), the test re-enters an interactive prompt to let \
                 the user play with the protocol (the first or second one, \
                 depending on the `--test-variant` option)." ]) ]
     in
     info "daemons-upgrade" ~man ~doc)
src/bin_sandbox/command_daemons_protocol_change.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition failf {A B : Type} (fmt : A) : B :=
  op_startypeminuserrorstar
    (fun s =>
      op_startypeminuserrorstar
        (* ❌ Variants not supported *)
        variant) fmt.

Definition wait_for_voting_period {A B C D E F : Type}
  (level_within_period : option A) (state : B) (client : C) (attempts : D)
  (period : E) : F :=
  let period_name := op_startypeminuserrorstar period in
  let message :=
    op_startypeminuserrorstar "Waiting for voting period: `%s`%s" % string
      period_name
      (op_startypeminuserrorstar level_within_period "" % string
        (op_startypeminuserrorstar " (and level-within-period ≥ %d)" % string))
    in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar state attempts
        (* ❌ Float constant 10. is approximated by the integer 10 *)
        10
        (fun nth =>
          op_startypeminuserrorstar
            (op_startypeminuserrorstar level_within_period
              (fun lvl =>
                op_startypeminuserrorstar
                  (op_startypeminuserrorstar state client
                    (* ❌ Variants not supported *)
                    variant "/chains/main/blocks/head/metadata" % string)
                  (fun json =>
                    (* ❌ Try-with are not handled *)
                    try
                      (let voting_period_position :=
                        OCaml.Stdlib.reverse_apply
                          (OCaml.Stdlib.reverse_apply
                            (op_startypeminuserrorstar "level" % string json)
                            (op_startypeminuserrorstar
                              "voting_period_position" % string))
                          op_startypeminuserrorstar in
                      op_startypeminuserrorstar
                        (OCaml.Stdlib.ge voting_period_position lvl)))))
            (fun lvl_ok =>
              op_startypeminuserrorstar
                (op_startypeminuserrorstar state client
                  (* ❌ Variants not supported *)
                  variant
                  "/chains/main/blocks/head/votes/current_period_kind" % string)
                (fun function_parameter =>
                  match function_parameter with
                  | String p =>
                    op_startypeminuserrorstar
                      (* ❌ Variants not supported *)
                      variant
                  | _ =>
                    op_startypeminuserrorstar
                      (op_startypeminuserrorstar state client
                        (cons "show" % string
                          (cons "voting" % string (cons "period" % string []))))
                      (fun res =>
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar state
                            op_startypeminuserrorstar)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_startypeminuserrorstar
                              (* ❌ Variants not supported *)
                              variant))
                  end)))).

Definition run {A B C D E F G H I J K L M : Type}
  (state : A) (protocol : B) (size : C) (base_port : D) (no_daemons_for : E)
  (external_peer_ports : option F) (generate_kiln_config : option G)
  (node_exec : H) (client_exec : H) (first_baker_exec : H)
  (first_endorser_exec : H) (first_accuser_exec : H) (second_baker_exec : H)
  (second_endorser_exec : H) (second_accuser_exec : H) (admin_exec : I)
  (new_protocol_path : J) (extra_dummy_proposals_batch_size : Z)
  (extra_dummy_proposals_batch_levels : K) (waiting_attempts : L)
  (test_variant : variant) (function_parameter : unit) : M :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state
      (* ❌ Variants not supported *)
      variant (cons new_protocol_path [])
      (cons node_exec
        (cons client_exec
          (cons first_baker_exec
            (cons first_endorser_exec
              (cons first_accuser_exec
                (cons second_baker_exec
                  (cons second_endorser_exec (cons second_accuser_exec [])))))))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar external_peer_ports protocol size base_port
          state node_exec client_exec)
        (fun function_parameter =>
          let '(nodes, protocol) := function_parameter in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar state
              (op_startypeminuserrorstar (op_startypeminuserrorstar nodes)
                client_exec)
              (* ❌ Variants not supported *)
              variant "/chains/main/chain_id" % string)
            (fun chain_id_json =>
              let network_id :=
                match chain_id_json with
                | String s => s
                | _ =>
                  (* ❌ Assert instruction is not handled. *)
                  assert false
                end in
              let accusers :=
                op_startypeminuserrorstar nodes
                  (fun node =>
                    let client := op_startypeminuserrorstar node client_exec in
                    cons
                      (op_startypeminuserrorstar first_accuser_exec client node
                        "first" % string)
                      (cons
                        (op_startypeminuserrorstar second_accuser_exec client
                          node "second" % string) [])) in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar accusers
                  (fun acc =>
                    op_startypeminuserrorstar
                      (op_startypeminuserrorstar state
                        (op_startypeminuserrorstar acc state))
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        op_startypeminuserrorstar tt)))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let keys_and_daemons :=
                    let pick_a_node_and_client {N O : Type} (idx : Z) : N * O :=
                      match
                        Stdlib.List.nth nodes
                          (Z.modulo (Z.add 1 idx) (OCaml.List.length nodes))
                        with
                      | Some node =>
                        (node, (op_startypeminuserrorstar node client_exec))
                      | None =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end in
                    OCaml.Stdlib.reverse_apply
                      (op_startypeminuserrorstar protocol)
                      (op_startypeminuserrorstar
                        (fun idx =>
                          fun acc =>
                            let '(node, client) := pick_a_node_and_client idx in
                            let key := op_startypeminuserrorstar acc in
                            if
                              Stdlib.List.mem no_daemons_for key
                                Stdlib.String.equal then
                              None
                            else
                              Some
                                (acc, client,
                                  (cons
                                    (op_startypeminuserrorstar first_baker_exec
                                      client node key "first" % string)
                                    (cons
                                      (op_startypeminuserrorstar
                                        second_baker_exec client
                                        "second" % string node key)
                                      (cons
                                        (op_startypeminuserrorstar
                                          first_endorser_exec "first" % string
                                          client node key)
                                        (cons
                                          (op_startypeminuserrorstar
                                            second_endorser_exec
                                            "second" % string client node key)
                                          []))))))) in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar keys_and_daemons
                      (fun function_parameter =>
                        let '(acc, client, daemons) := function_parameter in
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar state client)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            let '(key, priv) := op_startypeminuserrorstar in
                            op_startypeminuserrorstar
                              (op_startypeminuserrorstar state client key priv)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_startypeminuserrorstar
                                  (op_startypeminuserrorstar state
                                    op_startypeminuserrorstar)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_startypeminuserrorstar
                                      (op_startypeminuserrorstar state client
                                        key)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_startypeminuserrorstar
                                          (op_startypeminuserrorstar state
                                            op_startypeminuserrorstar)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_startypeminuserrorstar daemons
                                              (fun daemon =>
                                                op_startypeminuserrorstar
                                                  (op_startypeminuserrorstar
                                                    state
                                                    (op_startypeminuserrorstar
                                                      daemon state))
                                                  (fun function_parameter =>
                                                    let '_ := function_parameter
                                                      in
                                                    op_startypeminuserrorstar tt)))))))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let client_0 :=
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar nodes 0) client_exec in
                      let make_admin := op_startypeminuserrorstar admin_exec in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        op_startypeminuserrorstar state
                          op_startypeminuserrorstar in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar
                          (op_startypeminuserrorstar None) nodes
                          (fun prevm =>
                            fun nod =>
                              op_startypeminuserrorstar prevm
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state
                                      (op_startypeminuserrorstar
                                        new_protocol_path
                                        "TEZOS_PROTOCOL" % string))
                                    (fun protocol =>
                                      op_startypeminuserrorstar
                                        (* ❌ Try-with are not handled *)
                                        (try
                                          (op_startypeminuserrorstar
                                            op_startypeminuserrorstar))
                                        (fun hash =>
                                          let client :=
                                            op_startypeminuserrorstar
                                              client_exec nod in
                                          op_startypeminuserrorstar
                                            (op_startypeminuserrorstar state
                                              client
                                              (* ❌ Variants not supported *)
                                              variant "/protocols" % string)
                                            (fun protocols =>
                                              match protocols with
                                              | A l =>
                                                op_startypeminuserrorstar
                                                  (op_startypeminuserrorstar
                                                    state
                                                    op_startypeminuserrorstar)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_startypeminuserrorstar
                                                      (Some hash))
                                              | _ =>
                                                let admin := make_admin client
                                                  in
                                                op_startypeminuserrorstar
                                                  (op_startypeminuserrorstar
                                                    admin state
                                                    new_protocol_path)
                                                  (fun function_parameter =>
                                                    let
                                                      '(_, new_protocol_hash) :=
                                                      function_parameter in
                                                    op_startypeminuserrorstar
                                                      (if
                                                        equiv_decb
                                                          new_protocol_hash hash
                                                        then
                                                        op_startypeminuserrorstar
                                                          state
                                                          op_startypeminuserrorstar
                                                      else
                                                        failf
                                                          "Injecting protocol %s failed (≠ %s)"
                                                            % string
                                                          new_protocol_hash hash)
                                                      (fun function_parameter =>
                                                        let 'tt :=
                                                          function_parameter in
                                                        op_startypeminuserrorstar
                                                          (Some hash)))
                                              end))))))
                        (fun prot_opt =>
                          op_startypeminuserrorstar
                            match prot_opt with
                            | Some s => op_startypeminuserrorstar s
                            | None =>
                              failf "protocol injection problem?" % string
                            end
                            (fun new_protocol_hash =>
                              op_startypeminuserrorstar
                                (op_startypeminuserrorstar generate_kiln_config
                                  (fun kiln_config =>
                                    op_startypeminuserrorstar
                                      (op_startypeminuserrorstar state
                                        kiln_config op_startypeminuserrorstar
                                        (op_startypeminuserrorstar state
                                          protocol) op_startypeminuserrorstar
                                        (List.map
                                          (Tezos_protocol.bootstrap_accounts
                                            protocol)
                                          (* ❌ expected an argument *)
                                          expected_argument
                                          (fun function_parameter =>
                                            let '(account, _) :=
                                              function_parameter in
                                            op_startypeminuserrorstar))
                                        network_id node_exec client_exec
                                        (cons
                                          ((Tezos_protocol.hash protocol),
                                            first_baker_exec,
                                            first_endorser_exec)
                                          (cons
                                            (new_protocol_hash,
                                              second_baker_exec,
                                              second_endorser_exec) [])))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        let msg := op_startypeminuserrorstar in
                                        op_startypeminuserrorstar
                                          (op_startypeminuserrorstar state msg)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_startypeminuserrorstar msg))))
                                (fun kiln_info_opt =>
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state
                                      waiting_attempts
                                      (* ❌ Float constant 10. is approximated by the integer 10 *)
                                      10 nodes
                                      (* ❌ Variants not supported *)
                                      variant)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar
                                        (op_startypeminuserrorstar state
                                          op_startypeminuserrorstar true)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (wait_for_voting_period (Some 3)
                                              state client_0 waiting_attempts
                                              (* ❌ Variants not supported *)
                                              variant)
                                            (fun function_parameter =>
                                              let '_ := function_parameter in
                                              let submit_prop {N O P : Type}
                                                (acc : N) (client : O) (hash :
                                                string) : P :=
                                                op_startypeminuserrorstar
                                                  (op_startypeminuserrorstar
                                                    state client
                                                    (cons "submit" % string
                                                      (cons "proposals" % string
                                                        (cons "for" % string
                                                          (cons
                                                            (op_startypeminuserrorstar
                                                              acc)
                                                            (cons hash
                                                              (cons
                                                                "--force" %
                                                                  string [])))))))
                                                  (fun function_parameter =>
                                                    let '_ := function_parameter
                                                      in
                                                    op_startypeminuserrorstar
                                                      state
                                                      op_startypeminuserrorstar)
                                                in
                                              op_startypeminuserrorstar
                                                (op_startypeminuserrorstar
                                                  keys_and_daemons
                                                  (fun function_parameter =>
                                                    let '(acc, client, _) :=
                                                      function_parameter in
                                                    submit_prop acc client
                                                      new_protocol_hash))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  let make_dummy_protocol_hashes
                                                    {N O P : Type}
                                                    (t : N) (tag : O)
                                                    : (list (Z -> P)) ->
                                                      list (list P) :=
                                                    List.map
                                                      (Stdlib.List.init
                                                        extra_dummy_proposals_batch_size
                                                        (* ❌ expected an argument *)
                                                        expected_argument
                                                        (fun s =>
                                                          op_startypeminuserrorstar
                                                            "proto-%s-%d" %
                                                              string tag s))
                                                      (* ❌ expected an argument *)
                                                      expected_argument
                                                      (fun s =>
                                                        (t,
                                                          op_startypeminuserrorstar))
                                                    in
                                                  let extra_dummy_protocols :=
                                                    op_startypeminuserrorstar
                                                      extra_dummy_proposals_batch_levels
                                                      (fun l =>
                                                        make_dummy_protocol_hashes
                                                          l
                                                          (op_startypeminuserrorstar
                                                            "%d" % string l)) in
                                                  op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      state
                                                      op_startypeminuserrorstar)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (op_startypeminuserrorstar
                                                          extra_dummy_protocols
                                                          (fun nth =>
                                                            fun
                                                              function_parameter
                                                              =>
                                                              let
                                                                '(level,
                                                                  proto_hash) :=
                                                                function_parameter
                                                                in
                                                              match
                                                                Stdlib.List.nth
                                                                  keys_and_daemons
                                                                  (Z.div nth 19)
                                                                with
                                                              | None =>
                                                                failf
                                                                  "Too many dummy protocols Vs available voting power (%d)"
                                                                    % string nth
                                                              |
                                                                Some
                                                                  (acc, client,
                                                                    _) =>
                                                                op_startypeminuserrorstar
                                                                  (wait_for_voting_period
                                                                    (Some level)
                                                                    state
                                                                    client_0
                                                                    waiting_attempts
                                                                    (* ❌ Variants not supported *)
                                                                    variant)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let '_ :=
                                                                      function_parameter
                                                                      in
                                                                    submit_prop
                                                                      acc client
                                                                      proto_hash)
                                                              end))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_startypeminuserrorstar
                                                            (wait_for_voting_period
                                                              None state
                                                              client_0
                                                              waiting_attempts
                                                              (* ❌ Variants not supported *)
                                                              variant)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let '_ :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  keys_and_daemons
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let
                                                                      '(acc,
                                                                        client,
                                                                        _) :=
                                                                      function_parameter
                                                                      in
                                                                    op_startypeminuserrorstar
                                                                      (op_startypeminuserrorstar
                                                                        state
                                                                        client
                                                                        (cons
                                                                          "submit"
                                                                            %
                                                                            string
                                                                          (cons
                                                                            "ballot"
                                                                              %
                                                                              string
                                                                            (cons
                                                                              "for"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                (op_startypeminuserrorstar
                                                                                  acc)
                                                                                (cons
                                                                                  new_protocol_hash
                                                                                  (cons
                                                                                    "yea"
                                                                                      %
                                                                                      string
                                                                                    [])))))))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        let
                                                                          '_ :=
                                                                          function_parameter
                                                                          in
                                                                        op_startypeminuserrorstar
                                                                          state
                                                                          op_startypeminuserrorstar)))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    (wait_for_voting_period
                                                                      None state
                                                                      client_0
                                                                      waiting_attempts
                                                                      (* ❌ Variants not supported *)
                                                                      variant)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let '_ :=
                                                                        function_parameter
                                                                        in
                                                                      let
                                                                        protocol_switch_will_happen :=
                                                                        match
                                                                          test_variant
                                                                          with
                                                                        |
                                                                          Full_upgrade
                                                                          =>
                                                                          true
                                                                        |
                                                                          Nay_for_promotion
                                                                          =>
                                                                          false
                                                                        end in
                                                                      op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          keys_and_daemons
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              '(acc,
                                                                                client,
                                                                                _) :=
                                                                              function_parameter
                                                                              in
                                                                            op_startypeminuserrorstar
                                                                              (op_startypeminuserrorstar
                                                                                state
                                                                                client
                                                                                (cons
                                                                                  "submit"
                                                                                    %
                                                                                    string
                                                                                  (cons
                                                                                    "ballot"
                                                                                      %
                                                                                      string
                                                                                    (cons
                                                                                      "for"
                                                                                        %
                                                                                        string
                                                                                      (cons
                                                                                        (op_startypeminuserrorstar
                                                                                          acc)
                                                                                        (cons
                                                                                          new_protocol_hash
                                                                                          (cons
                                                                                            (if
                                                                                              protocol_switch_will_happen
                                                                                              then
                                                                                              "yea"
                                                                                                %
                                                                                                string
                                                                                            else
                                                                                              "nay"
                                                                                                %
                                                                                                string)
                                                                                            [])))))))
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                let
                                                                                  '_ :=
                                                                                  function_parameter
                                                                                  in
                                                                                op_startypeminuserrorstar
                                                                                  state
                                                                                  op_startypeminuserrorstar)))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (wait_for_voting_period
                                                                              None
                                                                              state
                                                                              client_0
                                                                              waiting_attempts
                                                                              (* ❌ Variants not supported *)
                                                                              variant)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                '_ :=
                                                                                function_parameter
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                (op_startypeminuserrorstar
                                                                                  state
                                                                                  client_0
                                                                                  (cons
                                                                                    "show"
                                                                                      %
                                                                                      string
                                                                                    (cons
                                                                                      "voting"
                                                                                        %
                                                                                        string
                                                                                      (cons
                                                                                        "period"
                                                                                          %
                                                                                          string
                                                                                        []))))
                                                                                (fun
                                                                                  res
                                                                                  =>
                                                                                  let
                                                                                    protocol_to_wait_for :=
                                                                                    if
                                                                                      protocol_switch_will_happen
                                                                                      then
                                                                                      new_protocol_hash
                                                                                    else
                                                                                      Tezos_protocol.hash
                                                                                        protocol
                                                                                    in
                                                                                  op_startypeminuserrorstar
                                                                                    (op_startypeminuserrorstar
                                                                                      state
                                                                                      waiting_attempts
                                                                                      (* ❌ Float constant 4. is approximated by the integer 4 *)
                                                                                      4
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        let
                                                                                          '_ :=
                                                                                          function_parameter
                                                                                          in
                                                                                        op_startypeminuserrorstar
                                                                                          (op_startypeminuserrorstar
                                                                                            state
                                                                                            op_startypeminuserrorstar)
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              'tt :=
                                                                                              function_parameter
                                                                                              in
                                                                                            op_startypeminuserrorstar
                                                                                              (op_startypeminuserrorstar
                                                                                                state
                                                                                                client_0
                                                                                                (* ❌ Variants not supported *)
                                                                                                variant
                                                                                                "/chains/main/blocks/head/metadata"
                                                                                                  %
                                                                                                  string)
                                                                                              (fun
                                                                                                json
                                                                                                =>
                                                                                                op_startypeminuserrorstar
                                                                                                  (* ❌ Try-with are not handled *)
                                                                                                  (try
                                                                                                    (OCaml.Stdlib.reverse_apply
                                                                                                      (OCaml.Stdlib.reverse_apply
                                                                                                        (op_startypeminuserrorstar
                                                                                                          "protocol"
                                                                                                            %
                                                                                                            string
                                                                                                          json)
                                                                                                        op_startypeminuserrorstar)
                                                                                                      op_startypeminuserrorstar))
                                                                                                  (fun
                                                                                                    proto_hash
                                                                                                    =>
                                                                                                    if
                                                                                                      nequiv_decb
                                                                                                        proto_hash
                                                                                                        protocol_to_wait_for
                                                                                                      then
                                                                                                      op_startypeminuserrorstar
                                                                                                        (* ❌ Variants not supported *)
                                                                                                        variant
                                                                                                    else
                                                                                                      op_startypeminuserrorstar
                                                                                                        (* ❌ Variants not supported *)
                                                                                                        variant)))))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_startypeminuserrorstar
                                                                                        state
                                                                                        op_startypeminuserrorstar
                                                                                        true))))))))))))))))))))).

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

src/bin_sandbox/command_ledger_baking.ml 255 errors
open Flextesa
open Internal_pervasives

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let ledger_prompt_notice state ~ef ?(button = `Checkmark) () =
  let button_str =
    match button with
    | `Checkmark ->
        "✔"
    | `X ->
        "❌"
    | `Both ->
        "❌ and ✔ at the same time"
  in
  Console.say
    state
    EF.(
      desc
        (shout "Ledger-prompt")
        (list [ef; wf "Press %s on the ledger." button_str]))

let assert_failure state msg f () =
  Console.say state EF.(wf "Asserting %s" msg)
  >>= fun () ->
  Asynchronous_result.bind_on_error
    (f () >>= fun _ -> return `Worked)
    ~f:(fun ~result:_ _ -> return `Didn'tWork)
  >>= function `Worked -> failf "%s" msg | `Didn'tWork -> return ()

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let assert_ a = if a then return () else failf "Assertion failed"

let assert_eq to_string ~expected ~actual =
  if expected = actual then return ()
  else
    failf
      "Assertion failed: expected %s but got %s"
      (to_string expected)
      (to_string actual)

let rec ask state ef =
  Console.say state EF.(list [ef; wf " (y/n)?"])
  >>= fun () ->
  System_error.catch Lwt_io.read_char Lwt_io.stdin
  >>= function
  | 'y' | 'Y' -> return true | 'n' | 'N' -> return false | _ -> ask state ef

let ask_assert state ef () = ask state ef >>= fun b -> assert_ b

let with_ledger_prompt state message expectation ~f =
  ledger_prompt_notice
    state
    ()
    ~button:(match expectation with `Succeeds -> `Checkmark | `Fails -> `X)
    ~ef:
      EF.(
        list
          [ message;
            wf "\n\n";
            wf
              ( match expectation with
              | `Succeeds ->
                  ">> ACCEPT THIS <<"
              | `Fails ->
                  ">> REJECT THIS <<" ) ])
  >>= fun () ->
  match expectation with
  | `Succeeds ->
      f () >>= fun _ -> Console.say state EF.(wf "> Got response: ACCEPTED")
  | `Fails ->
      assert_failure state "expected failure" f ()
      >>= fun () -> Console.say state EF.(wf "> Got response: REJECTED")

let with_ledger_test_reject_and_succeed state ef f =
  with_ledger_prompt state ef `Fails ~f
  >>= fun () -> with_ledger_prompt state ef `Succeeds ~f

let assert_hwms state ~client ~uri ~main ~test =
  Console.say
    state
    EF.(wf "Asserting main HWM = %d and test HWM = %d" main test)
  >>= fun () ->
  Tezos_client.Ledger.get_hwm state ~client ~uri
  >>= fun {main = main_actual; test = test_actual; _} ->
  assert_eq string_of_int ~actual:main_actual ~expected:main
  >>= fun () -> assert_eq string_of_int ~actual:test_actual ~expected:test

let get_chain_id state ~client =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
  >>= (function
        | `String x ->
            return x
        | _ ->
            failf "Failed to parse chain_id JSON from node")
  >>= fun chain_id_string ->
  return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)

let get_head_block_hash state ~client () =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
  >>= function
  | `String x ->
      return x
  | _ ->
      failf "Failed to parse block hash JSON from node"

let forge_endorsement state ~client ~chain_id ~level () =
  get_head_block_hash state ~client ()
  >>= fun branch ->
  let json =
    `O
      [ ("branch", `String branch);
        ( "contents",
          `A
            [ `O
                [ ("kind", `String "endorsement");
                  ("level", `Float (float_of_int level)) ] ] ) ]
  in
  Tezos_client.rpc
    state
    ~client
    ~path:"/chains/main/blocks/head/helpers/forge/operations"
    (`Post (Ezjsonm.to_string json))
  >>= function
  | `String operation_bytes ->
      let endorsement_magic_byte = "02" in
      return
        ( endorsement_magic_byte
        ^ (chain_id |> Tezos_crypto.Chain_id.to_hex |> Hex.show)
        ^ operation_bytes )
  | _ ->
      failf "Failed to forge operation or parse result"

let forge_delegation state ~client ~src ~dest ?(fee = 0.00126) () =
  get_head_block_hash state ~client ()
  >>= fun branch ->
  let json =
    `O
      [ ("branch", `String branch);
        ( "contents",
          `A
            [ `O
                [ ("kind", `String "delegation");
                  ("source", `String src);
                  ( "fee",
                    `String (string_of_int (int_of_float (fee *. 1000000.))) );
                  ("counter", `String (string_of_int 30713));
                  ("gas_limit", `String (string_of_int 10100));
                  ("delegate", `String dest);
                  ("storage_limit", `String (string_of_int 277)) ] ] ) ]
  in
  Tezos_client.rpc
    state
    ~client
    ~path:"/chains/main/blocks/head/helpers/forge/operations"
    (`Post (Ezjsonm.to_string json))
  >>= function
  | `String operation_bytes ->
      let magic_byte = "03" in
      return (magic_byte ^ operation_bytes)
  | _ ->
      failf "Failed to forge operation or parse result"

let sign state ~client ~bytes () =
  Tezos_client.successful_client_cmd
    state
    ~client:client.Tezos_client.Keyed.client
    ["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]
  >>= fun _ -> return ()

let originate_account_from state ~client ~account =
  let orig_account_name =
    Tezos_protocol.Account.name account ^ "-originated-account"
  in
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "originate";
      "account";
      orig_account_name;
      "for";
      Tezos_protocol.Account.name account;
      "transferring";
      string_of_int 1000;
      "from";
      Tezos_protocol.Account.name account;
      "--burn-cap";
      string_of_float 0.257 ]
  >>= fun _ -> return orig_account_name

let setup_baking_ledger state uri ~client ~protocol =
  Console.say state EF.(wf "Setting up the ledger device %S" uri)
  >>= fun () ->
  let key_name = "ledgered" in
  let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
  let assert_baking_key x () =
    let to_string = function Some x -> x | None -> "<none>" in
    Console.say
      state
      EF.(wf "Asserting that the authorized key is %s" (to_string x))
    >>= fun () ->
    Tezos_client.Ledger.get_authorized_key state ~client ~uri
    >>= fun auth_key -> assert_eq to_string ~expected:x ~actual:auth_key
  in
  Tezos_client.Ledger.deauthorize_baking state ~client ~uri
  (* TODO: The following assertion doesn't confirm anything if the ledger was already not authorized to bake. *)
  >>= assert_baking_key None
  >>= fun () ->
  Tezos_client.Ledger.show_ledger state ~client ~uri
  >>= fun account ->
  with_ledger_test_reject_and_succeed
    state
    EF.(
      wf
        "Importing %S in client `%s`. The ledger should be prompting for \
         acknowledgment to provide the public key of %s"
        uri
        client.Tezos_client.id
        (Tezos_protocol.Account.pubkey_hash account))
    (fun () ->
      Tezos_client.Keyed.initialize state baker >>= fun _ -> return ())
  >>= assert_failure state "baking before setup should fail" (fun () ->
          Tezos_client.Keyed.bake state baker "Baked by ledger")
  >>= assert_failure state "endorsing before setup should fail" (fun () ->
          Tezos_client.Keyed.endorse state baker "Endorsed by ledger")
  >>= fun () ->
  let test_invalid_delegations () =
    let ledger_pkh = Tezos_protocol.Account.pubkey_hash account in
    let other_pkh =
      Tezos_protocol.Account.pubkey_hash
        (fst (List.last_exn protocol.Tezos_protocol.bootstrap_accounts))
    in
    let cases =
      [ (ledger_pkh, other_pkh, "ledger to another account");
        (other_pkh, ledger_pkh, "another account to ledger");
        (other_pkh, other_pkh, "another account to another account") ]
    in
    List_sequential.iter cases ~f:(fun (src, dest, msg) ->
        forge_delegation state ~client ~src ~dest ()
        >>= fun forged_delegation_bytes ->
        assert_failure
          state
          (sprintf
             "signing a delegation from %s (%s to %s) should fail"
             msg
             src
             dest)
          (sign state ~client:baker ~bytes:forged_delegation_bytes)
          ())
  in
  test_invalid_delegations ()
  >>= fun () ->
  with_ledger_test_reject_and_succeed
    state
    EF.(
      wf
        "Setting up %S for baking.\n\
         Address: %S\n\
         Chain: mainnet\n\
         Main Chain HWM: 0\n\
         Test Chain HWM: 0"
        uri
        (Tezos_protocol.Account.pubkey_hash account))
    (fun () ->
      Tezos_client.successful_client_cmd
        state
        ~client
        [ "setup";
          "ledger";
          "to";
          "bake";
          "for";
          key_name;
          "--main-hwm";
          "0";
          "--test-hwm";
          "0" ])
  >>= assert_failure
        state
        "signing a 'Withdraw delegate' operation in Baking App should fail"
        (fun () ->
          Tezos_client.successful_client_cmd
            state
            ~client
            [ "--wait";
              "none";
              "withdraw";
              "delegate";
              "from";
              Tezos_protocol.Account.pubkey_hash account ])
  >>= assert_baking_key (Some uri)
  >>= test_invalid_delegations
  >>= fun () -> return (baker, account)

let run state ~protocol ~node_exec ~client_exec ~admin_exec ~size ~base_port
    ~uri ~enable_deterministic_nonce_tests () =
  Helpers.clear_root state
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
  Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
  >>= fun ledger_account ->
  let protocol =
    let open Tezos_protocol in
    {
      protocol with
      time_between_blocks = [1; 2];
      bootstrap_accounts =
        (ledger_account, 1_000_000_000_000L) :: protocol.bootstrap_accounts;
    }
  in
  let other_baker_account =
    fst (List.nth_exn protocol.Tezos_protocol.bootstrap_accounts 1)
  in
  Test_scenario.network_with_protocol
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
  >>= fun () ->
  let client n =
    Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
  in
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    Tezos_protocol.Account.
      [ "import";
        "secret";
        "key";
        name other_baker_account;
        private_key other_baker_account ]
  >>= fun _ ->
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    Tezos_protocol.Account.["bake"; "for"; name other_baker_account]
  >>= fun _ ->
  let assert_hwms_ ~main ~test () =
    assert_hwms state ~client:(client 0) ~uri ~main ~test
  in
  let set_hwm_ level () =
    with_ledger_prompt
      state
      EF.(wf "Setting HWM to %d" level)
      `Succeeds
      ~f:(fun () ->
        Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level)
  in
  get_chain_id state ~client:(client 0)
  >>= fun chain_id ->
  setup_baking_ledger state uri ~client:(client 0) ~protocol
  >>= fun (baker, ledger_account) ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.
      [ arbitrary_command_on_all_clients
          state
          ~command_names:["baker"]
          ~make_admin
          ~clients:[baker.Tezos_client.Keyed.client] ] ;
  let bake () = Tezos_client.Keyed.bake state baker "Baked by ledger" in
  let endorse () =
    Tezos_client.Keyed.endorse state baker "Endorsed by ledger"
  in
  let ask_hwm ~main ~test () =
    assert_hwms_ ~main ~test ()
    >>= ask_assert
          state
          EF.(wf "Is 'Chain' = %S and 'Last Block Level' = %d" "mainnet" main)
  in
  ( if enable_deterministic_nonce_tests then
    (* Test determinism of nonces *)
    Tezos_client.Keyed.generate_nonce state baker "this"
    >>= fun thisNonce1 ->
    Tezos_client.Keyed.generate_nonce state baker "that"
    >>= fun thatNonce1 ->
    Tezos_client.Keyed.generate_nonce state baker "this"
    >>= fun thisNonce2 ->
    Tezos_client.Keyed.generate_nonce state baker "that"
    >>= fun thatNonce2 ->
    assert_eq (fun x -> x) ~expected:thisNonce1 ~actual:thisNonce2
    >>= fun () ->
    assert_eq (fun x -> x) ~expected:thatNonce1 ~actual:thatNonce2
    >>= fun () -> assert_ (thisNonce1 <> thatNonce1)
  else return () )
  >>= fun () ->
  assert_failure
    state
    "originating an account from the Tezos Baking app should fail"
    (fun () ->
      originate_account_from state ~client:(client 0) ~account:ledger_account
      >>= fun _ -> return ())
    ()
  >>= fun () ->
  let fee = 0.00126 in
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  forge_delegation
    state
    ~client:(client 0)
    ()
    ~src:ledger_pkh
    ~dest:ledger_pkh
    ~fee
  >>= fun forged_delegation_bytes ->
  with_ledger_test_reject_and_succeed
    state
    EF.(wf "Self delegating address %s with fee %f" ledger_pkh fee)
    (sign state ~client:baker ~bytes:forged_delegation_bytes)
  >>= bake >>= ask_hwm ~main:3 ~test:0
  >>= fun () ->
  (let level = 1 in
   with_ledger_test_reject_and_succeed
     state
     EF.(wf "Setting HWM to %d" level)
     (fun () ->
       Tezos_client.Ledger.set_hwm state ~client:(client 0) ~uri ~level))
  >>= assert_hwms_ ~main:1 ~test:1
  >>= bake
  >>= assert_hwms_ ~main:4 ~test:1
  >>= set_hwm_ 5
  >>= assert_hwms_ ~main:5 ~test:5
  >>= assert_failure state "endorsing a level beneath HWM should fail" endorse
  >>= assert_failure state "baking a level beneath HWM should fail" bake
  >>= set_hwm_ 4 >>= bake
  >>= assert_hwms_ ~main:5 ~test:4
  >>= endorse (* does not increase level since we just baked *)
  >>= assert_failure state "endorsing same block twice should not work" endorse
  >>= assert_hwms_ ~main:5 ~test:4
  >>= bake
  >>= assert_hwms_ ~main:6 ~test:4
  >>= forge_endorsement state ~client:baker.client ~chain_id ~level:1
  >>= fun endorsement_at_low_level_bytes ->
  assert_failure
    state
    "endorsing-after-baking a level beneath HWM should fail"
    (sign state ~client:baker ~bytes:endorsement_at_low_level_bytes)
    ()
  >>= assert_hwms_ ~main:6 ~test:4
  (* HWM has not changed *)
  >>= endorse
  (* HWM still has not changed *)
  >>= assert_hwms_ ~main:6 ~test:4
  (* Forge an endorsement on a different chain *)
  >>= fun () ->
  let other_chain_id = "NetXSzLHKwSumh7" in
  Console.say
    state
    EF.(
      wf "Signing a forged endorsement on a different chain: %s" other_chain_id)
  >>= forge_endorsement
        state
        ~client:baker.client
        ~chain_id:(Tezos_crypto.Chain_id.of_b58check_exn other_chain_id)
        ~level:5
  >>= fun endorsement_on_different_chain_bytes ->
  sign state ~client:baker ~bytes:endorsement_on_different_chain_bytes ()
  (* Only the test HWM has changed *)
  >>= assert_hwms_ ~main:6 ~test:5
  >>= fun () ->
  Loop.n_times 5 (fun _ -> bake ())
  >>= ask_hwm ~main:11 ~test:5
  >>= fun () ->
  Tezos_client.Ledger.deauthorize_baking state ~client:(client 0) ~uri
  >>= assert_failure state "baking after deauthorization should fail" bake
  >>= assert_failure
        state
        "endorsing after deauthorization should fail"
        endorse

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun uri
             node_exec
             client_exec
             admin_exec
             size
             (`Base_port base_port)
             no_deterministic_nonce_tests
             protocol
             state
             ->
          ( state,
            Interactive_test.Pauser.run_test
              ~pp_error
              state
              (run
                 state
                 ~protocol
                 ~node_exec
                 ~size
                 ~admin_exec
                 ~base_port
                 ~client_exec
                 ~enable_deterministic_nonce_tests:
                   (not no_deterministic_nonce_tests)
                 ~uri) ))
    $ Arg.(
        required
          (pos
             0
             (some string)
             None
             (info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Admin "tezos"
    $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network")))
    $ Arg.(
        pure (fun p -> `Base_port p)
        $ value
            (opt
               int
               46_000
               (info ["base-port"; "P"] ~doc:"Base port number to build upon")))
    $ Arg.(
        value
          (flag
             (info
                ["no-deterministic-nonce-tests"]
                ~doc:"Disable tests for deterministic nonces")))
    $ Tezos_protocol.cli_term ()
    $ Test_command_line.cli_state ~name:"ledger-baking" () )
    (let doc = "Interactive test exercising the Ledger Baking app features" in
     info ~doc "ledger-baking")
src/bin_sandbox/command_ledger_baking.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition failf {A B : Type} (fmt : A) : B :=
  op_startypeminuserrorstar
    (fun s =>
      op_startypeminuserrorstar
        (* ❌ Variants not supported *)
        variant) fmt.

Definition ledger_prompt_notice {A B C : Type}
  (state : A) (ef : B) (op_staroptstar : option variant) : unit -> C :=
  let button :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    let button_str :=
      match button with
      | Checkmark => "✔" % string
      | X => "❌" % string
      | Both => "❌ and ✔ at the same time" % string
      end in
    op_startypeminuserrorstar state op_startypeminuserrorstar.

Definition assert_failure {A B C D : Type}
  (state : A) (msg : B) (f : unit -> C) (function_parameter : unit) : D :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar
          (op_startypeminuserrorstar (f tt)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_startypeminuserrorstar
                (* ❌ Variants not supported *)
                variant))
          (fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '_ := function_parameter in
              op_startypeminuserrorstar
                (* ❌ Variants not supported *)
                variant))
        (fun function_parameter =>
          match function_parameter with
          | Worked => failf "%s" % string msg
          | Didn'tWork => op_startypeminuserrorstar tt
          end)).

Definition failf {A B : Type} (fmt : A) : B :=
  op_startypeminuserrorstar
    (fun s =>
      op_startypeminuserrorstar
        (* ❌ Variants not supported *)
        variant) fmt.

Definition assert_ {A : Type} (a : bool) : A :=
  if a then
    op_startypeminuserrorstar tt
  else
    failf "Assertion failed" % string.

Definition assert_eq {A B C : Type}
  (to_string : A -> B) (expected : A) (actual : A) : C :=
  if equiv_decb expected actual then
    op_startypeminuserrorstar tt
  else
    failf "Assertion failed: expected %s but got %s" % string
      (to_string expected) (to_string actual).

Fixpoint ask {A B C : Type} (state : A) (ef : B) : C :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar op_startypeminuserrorstar
          op_startypeminuserrorstar)
        (fun function_parameter =>
          match function_parameter with
          | "y" % char | "Y" % char => op_startypeminuserrorstar true
          | "n" % char | "N" % char => op_startypeminuserrorstar false
          | _ => ask state ef
          end)).

Definition ask_assert {A B C : Type}
  (state : A) (ef : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar (ask state ef) (fun b => assert_ b).

Definition with_ledger_prompt {A B C D : Type}
  (state : A) (message : B) (expectation : variant) (f : unit -> C) : D :=
  op_startypeminuserrorstar
    (ledger_prompt_notice state op_startypeminuserrorstar
      (Some
        match expectation with
        | Succeeds =>
          (* ❌ Variants not supported *)
          variant
        | Fails =>
          (* ❌ Variants not supported *)
          variant
        end) tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      match expectation with
      | Succeeds =>
        op_startypeminuserrorstar (f tt)
          (fun function_parameter =>
            let '_ := function_parameter in
            op_startypeminuserrorstar state op_startypeminuserrorstar)
      | Fails =>
        op_startypeminuserrorstar
          (assert_failure state "expected failure" % string f tt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_startypeminuserrorstar state op_startypeminuserrorstar)
      end).

Definition with_ledger_test_reject_and_succeed {A B C D : Type}
  (state : A) (ef : B) (f : unit -> C) : D :=
  op_startypeminuserrorstar
    (with_ledger_prompt state ef
      (* ❌ Variants not supported *)
      variant f)
    (fun function_parameter =>
      let 'tt := function_parameter in
      with_ledger_prompt state ef
        (* ❌ Variants not supported *)
        variant f).

Definition assert_hwms {A B C D : Type}
  (state : A) (client : B) (uri : C) (main : Z) (test : Z) : D :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_startypeminuserrorstar
            (assert_eq OCaml.Stdlib.string_of_int main op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              assert_eq OCaml.Stdlib.string_of_int test
                op_startypeminuserrorstar))).

Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar
      (op_startypeminuserrorstar state client
        (* ❌ Variants not supported *)
        variant "/chains/main/chain_id" % string)
      (fun function_parameter =>
        match function_parameter with
        | String x => op_startypeminuserrorstar x
        | _ => failf "Failed to parse chain_id JSON from node" % string
        end))
    (fun chain_id_string =>
      op_startypeminuserrorstar (op_startypeminuserrorstar chain_id_string)).

Definition get_head_block_hash {A B C : Type}
  (state : A) (client : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state client
      (* ❌ Variants not supported *)
      variant "/chains/main/blocks/head/hash" % string)
    (fun function_parameter =>
      match function_parameter with
      | String x => op_startypeminuserrorstar x
      | _ => failf "Failed to parse block hash JSON from node" % string
      end).

Definition forge_endorsement {A B C D : Type}
  (state : A) (client : B) (chain_id : C) (level : Z)
  (function_parameter : unit) : D :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar (get_head_block_hash state client tt)
    (fun branch =>
      let json :=
        (* ❌ Variants not supported *)
        variant in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state client
          "/chains/main/blocks/head/helpers/forge/operations" % string
          (* ❌ Variants not supported *)
          variant)
        (fun function_parameter =>
          match function_parameter with
          | String operation_bytes =>
            let endorsement_magic_byte := "02" % string in
            op_startypeminuserrorstar
              (String.append endorsement_magic_byte
                (String.append
                  (OCaml.Stdlib.reverse_apply
                    (OCaml.Stdlib.reverse_apply chain_id
                      op_startypeminuserrorstar) op_startypeminuserrorstar)
                  operation_bytes))
          | _ => failf "Failed to forge operation or parse result" % string
          end)).

Definition forge_delegation {A B C : Type}
  (state : A) (client : B) (src : string) (dest : string)
  (op_staroptstar : option Z) : unit -> C :=
  let fee :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Float constant 0.00126 is approximated by the integer 0 *)
      0
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    op_startypeminuserrorstar (get_head_block_hash state client tt)
      (fun branch =>
        let json :=
          (* ❌ Variants not supported *)
          variant in
        op_startypeminuserrorstar
          (op_startypeminuserrorstar state client
            "/chains/main/blocks/head/helpers/forge/operations" % string
            (* ❌ Variants not supported *)
            variant)
          (fun function_parameter =>
            match function_parameter with
            | String operation_bytes =>
              let magic_byte := "03" % string in
              op_startypeminuserrorstar
                (String.append magic_byte operation_bytes)
            | _ => failf "Failed to forge operation or parse result" % string
            end)).

Definition sign {A B C : Type}
  (state : A) (client : B) (bytes : string) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state (Tezos_client.Keyed.client client)
      (cons "sign" % string
        (cons "bytes" % string
          (cons (String.append "0x" % string string)
            (cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))))
    (fun function_parameter =>
      let '_ := function_parameter in
      op_startypeminuserrorstar tt).

Definition originate_account_from {A B C D : Type}
  (state : A) (client : B) (account : C) : D :=
  let orig_account_name :=
    String.append (op_startypeminuserrorstar account)
      "-originated-account" % string in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state client
      (cons "originate" % string
        (cons "account" % string
          (cons orig_account_name
            (cons "for" % string
              (cons (op_startypeminuserrorstar account)
                (cons "transferring" % string
                  (cons (OCaml.Stdlib.string_of_int 1000)
                    (cons "from" % string
                      (cons (op_startypeminuserrorstar account)
                        (cons "--burn-cap" % string
                          (cons
                            (Stdlib.string_of_float
                              (* ❌ Float constant 0.257 is approximated by the integer 0 *)
                              0) []))))))))))))
    (fun function_parameter =>
      let '_ := function_parameter in
      op_startypeminuserrorstar orig_account_name).

Definition setup_baking_ledger {A B C D : Type}
  (state : A) (uri : string) (client : B) (protocol : C) : D :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let key_name := "ledgered" % string in
      let baker := op_startypeminuserrorstar client key_name uri in
      let assert_baking_key {E : Type}
        (x : option string) (function_parameter : unit) : E :=
        let 'tt := function_parameter in
        let to_string (function_parameter : option string) : string :=
          match function_parameter with
          | Some x => x
          | None => "<none>" % string
          end in
        op_startypeminuserrorstar
          (op_startypeminuserrorstar state op_startypeminuserrorstar)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_startypeminuserrorstar
              (op_startypeminuserrorstar state client uri)
              (fun auth_key => assert_eq to_string x auth_key)) in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
          (assert_baking_key None))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar (op_startypeminuserrorstar state client uri)
            (fun account =>
              op_startypeminuserrorstar
                (op_startypeminuserrorstar
                  (op_startypeminuserrorstar
                    (with_ledger_test_reject_and_succeed state
                      op_startypeminuserrorstar
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar state baker)
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            op_startypeminuserrorstar tt)))
                    (assert_failure state
                      "baking before setup should fail" % string
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar state baker
                          "Baked by ledger" % string)))
                  (assert_failure state
                    "endorsing before setup should fail" % string
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar state baker
                        "Endorsed by ledger" % string)))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let test_invalid_delegations {E : Type}
                    (function_parameter : unit) : E :=
                    let 'tt := function_parameter in
                    let ledger_pkh := op_startypeminuserrorstar account in
                    let other_pkh :=
                      op_startypeminuserrorstar
                        (fst
                          (op_startypeminuserrorstar
                            (Tezos_protocol.bootstrap_accounts protocol))) in
                    let cases :=
                      cons
                        (ledger_pkh, other_pkh,
                          "ledger to another account" % string)
                        (cons
                          (other_pkh, ledger_pkh,
                            "another account to ledger" % string)
                          (cons
                            (other_pkh, other_pkh,
                              "another account to another account" % string) []))
                      in
                    op_startypeminuserrorstar cases
                      (fun function_parameter =>
                        let '(src, dest, msg) := function_parameter in
                        op_startypeminuserrorstar
                          (forge_delegation state client src dest None tt)
                          (fun forged_delegation_bytes =>
                            assert_failure state
                              (op_startypeminuserrorstar
                                "signing a delegation from %s (%s to %s) should fail"
                                  % string msg src dest)
                              (sign state baker forged_delegation_bytes) tt)) in
                  op_startypeminuserrorstar (test_invalid_delegations tt)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar
                          (op_startypeminuserrorstar
                            (op_startypeminuserrorstar
                              (with_ledger_test_reject_and_succeed state
                                op_startypeminuserrorstar
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar state client
                                    (cons "setup" % string
                                      (cons "ledger" % string
                                        (cons "to" % string
                                          (cons "bake" % string
                                            (cons "for" % string
                                              (cons key_name
                                                (cons "--main-hwm" % string
                                                  (cons "0" % string
                                                    (cons "--test-hwm" % string
                                                      (cons "0" % string []))))))))))))
                              (assert_failure state
                                "signing a 'Withdraw delegate' operation in Baking App should fail"
                                  % string
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar state client
                                    (cons "--wait" % string
                                      (cons "none" % string
                                        (cons "withdraw" % string
                                          (cons "delegate" % string
                                            (cons "from" % string
                                              (cons
                                                (op_startypeminuserrorstar
                                                  account) [])))))))))
                            (assert_baking_key (Some uri)))
                          test_invalid_delegations)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar (baker, account))))))).

Definition run {A B C D E F G H : Type}
  (state : A) (protocol : B) (node_exec : C) (client_exec : D) (admin_exec : E)
  (size : F) (base_port : G) (uri : string)
  (enable_deterministic_nonce_tests : bool) (function_parameter : unit) : H :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar (op_startypeminuserrorstar state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state op_startypeminuserrorstar)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let ledger_client := op_startypeminuserrorstar client_exec in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar state ledger_client uri)
            (fun ledger_account =>
              let protocol := op_startypeminuserrorstar in
              let other_baker_account :=
                fst
                  (op_startypeminuserrorstar
                    (Tezos_protocol.bootstrap_accounts protocol) 1) in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar protocol size base_port state
                  node_exec client_exec)
                (fun function_parameter =>
                  let '(nodes, protocol) := function_parameter in
                  let make_admin := op_startypeminuserrorstar admin_exec in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    op_startypeminuserrorstar state op_startypeminuserrorstar in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar state op_startypeminuserrorstar)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let client {I J : Type} (n : I) : J :=
                        op_startypeminuserrorstar client_exec
                          (op_startypeminuserrorstar nodes n) in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar state (client 0)
                          op_startypeminuserrorstar)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          op_startypeminuserrorstar
                            (op_startypeminuserrorstar state (client 0)
                              op_startypeminuserrorstar)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              let assert_hwms_ {I : Type}
                                (main : Z) (test : Z) (function_parameter :
                                unit) : I :=
                                let 'tt := function_parameter in
                                assert_hwms state (client 0) uri main test in
                              let set_hwm_ {I J : Type}
                                (level : I) (function_parameter : unit) : J :=
                                let 'tt := function_parameter in
                                with_ledger_prompt state
                                  op_startypeminuserrorstar
                                  (* ❌ Variants not supported *)
                                  variant
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_startypeminuserrorstar state (client 0)
                                      uri level) in
                              op_startypeminuserrorstar
                                (get_chain_id state (client 0))
                                (fun chain_id =>
                                  op_startypeminuserrorstar
                                    (setup_baking_ledger state uri (client 0)
                                      protocol)
                                    (fun function_parameter =>
                                      let '(baker, ledger_account) :=
                                        function_parameter in
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        op_startypeminuserrorstar state
                                          op_startypeminuserrorstar in
                                      let bake {I : Type}
                                        (function_parameter : unit) : I :=
                                        let 'tt := function_parameter in
                                        op_startypeminuserrorstar state baker
                                          "Baked by ledger" % string in
                                      let endorse {I : Type}
                                        (function_parameter : unit) : I :=
                                        let 'tt := function_parameter in
                                        op_startypeminuserrorstar state baker
                                          "Endorsed by ledger" % string in
                                      let ask_hwm {I : Type}
                                        (main : Z) (test : Z)
                                        (function_parameter : unit) : I :=
                                        let 'tt := function_parameter in
                                        op_startypeminuserrorstar
                                          (assert_hwms_ main test tt)
                                          (ask_assert state
                                            op_startypeminuserrorstar) in
                                      op_startypeminuserrorstar
                                        (if enable_deterministic_nonce_tests
                                          then
                                          op_startypeminuserrorstar
                                            (op_startypeminuserrorstar state
                                              baker "this" % string)
                                            (fun thisNonce1 =>
                                              op_startypeminuserrorstar
                                                (op_startypeminuserrorstar state
                                                  baker "that" % string)
                                                (fun thatNonce1 =>
                                                  op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      state baker
                                                      "this" % string)
                                                    (fun thisNonce2 =>
                                                      op_startypeminuserrorstar
                                                        (op_startypeminuserrorstar
                                                          state baker
                                                          "that" % string)
                                                        (fun thatNonce2 =>
                                                          op_startypeminuserrorstar
                                                            (assert_eq
                                                              (fun x => x)
                                                              thisNonce1
                                                              thisNonce2)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (assert_eq
                                                                  (fun x => x)
                                                                  thatNonce1
                                                                  thatNonce2)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  assert_
                                                                    (nequiv_decb
                                                                      thisNonce1
                                                                      thatNonce1)))))))
                                        else
                                          op_startypeminuserrorstar tt)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (assert_failure state
                                              "originating an account from the Tezos Baking app should fail"
                                                % string
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                op_startypeminuserrorstar
                                                  (originate_account_from state
                                                    (client 0) ledger_account)
                                                  (fun function_parameter =>
                                                    let '_ := function_parameter
                                                      in
                                                    op_startypeminuserrorstar tt))
                                              tt)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              let fee :=
                                                (* ❌ Float constant 0.00126 is approximated by the integer 0 *)
                                                0 in
                                              let ledger_pkh :=
                                                op_startypeminuserrorstar
                                                  ledger_account in
                                              op_startypeminuserrorstar
                                                (forge_delegation state
                                                  (client 0) ledger_pkh
                                                  ledger_pkh (Some fee) tt)
                                                (fun forged_delegation_bytes =>
                                                  op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      (op_startypeminuserrorstar
                                                        (with_ledger_test_reject_and_succeed
                                                          state
                                                          op_startypeminuserrorstar
                                                          (sign state baker
                                                            forged_delegation_bytes))
                                                        bake) (ask_hwm 3 0))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (op_startypeminuserrorstar
                                                          (op_startypeminuserrorstar
                                                            (op_startypeminuserrorstar
                                                              (op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  (op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      (op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          (op_startypeminuserrorstar
                                                                            (op_startypeminuserrorstar
                                                                              (op_startypeminuserrorstar
                                                                                (op_startypeminuserrorstar
                                                                                  (op_startypeminuserrorstar
                                                                                    (op_startypeminuserrorstar
                                                                                      (op_startypeminuserrorstar
                                                                                        (let
                                                                                          level :=
                                                                                          1
                                                                                          in
                                                                                        with_ledger_test_reject_and_succeed
                                                                                          state
                                                                                          op_startypeminuserrorstar
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              'tt :=
                                                                                              function_parameter
                                                                                              in
                                                                                            op_startypeminuserrorstar
                                                                                              state
                                                                                              (client
                                                                                                0)
                                                                                              uri
                                                                                              level))
                                                                                        (assert_hwms_
                                                                                          1
                                                                                          1))
                                                                                      bake)
                                                                                    (assert_hwms_
                                                                                      4
                                                                                      1))
                                                                                  (set_hwm_
                                                                                    5))
                                                                                (assert_hwms_
                                                                                  5
                                                                                  5))
                                                                              (assert_failure
                                                                                state
                                                                                "endorsing a level beneath HWM should fail"
                                                                                  %
                                                                                  string
                                                                                endorse))
                                                                            (assert_failure
                                                                              state
                                                                              "baking a level beneath HWM should fail"
                                                                                %
                                                                                string
                                                                              bake))
                                                                          (set_hwm_
                                                                            4))
                                                                        bake)
                                                                      (assert_hwms_
                                                                        5 4))
                                                                    endorse)
                                                                  (assert_failure
                                                                    state
                                                                    "endorsing same block twice should not work"
                                                                      % string
                                                                    endorse))
                                                                (assert_hwms_ 5
                                                                  4)) bake)
                                                            (assert_hwms_ 6 4))
                                                          (forge_endorsement
                                                            state (client baker)
                                                            chain_id 1))
                                                        (fun
                                                          endorsement_at_low_level_bytes
                                                          =>
                                                          op_startypeminuserrorstar
                                                            (op_startypeminuserrorstar
                                                              (op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  (assert_failure
                                                                    state
                                                                    "endorsing-after-baking a level beneath HWM should fail"
                                                                      % string
                                                                    (sign state
                                                                      baker
                                                                      endorsement_at_low_level_bytes)
                                                                    tt)
                                                                  (assert_hwms_
                                                                    6 4))
                                                                endorse)
                                                              (assert_hwms_ 6 4))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              let
                                                                other_chain_id :=
                                                                "NetXSzLHKwSumh7"
                                                                  % string in
                                                              op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  (op_startypeminuserrorstar
                                                                    state
                                                                    op_startypeminuserrorstar)
                                                                  (forge_endorsement
                                                                    state
                                                                    (client
                                                                      baker)
                                                                    (op_startypeminuserrorstar
                                                                      other_chain_id)
                                                                    5))
                                                                (fun
                                                                  endorsement_on_different_chain_bytes
                                                                  =>
                                                                  op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      (sign
                                                                        state
                                                                        baker
                                                                        endorsement_on_different_chain_bytes
                                                                        tt)
                                                                      (assert_hwms_
                                                                        6 5))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          (op_startypeminuserrorstar
                                                                            5
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                '_ :=
                                                                                function_parameter
                                                                                in
                                                                              bake
                                                                                tt))
                                                                          (ask_hwm
                                                                            11 5))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (op_startypeminuserrorstar
                                                                              (op_startypeminuserrorstar
                                                                                state
                                                                                (client
                                                                                  0)
                                                                                uri)
                                                                              (assert_failure
                                                                                state
                                                                                "baking after deauthorization should fail"
                                                                                  %
                                                                                  string
                                                                                bake))
                                                                            (assert_failure
                                                                              state
                                                                              "endorsing after deauthorization should fail"
                                                                                %
                                                                                string
                                                                              endorse))))))))))))))))))).

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

src/bin_sandbox/command_ledger_wallet.ml 527 errors
open Flextesa
open Internal_pervasives

let client_async_cmd state ~client args ~f =
  Running_processes.Async.run_cmdf
    ~id_base:"client_async_cmd"
    state
    ~f
    "sh -c %s"
    ( Tezos_client.client_command client ~state args
    |> Genspio.Compile.to_one_liner |> Filename.quote )
  >>= fun (status, res) ->
  return
    ( object
        method out = fst res

        method err = snd res

        method status = status
      end
      : Process_result.t )

let ledger_hash_re =
  lazy
    Re.(
      compile
        (seq
           [ str "* Blake 2B Hash (ledger-style, with operation watermark):";
             rep1 (alt [space; eol]);
             group (rep1 alnum);
             rep1 (alt [space; eol]) ]))

(* Searches a stream for an expected ledger hash from `tezos-client --verbose-signing`*)
let find_and_print_signature_hash ?(display_expectation = true) state process =
  let re = Lazy.force ledger_hash_re in
  let check lines =
    Re.(
      match exec_opt re lines with
      | None ->
          None
      | Some matches ->
          Some (Group.get matches 1))
  in
  (* Dbg.e EF.(wf "find_and_print_signature_hash") ; *)
  Running_processes.Async.fold_process
    process
    ~init:("", "", not display_expectation)
    ~f:(fun (all_output_prev, all_error_prev, showed_message_prev) out err ->
      (* Dbg.e EF.(wf "find_and_print_signature_hash.fold_process %S %S" out err) ; *)
      let all_output = all_output_prev ^ out in
      let all_error = all_error_prev ^ err in
      ( if not showed_message_prev then
        match check all_output with
        | None ->
            return false
        | Some x ->
            Console.say state EF.(wf "Displayed hash should be: `%s`" x)
            >>= fun () -> return true
      else return true )
      >>= fun showed_message ->
      return (`Continue (all_output, all_error, showed_message)))
  >>= fun (output, error, _) ->
  return (String.split ~on:'\n' output, String.split ~on:'\n' error)

module MFmt = Experiments.More_fmt

let failf ?attach fmt =
  ksprintf (fun s -> fail ?attach (`Scenario_error s)) fmt

let process_should_fail msg f =
  Asynchronous_result.bind_on_error
    ( f ()
    >>= fun (proc : Process_result.t) ->
    match proc#status with
    | Unix.WEXITED 0 ->
        failf
          "Process should have failed: %s"
          msg
          ~attach:
            [("stdout", `Verbatim proc#out); ("stderr", `Verbatim proc#err)]
    | _ ->
        return () )
    ~f:(fun ~result:_ _ -> return ())

let ledger_prompt_notice state ~msgs ?(button = `Checkmark) () =
  let button_str =
    match button with
    | `Checkmark ->
        "✔"
    | `X ->
        "❌"
    | `Both ->
        "❌ and ✔ at the same time"
  in
  Console.sayf
    state
    MFmt.(
      fun ppf () ->
        vertical_box ~indent:4 ppf (fun ppf ->
            shout ppf (fun ppf -> const string "Ledger-prompt:" ppf ()) ;
            cut ppf () ;
            List.iter msgs ~f:(fun f -> f ppf () ; cut ppf ()) ;
            wf ppf "→ Press %s on the ledger." button_str))

let ledger_prompt_notice_expectation state ~messages ~user_answer =
  ledger_prompt_notice
    state
    ()
    ~button:(match user_answer with `Accept -> `Checkmark | `Reject -> `X)
    ~msgs:
      ( messages
      @ MFmt.
          [ cut;
            (fun ppf () ->
              match user_answer with
              | `Accept ->
                  shout ppf (fun ppf -> pf ppf ">> ACCEPT THIS <<")
              | `Reject ->
                  shout ppf (fun ppf -> pf ppf ">> REJECT THIS <<")) ] )

let with_ledger_test_reject_and_accept ?(only_success = false) state ~messages
    f =
  let with_ledger_prompt state ~messages ~user_answer ~f =
    ledger_prompt_notice_expectation state ~messages ~user_answer
    >>= fun () -> f ~user_answer
  in
  ( if only_success then return ()
  else with_ledger_prompt state ~messages ~user_answer:`Reject ~f )
  >>= fun () -> with_ledger_prompt state ~messages ~user_answer:`Accept ~f

let get_chain_id state ~client =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/chain_id"
  >>= (function
        | `String x ->
            return x
        | _ ->
            failf "Failed to parse chain_id JSON from node")
  >>= fun chain_id_string ->
  return (Tezos_crypto.Chain_id.of_b58check_exn chain_id_string)

let get_head_block_hash state ~client () =
  Tezos_client.rpc state ~client `Get ~path:"/chains/main/blocks/head/hash"
  >>= function
  | `String x ->
      return x
  | _ ->
      failf "Failed to parse block hash JSON from node"

let please_check_the_hash ppf () =
  let open MFmt in
  tag "prompt" ppf (fun ppf ->
      wf ppf "The ledger cannot parse this operation, please verify the hash.")

let forge_batch_transactions state ~client ~src ~dest:_ ~n ?(fee = 0.00126) ()
    =
  get_head_block_hash state ~client ()
  >>= fun branch ->
  let json =
    `O
      [ ("branch", `String branch);
        ( "contents",
          `A
            (List.map (List.range 0 n) ~f:(fun i ->
                 `O
                   [ ("kind", `String "transaction");
                     ("source", `String src);
                     ( "destination",
                       `String "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F" );
                     ("amount", `String (string_of_int 100));
                     ( "fee",
                       `String (string_of_int (int_of_float (fee *. 1000000.)))
                     );
                     ("counter", `String (string_of_int i));
                     ("gas_limit", `String (string_of_int 127));
                     ("storage_limit", `String (string_of_int 277)) ])) ) ]
  in
  Tezos_client.rpc
    state
    ~client
    ~path:"/chains/main/blocks/head/helpers/forge/operations"
    (`Post (Ezjsonm.to_string json))
  >>= function
  | `String operation_bytes ->
      let magic_byte = "03" in
      return (magic_byte ^ operation_bytes)
  | _ ->
      failf "Failed to forge operation or parse result"

let expect_from_output ~expectation ~message (proc_res : Process_result.t) =
  (* let expect_rejection msg (success, (stdout, stderr)) = *)
  let exp =
    match expectation with
    | `Ledger_reject_or_timeout ->
        "rejection"
    | `Not_a_delegate ->
        "not-delegate-error"
    | `Success ->
        "success"
    | `Origination_failed ->
        "origination-failure"
  in
  let nope s =
    failf
      ~attach:
        [("stdout", `Verbatim proc_res#out); ("stderr", `Verbatim proc_res#err)]
      "%s, expected %s: %s."
      message
      exp
      s
  in
  let success = proc_res#status = Unix.WEXITED 0 in
  match expectation with
  | `Success when success ->
      return ()
  | `Success ->
      nope "did not succeed"
  | (`Ledger_reject_or_timeout | `Not_a_delegate | `Origination_failed) as e
    -> (
      let pattern =
        match e with
        | `Ledger_reject_or_timeout ->
            "Conditions of use not satisfied"
        | `Not_a_delegate ->
            "not registered as valid delegate key"
        | `Origination_failed ->
            "origination simulation failed"
      in
      let all_output = String.concat ~sep:"\n" (proc_res#out @ proc_res#err) in
      match (success, String.substr_index all_output ~pattern) with
      | (false, Some _) ->
          return ()
      | (false, None) ->
          nope "cannot find the right error message"
      | (true, _) ->
          nope "command succeeded??" )

let voting_tests state ~client ~src ~with_rejections ~protocol_kind
    ~ledger_account ~tested_proposal ~go_to_next_period () =
  let expect_success message v =
    expect_from_output ~expectation:`Not_a_delegate ~message v
  in
  let expect_rejection message v =
    expect_from_output ~expectation:`Ledger_reject_or_timeout ~message v
  in
  let test_reject_and_accept name ~messages action =
    ( if with_rejections then
      ledger_prompt_notice_expectation state ~messages ~user_answer:`Reject
      >>= fun () -> action () >>= fun res -> expect_rejection name res
    else return () )
    >>= fun () ->
    ledger_prompt_notice_expectation state ~messages ~user_answer:`Accept
    >>= fun () -> action () >>= fun res -> expect_success name res
  in
  let source_display = Tezos_protocol.Account.pubkey_hash ledger_account in
  let submit_proposals ~display_expectation proposals () =
    client_async_cmd
      state
      ~client:(client 0)
      ~f:(fun _ proc ->
        find_and_print_signature_hash ~display_expectation state proc)
      ( ["submit"; "proposals"; "for"; src]
      @ proposals
      @ ["--force"; "--verbose-signing"] )
  in
  test_reject_and_accept
    "single-proposal"
    ~messages:
      MFmt.
        [ (fun ppf () -> wf ppf "Submitting single proposal %s" tested_proposal);
          (fun ppf () ->
            match protocol_kind with
            | `Athens ->
                ()
            | `Babylon ->
                wf
                  ppf
                  "On Babylon, You will first be asked to provide the public \
                   key." ;
                cut ppf () ;
                wf
                  ppf
                  "Accept this prompt, regardless of below, then continue.");
          (fun ppf () ->
            vertical_box ppf ~indent:4 (fun ppf ->
                wf
                  ppf
                  "Protocol is %a, the ledger should be able to display \
                   voting parameters:"
                  Tezos_protocol.Protocol_kind.pp
                  protocol_kind ;
                cut ppf () ;
                wf ppf "* Source: `%s`" source_display ;
                cut ppf () ;
                wf ppf "* Period: `0`" ;
                cut ppf () ;
                wf ppf "* Protocol: `%s`" tested_proposal)) ]
    (submit_proposals ~display_expectation:false [tested_proposal])
  >>= fun () ->
  test_reject_and_accept
    "multiple-proposal"
    ~messages:
      MFmt.
        [ (fun ppf () -> wf ppf "Submitting 2 proposals together");
          please_check_the_hash ]
    (submit_proposals
       ~display_expectation:true
       [tested_proposal; "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z"])
  >>= fun () ->
  go_to_next_period ()
  >>= fun () ->
  List_sequential.iteri ["yea"; "nay"] ~f:(fun n vote ->
      test_reject_and_accept
        (Fmt.strf "vote-%s" vote)
        ~messages:
          MFmt.
            [ (fun ppf () ->
                match protocol_kind with
                | `Athens ->
                    ()
                | `Babylon ->
                    wf
                      ppf
                      "On Babylon, You will first be asked to provide the \
                       public key." ;
                    cut ppf () ;
                    wf
                      ppf
                      "Accept this prompt, regardless of below, then continue.");
              (fun ppf () -> wf ppf "Voting %s for %s" vote tested_proposal);
              (fun ppf () -> wf ppf "Source: `%s`" source_display);
              (fun ppf () -> wf ppf "Period: `%i`" (n + 1));
              (fun ppf () -> wf ppf "Protocol: `%s`" tested_proposal) ]
        (fun () ->
          Tezos_client.client_cmd
            state
            ~client:(client 0)
            ["submit"; "ballot"; "for"; src; tested_proposal; vote]
          >>= fun (_, proc) -> return proc))

let ledger_should_display ppf l =
  let open MFmt in
  vertical_box ~indent:4 ppf (fun ppf ->
      wf ppf "Ledger should display:" ;
      List.iter l ~f:(fun (s, f) -> cut ppf () ; pf ppf "* %s: %a." s f ()))

let show_command_message command =
  MFmt.(
    fun ppf () ->
      wrapping_box ~indent:2 ppf (fun ppf ->
          wf ppf "Command:" ;
          sp ppf () ;
          const
            (list ~sep:sp string)
            ("<tezos-client>" :: command |> List.map ~f:Filename.quote)
            ppf
            ()))

let sign state ~client ~bytes =
  Tezos_client.client_cmd
    state
    ~client:client.Tezos_client.Keyed.client
    ["sign"; "bytes"; "0x" ^ bytes; "for"; client.Tezos_client.Keyed.key_name]

let delegation_tests state ~client ~src ~with_rejections ~protocol_kind
    ~ledger_account ~delegate ~bake () =
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  let only_success = not with_rejections in
  let self_delegation () =
    (* Which is equivalent to registration as delegate. *)
    let command =
      [ "--wait";
        "none";
        "set";
        "delegate";
        "for";
        src;
        "to";
        src;
        "--verbose-signing" ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () -> wf ppf "Self-delegating account `%s`" ledger_pkh);
            show_command_message command;
            (fun ppf () ->
              wf
                ppf
                "Note that X is a placeholder for some value that will vary \
                 between runs");
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Fee", const string "0.00XXX");
                  ("Source", const string ledger_pkh);
                  ("Delegate", const string ledger_pkh);
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash
              ~display_expectation:(protocol_kind = `Babylon)
              state
              proc)
          command
        >>= fun res ->
        expect_from_output
          ~message:"self-delegation"
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "setting self-delegate of %s" src
    (* Self-delegate deletion is forbidden for both Athens and Babylon *)
  in
  let tz_account_delegation () =
    let command =
      [ "--wait";
        "none";
        "set";
        "delegate";
        "for";
        src;
        "to";
        delegate;
        "--verbose-signing" ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Delegating account `%s` to `%s`" ledger_pkh delegate);
            show_command_message command;
            (fun ppf () ->
              wf
                ppf
                "Note that X is a placeholder for some value that will vary \
                 between runs");
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Fee", const string "0.00XXX");
                  ("Source", const string ledger_pkh);
                  ("Delegate", const string delegate);
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash
              ~display_expectation:(protocol_kind = `Babylon)
              state
              proc)
          command
        >>= fun res ->
        expect_from_output
          ~message:"tz123-delegation"
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "setting delegate of %s" src
    (* Self-delegate deletion is forbidden for both Athens and Babylon *)
  in
  let run_command_and_check state ~client ~command ~message ~user_answer =
    Tezos_client.client_cmd state ~client command
    >>= fun (_, res) ->
    expect_from_output
      ~message
      res
      ~expectation:
        ( match user_answer with
        | `Reject ->
            `Ledger_reject_or_timeout
        | `Accept ->
            `Success )
  in
  let delegate_with_scriptless_account () =
    let originated_account_name = "ledginated" in
    let amount = "200" in
    let burn_cap = "0.257" in
    let command =
      [ "--wait";
        "none";
        "originate";
        "account";
        originated_account_name;
        "for";
        src;
        "transferring";
        "200";
        "from";
        src;
        "--delegatable";
        "--burn-cap";
        burn_cap;
        "--force" ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Originating account `%s`" originated_account_name);
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Amount", const string amount);
                  ("Fee", const string (strf "≤ %S" burn_cap));
                  ("Source", const string ledger_pkh);
                  ("Manager", const string ledger_pkh);
                  ("Delegation", const string "Any");
                  ("Storage", const int 277) ]) ]
      (fun ~user_answer ->
        run_command_and_check
          state
          ~client
          ~command
          ~message:"account origination"
          ~user_answer)
    >>= fun _ ->
    ksprintf bake "origination of %s" originated_account_name
    >>= fun () ->
    Tezos_client.client_cmd
      state
      ~client
      ["show"; "known"; "contract"; originated_account_name]
    >>= fun (_, proc_result) ->
    let contract_address = proc_result#out |> String.concat ~sep:"" in
    Tezos_client.client_cmd state ~client ["show"; "address"; delegate]
    >>= fun (_, proc_result) ->
    let delegate_address =
      List.hd_exn proc_result#out
      |> String.split ~on:' ' |> List.last
      |> Option.value ~default:delegate
    in
    let command =
      [ "--wait";
        "none";
        "set";
        "delegate";
        "for";
        originated_account_name;
        "to";
        delegate ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf
                ppf
                "Setting `%s` as delegate for `%s`"
                delegate
                originated_account_name);
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Source", const string contract_address);
                  ("Fee", const string "≤ 0.001");
                  ("Delegate", const string delegate_address);
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        run_command_and_check
          state
          ~client
          ~command
          ~message:"setting delegate of KT1"
          ~user_answer)
    >>= fun () ->
    ksprintf bake "setting delegate of %s" originated_account_name
    >>= fun () ->
    let withdraw_command =
      [ "--wait";
        "none";
        "withdraw";
        "delegate";
        "from";
        originated_account_name ]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Withdrawing delegate from `%s`" originated_account_name);
            show_command_message withdraw_command;
            (fun ppf () ->
              ledger_should_display
                ppf
                [ ("Source", const string contract_address);
                  ("Fee", const string "≤ 0.001");
                  ("Delegate", const string "None");
                  ("Storage", const int 0) ]) ]
      (fun ~user_answer ->
        run_command_and_check
          state
          ~client
          ~command:withdraw_command
          ~message:"withdrawing delegate from originated account"
          ~user_answer)
    >>= fun () ->
    ksprintf bake "withdrawing delegate of %s" originated_account_name
  in
  match protocol_kind with
  | `Athens ->
      self_delegation () >>= fun () -> delegate_with_scriptless_account ()
  | `Babylon ->
      tz_account_delegation () >>= fun () -> self_delegation ()

let transaction_tests state ~client ~src ~with_rejections ~protocol_kind
    ~pair_string_nat_kt1_account ~ledger_account ~unit_kt1_account ~bake () =
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  let only_success = not with_rejections in
  let test_transaction ?(storage = 0) ?arguments ~name ~dst_name ~dst_pkh () =
    let amount = "15" in
    let command =
      ["--wait"; "none"; "transfer"; amount; "from"; src; "to"; dst_name]
      @ Option.value_map ~default:[] arguments ~f:(fun a -> ["--arg"; a])
      @ ["--burn-cap"; "100"; "--verbose-signing"]
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () -> wf ppf "%s with account `%s`" name ledger_pkh);
            show_command_message command;
            (fun ppf () ->
              wf
                ppf
                "Note that X is a placeholder for some value that will vary \
                 between runs");
            (fun ppf () ->
              match arguments with
              | None ->
                  ledger_should_display
                    ppf
                    [ ("Amount", const string amount);
                      ("Fee", const string "0.00XXX");
                      ("Source", const string ledger_pkh);
                      ("Destination", const string dst_pkh);
                      ("Storage", const int storage) ]
              | _ (* some arguments *) ->
                  please_check_the_hash ppf ()) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash
              ~display_expectation:
                (protocol_kind = `Babylon || arguments <> None)
              state
              proc)
          command
        >>= fun res ->
        expect_from_output
          ~message:name
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "%s with %s" name src
  in
  test_transaction
    ~name:"Self-transaction"
    ~dst_pkh:ledger_pkh
    ~dst_name:src
    ()
  >>= fun () ->
  let module Acc = Tezos_protocol.Account in
  let random_account = Acc.of_name "random-account-for-transaction-test" in
  test_transaction
    ~name:"transaction-to-random-tz1"
    ~dst_pkh:(Acc.pubkey_hash random_account)
    ~dst_name:(Acc.pubkey_hash random_account)
    ~storage:277
    (* First time: there is a reveal *) ()
  >>= fun () ->
  test_transaction
    ~name:"transaction-to-random-tz1-again"
    ~dst_pkh:(Acc.pubkey_hash random_account)
    ~dst_name:(Acc.pubkey_hash random_account)
    ~storage:0
    (* no moa reveal *) ()
  >>= fun () ->
  test_transaction
    ~name:"parameterless-transaction-to-kt1"
    ~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
    ~dst_name:unit_kt1_account
    ()
  >>= fun () ->
  test_transaction
    ~name:"parameterfull-transaction-to-kt1"
    ~dst_pkh:"KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"
    ~arguments:"Pair \"hello from the ledger\" 51"
    ~dst_name:pair_string_nat_kt1_account
    ()

let prepare_origination_of_id_script ?(spendable = false)
    ?(delegatable = false) ?delegate ?(push_drops = 0) ?(amount = "2") state
    ~client:_ ~name ~from ~protocol_kind ~parameter ~init_storage =
  let id_script parameter =
    Fmt.strf
      "parameter %s;\n\
       storage %s;\n\
       code\n\
      \  {\n\
      \    %s\n\
      \    { CAR; NIL operation; PAIR }\n\
      \  };\n"
      parameter
      parameter
      ( match push_drops with
      | 0 ->
          "# No push-drops"
      | n ->
          Fmt.strf
            "# %d push-drop%s\n    %s"
            n
            (if n > 1 then "s" else "")
            ( List.init push_drops ~f:(fun ith ->
                  Fmt.strf
                    "{ PUSH string %S ; DROP } ;"
                    (Fmt.strf
                       "push-dropping %d adds stupid bytes to the contract"
                       ith))
            |> String.concat ~sep:"\n    " ) )
  in
  let tmp = Filename.temp_file "little-id-script" ".tz" in
  System.write_file state tmp ~content:(id_script parameter)
  >>= fun () ->
  Dbg.e EF.(wf "id_script %s: %s" parameter tmp) ;
  let origination =
    let opt = Option.value_map ~default:[] in
    ["--wait"; "none"; "originate"; "contract"; name]
    @ (match protocol_kind with `Athens -> ["for"; from] | `Babylon -> [])
    @ [ "transferring";
        amount;
        "from";
        from;
        "running";
        tmp;
        "--init";
        init_storage;
        "--force";
        "--burn-cap";
        "300000000000";
        (* ; "--fee-cap" ; "20000000000000" *)
        "--gas-limit";
        "1000000000000000";
        "--storage-limit";
        "20000000000000";
        "--verbose-signing" ]
    @ opt delegate ~f:(fun s -> (* Baby & Aths *) ["--delegate"; s])
    @ (if delegatable then [(* Aths *) "--delegatable"] else [])
    @ if spendable then [(* Aths *) "--spendable"] else []
  in
  return origination

let originate_id_script ?push_drops state ~client ~name ~from ~bake
    ~protocol_kind ~parameter ~init_storage =
  prepare_origination_of_id_script
    state
    ~client
    ~name
    ~from
    ~protocol_kind
    ?push_drops
    ~parameter
    ~init_storage
  >>= fun origination ->
  Tezos_client.successful_client_cmd state ~client origination
  >>= fun _ -> Fmt.kstrf bake "baking `%s` in" name

let pp_warning_ledger_takes_a_while ~adjective =
  let open MFmt in
  fun ppf () ->
    cut ppf () ;
    let prompt = "WARNING: " in
    let warning1 = "The ledger will take a few seconds to show" in
    let warning2 = strf "the hash for such a %s operation." adjective in
    let wl = String.length prompt + String.length warning1 in
    tag "shout" ppf (fun ppf -> string ppf ("/" ^ String.make wl '=' ^ "\\")) ;
    cut ppf () ;
    tag "shout" ppf (fun ppf -> pf ppf "|%s" prompt) ;
    string ppf warning1 ;
    tag "shout" ppf (fun ppf -> string ppf "|") ;
    cut ppf () ;
    tag "shout" ppf (fun ppf -> pf ppf "|") ;
    string ppf String.(make (length prompt) ' ') ;
    string ppf warning2 ;
    string ppf String.(make (length warning1 - length warning2) ' ') ;
    tag "shout" ppf (fun ppf -> string ppf "|") ;
    cut ppf () ;
    tag "shout" ppf (fun ppf -> string ppf ("\\" ^ String.make wl '=' ^ "/"))

let basic_contract_operations_tests state ~client ~src ~with_rejections
    ~protocol_kind ~ledger_account ~bake ~delegate () =
  let ledger_pkh = Tezos_protocol.Account.pubkey_hash ledger_account in
  let only_success = not with_rejections in
  let test_origination ?delegate ?delegatable ?spendable ?push_drops ~name
      ~amount ~parameter ~init_storage () =
    prepare_origination_of_id_script
      ~amount
      ?push_drops
      state
      ~client
      ~name
      ~from:src
      ?delegate
      ?delegatable
      ?spendable
      ~protocol_kind
      ~parameter
      ~init_storage
    >>= fun origination ->
    with_ledger_test_reject_and_accept
      state
      ~only_success
      ~messages:
        MFmt.
          [ (fun ppf () ->
              wf ppf "Origination: %s (ledger: %s)" name ledger_pkh);
            show_command_message origination;
            please_check_the_hash;
            ( if push_drops <> None then
              pp_warning_ledger_takes_a_while ~adjective:"huge"
            else const string "" ) ]
      (fun ~user_answer ->
        client_async_cmd
          state
          ~client
          ~f:(fun _ proc ->
            find_and_print_signature_hash ~display_expectation:true state proc)
          origination
        >>= fun res ->
        expect_from_output
          ~message:name
          res
          ~expectation:
            ( match user_answer with
            | `Reject ->
                `Ledger_reject_or_timeout
            | `Accept ->
                `Success ))
    >>= fun _ -> ksprintf bake "%s with %s" name src
  in
  test_origination
    ~name:"ID-unit"
    ~amount:"0"
    ~parameter:"unit"
    ~init_storage:"Unit"
    ()
  >>= fun () ->
  test_origination
    ~name:"ID-string"
    ~amount:"10"
    ~parameter:"string"
    ~init_storage:"\"some string\""
    ()
  >>= fun () ->
  test_origination
    ~name:"ID-string-nat-mutez"
    ~amount:"10"
    ~parameter:"(pair string (pair nat mutez))"
    ~init_storage:"Pair \"hello\" (Pair 12 1)"
    ()
  >>= fun () ->
  test_origination
    ~name:"ID-address+delegate"
    ~amount:"1"
    ~parameter:"address"
    ~delegate
    ~init_storage:"\"tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU\""
    ()
  >>= fun () ->
  ( match protocol_kind with
  | `Athens ->
      test_origination
        ~name:"ID-string+delegatable"
        ~amount:"0"
        ~parameter:"string"
        ~delegate
        ~init_storage:"\"delegatable contract\""
        ~delegatable:true
        ()
  | `Babylon ->
      return () )
  >>= fun () ->
  let push_drops =
    (* Found by dichotomic trial-and-error :)
       240 works, 250 fails at 16870 bytes, … *)
    242
  in
  test_origination
    ~push_drops
    ~name:"giant-contract"
    ~amount:"10"
    ~parameter:"(pair string nat)"
    ~init_storage:"Pair \"the answer is: \" 42"
    ()

module Wallet_scenario = struct
  type root =
    [ `All
    | `Voting
    | `Batch_transactions
    | `Delegation
    | `Transactions
    | `Contracts
    | `None ]

  type t = [root | `Without_rejections of root]

  let with_rejections : t -> bool = function
    | `Without_rejections _ ->
        false
    | _ ->
        true

  let enum_assoc : (string * root) list =
    [ ("everything", `All);
      ("voting", `Voting);
      ("none", `None);
      ("delegation", `Delegation);
      ("transactions", `Transactions);
      ("contracts", `Contracts);
      ("batch-transactions", `Batch_transactions) ]

  let root (ws : t) =
    match ws with `Without_rejections r -> r | #root as r -> r

  let run_if v t ~yes ~no =
    let with_rejections = with_rejections t in
    match root t with
    | `All ->
        yes ~with_rejections
    | other when other = v ->
        yes ~with_rejections
    | _other ->
        no
          (List.find_map_exn enum_assoc ~f:(function
              | (k, this) when v = this ->
                  Some k
              | _ ->
                  None))

  let if_voting t = run_if `Voting t

  let if_batch_transactions t = run_if `Batch_transactions t

  let if_delegation t = run_if `Delegation t

  let if_transactions t = run_if `Transactions t

  let if_contracts t = run_if `Contracts t

  let cli_term () =
    let make no_rejections v =
      if no_rejections then `Without_rejections v else (v :> t)
    in
    let open Cmdliner in
    let open Term in
    pure make
    $ Arg.(
        value
          (flag (info ["no-rejections"] ~doc:"Do not test ledger rejections.")))
    $ Arg.(
        value
          (opt
             (enum ([("all", `All)] @ enum_assoc))
             `All
             (info
                ["only-test"]
                ~doc:
                  (Fmt.strf
                     "Limit to a family of tests (one of: %s)."
                     ( List.map enum_assoc ~f:(fun (n, _) -> sprintf "`%s`" n)
                     |> String.concat ~sep:", " )))))
end

let run state ~pp_error ~protocol ~protocol_kind ~node_exec ~client_exec
    ~admin_exec ~wallet_scenario ~size ~base_port ~uri () =
  Helpers.clear_root state
  >>= fun () ->
  Helpers.System_dependencies.precheck
    state
    `Or_fail
    ~executables:[node_exec; client_exec; admin_exec]
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let ledger_client = Tezos_client.no_node_client ~exec:client_exec in
  Tezos_client.Ledger.show_ledger state ~client:ledger_client ~uri
  >>= fun _ledger_account ->
  let (protocol, baker_0_account, _baker_0_balance) =
    let open Tezos_protocol in
    let d = protocol in
    let baker = List.nth_exn d.bootstrap_accounts 0 in
    ( {
        d with
        kind = protocol_kind;
        time_between_blocks = [1; 0];
        bootstrap_accounts =
          List.map d.bootstrap_accounts ~f:(fun (n, v) ->
              if fst baker = n then (n, v) else (n, 1_000L));
      },
      fst baker,
      snd baker )
  in
  Test_scenario.network_with_protocol
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  let client n =
    Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
  in
  let client_0 = client 0 in
  let baker_0 =
    Tezos_client.Keyed.make
      client_0
      ~key_name:"baker-0"
      ~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
  in
  Tezos_client.Keyed.initialize state baker_0
  >>= fun _ ->
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  let first_bakes = 3 in
  Loop.n_times first_bakes (fun nth ->
      ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
  >>= fun () ->
  Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
  >>= fun () ->
  let signer =
    Tezos_client.Keyed.make (client 0) ~key_name:"ledgered" ~secret_key:uri
  in
  Tezos_client.Ledger.show_ledger state ~client:client_0 ~uri
  >>= fun ledger_account ->
  Tezos_client.successful_client_cmd
    state
    ~client:client_0
    [ "--wait";
      "none";
      "transfer";
      "20000";
      "from";
      baker_0.Tezos_client.Keyed.key_name;
      "to" (*  *);
      Tezos_protocol.Account.pubkey_hash ledger_account;
      "--burn-cap";
      "100" ]
  >>= fun _ ->
  let bake msg = Tezos_client.Keyed.bake state baker_0 msg in
  bake "After transferring tez to the ledger account"
  >>= fun () ->
  with_ledger_test_reject_and_accept
    ~only_success:(Wallet_scenario.with_rejections wallet_scenario |> not)
    state
    ~messages:
      MFmt.
        [ (fun ppf () ->
            wf ppf "Importing %S in client `%s`." uri client_0.Tezos_client.id);
          (fun ppf () ->
            wf
              ppf
              "The ledger should be prompting for acknowledgment to provide \
               the public key of `%s`."
              (Tezos_protocol.Account.pubkey_hash ledger_account)) ]
    (fun ~user_answer ->
      Tezos_client.client_cmd
        state
        ~client:client_0
        [ "import";
          "secret";
          "key";
          signer.key_name;
          signer.secret_key;
          "--force" ]
      >>= fun (_, proc) ->
      expect_from_output
        ~message:"importing key"
        proc
        ~expectation:
          ( match user_answer with
          | `Accept ->
              `Success
          | `Reject ->
              `Ledger_reject_or_timeout ))
  >>= fun () ->
  let skipping s = Console.say state EF.(haf "Skipping %s tests" s) in
  let voting_test ~with_rejections =
    let tested_proposal =
      "Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
    in
    voting_tests
      state
      ~client
      ~ledger_account
      ~src:signer.key_name
      ()
      ~with_rejections
      ~protocol_kind
      ~tested_proposal
      ~go_to_next_period:(fun () ->
        Tezos_client.successful_client_cmd
          state
          ~client:client_0
          [ "--wait";
            "none";
            "submit";
            "proposals";
            "for";
            baker_0.Tezos_client.Keyed.key_name;
            tested_proposal;
            "--force" ]
        >>= fun _ ->
        let blocks = protocol.Tezos_protocol.blocks_per_voting_period in
        Loop.n_times blocks (fun nth ->
            ksprintf
              (Tezos_client.Keyed.bake state baker_0)
              "going to testing-vote period %d/%d"
              (nth + 1)
              blocks)
        >>= fun () -> return ())
  in
  let batch_test ~with_rejections =
    let n = 50 in
    forge_batch_transactions
      state
      ~client:(client 0)
      ~src:(Tezos_protocol.Account.pubkey_hash ledger_account)
      ~dest:"tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
      ~n
      ()
    >>= fun batch_transaction_bytes ->
    let bytes_hash =
      Tezos_crypto.(
        `Hex batch_transaction_bytes |> Hex.to_bytes
        |> (fun x -> [x])
        |> Blake2B.hash_bytes |> Blake2B.to_string |> Base58.raw_encode)
    in
    with_ledger_test_reject_and_accept
      state
      ~only_success:(not with_rejections)
      ~messages:
        MFmt.
          [ (fun ppf () -> wf ppf "Signing batch of %d transactions" n);
            (fun ppf () ->
              wf
                ppf
                "Ledger should display “Sign Hash” → `%s`"
                bytes_hash);
            pp_warning_ledger_takes_a_while ~adjective:"big" ]
      (fun ~user_answer ->
        sign state ~client:signer ~bytes:batch_transaction_bytes
        >>= fun (_, proc) ->
        expect_from_output
          ~message:"Signing batch operation"
          proc
          ~expectation:
            ( match user_answer with
            | `Accept ->
                `Success
            | `Reject ->
                `Ledger_reject_or_timeout ))
  in
  let delegation_tests ~with_rejections =
    delegation_tests
      state
      ~client:client_0
      ~ledger_account
      ~delegate:baker_0.Tezos_client.Keyed.key_name
      ~src:signer.key_name
      ()
      ~bake
      ~with_rejections
      ~protocol_kind
  in
  let unit_kt1_account = "unit-kt1-of-the-baker" in
  originate_id_script
    state
    ~client:client_0
    ~name:unit_kt1_account
    ~from:baker_0.Tezos_client.Keyed.key_name
    ~bake
    ~protocol_kind
    ~parameter:"unit"
    ~init_storage:"Unit"
  >>= fun () ->
  let pair_string_nat_kt1_account = "pair-string-nat-kt1-of-the-baker" in
  originate_id_script
    state
    ~client:client_0
    ~name:pair_string_nat_kt1_account
    ~push_drops:10
    ~from:baker_0.Tezos_client.Keyed.key_name
    ~bake
    ~protocol_kind
    ~parameter:"(pair string nat)"
    ~init_storage:"Pair \"the answer is: \" 42"
  >>= fun () ->
  let transactions_test ~with_rejections =
    transaction_tests
      state
      ~client:client_0
      ~ledger_account
      ~unit_kt1_account
      ~pair_string_nat_kt1_account
      ~src:signer.key_name
      ()
      ~bake
      ~with_rejections
      ~protocol_kind
  in
  let contracts_test ~with_rejections =
    basic_contract_operations_tests
      state
      ~client:client_0
      ~ledger_account
      ~delegate:baker_0.Tezos_client.Keyed.key_name
      ~src:signer.key_name
      ()
      ~bake
      ~with_rejections
      ~protocol_kind
  in
  let bake_command =
    Console.Prompt.unit_and_loop
      EF.(wf "Bake a block with the default baker.")
      ["bake"]
      (fun _sexps ->
        Asynchronous_result.transform_error
          ~f:(fun e ->
            Format.kasprintf
              (fun s -> `Command_line s)
              "run-test-error: %a"
              pp_error
              e)
          (bake "Interactive"))
  in
  let run_test_command =
    Console.Prompt.unit_and_loop
      EF.(
        wf
          "Run a test (%s)."
          (List.map Wallet_scenario.enum_assoc ~f:fst |> String.concat ~sep:"|"))
      ["rt"; "run-test"]
      (fun sexps ->
        Asynchronous_result.transform_error
          ~f:(fun e ->
            Format.kasprintf
              (fun s -> `Command_line s)
              "run-test-error: %a"
              pp_error
              e)
          ( match sexps with
          | [Atom a] -> (
              let run f = f ~with_rejections:true in
              match
                List.Assoc.find
                  ~equal:String.equal
                  Wallet_scenario.enum_assoc
                  a
              with
              | Some `None ->
                  return ()
              | Some `Delegation ->
                  run delegation_tests
              | Some `All ->
                  run delegation_tests
                  >>= fun () -> run batch_test >>= fun () -> run voting_test
              | Some `Batch_transactions ->
                  run batch_test
              | Some `Transactions ->
                  run transactions_test
              | Some `Voting ->
                  run voting_test
              | Some `Contracts ->
                  run contracts_test
              | None ->
                  failf "Don't know this test: %S" a )
          | _ ->
              failf "Cannot understand command line" ))
  in
  Interactive_test.Pauser.add_commands state [run_test_command; bake_command] ;
  Wallet_scenario.if_voting wallet_scenario ~yes:voting_test ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_batch_transactions
    wallet_scenario
    ~yes:batch_test
    ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_transactions
    wallet_scenario
    ~yes:transactions_test
    ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_contracts wallet_scenario ~yes:contracts_test ~no:skipping
  >>= fun () ->
  Wallet_scenario.if_delegation
    wallet_scenario
    ~yes:delegation_tests
    ~no:skipping
  >>= fun () -> Interactive_test.Pauser.generic state EF.[af "Tests done."]

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun uri
             node_exec
             client_exec
             admin_exec
             size
             (`Base_port base_port)
             protocol
             wallet_scenario
             state
             ->
          ( state,
            Interactive_test.Pauser.run_test
              ~pp_error
              state
              (run
                 state
                 ~protocol_kind:protocol.kind
                 ~node_exec
                 ~size
                 ~admin_exec
                 ~base_port
                 ~pp_error
                 ~wallet_scenario
                 ~protocol
                 ~client_exec
                 ~uri) ))
    $ Arg.(
        required
          (pos
             0
             (some string)
             None
             (info [] ~docv:"LEDGER-URI" ~doc:"ledger:// URI")))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Tezos_executable.cli_term `Admin "tezos"
    $ Arg.(value (opt int 2 (info ["size"; "S"] ~doc:"Size of the Network")))
    $ Arg.(
        pure (fun p -> `Base_port p)
        $ value
            (opt
               int
               32_000
               (info ["base-port"; "P"] ~doc:"Base port number to build upon")))
    $ Tezos_protocol.cli_term ()
    $ Wallet_scenario.cli_term ()
    $ Test_command_line.cli_state ~name:"ledger-wallet" () )
    (let doc = "Interactive test exercising the Ledger Wallet app features" in
     info ~doc "ledger-wallet")
src/bin_sandbox/command_ledger_wallet.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition client_async_cmd {A B C D E F : Type}
  (state : A) (client : B) (args : list string) (f : C -> D -> E) : F :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar "client_async_cmd" % string state f
      "sh -c %s" % string
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (op_startypeminuserrorstar client state args)
          op_startypeminuserrorstar) Filename.quote))
    (fun function_parameter =>
      let '(status, res) := function_parameter in
      op_startypeminuserrorstar op_startypeminuserrorstar).

Definition ledger_hash_re {A : Type} : lazy_t A :=
  (* ❌ Lazy expressions are not handled *)
  lazy op_startypeminuserrorstar.

Definition find_and_print_signature_hash {A B C : Type}
  (op_staroptstar : option bool) : A -> B -> C :=
  let display_expectation :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun state =>
    fun process =>
      let re := Lazy.force ledger_hash_re in
      let check {D E : Type} (lines : D) : E :=
        op_startypeminuserrorstar in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar process
          ("" % string, "" % string, (negb display_expectation))
          (fun function_parameter =>
            let '(all_output_prev, all_error_prev, showed_message_prev) :=
              function_parameter in
            fun out =>
              fun err =>
                let all_output := String.append all_output_prev out in
                let all_error := String.append all_error_prev err in
                op_startypeminuserrorstar
                  (if negb showed_message_prev then
                    match check all_output with
                    | None => op_startypeminuserrorstar false
                    | Some x =>
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar state
                          op_startypeminuserrorstar)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar true)
                    end
                  else
                    op_startypeminuserrorstar true)
                  (fun showed_message =>
                    op_startypeminuserrorstar
                      (* ❌ Variants not supported *)
                      variant)))
        (fun function_parameter =>
          let '(output, error, _) := function_parameter in
          op_startypeminuserrorstar
            ((op_startypeminuserrorstar "010" % char output),
              (op_startypeminuserrorstar "010" % char error))).

Module MFmt.

End MFmt.

Definition failf {A B C : Type} (attach : option A) (fmt : B) : C :=
  op_startypeminuserrorstar
    (fun s =>
      op_startypeminuserrorstar attach
        (* ❌ Variants not supported *)
        variant) fmt.

Definition process_should_fail {A B C : Type} (msg : A) (f : unit -> B) : C :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar (f tt)
      (fun function_parameter =>
        let '_ := function_parameter in
        match
          (* ❌ Sending method message is not handled *)
          send with
        | Unix.WEXITED 0 =>
          failf
            (Some
              (cons
                ("stdout" % string,
                  (* ❌ Variants not supported *)
                  variant)
                (cons
                  ("stderr" % string,
                    (* ❌ Variants not supported *)
                    variant) []))) "Process should have failed: %s" % string msg
        | _ => op_startypeminuserrorstar tt
        end))
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        op_startypeminuserrorstar tt).

Definition ledger_prompt_notice {A B C : Type}
  (state : A) (msgs : B -> unit) (op_staroptstar : option variant)
  : unit -> C :=
  let button :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    let button_str :=
      match button with
      | Checkmark => "✔" % string
      | X => "❌" % string
      | Both => "❌ and ✔ at the same time" % string
      end in
    op_startypeminuserrorstar state
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar 4 ppf
            (fun ppf =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                op_startypeminuserrorstar ppf
                  (fun ppf =>
                    op_startypeminuserrorstar op_startypeminuserrorstar
                      "Ledger-prompt:" % string ppf tt) in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := op_startypeminuserrorstar ppf tt in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Stdlib.List.iter msgs
                  (* ❌ expected an argument *)
                  expected_argument
                  (fun f =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := f ppf tt in
                    op_startypeminuserrorstar ppf tt) in
              op_startypeminuserrorstar ppf
                "→ Press %s on the ledger." % string button_str)).

Definition ledger_prompt_notice_expectation {A B C : Type}
  (state : A) (messages : list (B -> unit -> unit)) (user_answer : variant)
  : C := op_startypeminuserrorstar.

Definition with_ledger_test_reject_and_accept {A B C D : Type}
  (op_staroptstar : option bool)
  : A -> (list (B -> unit -> unit)) -> (variant -> C) -> D :=
  let only_success :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun state =>
    fun messages =>
      fun f =>
        let with_ledger_prompt {E F : Type}
          (state : A) (messages : list (B -> unit -> unit)) (user_answer :
          variant) (f : variant -> E) : F :=
          op_startypeminuserrorstar
            (ledger_prompt_notice_expectation state messages user_answer)
            (fun function_parameter =>
              let 'tt := function_parameter in
              f user_answer) in
        op_startypeminuserrorstar
          (if only_success then
            op_startypeminuserrorstar tt
          else
            with_ledger_prompt state messages
              (* ❌ Variants not supported *)
              variant f)
          (fun function_parameter =>
            let 'tt := function_parameter in
            with_ledger_prompt state messages
              (* ❌ Variants not supported *)
              variant f).

Definition get_chain_id {A B C : Type} (state : A) (client : B) : C :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar
      (op_startypeminuserrorstar state client
        (* ❌ Variants not supported *)
        variant "/chains/main/chain_id" % string)
      (fun function_parameter =>
        match function_parameter with
        | String x => op_startypeminuserrorstar x
        | _ => failf None "Failed to parse chain_id JSON from node" % string
        end))
    (fun chain_id_string =>
      op_startypeminuserrorstar (op_startypeminuserrorstar chain_id_string)).

Definition get_head_block_hash {A B C : Type}
  (state : A) (client : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state client
      (* ❌ Variants not supported *)
      variant "/chains/main/blocks/head/hash" % string)
    (fun function_parameter =>
      match function_parameter with
      | String x => op_startypeminuserrorstar x
      | _ => failf None "Failed to parse block hash JSON from node" % string
      end).

Definition please_check_the_hash {A B : Type}
  (ppf : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar "prompt" % string ppf
    (fun ppf =>
      op_startypeminuserrorstar ppf
        "The ledger cannot parse this operation, please verify the hash." %
          string).

Definition forge_batch_transactions {A B C D E : Type}
  (state : A) (client : B) (src : string) (function_parameter : C)
  : D -> (option Z) -> unit -> E :=
  let '_ := function_parameter in
  fun n =>
    fun op_staroptstar =>
      let fee :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Float constant 0.00126 is approximated by the integer 0 *)
          0
        end in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_startypeminuserrorstar (get_head_block_hash state client tt)
          (fun branch =>
            let json :=
              (* ❌ Variants not supported *)
              variant in
            op_startypeminuserrorstar
              (op_startypeminuserrorstar state client
                "/chains/main/blocks/head/helpers/forge/operations" % string
                (* ❌ Variants not supported *)
                variant)
              (fun function_parameter =>
                match function_parameter with
                | String operation_bytes =>
                  let magic_byte := "03" % string in
                  op_startypeminuserrorstar
                    (String.append magic_byte operation_bytes)
                | _ =>
                  failf None
                    "Failed to forge operation or parse result" % string
                end)).

Definition expect_from_output {A B : Type}
  (expectation : variant) (message : string) (function_parameter : A) : B :=
  let '_ := function_parameter in
  let exp :=
    match expectation with
    | Ledger_reject_or_timeout => "rejection" % string
    | Not_a_delegate => "not-delegate-error" % string
    | Success => "success" % string
    | Origination_failed => "origination-failure" % string
    end in
  let nope {C D : Type} (s : C) : D :=
    failf
      (Some
        (cons
          ("stdout" % string,
            (* ❌ Variants not supported *)
            variant)
          (cons
            ("stderr" % string,
              (* ❌ Variants not supported *)
              variant) []))) "%s, expected %s: %s." % string message exp s in
  let success :=
    equiv_decb
      (* ❌ Sending method message is not handled *)
      send (Unix.WEXITED 0) in
  match expectation with
  | Success => op_startypeminuserrorstar tt
  | Success => nope "did not succeed" % string
  | (Ledger_reject_or_timeout | Not_a_delegate | Origination_failed) as e =>
    let pattern :=
      match e with
      | Ledger_reject_or_timeout => "Conditions of use not satisfied" % string
      | Not_a_delegate => "not registered as valid delegate key" % string
      | Origination_failed => "origination simulation failed" % string
      end in
    let all_output :=
      Stdlib.String.concat op_startypeminuserrorstar
        (* ❌ expected an argument *)
        expected_argument "
" % string in
    match (success, (op_startypeminuserrorstar all_output pattern)) with
    | (false, Some _) => op_startypeminuserrorstar tt
    | (false, None) => nope "cannot find the right error message" % string
    | (true, _) => nope "command succeeded??" % string
    end
  end.

Definition voting_tests {A B C D E : Type}
  (state : A) (client : Z -> B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (ledger_account : C) (tested_proposal : string)
  (go_to_next_period : unit -> D) (function_parameter : unit) : E :=
  let 'tt := function_parameter in
  let expect_success {F G : Type} (message : string) (v : F) : G :=
    expect_from_output
      (* ❌ Variants not supported *)
      variant message v in
  let expect_rejection {F G : Type} (message : string) (v : F) : G :=
    expect_from_output
      (* ❌ Variants not supported *)
      variant message v in
  let test_reject_and_accept {F G H : Type}
    (name : string) (messages : list (F -> unit -> unit)) (action : unit -> G)
    : H :=
    op_startypeminuserrorstar
      (if with_rejections then
        op_startypeminuserrorstar
          (ledger_prompt_notice_expectation state messages
            (* ❌ Variants not supported *)
            variant)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_startypeminuserrorstar (action tt)
              (fun res => expect_rejection name res))
      else
        op_startypeminuserrorstar tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_startypeminuserrorstar
          (ledger_prompt_notice_expectation state messages
            (* ❌ Variants not supported *)
            variant)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_startypeminuserrorstar (action tt)
              (fun res => expect_success name res))) in
  let source_display := op_startypeminuserrorstar ledger_account in
  let submit_proposals {F : Type}
    (display_expectation : bool) (proposals : list string) (function_parameter :
    unit) : F :=
    let 'tt := function_parameter in
    client_async_cmd state (client 0)
      (OCaml.Stdlib.app
        (cons "submit" % string
          (cons "proposals" % string (cons "for" % string (cons src []))))
        (OCaml.Stdlib.app proposals
          (cons "--force" % string (cons "--verbose-signing" % string []))))
      (fun function_parameter =>
        let '_ := function_parameter in
        fun proc =>
          find_and_print_signature_hash (Some display_expectation) state proc)
    in
  op_startypeminuserrorstar
    (test_reject_and_accept "single-proposal" % string
      (cons
        (fun ppf =>
          fun function_parameter =>
            let 'tt := function_parameter in
            op_startypeminuserrorstar ppf
              "Submitting single proposal %s" % string tested_proposal)
        (cons
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              match protocol_kind with
              | Athens => tt
              | Babylon =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  op_startypeminuserrorstar ppf
                    "On Babylon, You will first be asked to provide the public key."
                      % string in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := op_startypeminuserrorstar ppf tt in
                op_startypeminuserrorstar ppf
                  "Accept this prompt, regardless of below, then continue." %
                    string
              end)
          (cons
            (fun ppf =>
              fun function_parameter =>
                let 'tt := function_parameter in
                op_startypeminuserrorstar ppf 4
                  (fun ppf =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar ppf
                        "Protocol is %a, the ledger should be able to display voting parameters:"
                          % string op_startypeminuserrorstar protocol_kind in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := op_startypeminuserrorstar ppf tt in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar ppf "* Source: `%s`" % string
                        source_display in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := op_startypeminuserrorstar ppf tt in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar ppf "* Period: `0`" % string in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := op_startypeminuserrorstar ppf tt in
                    op_startypeminuserrorstar ppf "* Protocol: `%s`" % string
                      tested_proposal)) [])))
      (submit_proposals false (cons tested_proposal [])))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (test_reject_and_accept "multiple-proposal" % string
          (cons
            (fun ppf =>
              fun function_parameter =>
                let 'tt := function_parameter in
                op_startypeminuserrorstar ppf
                  "Submitting 2 proposals together" % string)
            (cons please_check_the_hash []))
          (submit_proposals true
            (cons tested_proposal
              (cons
                "Psd1ynUBhMZAeajwcZJAeq5NrxorM6UCU4GJqxZ7Bx2e9vUWB6z" % string
                []))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar (go_to_next_period tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (cons "yea" % string (cons "nay" % string []))
                (fun n =>
                  fun vote =>
                    test_reject_and_accept
                      (op_startypeminuserrorstar "vote-%s" % string vote)
                      (cons
                        (fun ppf =>
                          fun function_parameter =>
                            let 'tt := function_parameter in
                            match protocol_kind with
                            | Athens => tt
                            | Babylon =>
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                op_startypeminuserrorstar ppf
                                  "On Babylon, You will first be asked to provide the public key."
                                    % string in
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ := op_startypeminuserrorstar ppf tt in
                              op_startypeminuserrorstar ppf
                                "Accept this prompt, regardless of below, then continue."
                                  % string
                            end)
                        (cons
                          (fun ppf =>
                            fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar ppf
                                "Voting %s for %s" % string vote tested_proposal)
                          (cons
                            (fun ppf =>
                              fun function_parameter =>
                                let 'tt := function_parameter in
                                op_startypeminuserrorstar ppf
                                  "Source: `%s`" % string source_display)
                            (cons
                              (fun ppf =>
                                fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar ppf
                                    "Period: `%i`" % string (Z.add n 1))
                              (cons
                                (fun ppf =>
                                  fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_startypeminuserrorstar ppf
                                      "Protocol: `%s`" % string tested_proposal)
                                [])))))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar state (client 0)
                            (cons "submit" % string
                              (cons "ballot" % string
                                (cons "for" % string
                                  (cons src
                                    (cons tested_proposal (cons vote [])))))))
                          (fun function_parameter =>
                            let '(_, proc) := function_parameter in
                            op_startypeminuserrorstar proc)))))).

Definition ledger_should_display {A B C : Type} (ppf : A) (l : B -> unit) : C :=
  op_startypeminuserrorstar 4 ppf
    (fun ppf =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := op_startypeminuserrorstar ppf "Ledger should display:" % string
        in
      Stdlib.List.iter l
        (* ❌ expected an argument *)
        expected_argument
        (fun function_parameter =>
          let '(s, f) := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := op_startypeminuserrorstar ppf tt in
          op_startypeminuserrorstar ppf "* %s: %a." % string s f tt)).

Definition show_command_message {A : Type}
  (command : list string) (ppf : A) (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar 2 ppf
    (fun ppf =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := op_startypeminuserrorstar ppf "Command:" % string in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := op_startypeminuserrorstar ppf tt in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar op_startypeminuserrorstar
          op_startypeminuserrorstar) op_startypeminuserrorstar ppf tt).

Definition sign {A B C : Type} (state : A) (client : B) (bytes : string) : C :=
  op_startypeminuserrorstar state (Tezos_client.Keyed.client client)
    (cons "sign" % string
      (cons "bytes" % string
        (cons (String.append "0x" % string string)
          (cons "for" % string (cons (Tezos_client.Keyed.key_name client) []))))).

Definition delegation_tests {A B C D E : Type}
  (state : A) (client : B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (ledger_account : C) (delegate : string) (bake : D)
  (function_parameter : unit) : E :=
  let 'tt := function_parameter in
  let ledger_pkh := op_startypeminuserrorstar ledger_account in
  let only_success := negb with_rejections in
  let self_delegation {F : Type} (function_parameter : unit) : F :=
    let 'tt := function_parameter in
    let command :=
      cons "--wait" % string
        (cons "none" % string
          (cons "set" % string
            (cons "delegate" % string
              (cons "for" % string
                (cons src
                  (cons "to" % string
                    (cons src (cons "--verbose-signing" % string [])))))))) in
    op_startypeminuserrorstar
      (with_ledger_test_reject_and_accept (Some only_success) state
        (cons
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar ppf
                "Self-delegating account `%s`" % string ledger_pkh)
          (cons (show_command_message command)
            (cons
              (fun ppf =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar ppf
                    "Note that X is a placeholder for some value that will vary between runs"
                      % string)
              (cons
                (fun ppf =>
                  fun function_parameter =>
                    let 'tt := function_parameter in
                    ledger_should_display ppf op_startypeminuserrorstar) []))))
        (fun user_answer =>
          op_startypeminuserrorstar
            (client_async_cmd state client command
              (fun function_parameter =>
                let '_ := function_parameter in
                fun proc =>
                  find_and_print_signature_hash
                    (Some
                      (equiv_decb protocol_kind
                        (* ❌ Variants not supported *)
                        variant)) state proc))
            (fun res =>
              expect_from_output
                match user_answer with
                | Reject =>
                  (* ❌ Variants not supported *)
                  variant
                | Accept =>
                  (* ❌ Variants not supported *)
                  variant
                end "self-delegation" % string res)))
      (fun function_parameter =>
        let '_ := function_parameter in
        op_startypeminuserrorstar bake "setting self-delegate of %s" % string
          src) in
  let tz_account_delegation {F : Type} (function_parameter : unit) : F :=
    let 'tt := function_parameter in
    let command :=
      cons "--wait" % string
        (cons "none" % string
          (cons "set" % string
            (cons "delegate" % string
              (cons "for" % string
                (cons src
                  (cons "to" % string
                    (cons delegate (cons "--verbose-signing" % string []))))))))
      in
    op_startypeminuserrorstar
      (with_ledger_test_reject_and_accept (Some only_success) state
        (cons
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar ppf
                "Delegating account `%s` to `%s`" % string ledger_pkh delegate)
          (cons (show_command_message command)
            (cons
              (fun ppf =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar ppf
                    "Note that X is a placeholder for some value that will vary between runs"
                      % string)
              (cons
                (fun ppf =>
                  fun function_parameter =>
                    let 'tt := function_parameter in
                    ledger_should_display ppf op_startypeminuserrorstar) []))))
        (fun user_answer =>
          op_startypeminuserrorstar
            (client_async_cmd state client command
              (fun function_parameter =>
                let '_ := function_parameter in
                fun proc =>
                  find_and_print_signature_hash
                    (Some
                      (equiv_decb protocol_kind
                        (* ❌ Variants not supported *)
                        variant)) state proc))
            (fun res =>
              expect_from_output
                match user_answer with
                | Reject =>
                  (* ❌ Variants not supported *)
                  variant
                | Accept =>
                  (* ❌ Variants not supported *)
                  variant
                end "tz123-delegation" % string res)))
      (fun function_parameter =>
        let '_ := function_parameter in
        op_startypeminuserrorstar bake "setting delegate of %s" % string src) in
  let run_command_and_check {F G H I : Type}
    (state : F) (client : G) (command : H) (message : string) (user_answer :
    variant) : I :=
    op_startypeminuserrorstar (op_startypeminuserrorstar state client command)
      (fun function_parameter =>
        let '(_, res) := function_parameter in
        expect_from_output
          match user_answer with
          | Reject =>
            (* ❌ Variants not supported *)
            variant
          | Accept =>
            (* ❌ Variants not supported *)
            variant
          end message res) in
  let delegate_with_scriptless_account {F : Type} (function_parameter : unit)
    : F :=
    let 'tt := function_parameter in
    let originated_account_name := "ledginated" % string in
    let amount := "200" % string in
    let burn_cap := "0.257" % string in
    let command :=
      cons "--wait" % string
        (cons "none" % string
          (cons "originate" % string
            (cons "account" % string
              (cons originated_account_name
                (cons "for" % string
                  (cons src
                    (cons "transferring" % string
                      (cons "200" % string
                        (cons "from" % string
                          (cons src
                            (cons "--delegatable" % string
                              (cons "--burn-cap" % string
                                (cons burn_cap (cons "--force" % string []))))))))))))))
      in
    op_startypeminuserrorstar
      (with_ledger_test_reject_and_accept (Some only_success) state
        (cons
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar ppf "Originating account `%s`" % string
                originated_account_name)
          (cons
            (fun ppf =>
              fun function_parameter =>
                let 'tt := function_parameter in
                ledger_should_display ppf op_startypeminuserrorstar) []))
        (fun user_answer =>
          run_command_and_check state client command
            "account origination" % string user_answer))
      (fun function_parameter =>
        let '_ := function_parameter in
        op_startypeminuserrorstar
          (op_startypeminuserrorstar bake "origination of %s" % string
            originated_account_name)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_startypeminuserrorstar
              (op_startypeminuserrorstar state client
                (cons "show" % string
                  (cons "known" % string
                    (cons "contract" % string (cons originated_account_name [])))))
              (fun function_parameter =>
                let '(_, proc_result) := function_parameter in
                let contract_address :=
                  OCaml.Stdlib.reverse_apply
                    (* ❌ Sending method message is not handled *)
                    send
                    (Stdlib.String.concat
                      (* ❌ expected an argument *)
                      expected_argument
                      (* ❌ expected an argument *)
                      expected_argument "" % string) in
                op_startypeminuserrorstar
                  (op_startypeminuserrorstar state client
                    (cons "show" % string
                      (cons "address" % string (cons delegate []))))
                  (fun function_parameter =>
                    let '(_, proc_result) := function_parameter in
                    let delegate_address :=
                      OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply
                          (OCaml.Stdlib.reverse_apply
                            (op_startypeminuserrorstar
                              (* ❌ Sending method message is not handled *)
                              send) (op_startypeminuserrorstar " " % char))
                          op_startypeminuserrorstar)
                        (op_startypeminuserrorstar delegate) in
                    let command :=
                      cons "--wait" % string
                        (cons "none" % string
                          (cons "set" % string
                            (cons "delegate" % string
                              (cons "for" % string
                                (cons originated_account_name
                                  (cons "to" % string (cons delegate [])))))))
                      in
                    op_startypeminuserrorstar
                      (with_ledger_test_reject_and_accept (Some only_success)
                        state
                        (cons
                          (fun ppf =>
                            fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar ppf
                                "Setting `%s` as delegate for `%s`" % string
                                delegate originated_account_name)
                          (cons
                            (fun ppf =>
                              fun function_parameter =>
                                let 'tt := function_parameter in
                                ledger_should_display ppf
                                  op_startypeminuserrorstar) []))
                        (fun user_answer =>
                          run_command_and_check state client command
                            "setting delegate of KT1" % string user_answer))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar bake
                            "setting delegate of %s" % string
                            originated_account_name)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            let withdraw_command :=
                              cons "--wait" % string
                                (cons "none" % string
                                  (cons "withdraw" % string
                                    (cons "delegate" % string
                                      (cons "from" % string
                                        (cons originated_account_name []))))) in
                            op_startypeminuserrorstar
                              (with_ledger_test_reject_and_accept
                                (Some only_success) state
                                (cons
                                  (fun ppf =>
                                    fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar ppf
                                        "Withdrawing delegate from `%s`" %
                                          string originated_account_name)
                                  (cons (show_command_message withdraw_command)
                                    (cons
                                      (fun ppf =>
                                        fun function_parameter =>
                                          let 'tt := function_parameter in
                                          ledger_should_display ppf
                                            op_startypeminuserrorstar) [])))
                                (fun user_answer =>
                                  run_command_and_check state client
                                    withdraw_command
                                    "withdrawing delegate from originated account"
                                      % string user_answer))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_startypeminuserrorstar bake
                                  "withdrawing delegate of %s" % string
                                  originated_account_name))))))) in
  match protocol_kind with
  | Athens =>
    op_startypeminuserrorstar (self_delegation tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        delegate_with_scriptless_account tt)
  | Babylon =>
    op_startypeminuserrorstar (tz_account_delegation tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        self_delegation tt)
  end.

Definition transaction_tests {A B C D E : Type}
  (state : A) (client : B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (pair_string_nat_kt1_account : string)
  (ledger_account : C) (unit_kt1_account : string) (bake : D)
  (function_parameter : unit) : E :=
  let 'tt := function_parameter in
  let ledger_pkh := op_startypeminuserrorstar ledger_account in
  let only_success := negb with_rejections in
  let test_transaction {F G H : Type} (op_staroptstar : option Z)
    : (option F) -> string -> string -> G -> unit -> H :=
    let storage :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => 0
      end in
    fun arguments =>
      fun name =>
        fun dst_name =>
          fun dst_pkh =>
            fun function_parameter =>
              let 'tt := function_parameter in
              let amount := "15" % string in
              let command :=
                OCaml.Stdlib.app
                  (cons "--wait" % string
                    (cons "none" % string
                      (cons "transfer" % string
                        (cons amount
                          (cons "from" % string
                            (cons src (cons "to" % string (cons dst_name []))))))))
                  (OCaml.Stdlib.app
                    (op_startypeminuserrorstar [] arguments
                      (fun a => cons "--arg" % string (cons a [])))
                    (cons "--burn-cap" % string
                      (cons "100" % string
                        (cons "--verbose-signing" % string [])))) in
              op_startypeminuserrorstar
                (with_ledger_test_reject_and_accept (Some only_success) state
                  (cons
                    (fun ppf =>
                      fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar ppf
                          "%s with account `%s`" % string name ledger_pkh)
                    (cons (show_command_message command)
                      (cons
                        (fun ppf =>
                          fun function_parameter =>
                            let 'tt := function_parameter in
                            op_startypeminuserrorstar ppf
                              "Note that X is a placeholder for some value that will vary between runs"
                                % string)
                        (cons
                          (fun ppf =>
                            fun function_parameter =>
                              let 'tt := function_parameter in
                              match arguments with
                              | None =>
                                ledger_should_display ppf
                                  op_startypeminuserrorstar
                              | _ => please_check_the_hash ppf tt
                              end) []))))
                  (fun user_answer =>
                    op_startypeminuserrorstar
                      (client_async_cmd state client command
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          fun proc =>
                            find_and_print_signature_hash
                              (Some
                                (orb
                                  (equiv_decb protocol_kind
                                    (* ❌ Variants not supported *)
                                    variant) (nequiv_decb arguments None)))
                              state proc))
                      (fun res =>
                        expect_from_output
                          match user_answer with
                          | Reject =>
                            (* ❌ Variants not supported *)
                            variant
                          | Accept =>
                            (* ❌ Variants not supported *)
                            variant
                          end name res)))
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_startypeminuserrorstar bake "%s with %s" % string name src)
    in
  op_startypeminuserrorstar
    (test_transaction None None "Self-transaction" % string src ledger_pkh tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let Acc :=
        (* ❌ The signature name of this module could not be found *)
        existT _ _
          {|
            
            |} in
      let random_account :=
        op_startypeminuserrorstar "random-account-for-transaction-test" % string
        in
      op_startypeminuserrorstar
        (test_transaction (Some 277) None "transaction-to-random-tz1" % string
          (op_startypeminuserrorstar random_account)
          (op_startypeminuserrorstar random_account) tt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (test_transaction (Some 0) None
              "transaction-to-random-tz1-again" % string
              (op_startypeminuserrorstar random_account)
              (op_startypeminuserrorstar random_account) tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (test_transaction None None
                  "parameterless-transaction-to-kt1" % string unit_kt1_account
                  "KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  test_transaction None
                    (Some "Pair ""hello from the ledger"" 51" % string)
                    "parameterfull-transaction-to-kt1" % string
                    pair_string_nat_kt1_account
                    "KT1XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX" % string tt)))).

Definition prepare_origination_of_id_script {A B C D : Type}
  (op_staroptstar : option bool)
  : (option bool) ->
    (option A) ->
      (option Z) ->
        (option string) ->
          B -> C -> string -> string -> variant -> string -> string -> D :=
  let spendable :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun op_staroptstar =>
    let delegatable :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun delegate =>
      fun op_staroptstar =>
        let push_drops :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => 0
          end in
        fun op_staroptstar =>
          let amount :=
            match op_staroptstar with
            | Some op_starsthstar => op_starsthstar
            | None => "2" % string
            end in
          fun state =>
            fun function_parameter =>
              let '_ := function_parameter in
              fun name =>
                fun from =>
                  fun protocol_kind =>
                    fun parameter =>
                      fun init_storage =>
                        let id_script {E : Type} (parameter : string) : E :=
                          op_startypeminuserrorstar
                            "parameter %s;
storage %s;
code
  {
    %s
    { CAR; NIL operation; PAIR }
  };
"
                              % string parameter parameter
                            match push_drops with
                            | 0 => "# No push-drops" % string
                            | n =>
                              op_startypeminuserrorstar
                                "# %d push-drop%s
    %s" % string n
                                (if OCaml.Stdlib.gt n 1 then
                                  "s" % string
                                else
                                  "" % string) op_startypeminuserrorstar
                            end in
                        let tmp :=
                          Filename.temp_file None "little-id-script" % string
                            ".tz" % string in
                        op_startypeminuserrorstar
                          (op_startypeminuserrorstar state tmp
                            (id_script parameter))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              op_startypeminuserrorstar
                                op_startypeminuserrorstar in
                            let origination :=
                              let opt := op_startypeminuserrorstar [] in
                              OCaml.Stdlib.app
                                (cons "--wait" % string
                                  (cons "none" % string
                                    (cons "originate" % string
                                      (cons "contract" % string (cons name [])))))
                                (OCaml.Stdlib.app
                                  match protocol_kind with
                                  | Athens => cons "for" % string (cons from [])
                                  | Babylon => []
                                  end
                                  (OCaml.Stdlib.app
                                    (cons "transferring" % string
                                      (cons amount
                                        (cons "from" % string
                                          (cons from
                                            (cons "running" % string
                                              (cons tmp
                                                (cons "--init" % string
                                                  (cons init_storage
                                                    (cons "--force" % string
                                                      (cons
                                                        "--burn-cap" % string
                                                        (cons
                                                          "300000000000" %
                                                            string
                                                          (cons
                                                            "--gas-limit" %
                                                              string
                                                            (cons
                                                              "1000000000000000"
                                                                % string
                                                              (cons
                                                                "--storage-limit"
                                                                  % string
                                                                (cons
                                                                  "20000000000000"
                                                                    % string
                                                                  (cons
                                                                    "--verbose-signing"
                                                                      % string
                                                                    []))))))))))))))))
                                    (OCaml.Stdlib.app
                                      (opt delegate
                                        (fun s =>
                                          cons "--delegate" % string (cons s [])))
                                      (OCaml.Stdlib.app
                                        (if delegatable then
                                          cons "--delegatable" % string []
                                        else
                                          [])
                                        (if spendable then
                                          cons "--spendable" % string []
                                        else
                                          []))))) in
                            op_startypeminuserrorstar origination).

Definition originate_id_script {A B C D : Type}
  (push_drops : option Z) (state : A) (client : B) (name : string)
  (from : string) (bake : C) (protocol_kind : variant) (parameter : string)
  (init_storage : string) : D :=
  op_startypeminuserrorstar
    (prepare_origination_of_id_script None None None push_drops None state
      client name from protocol_kind parameter init_storage)
    (fun origination =>
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state client origination)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_startypeminuserrorstar bake "baking `%s` in" % string name)).

Definition pp_warning_ledger_takes_a_while {A B C : Type}
  (adjective : A) (ppf : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := op_startypeminuserrorstar ppf tt in
  let prompt := "WARNING: " % string in
  let warning1 := "The ledger will take a few seconds to show" % string in
  let warning2 :=
    op_startypeminuserrorstar "the hash for such a %s operation." % string
      adjective in
  let wl := Z.add (OCaml.String.length prompt) (OCaml.String.length warning1) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar "shout" % string ppf
      (fun ppf =>
        op_startypeminuserrorstar ppf
          (String.append "/" % string
            (String.append (Stdlib.String.make wl "=" % char) "\" % string))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := op_startypeminuserrorstar ppf tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar "shout" % string ppf
      (fun ppf => op_startypeminuserrorstar ppf "|%s" % string prompt) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := op_startypeminuserrorstar ppf warning1 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar "shout" % string ppf
      (fun ppf => op_startypeminuserrorstar ppf "|" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := op_startypeminuserrorstar ppf tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar "shout" % string ppf
      (fun ppf => op_startypeminuserrorstar ppf "|" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar ppf
      (Stdlib.String.make (OCaml.String.length prompt) " " % char) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := op_startypeminuserrorstar ppf warning2 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar ppf
      (Stdlib.String.make
        (Z.sub (OCaml.String.length warning1) (OCaml.String.length warning2))
        " " % char) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar "shout" % string ppf
      (fun ppf => op_startypeminuserrorstar ppf "|" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := op_startypeminuserrorstar ppf tt in
  op_startypeminuserrorstar "shout" % string ppf
    (fun ppf =>
      op_startypeminuserrorstar ppf
        (String.append "\" % string
          (String.append (Stdlib.String.make wl "=" % char) "/" % string))).

Definition basic_contract_operations_tests {A B C D E F : Type}
  (state : A) (client : B) (src : string) (with_rejections : bool)
  (protocol_kind : variant) (ledger_account : C) (bake : D) (delegate : E)
  (function_parameter : unit) : F :=
  let 'tt := function_parameter in
  let ledger_pkh := op_startypeminuserrorstar ledger_account in
  let only_success := negb with_rejections in
  let test_origination {G : Type}
    (delegate : option E) (delegatable : option bool) (spendable : option bool)
    (push_drops : option Z) (name : string) (amount : string) (parameter :
    string) (init_storage : string) (function_parameter : unit) : G :=
    let 'tt := function_parameter in
    op_startypeminuserrorstar
      (prepare_origination_of_id_script spendable delegatable delegate
        push_drops (Some amount) state client name src protocol_kind parameter
        init_storage)
      (fun origination =>
        op_startypeminuserrorstar
          (with_ledger_test_reject_and_accept (Some only_success) state
            (cons
              (fun ppf =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar ppf
                    "Origination: %s (ledger: %s)" % string name ledger_pkh)
              (cons (show_command_message origination)
                (cons please_check_the_hash
                  (cons
                    (if nequiv_decb push_drops None then
                      pp_warning_ledger_takes_a_while "huge" % string
                    else
                      op_startypeminuserrorstar op_startypeminuserrorstar
                        "" % string) []))))
            (fun user_answer =>
              op_startypeminuserrorstar
                (client_async_cmd state client origination
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    fun proc =>
                      find_and_print_signature_hash (Some true) state proc))
                (fun res =>
                  expect_from_output
                    match user_answer with
                    | Reject =>
                      (* ❌ Variants not supported *)
                      variant
                    | Accept =>
                      (* ❌ Variants not supported *)
                      variant
                    end name res)))
          (fun function_parameter =>
            let '_ := function_parameter in
            op_startypeminuserrorstar bake "%s with %s" % string name src)) in
  op_startypeminuserrorstar
    (test_origination None None None None "ID-unit" % string "0" % string
      "unit" % string "Unit" % string tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (test_origination None None None None "ID-string" % string "10" % string
          "string" % string """some string""" % string tt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (test_origination None None None None "ID-string-nat-mutez" % string
              "10" % string "(pair string (pair nat mutez))" % string
              "Pair ""hello"" (Pair 12 1)" % string tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (test_origination (Some delegate) None None None
                  "ID-address+delegate" % string "1" % string "address" % string
                  """tz1YPSCGWXwBdTncK2aCctSZAXWvGsGwVJqU""" % string tt)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    match protocol_kind with
                    | Athens =>
                      test_origination (Some delegate) (Some true) None None
                        "ID-string+delegatable" % string "0" % string
                        "string" % string """delegatable contract""" % string tt
                    | Babylon => op_startypeminuserrorstar tt
                    end
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let push_drops := 242 in
                      test_origination None None None (Some push_drops)
                        "giant-contract" % string "10" % string
                        "(pair string nat)" % string
                        "Pair ""the answer is: "" 42" % string tt))))).

Module Wallet_scenario.
  Definition root := variant.
  
  Definition t := variant.
  
  Definition with_rejections (function_parameter : t) : bool :=
    match function_parameter with
    | Without_rejections _ => false
    | _ => true
    end.
  
  Definition enum_assoc : list (string * root) :=
    cons
      ("everything" % string,
        (* ❌ Variants not supported *)
        variant)
      (cons
        ("voting" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("none" % string,
            (* ❌ Variants not supported *)
            variant)
          (cons
            ("delegation" % string,
              (* ❌ Variants not supported *)
              variant)
            (cons
              ("transactions" % string,
                (* ❌ Variants not supported *)
                variant)
              (cons
                ("contracts" % string,
                  (* ❌ Variants not supported *)
                  variant)
                (cons
                  ("batch-transactions" % string,
                    (* ❌ Variants not supported *)
                    variant) [])))))).
  
  Definition root (ws : t) : root :=
    match ws with
    | Without_rejections r => r
    |
      (Transactions |
        Delegation | Contracts | All | Batch_transactions | None | Voting) as r
      => r
    end.
  
  Definition run_if {A B : Type}
    (v : root) (t : t) (yes : bool -> A) (no : B -> A) : A :=
    let with_rejections := with_rejections t in
    match root t with
    | All => yes with_rejections
    | other => yes with_rejections
    | _other =>
      no
        (op_startypeminuserrorstar enum_assoc
          (fun function_parameter =>
            match function_parameter with
            | (k, this) => Some k
            | _ => None
            end))
    end.
  
  Definition if_voting {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
    run_if
      (* ❌ Variants not supported *)
      variant t.
  
  Definition if_batch_transactions {A B : Type} (t : t)
    : (bool -> A) -> (B -> A) -> A :=
    run_if
      (* ❌ Variants not supported *)
      variant t.
  
  Definition if_delegation {A B : Type} (t : t)
    : (bool -> A) -> (B -> A) -> A :=
    run_if
      (* ❌ Variants not supported *)
      variant t.
  
  Definition if_transactions {A B : Type} (t : t)
    : (bool -> A) -> (B -> A) -> A :=
    run_if
      (* ❌ Variants not supported *)
      variant t.
  
  Definition if_contracts {A B : Type} (t : t) : (bool -> A) -> (B -> A) -> A :=
    run_if
      (* ❌ Variants not supported *)
      variant t.
  
  Definition cli_term {A : Type} (function_parameter : unit) : A :=
    let 'tt := function_parameter in
    let make (no_rejections : bool) (v : root) : t :=
      if no_rejections then
        (* ❌ Variants not supported *)
        variant
      else
        v in
    op_startypeminuserrorstar.
End Wallet_scenario.

Definition run {A B C D E F G H : Type}
  (state : A) (pp_error : Stdlib.Format.formatter -> B -> unit) (protocol : C)
  (protocol_kind : variant) (node_exec : D) (client_exec : D) (admin_exec : D)
  (wallet_scenario : Wallet_scenario.t) (size : E) (base_port : F) (uri : G)
  (function_parameter : unit) : H :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar (op_startypeminuserrorstar state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state
          (* ❌ Variants not supported *)
          variant (cons node_exec (cons client_exec (cons admin_exec []))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar state op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              let ledger_client := op_startypeminuserrorstar client_exec in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar state ledger_client uri)
                (fun _ledger_account =>
                  let '(protocol, baker_0_account, _baker_0_balance) :=
                    op_startypeminuserrorstar in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar protocol size base_port state
                      node_exec client_exec)
                    (fun function_parameter =>
                      let '(nodes, protocol) := function_parameter in
                      let client {I J : Type} (n : I) : J :=
                        op_startypeminuserrorstar client_exec
                          (op_startypeminuserrorstar nodes n) in
                      let client_0 := client 0 in
                      let baker_0 :=
                        op_startypeminuserrorstar client_0 "baker-0" % string
                          (op_startypeminuserrorstar baker_0_account) in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar state baker_0)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          let make_admin := op_startypeminuserrorstar admin_exec
                            in
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            op_startypeminuserrorstar state
                              op_startypeminuserrorstar in
                          let first_bakes := 3 in
                          op_startypeminuserrorstar
                            (op_startypeminuserrorstar first_bakes
                              (fun nth =>
                                op_startypeminuserrorstar
                                  (op_startypeminuserrorstar state baker_0)
                                  "initial-bake %d" % string nth))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar
                                (op_startypeminuserrorstar state
                                  op_startypeminuserrorstar)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  let signer :=
                                    op_startypeminuserrorstar (client 0)
                                      "ledgered" % string uri in
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state client_0
                                      uri)
                                    (fun ledger_account =>
                                      op_startypeminuserrorstar
                                        (op_startypeminuserrorstar state
                                          client_0
                                          (cons "--wait" % string
                                            (cons "none" % string
                                              (cons "transfer" % string
                                                (cons "20000" % string
                                                  (cons "from" % string
                                                    (cons
                                                      (Tezos_client.Keyed.key_name
                                                        baker_0)
                                                      (cons "to" % string
                                                        (cons
                                                          (op_startypeminuserrorstar
                                                            ledger_account)
                                                          (cons
                                                            "--burn-cap" %
                                                              string
                                                            (cons "100" % string
                                                              [])))))))))))
                                        (fun function_parameter =>
                                          let '_ := function_parameter in
                                          let bake {I J : Type} (msg : I) : J :=
                                            op_startypeminuserrorstar state
                                              baker_0 msg in
                                          op_startypeminuserrorstar
                                            (bake
                                              "After transferring tez to the ledger account"
                                                % string)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar
                                                (with_ledger_test_reject_and_accept
                                                  (Some
                                                    (OCaml.Stdlib.reverse_apply
                                                      (Wallet_scenario.with_rejections
                                                        wallet_scenario) negb))
                                                  state
                                                  (cons
                                                    (fun ppf =>
                                                      fun function_parameter =>
                                                        let 'tt :=
                                                          function_parameter in
                                                        op_startypeminuserrorstar
                                                          ppf
                                                          "Importing %S in client `%s`."
                                                            % string uri
                                                          (Tezos_client.id
                                                            client_0))
                                                    (cons
                                                      (fun ppf =>
                                                        fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_startypeminuserrorstar
                                                            ppf
                                                            "The ledger should be prompting for acknowledgment to provide the public key of `%s`."
                                                              % string
                                                            (op_startypeminuserrorstar
                                                              ledger_account))
                                                      []))
                                                  (fun user_answer =>
                                                    op_startypeminuserrorstar
                                                      (op_startypeminuserrorstar
                                                        state client_0
                                                        (cons "import" % string
                                                          (cons
                                                            "secret" % string
                                                            (cons "key" % string
                                                              (cons
                                                                (key_name signer)
                                                                (cons
                                                                  (secret_key
                                                                    signer)
                                                                  (cons
                                                                    "--force" %
                                                                      string [])))))))
                                                      (fun function_parameter =>
                                                        let '(_, proc) :=
                                                          function_parameter in
                                                        expect_from_output
                                                          match user_answer with
                                                          | Accept =>
                                                            (* ❌ Variants not supported *)
                                                            variant
                                                          | Reject =>
                                                            (* ❌ Variants not supported *)
                                                            variant
                                                          end
                                                          "importing key" %
                                                            string proc)))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  let skipping {I J : Type}
                                                    (s : I) : J :=
                                                    op_startypeminuserrorstar
                                                      state
                                                      op_startypeminuserrorstar
                                                    in
                                                  let voting_test {I : Type}
                                                    (with_rejections : bool)
                                                    : I :=
                                                    let tested_proposal :=
                                                      "Pt24m4xiPbLDhVgVfABUjirbmda3yohdN82Sp9FeuAXJ4eV9otd"
                                                        % string in
                                                    voting_tests state client
                                                      (key_name signer)
                                                      with_rejections
                                                      protocol_kind
                                                      ledger_account
                                                      tested_proposal
                                                      (fun function_parameter =>
                                                        let 'tt :=
                                                          function_parameter in
                                                        op_startypeminuserrorstar
                                                          (op_startypeminuserrorstar
                                                            state client_0
                                                            (cons
                                                              "--wait" % string
                                                              (cons
                                                                "none" % string
                                                                (cons
                                                                  "submit" %
                                                                    string
                                                                  (cons
                                                                    "proposals"
                                                                      % string
                                                                    (cons
                                                                      "for" %
                                                                        string
                                                                      (cons
                                                                        (Tezos_client.Keyed.key_name
                                                                          baker_0)
                                                                        (cons
                                                                          tested_proposal
                                                                          (cons
                                                                            "--force"
                                                                              %
                                                                              string
                                                                            [])))))))))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let '_ :=
                                                              function_parameter
                                                              in
                                                            let blocks :=
                                                              Tezos_protocol.blocks_per_voting_period
                                                                protocol in
                                                            op_startypeminuserrorstar
                                                              (op_startypeminuserrorstar
                                                                blocks
                                                                (fun nth =>
                                                                  op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      state
                                                                      baker_0)
                                                                    "going to testing-vote period %d/%d"
                                                                      % string
                                                                    (Z.add nth 1)
                                                                    blocks))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                op_startypeminuserrorstar
                                                                  tt))) tt in
                                                  let batch_test {I : Type}
                                                    (with_rejections : bool)
                                                    : I :=
                                                    let n := 50 in
                                                    op_startypeminuserrorstar
                                                      (forge_batch_transactions
                                                        state (client 0)
                                                        (op_startypeminuserrorstar
                                                          ledger_account)
                                                        "tz2KZPgf2rshxNUBXFcTaCemik1LH1v9qz3F"
                                                          % string n None tt)
                                                      (fun
                                                        batch_transaction_bytes
                                                        =>
                                                        let bytes_hash :=
                                                          op_startypeminuserrorstar
                                                          in
                                                        with_ledger_test_reject_and_accept
                                                          (Some
                                                            (negb
                                                              with_rejections))
                                                          state
                                                          (cons
                                                            (fun ppf =>
                                                              fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                op_startypeminuserrorstar
                                                                  ppf
                                                                  "Signing batch of %d transactions"
                                                                    % string n)
                                                            (cons
                                                              (fun ppf =>
                                                                fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    ppf
                                                                    "Ledger should display “Sign Hash” → `%s`"
                                                                      % string
                                                                    bytes_hash)
                                                              (cons
                                                                (pp_warning_ledger_takes_a_while
                                                                  "big" % string)
                                                                [])))
                                                          (fun user_answer =>
                                                            op_startypeminuserrorstar
                                                              (sign state signer
                                                                batch_transaction_bytes)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let
                                                                  '(_, proc) :=
                                                                  function_parameter
                                                                  in
                                                                expect_from_output
                                                                  match
                                                                    user_answer
                                                                    with
                                                                  | Accept =>
                                                                    (* ❌ Variants not supported *)
                                                                    variant
                                                                  | Reject =>
                                                                    (* ❌ Variants not supported *)
                                                                    variant
                                                                  end
                                                                  "Signing batch operation"
                                                                    % string
                                                                  proc))) in
                                                  let delegation_tests
                                                    {I : Type}
                                                    (with_rejections : bool)
                                                    : I :=
                                                    delegation_tests state
                                                      client_0 (key_name signer)
                                                      with_rejections
                                                      protocol_kind
                                                      ledger_account
                                                      (Tezos_client.Keyed.key_name
                                                        baker_0) bake tt in
                                                  let unit_kt1_account :=
                                                    "unit-kt1-of-the-baker" %
                                                      string in
                                                  op_startypeminuserrorstar
                                                    (originate_id_script None
                                                      state client_0
                                                      unit_kt1_account
                                                      (Tezos_client.Keyed.key_name
                                                        baker_0) bake
                                                      protocol_kind
                                                      "unit" % string
                                                      "Unit" % string)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      let
                                                        pair_string_nat_kt1_account :=
                                                        "pair-string-nat-kt1-of-the-baker"
                                                          % string in
                                                      op_startypeminuserrorstar
                                                        (originate_id_script
                                                          (Some 10) state
                                                          client_0
                                                          pair_string_nat_kt1_account
                                                          (Tezos_client.Keyed.key_name
                                                            baker_0) bake
                                                          protocol_kind
                                                          "(pair string nat)" %
                                                            string
                                                          "Pair ""the answer is: "" 42"
                                                            % string)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          let transactions_test
                                                            {I : Type}
                                                            (with_rejections :
                                                            bool) : I :=
                                                            transaction_tests
                                                              state client_0
                                                              (key_name signer)
                                                              with_rejections
                                                              protocol_kind
                                                              pair_string_nat_kt1_account
                                                              ledger_account
                                                              unit_kt1_account
                                                              bake tt in
                                                          let contracts_test
                                                            {I : Type}
                                                            (with_rejections :
                                                            bool) : I :=
                                                            basic_contract_operations_tests
                                                              state client_0
                                                              (key_name signer)
                                                              with_rejections
                                                              protocol_kind
                                                              ledger_account
                                                              bake
                                                              (Tezos_client.Keyed.key_name
                                                                baker_0) tt in
                                                          let bake_command :=
                                                            op_startypeminuserrorstar
                                                              op_startypeminuserrorstar
                                                              (cons
                                                                "bake" % string
                                                                [])
                                                              (fun _sexps =>
                                                                op_startypeminuserrorstar
                                                                  (fun e =>
                                                                    Format.kasprintf
                                                                      (fun s =>
                                                                        (* ❌ Variants not supported *)
                                                                        variant)
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "run-test-error: "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Alpha
                                                                            CamlinternalFormatBasics.End_of_format))
                                                                        "run-test-error: %a"
                                                                          %
                                                                          string)
                                                                      pp_error e)
                                                                  (bake
                                                                    "Interactive"
                                                                      % string))
                                                            in
                                                          let
                                                            run_test_command :=
                                                            op_startypeminuserrorstar
                                                              op_startypeminuserrorstar
                                                              (cons
                                                                "rt" % string
                                                                (cons
                                                                  "run-test" %
                                                                    string []))
                                                              (fun sexps =>
                                                                op_startypeminuserrorstar
                                                                  (fun e =>
                                                                    Format.kasprintf
                                                                      (fun s =>
                                                                        (* ❌ Variants not supported *)
                                                                        variant)
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "run-test-error: "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Alpha
                                                                            CamlinternalFormatBasics.End_of_format))
                                                                        "run-test-error: %a"
                                                                          %
                                                                          string)
                                                                      pp_error e)
                                                                  match sexps
                                                                    with
                                                                  | _ =>
                                                                    let run
                                                                      {I : Type}
                                                                      (f :
                                                                      bool -> I)
                                                                      : I :=
                                                                      f true in
                                                                    match
                                                                      op_startypeminuserrorstar
                                                                        Stdlib.String.equal
                                                                        Wallet_scenario.enum_assoc
                                                                        op_startypeminuserrorstar
                                                                      with
                                                                    | Some None
                                                                      =>
                                                                      op_startypeminuserrorstar
                                                                        tt
                                                                    |
                                                                      Some
                                                                        Delegation
                                                                      =>
                                                                      run
                                                                        delegation_tests
                                                                    | Some All
                                                                      =>
                                                                      op_startypeminuserrorstar
                                                                        (run
                                                                          delegation_tests)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (run
                                                                              batch_test)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              run
                                                                                voting_test))
                                                                    |
                                                                      Some
                                                                        Batch_transactions
                                                                      =>
                                                                      run
                                                                        batch_test
                                                                    |
                                                                      Some
                                                                        Transactions
                                                                      =>
                                                                      run
                                                                        transactions_test
                                                                    |
                                                                      Some
                                                                        Voting
                                                                      =>
                                                                      run
                                                                        voting_test
                                                                    |
                                                                      Some
                                                                        Contracts
                                                                      =>
                                                                      run
                                                                        contracts_test
                                                                    | None =>
                                                                      failf None
                                                                        "Don't know this test: %S"
                                                                          %
                                                                          string
                                                                        op_startypeminuserrorstar
                                                                    end
                                                                  | _ =>
                                                                    failf None
                                                                      "Cannot understand command line"
                                                                        % string
                                                                  end) in
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            op_startypeminuserrorstar
                                                              state
                                                              (cons
                                                                run_test_command
                                                                (cons
                                                                  bake_command
                                                                  [])) in
                                                          op_startypeminuserrorstar
                                                            (Wallet_scenario.if_voting
                                                              wallet_scenario
                                                              voting_test
                                                              skipping)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (Wallet_scenario.if_batch_transactions
                                                                  wallet_scenario
                                                                  batch_test
                                                                  skipping)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    (Wallet_scenario.if_transactions
                                                                      wallet_scenario
                                                                      transactions_test
                                                                      skipping)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (Wallet_scenario.if_contracts
                                                                          wallet_scenario
                                                                          contracts_test
                                                                          skipping)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (Wallet_scenario.if_delegation
                                                                              wallet_scenario
                                                                              delegation_tests
                                                                              skipping)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                state
                                                                                op_startypeminuserrorstar))))))))))))))))))).

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

src/bin_sandbox/command_prevalidation.ml 17 errors
open Flextesa
open Internal_pervasives
open Console

let run state node_exec client_exec () =
  Test_scenario.network_with_protocol ~size:2 state ~node_exec ~client_exec
  >>= fun (nodes, _protocol) ->
  match nodes with
  | [] | [_] | _ :: _ :: _ :: _ ->
      assert false
  | [n1; n2] ->
      let c1 = Tezos_client.of_node ~exec:client_exec n1 in
      let c2 = Tezos_client.of_node ~exec:client_exec n2 in
      (* TODO: helpers for
         - injecting an op
         - displaying the mempool
         - setting filter plugin config

         TODO: non-interactive test for propagation
         TODO: commands for interactivea use *)
      Pervasives.ignore c1 ;
      Pervasives.ignore c2 ;
      return ()
      >>= fun () ->
      let commands = Interactive_test.Commands.all_defaults state ~nodes in
      Prompt.command state ~commands
      >>= fun () -> Running_processes.wait_all state

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure (fun bnod bcli state -> (state, run state bnod bcli))
    $ Tezos_executable.cli_term `Node "tezos"
    $ Tezos_executable.cli_term `Client "tezos"
    $ Test_command_line.cli_state ~name:"prevalidation" () )
    (info ~doc:"Work-in-progress." "prevalidation")
src/bin_sandbox/command_prevalidation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition run {A B C D : Type}
  (state : A) (node_exec : B) (client_exec : C) (function_parameter : unit)
  : D :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar 2 state node_exec client_exec)
    (fun function_parameter =>
      let '(nodes, _protocol) := function_parameter in
      match nodes with
      | [] | cons _ [] | cons _ (cons _ (cons _ _)) =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      | cons n1 (cons n2 []) =>
        let c1 := op_startypeminuserrorstar client_exec n1 in
        let c2 := op_startypeminuserrorstar client_exec n2 in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Pervasives.ignore c1 in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Pervasives.ignore c2 in
        op_startypeminuserrorstar (op_startypeminuserrorstar tt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            let commands := op_startypeminuserrorstar state nodes in
            op_startypeminuserrorstar (op_startypeminuserrorstar state commands)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_startypeminuserrorstar state))
      end).

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

src/bin_sandbox/command_voting.ml 423 errors
(* Semi-interactive test for voting *)
open Flextesa
open Internal_pervasives
module Counter_log = Helpers.Counter_log

let ledger_prompt_notice state ef =
  Console.say
    state
    EF.(
      desc
        (shout "Ledger-prompt")
        (list [ef; wf "Please hit “✔” on the ledger."]))

let setup_baking_ledger state uri ~client =
  Interactive_test.Pauser.generic
    state
    EF.
      [ wf "Setting up the ledger device %S" uri;
        haf
          "Please make sure the ledger is on the Baking app and quit (`q`) \
           this prompt to continue." ]
    ~force:true
  >>= fun () ->
  let key_name = "ledgered" in
  let baker = Tezos_client.Keyed.make client ~key_name ~secret_key:uri in
  ledger_prompt_notice
    state
    EF.(
      wf
        "Importing %S in client `%s`. The ledger should be prompting for \
         acknowledgment to provide the public key."
        uri
        client.Tezos_client.id)
  >>= fun () ->
  Tezos_client.Keyed.initialize state baker
  >>= fun _ ->
  ledger_prompt_notice
    state
    EF.(
      wf
        "Setting up %S for baking. The ledger should be showing the setup \
         parameters (Address, Main chain, HWMs)."
        uri)
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "setup";
      "ledger";
      "to";
      "bake";
      "for";
      key_name;
      "--main-hwm";
      "0";
      "--test-hwm";
      "0" ]
  >>= fun _ -> return baker

let failf fmt = ksprintf (fun s -> fail (`Scenario_error s)) fmt

let transfer state ~client ~src ~dst ~amount =
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "--wait";
      "none";
      "transfer";
      sprintf "%Ld" amount;
      "from";
      src;
      "to";
      dst;
      "--fee";
      "0.05";
      "--burn-cap";
      "0.3" ]

let register state ~client ~dst =
  Tezos_client.successful_client_cmd
    state
    ~client
    [ "--wait";
      "none";
      "register";
      "key";
      dst;
      "as";
      "delegate";
      "--fee";
      "0.05" ]

let bake_until_voting_period ?keep_alive_delegate state ~baker ~attempts period
    =
  let client = baker.Tezos_client.Keyed.client in
  let period_name = Tezos_protocol.Voting_period.to_string period in
  Helpers.wait_for state ~attempts ~seconds:0.5 (fun nth ->
      Tezos_client.rpc
        state
        ~client
        `Get
        ~path:"/chains/main/blocks/head/votes/current_period_kind"
      >>= function
      | `String p when p = period_name ->
          return (`Done (nth - 1))
      | _ ->
          Asynchronous_result.map_option keep_alive_delegate ~f:(fun dst ->
              register state ~client ~dst)
          >>= fun _ ->
          ksprintf
            (Tezos_client.Keyed.bake state baker)
            "Baker %s bakes %d/%d waiting for %S voting period"
            client.id
            nth
            attempts
            period_name
          >>= fun () ->
          return (`Not_done (sprintf "Waiting for %S period" period_name)))

let check_understood_protocols state ~chain ~client ~protocol_hash
    ~expect_clueless_client =
  Asynchronous_result.bind_on_result
    (Tezos_client.successful_client_cmd
       state
       ~client
       ["--chain"; chain; "list"; "understood"; "protocols"])
    ~f:(function
      | Ok client_protocols_result -> (
        match
          List.find client_protocols_result#out ~f:(fun prefix ->
              String.is_prefix protocol_hash ~prefix)
        with
        | Some _ ->
            return `Proper_understanding
        | None when expect_clueless_client ->
            return `Expected_misunderstanding
        | None ->
            return `Failure_to_understand )
      | Error (`Client_command_error _) when expect_clueless_client ->
          return `Expected_misunderstanding
      | Error e ->
          fail e)

let run state ~winner_path ~demo_path ~protocol ~node_exec ~client_exec
    ~clueless_winner ~admin_exec ~winner_client_exec ~size ~base_port
    ~serialize_proposals ?with_ledger () =
  let default_attempts = 50 in
  Helpers.clear_root state
  >>= fun () ->
  Helpers.System_dependencies.precheck
    state
    `Or_fail
    ~executables:[node_exec; client_exec; admin_exec; winner_client_exec]
    ~protocol_paths:[winner_path; demo_path]
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ready to start"; af "Root path deleted."]
  >>= fun () ->
  let (protocol, baker_0_account, baker_0_balance) =
    let open Tezos_protocol in
    let baker = List.nth_exn protocol.bootstrap_accounts 0 in
    ( {
        protocol with
        time_between_blocks = [1; 0];
        bootstrap_accounts =
          List.map protocol.bootstrap_accounts ~f:(fun (n, v) ->
              if fst baker = n then (n, v) else (n, 1_000L));
      },
      fst baker,
      snd baker )
  in
  Test_scenario.network_with_protocol
    ~protocol
    ~size
    ~base_port
    state
    ~node_exec
    ~client_exec
  >>= fun (nodes, protocol) ->
  let make_admin = Tezos_admin_client.of_client ~exec:admin_exec in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.(
      all_defaults state ~nodes
      @ [secret_keys state ~protocol; Log_recorder.Operations.show_all state]
      @ arbitrary_commands_for_each_and_all_clients
          state
          ~make_admin
          ~clients:(List.map nodes ~f:(Tezos_client.of_node ~exec:client_exec))) ;
  Interactive_test.Pauser.generic state EF.[af "About to really start playing"]
  >>= fun () ->
  let client n =
    Tezos_client.of_node ~exec:client_exec (List.nth_exn nodes n)
  in
  let baker_0 =
    Tezos_client.Keyed.make
      (client 0)
      ~key_name:"baker-0"
      ~secret_key:(Tezos_protocol.Account.private_key baker_0_account)
  in
  Tezos_client.Keyed.initialize state baker_0
  >>= fun _ ->
  let level_counter = Counter_log.create () in
  let first_bakes = 5 in
  Loop.n_times first_bakes (fun nth ->
      ksprintf (Tezos_client.Keyed.bake state baker_0) "initial-bake %d" nth)
  >>= fun () ->
  let initial_level = first_bakes + 1 in
  Counter_log.add level_counter "initial_level" initial_level ;
  ( match with_ledger with
  | None ->
      Console.say state EF.(wf "No ledger.")
      >>= fun () ->
      let account = Tezos_protocol.Account.of_name "special-baker" in
      let baker =
        Tezos_client.Keyed.make
          (client 0)
          ~key_name:(Tezos_protocol.Account.name account)
          ~secret_key:(Tezos_protocol.Account.private_key account)
      in
      Tezos_client.Keyed.initialize state baker >>= fun _ -> return baker
  | Some uri ->
      setup_baking_ledger state ~client:(client 0) uri )
  >>= fun special_baker ->
  let winner_client = {baker_0.client with exec = winner_client_exec} in
  let winner_baker_0 =
    let open Tezos_client.Keyed in
    {baker_0 with client = winner_client}
  in
  let winner_special_baker =
    let open Tezos_client.Keyed in
    {special_baker with client = winner_client}
  in
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.
      [ arbitrary_command_on_all_clients
          state
          ~command_names:["wc"; "winner-client"]
          ?make_admin:None
          ~clients:[winner_client] ] ;
  Interactive_test.Pauser.generic
    state
    EF.[wf "You can now try the new-client"]
  >>= fun () ->
  Interactive_test.Pauser.add_commands
    state
    Interactive_test.Commands.
      [ arbitrary_command_on_all_clients
          state
          ~command_names:["baker"]
          ~make_admin
          ~clients:[special_baker.Tezos_client.Keyed.client] ] ;
  transfer
    state (* Tezos_client.successful_client_cmd state *)
    ~client:(client 0)
    ~amount:(Int64.div baker_0_balance 2_000_000L)
    ~src:"baker-0"
    ~dst:special_baker.Tezos_client.Keyed.key_name
  >>= fun res ->
  Console.say
    state
    EF.(
      desc
        (wf "Successful transfer baker-0 -> special:")
        (ocaml_string_list res#out))
  >>= fun () ->
  let after_transfer_bakes = 2 in
  Loop.n_times after_transfer_bakes (fun nth ->
      ksprintf
        (Tezos_client.Keyed.bake state baker_0)
        "after-transfer-bake %d"
        nth)
  >>= fun () ->
  Counter_log.add level_counter "after-transfer-bakes" after_transfer_bakes ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      ledger_prompt_notice state EF.(wf "Registering as delegate."))
  >>= fun (_ : unit option) ->
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    [ "--wait";
      "none";
      "register";
      "key";
      special_baker.Tezos_client.Keyed.key_name;
      "as";
      "delegate";
      "--fee";
      "0.5" ]
  >>= fun _ ->
  let activation_bakes =
    let open Tezos_protocol in
    protocol.blocks_per_cycle * (protocol.preserved_cycles + 2)
  in
  Loop.n_times activation_bakes (fun nth ->
      ksprintf
        (Tezos_client.Keyed.bake state baker_0)
        "Baking after new delegate registered: %d/%d"
        nth
        activation_bakes
      >>= fun () ->
      Tezos_client.successful_client_cmd
        state
        ~client:(client 0)
        ["rpc"; "get"; "/chains/main/blocks/head/helpers/baking_rights"]
      >>= fun res ->
      Console.say
        state
        EF.(
          desc
            (haf "Baking rights")
            (markdown_verbatim (String.concat ~sep:"\n" res#out))))
  >>= fun () ->
  Counter_log.add level_counter "activation-bakes" activation_bakes ;
  Tezos_client.Keyed.bake state special_baker "Baked by Special Baker™"
  >>= fun () ->
  Counter_log.incr level_counter "special-baker-first-bake" ;
  let attempts =
    Tezos_protocol.(
      (* If we are right after the proposal period, we need to get to
         the next one *)
      3 * protocol.blocks_per_voting_period)
  in
  bake_until_voting_period
    state
    ~baker:special_baker
    ~attempts
    `Proposal
    ~keep_alive_delegate:baker_0.key_name
  >>= fun extra_bakes_waiting_for_proposal_period ->
  Counter_log.add
    level_counter
    "wait-for-proposal-period"
    extra_bakes_waiting_for_proposal_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  let admin_0 = Tezos_admin_client.of_client ~exec:admin_exec (client 0) in
  Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
  >>= fun res ->
  let default_protocols = res#out in
  let make_and_inject_protocol ?(make_different = false) name path =
    let tmpdir = Paths.root state // sprintf "protocol-%s" name in
    Console.say state EF.(wf "Injecting protocol from %s" tmpdir)
    >>= fun () ->
    Running_processes.run_successful_cmdf
      state
      "cp -L -R %s %s"
      (Filename.quote path)
      (Filename.quote tmpdir)
    >>= fun _ ->
    ( if make_different then
      Running_processes.run_successful_cmdf
        state
        "echo '(* Protocol %s *)' >> %s/main.mli"
        name
        (Filename.quote tmpdir)
      >>= fun _ -> return ()
    else return () )
    >>= fun () ->
    Tezos_admin_client.inject_protocol admin_0 state ~path:tmpdir
    >>= fun (res, hash) ->
    Interactive_test.Pauser.generic
      state
      EF.
        [ af "Just injected %s (%s): %s" name path hash;
          markdown_verbatim (String.concat ~sep:"\n" res#out) ]
    >>= fun () -> return hash
  in
  make_and_inject_protocol "winner" winner_path
  >>= fun winner_hash ->
  make_and_inject_protocol
    ~make_different:(winner_path = demo_path)
    "demo"
    demo_path
  >>= fun demo_hash ->
  Tezos_admin_client.successful_command admin_0 state ["list"; "protocols"]
  >>= fun res ->
  let after_injections_protocols = res#out in
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Network up";
        desc (haf "Protcols")
        @@ list
             (List.map after_injections_protocols ~f:(fun p ->
                  af
                    "`%s` (%s)"
                    p
                    ( if List.mem default_protocols p ~equal:String.equal then
                      "previously known"
                    else
                      match p with
                      | _ when p = winner_hash ->
                          "injected winner"
                      | _ when p = demo_hash ->
                          "injected demo"
                      | _ ->
                          "injected unknown" ))) ]
  >>= fun () ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      Interactive_test.Pauser.generic
        state
        EF.
          [ af "About to VOTE";
            haf "Please switch to the Wallet app and quit (`q`) this prompt."
          ]
        ~force:true)
  >>= fun (_ : unit option) ->
  let submit_proposals baker props =
    Asynchronous_result.map_option with_ledger ~f:(fun _ ->
        ledger_prompt_notice
          state
          EF.(
            wf
              "Submitting proposal%s: %s"
              (if List.length props = 1 then "" else "s")
              (String.concat ~sep:", " props)))
    >>= fun _ ->
    Tezos_client.successful_client_cmd
      state
      ~client:baker.Tezos_client.Keyed.client
      (["submit"; "proposals"; "for"; baker.key_name] @ props)
    >>= fun _ -> return ()
  in
  let to_submit_first = [winner_hash; demo_hash] in
  ( match serialize_proposals with
  | false ->
      submit_proposals special_baker to_submit_first
  | true ->
      List_sequential.iter to_submit_first ~f:(fun one ->
          submit_proposals special_baker [one]) )
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client:baker_0.client
    ["submit"; "proposals"; "for"; baker_0.key_name; winner_hash]
  >>= fun _ ->
  bake_until_voting_period
    state
    ~baker:baker_0
    ~attempts:protocol.blocks_per_voting_period
    `Testing_vote
    ~keep_alive_delegate:special_baker.key_name
  >>= fun extra_bakes_waiting_for_testing_vote_period ->
  Counter_log.add
    level_counter
    "wait-for-testing-vote-period"
    extra_bakes_waiting_for_testing_vote_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  Helpers.wait_for state ~attempts:default_attempts ~seconds:2. (fun _ ->
      Tezos_client.rpc
        state
        ~client:(client 1)
        `Get
        ~path:"/chains/main/blocks/head/votes/current_proposal"
      >>= fun current_proposal_json ->
      if current_proposal_json <> `String winner_hash then
        return
          (`Not_done
            (sprintf
               "Waiting for current_proposal_json to be %s (%s)"
               winner_hash
               Ezjsonm.(to_string (wrap current_proposal_json))))
      else return (`Done ()))
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client:baker_0.client
    ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      ledger_prompt_notice
        state
        EF.(wf "Submitting “Yes” ballot for %S" winner_hash))
  >>= fun (_ : unit option) ->
  Tezos_client.successful_client_cmd
    state
    ~client:special_baker.client
    ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Ballots are in (not baked though)"]
  >>= fun () ->
  bake_until_voting_period
    state
    ~baker:baker_0
    ~attempts:(1 + protocol.blocks_per_voting_period)
    ~keep_alive_delegate:special_baker.key_name
    `Testing
  >>= fun extra_bakes_waiting_for_testing_period ->
  Counter_log.add
    level_counter
    "wait-for-testing-period"
    extra_bakes_waiting_for_testing_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  check_understood_protocols
    state
    ~client:winner_client
    ~chain:"main"
    ~protocol_hash:winner_hash
    ~expect_clueless_client:clueless_winner
  >>= (function
        | `Proper_understanding ->
            let chain = "test" in
            Asynchronous_result.map_option with_ledger ~f:(fun _ ->
                Interactive_test.Pauser.generic
                  state
                  EF.
                    [ af "About to bake on the test chain.";
                      haf
                        "Please switch back to the Baking app and quit (`q`) \
                         this prompt." ]
                  ~force:true)
            >>= fun (_ : unit option) ->
            let testing_bakes = 5 in
            Loop.n_times testing_bakes (fun ith ->
                let baker =
                  if ith mod 2 = 0 then winner_baker_0
                  else winner_special_baker
                in
                Tezos_client.Keyed.bake
                  ~chain
                  state
                  baker
                  (sprintf
                     "Baking on the test chain [%d/%d]"
                     (ith + 1)
                     testing_bakes))
            >>= fun () ->
            Test_scenario.Queries.wait_for_all_levels_to_be
              state
              ~chain
              ~attempts:default_attempts
              ~seconds:8.
              nodes
              (`At_least (Counter_log.sum level_counter + testing_bakes))
            >>= fun () ->
            Interactive_test.Pauser.generic
              state
              EF.[wf "Testing period, with proper winner-client, have fun."]
            >>= fun () -> return ()
        | `Expected_misunderstanding ->
            Console.say
              state
              EF.(wf "Winner-Client cannot bake on test chain (expected)")
        | `Failure_to_understand ->
            failf "Winner-Client cannot bake on test chain!")
  >>= fun () ->
  Helpers.wait_for state ~attempts:default_attempts ~seconds:0.3 (fun _ ->
      Tezos_client.rpc
        state
        ~client:(client 1)
        `Get
        ~path:"/chains/main/blocks/head/metadata"
      >>= fun metadata_json ->
      try
        match
          Jqo.field metadata_json ~k:"test_chain_status"
          |> Jqo.field ~k:"protocol"
        with
        | `String s when s = winner_hash ->
            return (`Done ())
        | other ->
            return
              (`Not_done
                (sprintf "Wrong protocol: %s" Ezjsonm.(to_string (wrap other))))
      with e ->
        return
          (`Not_done
            (sprintf
               "Cannot get test-chain protocol: %s → %s"
               (Exn.to_string e)
               Ezjsonm.(to_string (wrap metadata_json)))))
  >>= fun () ->
  bake_until_voting_period
    state
    ~baker:baker_0
    ~attempts:(1 + protocol.blocks_per_voting_period)
    ~keep_alive_delegate:special_baker.key_name
    `Promotion_vote
  >>= fun extra_bakes_waiting_for_promotion_period ->
  Counter_log.add
    level_counter
    "wait-for-promotion-period"
    extra_bakes_waiting_for_promotion_period ;
  Test_scenario.Queries.wait_for_all_levels_to_be
    state
    ~attempts:default_attempts
    ~seconds:8.
    nodes
    (`At_least (Counter_log.sum level_counter))
  >>= fun () ->
  Interactive_test.Pauser.generic state EF.[haf "Before ballots"]
  >>= fun () ->
  Tezos_client.successful_client_cmd
    state
    ~client:baker_0.client
    ["submit"; "ballot"; "for"; baker_0.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Asynchronous_result.map_option with_ledger ~f:(fun _ ->
      Interactive_test.Pauser.generic
        state
        EF.
          [ af "About to cast approval ballot.";
            haf
              "Please switch back to the Wallet app and quit (`q`) this prompt."
          ]
        ~force:true
      >>= fun () ->
      ledger_prompt_notice
        state
        EF.(wf "Submitting “Yes” ballot for %S" winner_hash))
  >>= fun (_ : unit option) ->
  Tezos_client.successful_client_cmd
    state
    ~client:special_baker.client
    ["submit"; "ballot"; "for"; special_baker.key_name; winner_hash; "yay"]
  >>= fun _ ->
  Interactive_test.Pauser.generic
    state
    EF.[af "Final ballot(s) are in (not baked though)"]
  >>= fun () ->
  let ballot_bakes = 1 in
  Loop.n_times ballot_bakes (fun _ ->
      Tezos_client.Keyed.bake state baker_0 "Baking the promotion vote ballots")
  >>= fun () ->
  Counter_log.add level_counter "bake-the-ballots" ballot_bakes ;
  Tezos_client.successful_client_cmd
    state
    ~client:(client 0)
    ["list"; "understood"; "protocols"]
  >>= fun client_protocols_result ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ af "Final ballot(s) are baked in.";
        af
          "The client `%s` understands the following protocols: %s"
          Tezos_executable.(
            Option.value
              ~default:(default_binary client_exec)
              client_exec.binary)
          (String.concat ~sep:", " client_protocols_result#out) ]
  >>= fun () ->
  Helpers.wait_for
    state
    ~seconds:0.5
    ~attempts:(1 + protocol.blocks_per_voting_period)
    (fun nth ->
      let client = baker_0.client in
      Running_processes.run_successful_cmdf
        state
        "curl http://localhost:%d/chains/main/blocks/head/metadata"
        client.port
      >>= fun curl_res ->
      let json_string = curl_res#out |> String.concat ~sep:"\n" in
      let json_metadata = Ezjsonm.from_string json_string in
      match Jqo.field json_metadata ~k:"next_protocol" with
      | `String p when p = winner_hash ->
          return (`Done (nth - 1))
      | other ->
          transfer
            state
            ~client
            ~amount:1L
            ~src:baker_0.Tezos_client.Keyed.key_name
            ~dst:special_baker.Tezos_client.Keyed.key_name
          >>= fun _ ->
          ksprintf
            (Tezos_client.Keyed.bake state baker_0)
            "Baker %s bakes %d/%d waiting for next protocol: %S"
            client.id
            nth
            attempts
            winner_hash
          >>= fun () ->
          return
            (`Not_done
              (sprintf
                 "Waiting for next_protocol: %S (≠ %s)"
                 winner_hash
                 Ezjsonm.(to_string (wrap other)))))
  >>= fun extra_bakes_waiting_for_next_protocol ->
  Counter_log.add
    level_counter
    "wait-for-next-protocol"
    extra_bakes_waiting_for_next_protocol ;
  check_understood_protocols
    state
    ~client:winner_client
    ~chain:"main"
    ~protocol_hash:winner_hash
    ~expect_clueless_client:clueless_winner
  >>= (function
        | `Expected_misunderstanding ->
            Console.say
              state
              EF.(
                wf "As expected, the client does not know about %s" winner_hash)
        | `Failure_to_understand ->
            failf "The winner-client does not know about `%s`" winner_hash
        | `Proper_understanding -> (
            Console.say state EF.(wf "The client knows about %s" winner_hash)
            >>= fun () ->
            (* This actually depends on the protocol upgrade. *)
            Asynchronous_result.bind_on_result
              (Tezos_client.successful_client_cmd
                 state
                 ~client:winner_client
                 ["upgrade"; "baking"; "state"])
              ~f:(function
                | Ok _ ->
                    return ()
                | Error _ ->
                    Console.say
                      state
                      EF.(
                        desc
                          (shout "Warning")
                          (wf
                             "Command `upgrade baking state` failed, but we \
                              keep going with the baking.")))
            >>= fun () ->
            Asynchronous_result.map_option with_ledger ~f:(fun _ ->
                Interactive_test.Pauser.generic
                  state
                  EF.
                    [ af "About to bake on the new winning protocol.";
                      haf
                        "Please switch to the Baking app and quit (`q`) this \
                         prompt." ]
                  ~force:true
                >>= fun () ->
                Console.say state EF.(wf "Sleeping for a couple of seconds…")
                >>= fun () -> System.sleep 4.
                (* USB thing is often slower than humans hitting `q` *))
            >>= fun (_ : unit option) ->
            Tezos_client.Keyed.bake
              state
              winner_baker_0
              "First bake on new protocol !!"
            >>= fun () ->
            Counter_log.incr level_counter "baker-0-bakes-on-new-protocol" ;
            Tezos_client.Keyed.bake
              state
              winner_special_baker
              "Second bake on new protocol !!"
            >>= fun () ->
            Counter_log.incr
              level_counter
              "special-baker-bakes-on-new-protocol" ;
            Tezos_client.rpc
              state
              ~client:winner_client
              `Get
              ~path:"/chains/main/blocks/head/metadata"
            >>= fun json_metadata ->
            match Jqo.field json_metadata ~k:"protocol" with
            | `String p when p = winner_hash ->
                return ()
            | other ->
                failf
                  "Protocol is not `%s` but `%s`"
                  winner_hash
                  Ezjsonm.(to_string (wrap other)) ))
  >>= fun () ->
  Interactive_test.Pauser.generic
    state
    EF.
      [ haf "End of the Voting test: SUCCESS \\o/";
        desc
          (af "Estimated level: %d" (Counter_log.sum level_counter))
          (markdown_verbatim (Counter_log.to_table_string level_counter)) ]
  >>= fun () -> return ()

let cmd ~pp_error () =
  let open Cmdliner in
  let open Term in
  Test_command_line.Run_command.make
    ~pp_error
    ( pure
        (fun winner_path
             demo_path
             node_exec
             client_exec
             admin_exec
             winner_client_exec
             size
             (`Clueless_winner clueless_winner)
             (`Base_port base_port)
             (`With_ledger with_ledger)
             (`Serialize_proposals serialize_proposals)
             protocol
             state
             ->
          ( state,
            Interactive_test.Pauser.run_test
              state
              ~pp_error
              (run
                 state
                 ~serialize_proposals
                 ~winner_path
                 ~clueless_winner
                 ~demo_path
                 ~node_exec
                 ~size
                 ~admin_exec
                 ~base_port
                 ~client_exec
                 ~winner_client_exec
                 ~protocol
                 ?with_ledger) ))
    $ Arg.(
        pure Filename.dirname
        $ required
            (pos
               0
               (some string)
               None
               (info
                  []
                  ~docv:"WINNER-PROTOCOL-PATH"
                  ~doc:
                    "The protocol to inject and make win the election, e.g. \
                     `src/proto_004_Pt24m4xi/lib_protocol/src/TEZOS_PROTOCOL`.")))
    $ Arg.(
        pure Filename.dirname
        $ required
            (pos
               1
               (some string)
               None
               (info
                  []
                  ~docv:"LOSER-PROTOCOL-PATH"
                  ~doc:
                    "The protocol to inject and down-vote, e.g. \
                     `./src/bin_client/test/proto_test_injection/TEZOS_PROTOCOL` \
                     (if same as `WINNER-PROTOCOL-PATH` the scenario will \
                     make them automatically & artificially different).")))
    $ Tezos_executable.cli_term `Node "current"
    $ Tezos_executable.cli_term `Client "current"
    $ Tezos_executable.cli_term `Admin "current"
    $ Tezos_executable.cli_term `Client "winner"
    $ Arg.(value (opt int 5 (info ["size"; "S"] ~doc:"Size of the Network.")))
    $ Arg.(
        pure (fun b -> `Clueless_winner b)
        $ value
            (flag
               (info
                  ["winning-client-is-clueless"]
                  ~doc:
                    "Do not fail if the client does not know about “next” \
                     protocol.")))
    (*
$ Arg.(
        pure (fun p -> `Hash p)
        $ value
            (opt
               (some string)
               None
               (info
                  ["current-hash"]
                  ~doc:"The hash to advertise as the current protocol.")))
 *)
    $ Arg.(
        pure (fun p -> `Base_port p)
        $ value
            (opt
               int
               46_000
               (info ["base-port"] ~doc:"Base port number to build upon.")))
    $ Arg.(
        pure (fun x -> `With_ledger x)
        $ value
            (opt
               (some string)
               None
               (info
                  ["with-ledger"]
                  ~docv:"ledger://..."
                  ~doc:
                    "Do the test with a Ledger Nano device as one of the \
                     bakers/voters.")))
    $ Arg.(
        pure (fun x -> `Serialize_proposals x)
        $ value
            (flag
               (info
                  ["serialize-proposals"]
                  ~doc:
                    "Run the proposals one-by-one instead of all together \
                     (preferred by the Ledger).")))
    $ Tezos_protocol.cli_term ()
    $ Test_command_line.cli_state ~name:"voting" () )
    (let doc = "Sandbox network with a full round of voting." in
     let man : Manpage.block list =
       [ `S "VOTING TEST";
         `P
           "This command provides a test which uses a network sandbox to \
            perform a full round of protocol vote and upgrade, including \
            voting and baking on the test chain with or without a Ledger Nano \
            device.";
         `P "There are two main test behaviors:";
         `P
           "* $(b,SIMPLE:) The simple one does as much as possible with any \
            dummy protocol candidates and a Tezos code-base which doesn't \
            handle them: it tests all the voting periods until baking the \
            last block of the currently understood protocol.";
         `Noblank;
         `P
           "To allow the test to succeed in this case, the option \
            `--winning-client-is-clueless` is required; it is meant to signal \
            that the “winner” `tezos-client` executable (from the \
            `--winner-client-binary` option) is expected to not understand \
            the winning protocol.";
         `Noblank;
         `P
           "This is the version running in Gitlab-CI, see `bin_flextesa/dune`.";
         `P
           "* $(b,FULL:) Without the `--winning-client-is-clueless` option, \
            the test will try to bake on the test chain as well as after the \
            protocol switch (with the winner-client). This requires the \
            winning protocol to be a working one and, of course, the \
            winning-client to understand it.";
         `P
           "The test can run fully automated unless one uses the \
            `\"--with-ledger=ledger://...\"` option in which case some steps \
            have to be interactive. In this case, the option \
            `--serialize-proposals` is recommended, because if it is not \
            provided, the proposal vote will be a “Sign Unverfied” \
            operation." ]
     in
     info ~doc ~man "voting")
src/bin_sandbox/command_voting.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Counter_log.

End Counter_log.

Definition ledger_prompt_notice {A B C : Type} (state : A) (ef : B) : C :=
  op_startypeminuserrorstar state op_startypeminuserrorstar.

Definition setup_baking_ledger {A B C D : Type}
  (state : A) (uri : B) (client : C) : D :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state op_startypeminuserrorstar true)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let key_name := "ledgered" % string in
      let baker := op_startypeminuserrorstar client key_name uri in
      op_startypeminuserrorstar
        (ledger_prompt_notice state op_startypeminuserrorstar)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar (op_startypeminuserrorstar state baker)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_startypeminuserrorstar
                (ledger_prompt_notice state op_startypeminuserrorstar)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar state client
                      (cons "setup" % string
                        (cons "ledger" % string
                          (cons "to" % string
                            (cons "bake" % string
                              (cons "for" % string
                                (cons key_name
                                  (cons "--main-hwm" % string
                                    (cons "0" % string
                                      (cons "--test-hwm" % string
                                        (cons "0" % string [])))))))))))
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_startypeminuserrorstar baker))))).

Definition failf {A B : Type} (fmt : A) : B :=
  op_startypeminuserrorstar
    (fun s =>
      op_startypeminuserrorstar
        (* ❌ Variants not supported *)
        variant) fmt.

Definition transfer {A B C D : Type}
  (state : A) (client : B) (src : string) (dst : string) (amount : C) : D :=
  op_startypeminuserrorstar state client
    (cons "--wait" % string
      (cons "none" % string
        (cons "transfer" % string
          (cons (op_startypeminuserrorstar "%Ld" % string amount)
            (cons "from" % string
              (cons src
                (cons "to" % string
                  (cons dst
                    (cons "--fee" % string
                      (cons "0.05" % string
                        (cons "--burn-cap" % string (cons "0.3" % string [])))))))))))).

Definition register {A B C : Type} (state : A) (client : B) (dst : string)
  : C :=
  op_startypeminuserrorstar state client
    (cons "--wait" % string
      (cons "none" % string
        (cons "register" % string
          (cons "key" % string
            (cons dst
              (cons "as" % string
                (cons "delegate" % string
                  (cons "--fee" % string (cons "0.05" % string []))))))))).

Definition bake_until_voting_period {A B C D E F : Type}
  (keep_alive_delegate : option A) (state : B) (baker : C) (attempts : D)
  (period : E) : F :=
  let client := Tezos_client.Keyed.client baker in
  let period_name := op_startypeminuserrorstar period in
  op_startypeminuserrorstar state attempts
    (* ❌ Float constant 0.5 is approximated by the integer 0 *)
    0
    (fun nth =>
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state client
          (* ❌ Variants not supported *)
          variant "/chains/main/blocks/head/votes/current_period_kind" % string)
        (fun function_parameter =>
          match function_parameter with
          | String p =>
            op_startypeminuserrorstar
              (* ❌ Variants not supported *)
              variant
          | _ =>
            op_startypeminuserrorstar
              (op_startypeminuserrorstar keep_alive_delegate
                (fun dst => register state client dst))
              (fun function_parameter =>
                let '_ := function_parameter in
                op_startypeminuserrorstar
                  (op_startypeminuserrorstar
                    (op_startypeminuserrorstar state baker)
                    "Baker %s bakes %d/%d waiting for %S voting period" % string
                    (id client) nth attempts period_name)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_startypeminuserrorstar
                      (* ❌ Variants not supported *)
                      variant))
          end)).

Definition check_understood_protocols {A B C D : Type}
  (state : A) (chain : string) (client : B) (protocol_hash : C)
  (expect_clueless_client : bool) : D :=
  op_startypeminuserrorstar
    (op_startypeminuserrorstar state client
      (cons "--chain" % string
        (cons chain
          (cons "list" % string
            (cons "understood" % string (cons "protocols" % string []))))))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok client_protocols_result =>
        match
          Stdlib.List.find
            (* ❌ Sending method message is not handled *)
            send
            (* ❌ expected an argument *)
            expected_argument
            (fun prefix => op_startypeminuserrorstar protocol_hash prefix) with
        | _ =>
          op_startypeminuserrorstar
            (* ❌ Variants not supported *)
            variant
        | _ =>
          op_startypeminuserrorstar
            (* ❌ Variants not supported *)
            variant
        | _ =>
          op_startypeminuserrorstar
            (* ❌ Variants not supported *)
            variant
        end
      | Stdlib.Error (Client_command_error _) =>
        op_startypeminuserrorstar
          (* ❌ Variants not supported *)
          variant
      | Stdlib.Error e => op_startypeminuserrorstar e
      end).

Definition run {A B C D E F G : Type}
  (state : A) (winner_path : string) (demo_path : string) (protocol : B)
  (node_exec : C) (client_exec : C) (clueless_winner : bool) (admin_exec : C)
  (winner_client_exec : C) (size : D) (base_port : E)
  (serialize_proposals : bool) (with_ledger : option F)
  (function_parameter : unit) : G :=
  let 'tt := function_parameter in
  let default_attempts := 50 in
  op_startypeminuserrorstar (op_startypeminuserrorstar state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar state
          (* ❌ Variants not supported *)
          variant
          (cons node_exec
            (cons client_exec (cons admin_exec (cons winner_client_exec []))))
          (cons winner_path (cons demo_path [])))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar state op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              let '(protocol, baker_0_account, baker_0_balance) :=
                op_startypeminuserrorstar in
              op_startypeminuserrorstar
                (op_startypeminuserrorstar protocol size base_port state
                  node_exec client_exec)
                (fun function_parameter =>
                  let '(nodes, protocol) := function_parameter in
                  let make_admin := op_startypeminuserrorstar admin_exec in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    op_startypeminuserrorstar state op_startypeminuserrorstar in
                  op_startypeminuserrorstar
                    (op_startypeminuserrorstar state op_startypeminuserrorstar)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let client {H I : Type} (n : H) : I :=
                        op_startypeminuserrorstar client_exec
                          (op_startypeminuserrorstar nodes n) in
                      let baker_0 :=
                        op_startypeminuserrorstar (client 0) "baker-0" % string
                          (op_startypeminuserrorstar baker_0_account) in
                      op_startypeminuserrorstar
                        (op_startypeminuserrorstar state baker_0)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          let level_counter := op_startypeminuserrorstar tt in
                          let first_bakes := 5 in
                          op_startypeminuserrorstar
                            (op_startypeminuserrorstar first_bakes
                              (fun nth =>
                                op_startypeminuserrorstar
                                  (op_startypeminuserrorstar state baker_0)
                                  "initial-bake %d" % string nth))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              let initial_level := Z.add first_bakes 1 in
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                op_startypeminuserrorstar level_counter
                                  "initial_level" % string initial_level in
                              op_startypeminuserrorstar
                                match with_ledger with
                                | None =>
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state
                                      op_startypeminuserrorstar)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      let account :=
                                        op_startypeminuserrorstar
                                          "special-baker" % string in
                                      let baker :=
                                        op_startypeminuserrorstar (client 0)
                                          (op_startypeminuserrorstar account)
                                          (op_startypeminuserrorstar account) in
                                      op_startypeminuserrorstar
                                        (op_startypeminuserrorstar state baker)
                                        (fun function_parameter =>
                                          let '_ := function_parameter in
                                          op_startypeminuserrorstar baker))
                                | Some uri =>
                                  setup_baking_ledger state uri (client 0)
                                end
                                (fun special_baker =>
                                  let winner_client := op_startypeminuserrorstar
                                    in
                                  let winner_baker_0 :=
                                    op_startypeminuserrorstar in
                                  let winner_special_baker :=
                                    op_startypeminuserrorstar in
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    op_startypeminuserrorstar state
                                      op_startypeminuserrorstar in
                                  op_startypeminuserrorstar
                                    (op_startypeminuserrorstar state
                                      op_startypeminuserrorstar)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        op_startypeminuserrorstar state
                                          op_startypeminuserrorstar in
                                      op_startypeminuserrorstar
                                        (transfer state (client 0)
                                          "baker-0" % string
                                          (Tezos_client.Keyed.key_name
                                            special_baker)
                                          (Int64.div baker_0_balance
                                            (* ❌ Constant of type int64 is converted to int *)
                                            2000000))
                                        (fun res =>
                                          op_startypeminuserrorstar
                                            (op_startypeminuserrorstar state
                                              op_startypeminuserrorstar)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              let after_transfer_bakes := 2 in
                                              op_startypeminuserrorstar
                                                (op_startypeminuserrorstar
                                                  after_transfer_bakes
                                                  (fun nth =>
                                                    op_startypeminuserrorstar
                                                      (op_startypeminuserrorstar
                                                        state baker_0)
                                                      "after-transfer-bake %d" %
                                                        string nth))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                  let _ :=
                                                    op_startypeminuserrorstar
                                                      level_counter
                                                      "after-transfer-bakes" %
                                                        string
                                                      after_transfer_bakes in
                                                  op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      state default_attempts
                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                      8 nodes
                                                      (* ❌ Variants not supported *)
                                                      variant)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (op_startypeminuserrorstar
                                                          with_ledger
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let '_ :=
                                                              function_parameter
                                                              in
                                                            ledger_prompt_notice
                                                              state
                                                              op_startypeminuserrorstar))
                                                        (fun function_parameter
                                                          =>
                                                          let '_ :=
                                                            function_parameter
                                                            in
                                                          op_startypeminuserrorstar
                                                            (op_startypeminuserrorstar
                                                              state (client 0)
                                                              (cons
                                                                "--wait" %
                                                                  string
                                                                (cons
                                                                  "none" %
                                                                    string
                                                                  (cons
                                                                    "register" %
                                                                      string
                                                                    (cons
                                                                      "key" %
                                                                        string
                                                                      (cons
                                                                        (Tezos_client.Keyed.key_name
                                                                          special_baker)
                                                                        (cons
                                                                          "as" %
                                                                            string
                                                                          (cons
                                                                            "delegate"
                                                                              %
                                                                              string
                                                                            (cons
                                                                              "--fee"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                "0.5"
                                                                                  %
                                                                                  string
                                                                                []))))))))))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let '_ :=
                                                                function_parameter
                                                                in
                                                              let
                                                                activation_bakes :=
                                                                op_startypeminuserrorstar
                                                                in
                                                              op_startypeminuserrorstar
                                                                (op_startypeminuserrorstar
                                                                  activation_bakes
                                                                  (fun nth =>
                                                                    op_startypeminuserrorstar
                                                                      (op_startypeminuserrorstar
                                                                        (op_startypeminuserrorstar
                                                                          state
                                                                          baker_0)
                                                                        "Baking after new delegate registered: %d/%d"
                                                                          %
                                                                          string
                                                                        nth
                                                                        activation_bakes)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        let
                                                                          'tt :=
                                                                          function_parameter
                                                                          in
                                                                        op_startypeminuserrorstar
                                                                          (op_startypeminuserrorstar
                                                                            state
                                                                            (client
                                                                              0)
                                                                            (cons
                                                                              "rpc"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                "get"
                                                                                  %
                                                                                  string
                                                                                (cons
                                                                                  "/chains/main/blocks/head/helpers/baking_rights"
                                                                                    %
                                                                                    string
                                                                                  []))))
                                                                          (fun
                                                                            res
                                                                            =>
                                                                            op_startypeminuserrorstar
                                                                              state
                                                                              op_startypeminuserrorstar))))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    op_startypeminuserrorstar
                                                                      level_counter
                                                                      "activation-bakes"
                                                                        % string
                                                                      activation_bakes
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    (op_startypeminuserrorstar
                                                                      state
                                                                      special_baker
                                                                      "Baked by Special Baker™"
                                                                        % string)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                      let _ :=
                                                                        op_startypeminuserrorstar
                                                                          level_counter
                                                                          "special-baker-first-bake"
                                                                            %
                                                                            string
                                                                        in
                                                                      let
                                                                        attempts :=
                                                                        op_startypeminuserrorstar
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (bake_until_voting_period
                                                                          (Some
                                                                            (key_name
                                                                              baker_0))
                                                                          state
                                                                          special_baker
                                                                          attempts
                                                                          (* ❌ Variants not supported *)
                                                                          variant)
                                                                        (fun
                                                                          extra_bakes_waiting_for_proposal_period
                                                                          =>
                                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                          let _
                                                                            :=
                                                                            op_startypeminuserrorstar
                                                                              level_counter
                                                                              "wait-for-proposal-period"
                                                                                %
                                                                                string
                                                                              extra_bakes_waiting_for_proposal_period
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (op_startypeminuserrorstar
                                                                              state
                                                                              default_attempts
                                                                              (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                              8
                                                                              nodes
                                                                              (* ❌ Variants not supported *)
                                                                              variant)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              let
                                                                                admin_0 :=
                                                                                op_startypeminuserrorstar
                                                                                  admin_exec
                                                                                  (client
                                                                                    0)
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                (op_startypeminuserrorstar
                                                                                  admin_0
                                                                                  state
                                                                                  (cons
                                                                                    "list"
                                                                                      %
                                                                                      string
                                                                                    (cons
                                                                                      "protocols"
                                                                                        %
                                                                                        string
                                                                                      [])))
                                                                                (fun
                                                                                  res
                                                                                  =>
                                                                                  let
                                                                                    default_protocols :=
                                                                                    (* ❌ Sending method message is not handled *)
                                                                                    send
                                                                                    in
                                                                                  let
                                                                                    make_and_inject_protocol
                                                                                    {H
                                                                                    I
                                                                                    :
                                                                                    Type}
                                                                                    (op_staroptstar
                                                                                    :
                                                                                    option
                                                                                      bool)
                                                                                    : H
                                                                                      ->
                                                                                      string
                                                                                        ->
                                                                                        I :=
                                                                                    let
                                                                                      make_different :=
                                                                                      match
                                                                                        op_staroptstar
                                                                                        with
                                                                                      |
                                                                                        Some
                                                                                          op_starsthstar
                                                                                        =>
                                                                                        op_starsthstar
                                                                                      |
                                                                                        None
                                                                                        =>
                                                                                        false
                                                                                      end
                                                                                      in
                                                                                    fun
                                                                                      name
                                                                                      =>
                                                                                      fun
                                                                                        path
                                                                                        =>
                                                                                        let
                                                                                          tmpdir :=
                                                                                          op_startypeminuserrorstar
                                                                                            (op_startypeminuserrorstar
                                                                                              state)
                                                                                            (op_startypeminuserrorstar
                                                                                              "protocol-%s"
                                                                                                %
                                                                                                string
                                                                                              name)
                                                                                          in
                                                                                        op_startypeminuserrorstar
                                                                                          (op_startypeminuserrorstar
                                                                                            state
                                                                                            op_startypeminuserrorstar)
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              'tt :=
                                                                                              function_parameter
                                                                                              in
                                                                                            op_startypeminuserrorstar
                                                                                              (op_startypeminuserrorstar
                                                                                                state
                                                                                                "cp -L -R %s %s"
                                                                                                  %
                                                                                                  string
                                                                                                (Filename.quote
                                                                                                  path)
                                                                                                (Filename.quote
                                                                                                  tmpdir))
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                let
                                                                                                  '_ :=
                                                                                                  function_parameter
                                                                                                  in
                                                                                                op_startypeminuserrorstar
                                                                                                  (if
                                                                                                    make_different
                                                                                                    then
                                                                                                    op_startypeminuserrorstar
                                                                                                      (op_startypeminuserrorstar
                                                                                                        state
                                                                                                        "echo '(* Protocol %s *)' >> %s/main.mli"
                                                                                                          %
                                                                                                          string
                                                                                                        name
                                                                                                        (Filename.quote
                                                                                                          tmpdir))
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        let
                                                                                                          '_ :=
                                                                                                          function_parameter
                                                                                                          in
                                                                                                        op_startypeminuserrorstar
                                                                                                          tt)
                                                                                                  else
                                                                                                    op_startypeminuserrorstar
                                                                                                      tt)
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    let
                                                                                                      'tt :=
                                                                                                      function_parameter
                                                                                                      in
                                                                                                    op_startypeminuserrorstar
                                                                                                      (op_startypeminuserrorstar
                                                                                                        admin_0
                                                                                                        state
                                                                                                        tmpdir)
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        let
                                                                                                          '(res,
                                                                                                            hash) :=
                                                                                                          function_parameter
                                                                                                          in
                                                                                                        op_startypeminuserrorstar
                                                                                                          (op_startypeminuserrorstar
                                                                                                            state
                                                                                                            op_startypeminuserrorstar)
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            let
                                                                                                              'tt :=
                                                                                                              function_parameter
                                                                                                              in
                                                                                                            op_startypeminuserrorstar
                                                                                                              hash)))))
                                                                                    in
                                                                                  op_startypeminuserrorstar
                                                                                    (make_and_inject_protocol
                                                                                      None
                                                                                      "winner"
                                                                                        %
                                                                                        string
                                                                                      winner_path)
                                                                                    (fun
                                                                                      winner_hash
                                                                                      =>
                                                                                      op_startypeminuserrorstar
                                                                                        (make_and_inject_protocol
                                                                                          (Some
                                                                                            (equiv_decb
                                                                                              winner_path
                                                                                              demo_path))
                                                                                          "demo"
                                                                                            %
                                                                                            string
                                                                                          demo_path)
                                                                                        (fun
                                                                                          demo_hash
                                                                                          =>
                                                                                          op_startypeminuserrorstar
                                                                                            (op_startypeminuserrorstar
                                                                                              admin_0
                                                                                              state
                                                                                              (cons
                                                                                                "list"
                                                                                                  %
                                                                                                  string
                                                                                                (cons
                                                                                                  "protocols"
                                                                                                    %
                                                                                                    string
                                                                                                  [])))
                                                                                            (fun
                                                                                              res
                                                                                              =>
                                                                                              let
                                                                                                after_injections_protocols :=
                                                                                                (* ❌ Sending method message is not handled *)
                                                                                                send
                                                                                                in
                                                                                              op_startypeminuserrorstar
                                                                                                (op_startypeminuserrorstar
                                                                                                  state
                                                                                                  op_startypeminuserrorstar)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  op_startypeminuserrorstar
                                                                                                    (op_startypeminuserrorstar
                                                                                                      with_ledger
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        let
                                                                                                          '_ :=
                                                                                                          function_parameter
                                                                                                          in
                                                                                                        op_startypeminuserrorstar
                                                                                                          state
                                                                                                          op_startypeminuserrorstar
                                                                                                          true))
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        '_ :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      let
                                                                                                        submit_proposals
                                                                                                        {H
                                                                                                        I
                                                                                                        :
                                                                                                        Type}
                                                                                                        (baker
                                                                                                        :
                                                                                                        H)
                                                                                                        (props
                                                                                                        :
                                                                                                        list
                                                                                                          string)
                                                                                                        : I :=
                                                                                                        op_startypeminuserrorstar
                                                                                                          (op_startypeminuserrorstar
                                                                                                            with_ledger
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                '_ :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              ledger_prompt_notice
                                                                                                                state
                                                                                                                op_startypeminuserrorstar))
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            let
                                                                                                              '_ :=
                                                                                                              function_parameter
                                                                                                              in
                                                                                                            op_startypeminuserrorstar
                                                                                                              (op_startypeminuserrorstar
                                                                                                                state
                                                                                                                (Tezos_client.Keyed.client
                                                                                                                  baker)
                                                                                                                (OCaml.Stdlib.app
                                                                                                                  (cons
                                                                                                                    "submit"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    (cons
                                                                                                                      "proposals"
                                                                                                                        %
                                                                                                                        string
                                                                                                                      (cons
                                                                                                                        "for"
                                                                                                                          %
                                                                                                                          string
                                                                                                                        (cons
                                                                                                                          (key_name
                                                                                                                            baker)
                                                                                                                          []))))
                                                                                                                  props))
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                let
                                                                                                                  '_ :=
                                                                                                                  function_parameter
                                                                                                                  in
                                                                                                                op_startypeminuserrorstar
                                                                                                                  tt))
                                                                                                        in
                                                                                                      let
                                                                                                        to_submit_first :=
                                                                                                        cons
                                                                                                          winner_hash
                                                                                                          (cons
                                                                                                            demo_hash
                                                                                                            [])
                                                                                                        in
                                                                                                      op_startypeminuserrorstar
                                                                                                        match
                                                                                                          serialize_proposals
                                                                                                          with
                                                                                                        |
                                                                                                          false
                                                                                                          =>
                                                                                                          submit_proposals
                                                                                                            special_baker
                                                                                                            to_submit_first
                                                                                                        |
                                                                                                          true
                                                                                                          =>
                                                                                                          op_startypeminuserrorstar
                                                                                                            to_submit_first
                                                                                                            (fun
                                                                                                              one
                                                                                                              =>
                                                                                                              submit_proposals
                                                                                                                special_baker
                                                                                                                (cons
                                                                                                                  one
                                                                                                                  []))
                                                                                                        end
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_startypeminuserrorstar
                                                                                                            (op_startypeminuserrorstar
                                                                                                              state
                                                                                                              (client
                                                                                                                baker_0)
                                                                                                              (cons
                                                                                                                "submit"
                                                                                                                  %
                                                                                                                  string
                                                                                                                (cons
                                                                                                                  "proposals"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (cons
                                                                                                                    "for"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    (cons
                                                                                                                      (key_name
                                                                                                                        baker_0)
                                                                                                                      (cons
                                                                                                                        winner_hash
                                                                                                                        []))))))
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                '_ :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_startypeminuserrorstar
                                                                                                                (bake_until_voting_period
                                                                                                                  (Some
                                                                                                                    (key_name
                                                                                                                      special_baker))
                                                                                                                  state
                                                                                                                  baker_0
                                                                                                                  (blocks_per_voting_period
                                                                                                                    protocol)
                                                                                                                  (* ❌ Variants not supported *)
                                                                                                                  variant)
                                                                                                                (fun
                                                                                                                  extra_bakes_waiting_for_testing_vote_period
                                                                                                                  =>
                                                                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                  let
                                                                                                                    _
                                                                                                                    :=
                                                                                                                    op_startypeminuserrorstar
                                                                                                                      level_counter
                                                                                                                      "wait-for-testing-vote-period"
                                                                                                                        %
                                                                                                                        string
                                                                                                                      extra_bakes_waiting_for_testing_vote_period
                                                                                                                    in
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    (op_startypeminuserrorstar
                                                                                                                      state
                                                                                                                      default_attempts
                                                                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                      8
                                                                                                                      nodes
                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                      variant)
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        'tt :=
                                                                                                                        function_parameter
                                                                                                                        in
                                                                                                                      op_startypeminuserrorstar
                                                                                                                        (op_startypeminuserrorstar
                                                                                                                          state
                                                                                                                          default_attempts
                                                                                                                          (* ❌ Float constant 2. is approximated by the integer 2 *)
                                                                                                                          2
                                                                                                                          (fun
                                                                                                                            function_parameter
                                                                                                                            =>
                                                                                                                            let
                                                                                                                              '_ :=
                                                                                                                              function_parameter
                                                                                                                              in
                                                                                                                            op_startypeminuserrorstar
                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                state
                                                                                                                                (client
                                                                                                                                  1)
                                                                                                                                (* ❌ Variants not supported *)
                                                                                                                                variant
                                                                                                                                "/chains/main/blocks/head/votes/current_proposal"
                                                                                                                                  %
                                                                                                                                  string)
                                                                                                                              (fun
                                                                                                                                current_proposal_json
                                                                                                                                =>
                                                                                                                                if
                                                                                                                                  nequiv_decb
                                                                                                                                    current_proposal_json
                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                    variant
                                                                                                                                  then
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                    variant
                                                                                                                                else
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (* ❌ Variants not supported *)
                                                                                                                                    variant)))
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          let
                                                                                                                            'tt :=
                                                                                                                            function_parameter
                                                                                                                            in
                                                                                                                          op_startypeminuserrorstar
                                                                                                                            (op_startypeminuserrorstar
                                                                                                                              state
                                                                                                                              (client
                                                                                                                                baker_0)
                                                                                                                              (cons
                                                                                                                                "submit"
                                                                                                                                  %
                                                                                                                                  string
                                                                                                                                (cons
                                                                                                                                  "ballot"
                                                                                                                                    %
                                                                                                                                    string
                                                                                                                                  (cons
                                                                                                                                    "for"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    (cons
                                                                                                                                      (key_name
                                                                                                                                        baker_0)
                                                                                                                                      (cons
                                                                                                                                        winner_hash
                                                                                                                                        (cons
                                                                                                                                          "yay"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          [])))))))
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              let
                                                                                                                                '_ :=
                                                                                                                                function_parameter
                                                                                                                                in
                                                                                                                              op_startypeminuserrorstar
                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                  with_ledger
                                                                                                                                  (fun
                                                                                                                                    function_parameter
                                                                                                                                    =>
                                                                                                                                    let
                                                                                                                                      '_ :=
                                                                                                                                      function_parameter
                                                                                                                                      in
                                                                                                                                    ledger_prompt_notice
                                                                                                                                      state
                                                                                                                                      op_startypeminuserrorstar))
                                                                                                                                (fun
                                                                                                                                  function_parameter
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    '_ :=
                                                                                                                                    function_parameter
                                                                                                                                    in
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                      state
                                                                                                                                      (client
                                                                                                                                        special_baker)
                                                                                                                                      (cons
                                                                                                                                        "submit"
                                                                                                                                          %
                                                                                                                                          string
                                                                                                                                        (cons
                                                                                                                                          "ballot"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          (cons
                                                                                                                                            "for"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            (cons
                                                                                                                                              (key_name
                                                                                                                                                special_baker)
                                                                                                                                              (cons
                                                                                                                                                winner_hash
                                                                                                                                                (cons
                                                                                                                                                  "yay"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  [])))))))
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      let
                                                                                                                                        '_ :=
                                                                                                                                        function_parameter
                                                                                                                                        in
                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                          state
                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          let
                                                                                                                                            'tt :=
                                                                                                                                            function_parameter
                                                                                                                                            in
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                            (bake_until_voting_period
                                                                                                                                              (Some
                                                                                                                                                (key_name
                                                                                                                                                  special_baker))
                                                                                                                                              state
                                                                                                                                              baker_0
                                                                                                                                              (Z.add
                                                                                                                                                1
                                                                                                                                                (blocks_per_voting_period
                                                                                                                                                  protocol))
                                                                                                                                              (* ❌ Variants not supported *)
                                                                                                                                              variant)
                                                                                                                                            (fun
                                                                                                                                              extra_bakes_waiting_for_testing_period
                                                                                                                                              =>
                                                                                                                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                                              let
                                                                                                                                                _
                                                                                                                                                :=
                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                  level_counter
                                                                                                                                                  "wait-for-testing-period"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  extra_bakes_waiting_for_testing_period
                                                                                                                                                in
                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                  state
                                                                                                                                                  default_attempts
                                                                                                                                                  (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                                                  8
                                                                                                                                                  nodes
                                                                                                                                                  (* ❌ Variants not supported *)
                                                                                                                                                  variant)
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  let
                                                                                                                                                    'tt :=
                                                                                                                                                    function_parameter
                                                                                                                                                    in
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                      (check_understood_protocols
                                                                                                                                                        state
                                                                                                                                                        "main"
                                                                                                                                                          %
                                                                                                                                                          string
                                                                                                                                                        winner_client
                                                                                                                                                        winner_hash
                                                                                                                                                        clueless_winner)
                                                                                                                                                      (fun
                                                                                                                                                        function_parameter
                                                                                                                                                        =>
                                                                                                                                                        match
                                                                                                                                                          function_parameter
                                                                                                                                                          with
                                                                                                                                                        |
                                                                                                                                                          Proper_understanding
                                                                                                                                                          =>
                                                                                                                                                          let
                                                                                                                                                            chain :=
                                                                                                                                                            "test"
                                                                                                                                                              %
                                                                                                                                                              string
                                                                                                                                                            in
                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                              with_ledger
                                                                                                                                                              (fun
                                                                                                                                                                function_parameter
                                                                                                                                                                =>
                                                                                                                                                                let
                                                                                                                                                                  '_ :=
                                                                                                                                                                  function_parameter
                                                                                                                                                                  in
                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                  state
                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                  true))
                                                                                                                                                            (fun
                                                                                                                                                              function_parameter
                                                                                                                                                              =>
                                                                                                                                                              let
                                                                                                                                                                '_ :=
                                                                                                                                                                function_parameter
                                                                                                                                                                in
                                                                                                                                                              let
                                                                                                                                                                testing_bakes :=
                                                                                                                                                                5
                                                                                                                                                                in
                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                  testing_bakes
                                                                                                                                                                  (fun
                                                                                                                                                                    ith
                                                                                                                                                                    =>
                                                                                                                                                                    let
                                                                                                                                                                      baker :=
                                                                                                                                                                      if
                                                                                                                                                                        equiv_decb
                                                                                                                                                                          (Z.modulo
                                                                                                                                                                            ith
                                                                                                                                                                            2)
                                                                                                                                                                          0
                                                                                                                                                                        then
                                                                                                                                                                        winner_baker_0
                                                                                                                                                                      else
                                                                                                                                                                        winner_special_baker
                                                                                                                                                                      in
                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                      chain
                                                                                                                                                                      state
                                                                                                                                                                      baker
                                                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                                                        "Baking on the test chain [%d/%d]"
                                                                                                                                                                          %
                                                                                                                                                                          string
                                                                                                                                                                        (Z.add
                                                                                                                                                                          ith
                                                                                                                                                                          1)
                                                                                                                                                                        testing_bakes)))
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  let
                                                                                                                                                                    'tt :=
                                                                                                                                                                    function_parameter
                                                                                                                                                                    in
                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                      state
                                                                                                                                                                      chain
                                                                                                                                                                      default_attempts
                                                                                                                                                                      (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                                                                      8
                                                                                                                                                                      nodes
                                                                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                                                                      variant)
                                                                                                                                                                    (fun
                                                                                                                                                                      function_parameter
                                                                                                                                                                      =>
                                                                                                                                                                      let
                                                                                                                                                                        'tt :=
                                                                                                                                                                        function_parameter
                                                                                                                                                                        in
                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                          state
                                                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                                                        (fun
                                                                                                                                                                          function_parameter
                                                                                                                                                                          =>
                                                                                                                                                                          let
                                                                                                                                                                            'tt :=
                                                                                                                                                                            function_parameter
                                                                                                                                                                            in
                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                            tt))))
                                                                                                                                                        |
                                                                                                                                                          Expected_misunderstanding
                                                                                                                                                          =>
                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                            state
                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                        |
                                                                                                                                                          Failure_to_understand
                                                                                                                                                          =>
                                                                                                                                                          failf
                                                                                                                                                            "Winner-Client cannot bake on test chain!"
                                                                                                                                                              %
                                                                                                                                                              string
                                                                                                                                                        end))
                                                                                                                                                    (fun
                                                                                                                                                      function_parameter
                                                                                                                                                      =>
                                                                                                                                                      let
                                                                                                                                                        'tt :=
                                                                                                                                                        function_parameter
                                                                                                                                                        in
                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                          state
                                                                                                                                                          default_attempts
                                                                                                                                                          (* ❌ Float constant 0.3 is approximated by the integer 0 *)
                                                                                                                                                          0
                                                                                                                                                          (fun
                                                                                                                                                            function_parameter
                                                                                                                                                            =>
                                                                                                                                                            let
                                                                                                                                                              '_ :=
                                                                                                                                                              function_parameter
                                                                                                                                                              in
                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                                                state
                                                                                                                                                                (client
                                                                                                                                                                  1)
                                                                                                                                                                (* ❌ Variants not supported *)
                                                                                                                                                                variant
                                                                                                                                                                "/chains/main/blocks/head/metadata"
                                                                                                                                                                  %
                                                                                                                                                                  string)
                                                                                                                                                              (fun
                                                                                                                                                                metadata_json
                                                                                                                                                                =>
                                                                                                                                                                (* ❌ Try-with are not handled *)
                                                                                                                                                                try
                                                                                                                                                                  match
                                                                                                                                                                    OCaml.Stdlib.reverse_apply
                                                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                                                        metadata_json
                                                                                                                                                                        "test_chain_status"
                                                                                                                                                                          %
                                                                                                                                                                          string)
                                                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                                                        "protocol"
                                                                                                                                                                          %
                                                                                                                                                                          string)
                                                                                                                                                                    with
                                                                                                                                                                  |
                                                                                                                                                                    String
                                                                                                                                                                      s
                                                                                                                                                                    =>
                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                                                                      variant
                                                                                                                                                                  |
                                                                                                                                                                    other
                                                                                                                                                                    =>
                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                                                                      variant
                                                                                                                                                                  end)))
                                                                                                                                                        (fun
                                                                                                                                                          function_parameter
                                                                                                                                                          =>
                                                                                                                                                          let
                                                                                                                                                            'tt :=
                                                                                                                                                            function_parameter
                                                                                                                                                            in
                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                            (bake_until_voting_period
                                                                                                                                                              (Some
                                                                                                                                                                (key_name
                                                                                                                                                                  special_baker))
                                                                                                                                                              state
                                                                                                                                                              baker_0
                                                                                                                                                              (Z.add
                                                                                                                                                                1
                                                                                                                                                                (blocks_per_voting_period
                                                                                                                                                                  protocol))
                                                                                                                                                              (* ❌ Variants not supported *)
                                                                                                                                                              variant)
                                                                                                                                                            (fun
                                                                                                                                                              extra_bakes_waiting_for_promotion_period
                                                                                                                                                              =>
                                                                                                                                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                                                              let
                                                                                                                                                                _
                                                                                                                                                                :=
                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                  level_counter
                                                                                                                                                                  "wait-for-promotion-period"
                                                                                                                                                                    %
                                                                                                                                                                    string
                                                                                                                                                                  extra_bakes_waiting_for_promotion_period
                                                                                                                                                                in
                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                  state
                                                                                                                                                                  default_attempts
                                                                                                                                                                  (* ❌ Float constant 8. is approximated by the integer 8 *)
                                                                                                                                                                  8
                                                                                                                                                                  nodes
                                                                                                                                                                  (* ❌ Variants not supported *)
                                                                                                                                                                  variant)
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  let
                                                                                                                                                                    'tt :=
                                                                                                                                                                    function_parameter
                                                                                                                                                                    in
                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                      state
                                                                                                                                                                      op_startypeminuserrorstar)
                                                                                                                                                                    (fun
                                                                                                                                                                      function_parameter
                                                                                                                                                                      =>
                                                                                                                                                                      let
                                                                                                                                                                        'tt :=
                                                                                                                                                                        function_parameter
                                                                                                                                                                        in
                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                          state
                                                                                                                                                                          (client
                                                                                                                                                                            baker_0)
                                                                                                                                                                          (cons
                                                                                                                                                                            "submit"
                                                                                                                                                                              %
                                                                                                                                                                              string
                                                                                                                                                                            (cons
                                                                                                                                                                              "ballot"
                                                                                                                                                                                %
                                                                                                                                                                                string
                                                                                                                                                                              (cons
                                                                                                                                                                                "for"
                                                                                                                                                                                  %
                                                                                                                                                                                  string
                                                                                                                                                                                (cons
                                                                                                                                                                                  (key_name
                                                                                                                                                                                    baker_0)
                                                                                                                                                                                  (cons
                                                                                                                                                                                    winner_hash
                                                                                                                                                                                    (cons
                                                                                                                                                                                      "yay"
                                                                                                                                                                                        %
                                                                                                                                                                                        string
                                                                                                                                                                                      [])))))))
                                                                                                                                                                        (fun
                                                                                                                                                                          function_parameter
                                                                                                                                                                          =>
                                                                                                                                                                          let
                                                                                                                                                                            '_ :=
                                                                                                                                                                            function_parameter
                                                                                                                                                                            in
                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                              with_ledger
                                                                                                                                                                              (fun
                                                                                                                                                                                function_parameter
                                                                                                                                                                                =>
                                                                                                                                                                                let
                                                                                                                                                                                  '_ :=
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  in
                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                  (op_startypeminuserrorstar
                                                                                                                                                                                    state
                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                    true)
                                                                                                                                                                                  (fun
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    =>
                                                                                                                                                                                    let
                                                                                                                                                                                      'tt :=
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      in
                                                                                                                                                                                    ledger_prompt_notice
                                                                                                                                                                                      state
                                                                                                                                                                                      op_startypeminuserrorstar)))
                                                                                                                                                                            (fun
                                                                                                                                                                              function_parameter
                                                                                                                                                                              =>
                                                                                                                                                                              let
                                                                                                                                                                                '_ :=
                                                                                                                                                                                function_parameter
                                                                                                                                                                                in
                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                  state
                                                                                                                                                                                  (client
                                                                                                                                                                                    special_baker)
                                                                                                                                                                                  (cons
                                                                                                                                                                                    "submit"
                                                                                                                                                                                      %
                                                                                                                                                                                      string
                                                                                                                                                                                    (cons
                                                                                                                                                                                      "ballot"
                                                                                                                                                                                        %
                                                                                                                                                                                        string
                                                                                                                                                                                      (cons
                                                                                                                                                                                        "for"
                                                                                                                                                                                          %
                                                                                                                                                                                          string
                                                                                                                                                                                        (cons
                                                                                                                                                                                          (key_name
                                                                                                                                                                                            special_baker)
                                                                                                                                                                                          (cons
                                                                                                                                                                                            winner_hash
                                                                                                                                                                                            (cons
                                                                                                                                                                                              "yay"
                                                                                                                                                                                                %
                                                                                                                                                                                                string
                                                                                                                                                                                              [])))))))
                                                                                                                                                                                (fun
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  =>
                                                                                                                                                                                  let
                                                                                                                                                                                    '_ :=
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    in
                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                      state
                                                                                                                                                                                      op_startypeminuserrorstar)
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      let
                                                                                                                                                                                        'tt :=
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        in
                                                                                                                                                                                      let
                                                                                                                                                                                        ballot_bakes :=
                                                                                                                                                                                        1
                                                                                                                                                                                        in
                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                          ballot_bakes
                                                                                                                                                                                          (fun
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            =>
                                                                                                                                                                                            let
                                                                                                                                                                                              '_ :=
                                                                                                                                                                                              function_parameter
                                                                                                                                                                                              in
                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                              state
                                                                                                                                                                                              baker_0
                                                                                                                                                                                              "Baking the promotion vote ballots"
                                                                                                                                                                                                %
                                                                                                                                                                                                string))
                                                                                                                                                                                        (fun
                                                                                                                                                                                          function_parameter
                                                                                                                                                                                          =>
                                                                                                                                                                                          let
                                                                                                                                                                                            'tt :=
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            in
                                                                                                                                                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                                                                                          let
                                                                                                                                                                                            _
                                                                                                                                                                                            :=
                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                              level_counter
                                                                                                                                                                                              "bake-the-ballots"
                                                                                                                                                                                                %
                                                                                                                                                                                                string
                                                                                                                                                                                              ballot_bakes
                                                                                                                                                                                            in
                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                              state
                                                                                                                                                                                              (client
                                                                                                                                                                                                0)
                                                                                                                                                                                              (cons
                                                                                                                                                                                                "list"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string
                                                                                                                                                                                                (cons
                                                                                                                                                                                                  "understood"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string
                                                                                                                                                                                                  (cons
                                                                                                                                                                                                    "protocols"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      string
                                                                                                                                                                                                    []))))
                                                                                                                                                                                            (fun
                                                                                                                                                                                              client_protocols_result
                                                                                                                                                                                              =>
                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                  state
                                                                                                                                                                                                  op_startypeminuserrorstar)
                                                                                                                                                                                                (fun
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  let
                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    in
                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                      state
                                                                                                                                                                                                      (* ❌ Float constant 0.5 is approximated by the integer 0 *)
                                                                                                                                                                                                      0
                                                                                                                                                                                                      (Z.add
                                                                                                                                                                                                        1
                                                                                                                                                                                                        (blocks_per_voting_period
                                                                                                                                                                                                          protocol))
                                                                                                                                                                                                      (fun
                                                                                                                                                                                                        nth
                                                                                                                                                                                                        =>
                                                                                                                                                                                                        let
                                                                                                                                                                                                          client :=
                                                                                                                                                                                                          client
                                                                                                                                                                                                            baker_0
                                                                                                                                                                                                          in
                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                          (op_startypeminuserrorstar
                                                                                                                                                                                                            state
                                                                                                                                                                                                            "curl http://localhost:%d/chains/main/blocks/head/metadata"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              string
                                                                                                                                                                                                            (port
                                                                                                                                                                                                              client))
                                                                                                                                                                                                          (fun
                                                                                                                                                                                                            curl_res
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            let
                                                                                                                                                                                                              json_string :=
                                                                                                                                                                                                              OCaml.Stdlib.reverse_apply
                                                                                                                                                                                                                (* ❌ Sending method message is not handled *)
                                                                                                                                                                                                                send
                                                                                                                                                                                                                (Stdlib.String.concat
                                                                                                                                                                                                                  (* ❌ expected an argument *)
                                                                                                                                                                                                                  expected_argument
                                                                                                                                                                                                                  (* ❌ expected an argument *)
                                                                                                                                                                                                                  expected_argument
                                                                                                                                                                                                                  "
"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string)
                                                                                                                                                                                                              in
                                                                                                                                                                                                            let
                                                                                                                                                                                                              json_metadata :=
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                json_string
                                                                                                                                                                                                              in
                                                                                                                                                                                                            match
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                json_metadata
                                                                                                                                                                                                                "next_protocol"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  string
                                                                                                                                                                                                              with
                                                                                                                                                                                                            |
                                                                                                                                                                                                              String
                                                                                                                                                                                                                p
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                (* ❌ Variants not supported *)
                                                                                                                                                                                                                variant
                                                                                                                                                                                                            |
                                                                                                                                                                                                              other
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                (transfer
                                                                                                                                                                                                                  state
                                                                                                                                                                                                                  client
                                                                                                                                                                                                                  (Tezos_client.Keyed.key_name
                                                                                                                                                                                                                    baker_0)
                                                                                                                                                                                                                  (Tezos_client.Keyed.key_name
                                                                                                                                                                                                                    special_baker)
                                                                                                                                                                                                                  (* ❌ Constant of type int64 is converted to int *)
                                                                                                                                                                                                                  1)
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  let
                                                                                                                                                                                                                    '_ :=
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    in
                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                                                                                                        state
                                                                                                                                                                                                                        baker_0)
                                                                                                                                                                                                                      "Baker %s bakes %d/%d waiting for next protocol: %S"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string
                                                                                                                                                                                                                      (id
                                                                                                                                                                                                                        client)
                                                                                                                                                                                                                      nth
                                                                                                                                                                                                                      attempts
                                                                                                                                                                                                                      winner_hash)
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      let
                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        in
                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                        (* ❌ Variants not supported *)
                                                                                                                                                                                                                        variant))
                                                                                                                                                                                                            end)))
                                                                                                                                                                                                    (fun
                                                                                                                                                                                                      extra_bakes_waiting_for_next_protocol
                                                                                                                                                                                                      =>
                                                                                                                                                                                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                                                                                                      let
                                                                                                                                                                                                        _
                                                                                                                                                                                                        :=
                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                          level_counter
                                                                                                                                                                                                          "wait-for-next-protocol"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            string
                                                                                                                                                                                                          extra_bakes_waiting_for_next_protocol
                                                                                                                                                                                                        in
                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                                          (check_understood_protocols
                                                                                                                                                                                                            state
                                                                                                                                                                                                            "main"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              string
                                                                                                                                                                                                            winner_client
                                                                                                                                                                                                            winner_hash
                                                                                                                                                                                                            clueless_winner)
                                                                                                                                                                                                          (fun
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            =>
                                                                                                                                                                                                            match
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              with
                                                                                                                                                                                                            |
                                                                                                                                                                                                              Expected_misunderstanding
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                state
                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                            |
                                                                                                                                                                                                              Failure_to_understand
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              failf
                                                                                                                                                                                                                "The winner-client does not know about `%s`"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  string
                                                                                                                                                                                                                winner_hash
                                                                                                                                                                                                            |
                                                                                                                                                                                                              Proper_understanding
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                                  state
                                                                                                                                                                                                                  op_startypeminuserrorstar)
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  let
                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    in
                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                                                                                                        state
                                                                                                                                                                                                                        winner_client
                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                          "upgrade"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string
                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                            "baking"
                                                                                                                                                                                                                              %
                                                                                                                                                                                                                              string
                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                              "state"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string
                                                                                                                                                                                                                              []))))
                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        match
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          with
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          Stdlib.Ok
                                                                                                                                                                                                                            _
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                            tt
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          Stdlib.Error
                                                                                                                                                                                                                            _
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                            state
                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                        end))
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      let
                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        in
                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                                                          with_ledger
                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                            let
                                                                                                                                                                                                                              '_ :=
                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                              in
                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                                                                                                                state
                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                true)
                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                let
                                                                                                                                                                                                                                  'tt :=
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  in
                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                  (op_startypeminuserrorstar
                                                                                                                                                                                                                                    state
                                                                                                                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                    let
                                                                                                                                                                                                                                      'tt :=
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      in
                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                      (* ❌ Float constant 4. is approximated by the integer 4 *)
                                                                                                                                                                                                                                      4))))
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          let
                                                                                                                                                                                                                            '_ :=
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            in
                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                                                              state
                                                                                                                                                                                                                              winner_baker_0
                                                                                                                                                                                                                              "First bake on new protocol !!"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string)
                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                in
                                                                                                                                                                                                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                _
                                                                                                                                                                                                                                :=
                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                  level_counter
                                                                                                                                                                                                                                  "baker-0-bakes-on-new-protocol"
                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                in
                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                                                  state
                                                                                                                                                                                                                                  winner_special_baker
                                                                                                                                                                                                                                  "Second bake on new protocol !!"
                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                    string)
                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                    _
                                                                                                                                                                                                                                    :=
                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                      level_counter
                                                                                                                                                                                                                                      "special-baker-bakes-on-new-protocol"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                                                      state
                                                                                                                                                                                                                                      winner_client
                                                                                                                                                                                                                                      (* ❌ Variants not supported *)
                                                                                                                                                                                                                                      variant
                                                                                                                                                                                                                                      "/chains/main/blocks/head/metadata"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string)
                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                      json_metadata
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                          json_metadata
                                                                                                                                                                                                                                          "protocol"
                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                        String
                                                                                                                                                                                                                                          p
                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                          tt
                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                        other
                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                        failf
                                                                                                                                                                                                                                          "Protocol is not `%s` but `%s`"
                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                          winner_hash
                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                      end))))))
                                                                                                                                                                                                            end))
                                                                                                                                                                                                        (fun
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          let
                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            in
                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                                              state
                                                                                                                                                                                                              op_startypeminuserrorstar)
                                                                                                                                                                                                            (fun
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              let
                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                in
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                tt))))))))))))))))))))))))))))))))))))))))))))))))))).

Definition cmd {A B : Type} (pp_error : A) (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

src/bin_sandbox/main.ml 6 errors
open Flextesa
open Internal_pervasives

module Small_utilities = struct
  let key_of_name_command () =
    let open Cmdliner in
    let open Term in
    ( ( pure (fun n ->
            let open Tezos_protocol.Account in
            let account = of_name n in
            Printf.printf
              "%s,%s,%s,%s\n%!"
              (name account)
              (pubkey account)
              (pubkey_hash account)
              (private_key account))
      $ Arg.(
          required
            (pos
               0
               (some string)
               None
               (info [] ~docv:"NAME" ~doc:"String to generate the data from.")))
      ),
      info
        "key-of-name"
        ~doc:"Make an unencrypted key-pair deterministically from a string."
        ~man:
          [ `P
              "`flextesa key-of-name hello-world` generates a key-pair of the \
               `unencrypted:..` kind and outputs it as a 4 values separated \
               by commas: `name,pub-key,pub-key-hash,private-uri` (hence \
               compatible with the `--add-bootstrap-account` option of some \
               of the test scenarios)." ] )

  let netstat_ports ~pp_error () =
    let open Cmdliner in
    let open Term in
    Test_command_line.Run_command.make
      ~pp_error
      ( pure (fun state ->
            ( state,
              fun () ->
                Test_scenario.Network.netstat_listening_ports state
                >>= fun ports ->
                let to_display =
                  List.map ports ~f:(fun (p, _) -> p)
                  |> List.sort ~compare:Int.compare
                in
                Console.sayf
                  state
                  Fmt.(
                    hvbox ~indent:2 (fun ppf () ->
                        box words ppf "Netstat listening ports:" ;
                        sp ppf () ;
                        box
                          (list
                             ~sep:(fun ppf () -> string ppf "," ; sp ppf ())
                             (fun ppf p -> fmt "%d" ppf p))
                          ppf
                          to_display)) ))
      $ Test_command_line.cli_state
          ~disable_interactivity:true
          ~name:"netstat-ports"
          () )
      (info
         "netstat-listening-ports"
         ~doc:"Like `netstat -nut | awk something-something` but glorified.")

  let all ~pp_error () = [key_of_name_command (); netstat_ports ~pp_error ()]
end

let () =
  let open Cmdliner in
  let help = Term.(ret (pure (`Help (`Auto, None))), info "help") in
  let pp_error fmt = function
    | `Scenario_error s ->
        Format.fprintf fmt "%s" s
    | #Test_scenario.Inconsistency_error.t as e ->
        Format.fprintf fmt "%a" Test_scenario.Inconsistency_error.pp e
    | #Process_result.Error.t as e ->
        Format.fprintf fmt "%a" Process_result.Error.pp e
    | #System_error.t as e ->
        Format.fprintf fmt "%a" System_error.pp e
    | `Client_command_error _ as e ->
        Tezos_client.Command_error.pp fmt e
    | `Admin_command_error _ as e ->
        Tezos_admin_client.Command_error.pp fmt e
    | `Waiting_for (msg, `Time_out) ->
        Format.fprintf fmt "WAITING-FOR “%s”: Time-out" msg
    | `Precheck_failure _ as p ->
        Helpers.System_dependencies.Error.pp fmt p
    | `Die _ ->
        ()
  in
  Term.exit
  @@ Term.eval_choice
       (help : unit Term.t * _)
       ( Small_utilities.all ~pp_error ()
       @ [ Command_daemons_protocol_change.cmd () ~pp_error;
           Command_voting.cmd () ~pp_error;
           Command_accusations.cmd () ~pp_error;
           Command_prevalidation.cmd () ~pp_error;
           Command_ledger_baking.cmd () ~pp_error;
           Command_ledger_wallet.cmd () ~pp_error;
           Flextesa.Interactive_mini_network.cmd ~pp_error () ] )
src/bin_sandbox/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Small_utilities.
  Definition key_of_name_command {A : Type} (function_parameter : unit) : A :=
    let 'tt := function_parameter in
    op_startypeminuserrorstar.
  
  Definition netstat_ports {A B : Type}
    (pp_error : A) (function_parameter : unit) : B :=
    let 'tt := function_parameter in
    op_startypeminuserrorstar.
  
  Definition all {A B : Type} (pp_error : A) (function_parameter : unit)
    : list B :=
    let 'tt := function_parameter in
    cons (key_of_name_command tt) (cons (netstat_ports pp_error tt) []).
End Small_utilities.



src/bin_signer/handler.ml 163 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Signer_logging

let log = lwt_log_notice

module High_watermark = struct
  let encoding =
    let open Data_encoding in
    let raw_hash = conv Blake2B.to_bytes Blake2B.of_bytes_exn bytes in
    conv
      (List.map (fun (chain_id, marks) ->
           (Chain_id.to_b58check chain_id, marks)))
      (List.map (fun (chain_id, marks) ->
           (Chain_id.of_b58check_exn chain_id, marks)))
    @@ assoc
    @@ conv
         (List.map (fun (pkh, mark) ->
              (Signature.Public_key_hash.to_b58check pkh, mark)))
         (List.map (fun (pkh, mark) ->
              (Signature.Public_key_hash.of_b58check_exn pkh, mark)))
    @@ assoc
    @@ obj3
         (req "level" int32)
         (req "hash" raw_hash)
         (opt "signature" Signature.encoding)

  let mark_if_block_or_endorsement (cctxt : #Client_context.wallet) pkh bytes
      sign =
    let mark art name get_level =
      let file = name ^ "_high_watermark" in
      cctxt#with_lock
      @@ fun () ->
      cctxt#load file ~default:[] encoding
      >>=? fun all ->
      if Bytes.length bytes < 9 then
        failwith "byte sequence too short to be %s %s" art name
      else
        let hash = Blake2B.hash_bytes [bytes] in
        let chain_id = Chain_id.of_bytes_exn (Bytes.sub bytes 1 4) in
        let level = get_level () in
        ( match List.assoc_opt chain_id all with
        | None ->
            return_none
        | Some marks -> (
          match List.assoc_opt pkh marks with
          | None ->
              return_none
          | Some (previous_level, _, None) ->
              if previous_level >= level then
                failwith
                  "%s level %ld not above high watermark %ld"
                  name
                  level
                  previous_level
              else return_none
          | Some (previous_level, previous_hash, Some signature) ->
              if previous_level > level then
                failwith
                  "%s level %ld below high watermark %ld"
                  name
                  level
                  previous_level
              else if previous_level = level then
                if previous_hash <> hash then
                  failwith
                    "%s level %ld already signed with different data"
                    name
                    level
                else return_some signature
              else return_none ) )
        >>=? function
        | Some signature ->
            return signature
        | None ->
            sign bytes
            >>=? fun signature ->
            let rec update = function
              | [] ->
                  [(chain_id, [(pkh, (level, hash, Some signature))])]
              | (e_chain_id, marks) :: rest ->
                  if chain_id = e_chain_id then
                    let marks =
                      (pkh, (level, hash, Some signature))
                      :: List.filter (fun (pkh', _) -> pkh <> pkh') marks
                    in
                    (e_chain_id, marks) :: rest
                  else (e_chain_id, marks) :: update rest
            in
            cctxt#write file (update all) encoding
            >>=? fun () -> return signature
    in
    if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x01 then
      mark "a" "block" (fun () -> TzEndian.get_int32 bytes 5)
    else if Bytes.length bytes > 0 && TzEndian.get_uint8 bytes 0 = 0x02 then
      mark "an" "endorsement" (fun () ->
          TzEndian.get_int32 bytes (Bytes.length bytes - 4))
    else sign bytes
end

module Authorized_key = Client_aliases.Alias (struct
  include Signature.Public_key

  let name = "authorized_key"

  let to_source s = return (to_b58check s)

  let of_source t = Lwt.return (of_b58check t)
end)

let check_magic_byte magic_bytes data =
  match magic_bytes with
  | None ->
      return_unit
  | Some magic_bytes ->
      let byte = TzEndian.get_uint8 data 0 in
      if Bytes.length data > 1 && List.mem byte magic_bytes then return_unit
      else failwith "magic byte 0x%02X not allowed" byte

let check_authorization cctxt pkh data require_auth signature =
  match (require_auth, signature) with
  | (false, _) ->
      return_unit
  | (true, None) ->
      failwith "missing authentication signature field"
  | (true, Some signature) ->
      let to_sign = Signer_messages.Sign.Request.to_sign ~pkh ~data in
      Authorized_key.load cctxt
      >>=? fun keys ->
      if
        List.fold_left
          (fun acc (_, key) -> acc || Signature.check key signature to_sign)
          false
          keys
      then return_unit
      else failwith "invalid authentication signature"

let sign (cctxt : #Client_context.wallet)
    Signer_messages.Sign.Request.{pkh; data; signature} ?magic_bytes
    ~check_high_watermark ~require_auth =
  log
    Tag.DSL.(
      fun f ->
        f "Request for signing %d bytes of data for key %a, magic byte = %02X"
        -% t event "request_for_signing"
        -% s num_bytes (Bytes.length data)
        -% a Signature.Public_key_hash.Logging.tag pkh
        -% s magic_byte (TzEndian.get_uint8 data 0))
  >>= fun () ->
  check_magic_byte magic_bytes data
  >>=? fun () ->
  check_authorization cctxt pkh data require_auth signature
  >>=? fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f "Signing data for key %s"
        -% t event "signing_data"
        -% s Client_keys.Logging.tag name)
  >>= fun () ->
  let sign = Client_keys.sign cctxt sk_uri in
  if check_high_watermark then
    High_watermark.mark_if_block_or_endorsement cctxt pkh data sign
  else sign data

let deterministic_nonce (cctxt : #Client_context.wallet)
    Signer_messages.Deterministic_nonce.Request.{pkh; data; signature}
    ~require_auth =
  log
    Tag.DSL.(
      fun f ->
        f "Request for creating a nonce from %d input bytes for key %a"
        -% t event "request_for_deterministic_nonce"
        -% s num_bytes (Bytes.length data)
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  check_authorization cctxt pkh data require_auth signature
  >>=? fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f "Creating nonce for key %s"
        -% t event "creating_nonce"
        -% s Client_keys.Logging.tag name)
  >>= fun () -> Client_keys.deterministic_nonce sk_uri data

let deterministic_nonce_hash (cctxt : #Client_context.wallet)
    Signer_messages.Deterministic_nonce_hash.Request.{pkh; data; signature}
    ~require_auth =
  log
    Tag.DSL.(
      fun f ->
        f "Request for creating a nonce hash from %d input bytes for key %a"
        -% t event "request_for_deterministic_nonce_hash"
        -% s num_bytes (Bytes.length data)
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  check_authorization cctxt pkh data require_auth signature
  >>=? fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f "Creating nonce hash for key %s"
        -% t event "creating_nonce_hash"
        -% s Client_keys.Logging.tag name)
  >>= fun () -> Client_keys.deterministic_nonce_hash sk_uri data

let supports_deterministic_nonces (cctxt : #Client_context.wallet) pkh =
  log
    Tag.DSL.(
      fun f ->
        f
          "Request for checking whether the signer supports deterministic \
           nonces for key %a"
        -% t event "request_for_supports_deterministic_nonces"
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  Client_keys.get_key cctxt pkh
  >>=? fun (name, _pkh, sk_uri) ->
  log
    Tag.DSL.(
      fun f ->
        f
          "Returns true if and only if signer can generate determinstic \
           nonces for key %s"
        -% t event "supports_deterministic_nonces"
        -% s Client_keys.Logging.tag name)
  >>= fun () -> Client_keys.supports_deterministic_nonces sk_uri

let public_key (cctxt : #Client_context.wallet) pkh =
  log
    Tag.DSL.(
      fun f ->
        f "Request for public key %a"
        -% t event "request_for_public_key"
        -% a Signature.Public_key_hash.Logging.tag pkh)
  >>= fun () ->
  Client_keys.list_keys cctxt
  >>=? fun all_keys ->
  match
    List.find_opt
      (fun (_, h, _, _) -> Signature.Public_key_hash.equal h pkh)
      all_keys
  with
  | None ->
      log
        Tag.DSL.(
          fun f ->
            f "No public key found for hash %a"
            -% t event "not_found_public_key"
            -% a Signature.Public_key_hash.Logging.tag pkh)
      >>= fun () -> Lwt.fail Not_found
  | Some (_, _, None, _) ->
      log
        Tag.DSL.(
          fun f ->
            f "No public key found for hash %a"
            -% t event "not_found_public_key"
            -% a Signature.Public_key_hash.Logging.tag pkh)
      >>= fun () -> Lwt.fail Not_found
  | Some (name, _, Some pk, _) ->
      log
        Tag.DSL.(
          fun f ->
            f "Found public key for hash %a (name: %s)"
            -% t event "found_public_key"
            -% a Signature.Public_key_hash.Logging.tag pkh
            -% s Client_keys.Logging.tag name)
      >>= fun () -> return pk
src/bin_signer/handler.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Signer_logging.

Definition log {A : Type}
  : Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
  lwt_log_notice.

Module High_watermark.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (list
        (Tezos_base__TzPervasives.Chain_id.t *
          (list
            (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
              (int32 * Tezos_base__TzPervasives.Blake2B.t *
                (option Tezos_base__TzPervasives.Signature.t)))))) :=
    let raw_hash := conv Blake2B.to_bytes Blake2B.of_bytes_exn None bytes in
    apply
      (let arg :=
        conv
          (List.map
            (fun function_parameter =>
              let '(chain_id, marks) := function_parameter in
              ((Chain_id.to_b58check chain_id), marks)))
          (List.map
            (fun function_parameter =>
              let '(chain_id, marks) := function_parameter in
              ((Chain_id.of_b58check_exn chain_id), marks))) in
      fun eta => arg None eta)
      (apply assoc
        (apply
          (let arg :=
            conv
              (List.map
                (fun function_parameter =>
                  let '(pkh, mark) := function_parameter in
                  ((Signature.Public_key_hash.to_b58check pkh), mark)))
              (List.map
                (fun function_parameter =>
                  let '(pkh, mark) := function_parameter in
                  ((Signature.Public_key_hash.of_b58check_exn pkh), mark))) in
          fun eta => arg None eta)
          (apply assoc
            (obj3 (req None None "level" % string int32)
              (req None None "hash" % string raw_hash)
              (opt None None "signature" % string Signature.encoding))))).
  
  Definition mark_if_block_or_endorsement {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (bytes : Stdlib.Bytes.t)
    (sign :
      Stdlib.Bytes.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t))
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
    let mark (art : string) (name : string) (get_level : unit -> int32)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
      let file := String.append name "_high_watermark" % string in
      apply
        (* ❌ Sending method message is not handled *)
        send
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            ((* ❌ Sending method message is not handled *)
            send file [] encoding)
            (fun all =>
              if OCaml.Stdlib.lt (String.length string) 9 then
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "byte sequence too short to be " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format))))
                    "byte sequence too short to be %s %s" % string) art name
              else
                let hash := Blake2B.hash_bytes None (cons string []) in
                let chain_id := Chain_id.of_bytes_exn (String.sub string 1 4) in
                let level := get_level tt in
                op_gtgteqquestion
                  match List.assoc_opt chain_id all with
                  | None => return_none
                  | Some marks =>
                    match List.assoc_opt pkh marks with
                    | None => return_none
                    | Some (previous_level, _, None) =>
                      if OCaml.Stdlib.ge previous_level level then
                        failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                " level " % string
                                (CamlinternalFormatBasics.Int32
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " not above high watermark " % string
                                    (CamlinternalFormatBasics.Int32
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      CamlinternalFormatBasics.End_of_format)))))
                            "%s level %ld not above high watermark %ld" % string)
                          name level previous_level
                      else
                        return_none
                    | Some (previous_level, previous_hash, Some signature) =>
                      if OCaml.Stdlib.gt previous_level level then
                        failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                " level " % string
                                (CamlinternalFormatBasics.Int32
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " below high watermark " % string
                                    (CamlinternalFormatBasics.Int32
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      CamlinternalFormatBasics.End_of_format)))))
                            "%s level %ld below high watermark %ld" % string)
                          name level previous_level
                      else
                        if equiv_decb previous_level level then
                          if nequiv_decb previous_hash hash then
                            failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " level " % string
                                    (CamlinternalFormatBasics.Int32
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      (CamlinternalFormatBasics.String_literal
                                        " already signed with different data" %
                                          string
                                        CamlinternalFormatBasics.End_of_format))))
                                "%s level %ld already signed with different data"
                                  % string) name level
                          else
                            return_some signature
                        else
                          return_none
                    end
                  end
                  (fun function_parameter =>
                    match function_parameter with
                    | Some signature => _return signature
                    | None =>
                      op_gtgteqquestion (sign string)
                        (fun signature =>
                          let fix update
                            (function_parameter :
                            list
                              (Tezos_base__TzPervasives.Chain_id.t *
                                (list
                                  (Tezos_base__TzPervasives.Signature.Public_key_hash.t
                                    *
                                    (int32 * Tezos_base__TzPervasives.Blake2B.t
                                      *
                                      (option
                                        Tezos_base__TzPervasives.Signature.t))))))
                            : list
                              (Tezos_base__TzPervasives.Chain_id.t *
                                (list
                                  (Tezos_base__TzPervasives.Signature.Public_key_hash.t
                                    *
                                    (int32 * Tezos_base__TzPervasives.Blake2B.t
                                      *
                                      (option
                                        Tezos_base__TzPervasives.Signature.t))))) :=
                            match function_parameter with
                            | [] =>
                              cons
                                (chain_id,
                                  (cons (pkh, (level, hash, (Some signature)))
                                    [])) []
                            | cons (e_chain_id, marks) rest =>
                              if equiv_decb chain_id e_chain_id then
                                let marks :=
                                  cons (pkh, (level, hash, (Some signature)))
                                    (List.filter
                                      (fun function_parameter =>
                                        let '(pkh', _) := function_parameter in
                                        nequiv_decb pkh pkh') marks) in
                                cons (e_chain_id, marks) rest
                              else
                                cons (e_chain_id, marks) (update rest)
                            end in
                          op_gtgteqquestion
                            ((* ❌ Sending method message is not handled *)
                            send file (update all) encoding)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              _return signature))
                    end))) in
    if
      andb (OCaml.Stdlib.gt (String.length string) 0)
        (equiv_decb (TzEndian.get_uint8 string 0) 1) then
      mark "a" % string "block" % string
        (fun function_parameter =>
          let 'tt := function_parameter in
          TzEndian.get_int32 string 5)
    else
      if
        andb (OCaml.Stdlib.gt (String.length string) 0)
          (equiv_decb (TzEndian.get_uint8 string 0) 2) then
        mark "an" % string "endorsement" % string
          (fun function_parameter =>
            let 'tt := function_parameter in
            TzEndian.get_int32 string (Z.sub (String.length string) 4))
      else
        sign string.
End High_watermark.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition check_magic_byte (magic_bytes : option (list Z)) (data : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match magic_bytes with
  | None => return_unit
  | Some magic_bytes =>
    let byte := TzEndian.get_uint8 data 0 in
    if andb (OCaml.Stdlib.gt (String.length data) 1) (List.mem byte magic_bytes)
      then
      return_unit
    else
      failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "magic byte 0x" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 2)
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " not allowed" % string
                CamlinternalFormatBasics.End_of_format)))
          "magic byte 0x%02X not allowed" % string) byte
  end.

Definition check_authorization {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (data : Stdlib.Bytes.t) (require_auth : bool)
  (signature : option Tezos_base__TzPervasives.Signature.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match (require_auth, signature) with
  | (false, _) => return_unit
  | (true, None) =>
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "missing authentication signature field" % string
          CamlinternalFormatBasics.End_of_format)
        "missing authentication signature field" % string)
  | (true, Some signature) =>
    let to_sign := Signer_messages.Sign.Request.to_sign pkh data in
    op_gtgteqquestion (Authorized_key.load cctxt)
      (fun keys =>
        if
          List.fold_left
            (fun acc =>
              fun function_parameter =>
                let '(_, key) := function_parameter in
                orb acc (Signature.check None key signature to_sign)) false keys
          then
          return_unit
        else
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "invalid authentication signature" % string
                CamlinternalFormatBasics.End_of_format)
              "invalid authentication signature" % string))
  end.

Definition sign {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  (function_parameter : Tezos_signer_services.Signer_messages.Sign.Request.t)
  : (option (list Z)) ->
    bool ->
      bool ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t) :=
  let '{| pkh := pkh; data := data; signature := signature |} :=
    function_parameter in
  fun magic_bytes =>
    fun check_high_watermark =>
      fun require_auth =>
        op_gtgteq
          (log
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Request for signing " % string
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              (CamlinternalFormatBasics.String_literal
                                " bytes of data for key " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    ", magic byte = " % string
                                    (CamlinternalFormatBasics.Int
                                      CamlinternalFormatBasics.Int_X
                                      (CamlinternalFormatBasics.Lit_padding
                                        CamlinternalFormatBasics.Zeros 2)
                                      CamlinternalFormatBasics.No_precision
                                      CamlinternalFormatBasics.End_of_format))))))
                          "Request for signing %d bytes of data for key %a, magic byte = %02X"
                            % string)) (t event "request_for_signing" % string))
                    (s num_bytes (String.length data)))
                  (a Signature.Public_key_hash.Logging.tag pkh))
                (s magic_byte (TzEndian.get_uint8 data 0))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (check_magic_byte magic_bytes data)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (check_authorization cctxt pkh data require_auth signature)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion (Client_keys.get_key cctxt pkh)
                      (fun function_parameter =>
                        let '(name, _pkh, sk_uri) := function_parameter in
                        op_gtgteq
                          (log
                            (fun f =>
                              op_minuspercent
                                (op_minuspercent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Signing data for key " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "Signing data for key %s" % string))
                                  (t event "signing_data" % string))
                                (s Client_keys.Logging.tag name)))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            let sign := Client_keys.sign cctxt None sk_uri in
                            if check_high_watermark then
                              High_watermark.mark_if_block_or_endorsement cctxt
                                pkh data sign
                            else
                              sign data))))).

Definition deterministic_nonce {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  (function_parameter :
    Tezos_signer_services.Signer_messages.Deterministic_nonce.Request.t)
  : bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  let '{| pkh := pkh; data := data; signature := signature |} :=
    function_parameter in
  fun require_auth =>
    op_gtgteq
      (log
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Request for creating a nonce from " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " input bytes for key " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))
                    "Request for creating a nonce from %d input bytes for key %a"
                      % string))
                (t event "request_for_deterministic_nonce" % string))
              (s num_bytes (String.length data)))
            (a Signature.Public_key_hash.Logging.tag pkh)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (check_authorization cctxt pkh data require_auth signature)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (Client_keys.get_key cctxt pkh)
              (fun function_parameter =>
                let '(name, _pkh, sk_uri) := function_parameter in
                op_gtgteq
                  (log
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (f
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Creating nonce for key " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format))
                              "Creating nonce for key %s" % string))
                          (t event "creating_nonce" % string))
                        (s Client_keys.Logging.tag name)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Client_keys.deterministic_nonce sk_uri data)))).

Definition deterministic_nonce_hash {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  (function_parameter :
    Tezos_signer_services.Signer_messages.Deterministic_nonce_hash.Request.t)
  : bool -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  let '{| pkh := pkh; data := data; signature := signature |} :=
    function_parameter in
  fun require_auth =>
    op_gtgteq
      (log
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Request for creating a nonce hash from " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " input bytes for key " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))
                    "Request for creating a nonce hash from %d input bytes for key %a"
                      % string))
                (t event "request_for_deterministic_nonce_hash" % string))
              (s num_bytes (String.length data)))
            (a Signature.Public_key_hash.Logging.tag pkh)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (check_authorization cctxt pkh data require_auth signature)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (Client_keys.get_key cctxt pkh)
              (fun function_parameter =>
                let '(name, _pkh, sk_uri) := function_parameter in
                op_gtgteq
                  (log
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (f
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Creating nonce hash for key " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format))
                              "Creating nonce hash for key %s" % string))
                          (t event "creating_nonce_hash" % string))
                        (s Client_keys.Logging.tag name)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Client_keys.deterministic_nonce_hash sk_uri data)))).

Definition supports_deterministic_nonces {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  op_gtgteq
    (log
      (fun f =>
        op_minuspercent
          (op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Request for checking whether the signer supports deterministic nonces for key "
                    % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Request for checking whether the signer supports deterministic nonces for key %a"
                  % string))
            (t event "request_for_supports_deterministic_nonces" % string))
          (a Signature.Public_key_hash.Logging.tag pkh)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (Client_keys.get_key cctxt pkh)
        (fun function_parameter =>
          let '(name, _pkh, sk_uri) := function_parameter in
          op_gtgteq
            (log
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Returns true if and only if signer can generate determinstic nonces for key "
                            % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format))
                        "Returns true if and only if signer can generate determinstic nonces for key %s"
                          % string))
                    (t event "supports_deterministic_nonces" % string))
                  (s Client_keys.Logging.tag name)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Client_keys.supports_deterministic_nonces sk_uri))).

Definition public_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Tezos_crypto__Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.public_key) :=
  op_gtgteq
    (log
      (fun f =>
        op_minuspercent
          (op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Request for public key " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Request for public key %a" % string))
            (t event "request_for_public_key" % string))
          (a Signature.Public_key_hash.Logging.tag pkh)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (Client_keys.list_keys cctxt)
        (fun all_keys =>
          match
            List.find_opt
              (fun function_parameter =>
                let '(_, h, _, _) := function_parameter in
                Signature.Public_key_hash.equal h pkh) all_keys with
          | None =>
            op_gtgteq
              (log
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "No public key found for hash " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "No public key found for hash %a" % string))
                      (t event "not_found_public_key" % string))
                    (a Signature.Public_key_hash.Logging.tag pkh)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.fail OCaml.Not_found)
          | Some (_, _, None, _) =>
            op_gtgteq
              (log
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "No public key found for hash " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "No public key found for hash %a" % string))
                      (t event "not_found_public_key" % string))
                    (a Signature.Public_key_hash.Logging.tag pkh)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.fail OCaml.Not_found)
          | Some (name, _, Some pk, _) =>
            op_gtgteq
              (log
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Found public key for hash " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " (name: " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      CamlinternalFormatBasics.End_of_format)))))
                            "Found public key for hash %a (name: %s)" % string))
                        (t event "found_public_key" % string))
                      (a Signature.Public_key_hash.Logging.tag pkh))
                    (s Client_keys.Logging.tag name)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                _return pk)
          end)).

src/bin_signer/http_daemon.ml 43 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let log = Signer_logging.lwt_log_notice

open Signer_logging

let run (cctxt : #Client_context.wallet) ~hosts ?magic_bytes
    ~check_high_watermark ~require_auth mode =
  let dir = RPC_directory.empty in
  let dir =
    RPC_directory.register1 dir Signer_services.sign (fun pkh signature data ->
        Handler.sign
          cctxt
          {pkh; data; signature}
          ?magic_bytes
          ~check_high_watermark
          ~require_auth)
  in
  let dir =
    RPC_directory.register1 dir Signer_services.public_key (fun pkh () () ->
        Handler.public_key cctxt pkh)
  in
  let dir =
    RPC_directory.register0 dir Signer_services.authorized_keys (fun () () ->
        if require_auth then
          Handler.Authorized_key.load cctxt
          >>=? fun keys ->
          return_some
            (keys |> List.split |> snd |> List.map Signature.Public_key.hash)
        else return_none)
  in
  Lwt.catch
    (fun () ->
      List.map
        (fun host ->
          let host = Ipaddr.V6.to_string host in
          log
            Tag.DSL.(
              fun f ->
                f "Listening on address %s"
                -% t event "signer_listening" -% s host_name host)
          >>= fun () ->
          RPC_server.launch
            ~host
            mode
            dir
            ~media_types:Media_type.all_media_types
          >>= fun _server -> fst (Lwt.wait ()))
        hosts
      |> Lwt.choose)
    (function
      | Unix.Unix_error (Unix.EADDRINUSE, "bind", "") ->
          failwith "Port already in use."
      | exn ->
          Lwt.return (error_exn exn))

let run_https (cctxt : #Client_context.wallet) ~host ~port ~cert ~key
    ?magic_bytes ~check_high_watermark ~require_auth =
  Lwt_utils_unix.getaddrinfo
    ~passive:true
    ~node:host
    ~service:(string_of_int port)
  >>= function
  | [] ->
      failwith "Cannot resolve listening address: %S" host
  | points ->
      let hosts = fst (List.split points) in
      log
        Tag.DSL.(
          fun f ->
            f "Accepting HTTPS requests on port %d"
            -% t event "accepting_https_requests"
            -% s port_number port)
      >>= fun () ->
      let mode : Conduit_lwt_unix.server =
        `TLS (`Crt_file_path cert, `Key_file_path key, `No_password, `Port port)
      in
      run
        (cctxt : #Client_context.wallet)
        ~hosts
        ?magic_bytes
        ~check_high_watermark
        ~require_auth
        mode

let run_http (cctxt : #Client_context.wallet) ~host ~port ?magic_bytes
    ~check_high_watermark ~require_auth =
  Lwt_utils_unix.getaddrinfo
    ~passive:true
    ~node:host
    ~service:(string_of_int port)
  >>= function
  | [] ->
      failwith "Cannot resolve listening address: %S" host
  | points ->
      let hosts = fst (List.split points) in
      log
        Tag.DSL.(
          fun f ->
            f "Accepting HTTP requests on port %d"
            -% t event "accepting_http_requests"
            -% s port_number port)
      >>= fun () ->
      let mode : Conduit_lwt_unix.server = `TCP (`Port port) in
      run
        (cctxt : #Client_context.wallet)
        ~hosts
        ?magic_bytes
        ~check_high_watermark
        ~require_auth
        mode
src/bin_signer/http_daemon.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition log {A : Type}
  : Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
  Signer_logging.lwt_log_notice.

Import Signer_logging.

Definition run {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (hosts : list Ipaddr.V6.t) (magic_bytes : option (list Z))
  (check_high_watermark : bool) (require_auth : bool)
  (mode : Conduit_lwt_unix.server)
  : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  let dir := RPC_directory.empty in
  let dir :=
    RPC_directory.register1 dir Signer_services.sign
      (fun pkh =>
        fun signature =>
          fun data =>
            Handler.sign cctxt
              {| pkh := pkh; data := data; signature := signature |} magic_bytes
              check_high_watermark require_auth) in
  let dir :=
    RPC_directory.register1 dir Signer_services.public_key
      (fun pkh =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            Handler.public_key cctxt pkh) in
  let dir :=
    RPC_directory.register0 dir Signer_services.authorized_keys
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          if require_auth then
            op_gtgteqquestion (Handler.Authorized_key.load cctxt)
              (fun keys =>
                return_some
                  (OCaml.Stdlib.reverse_apply
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply keys List.split) snd)
                    (List.map Signature.Public_key.hash)))
          else
            return_none) in
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      OCaml.Stdlib.reverse_apply
        (List.map
          (fun host =>
            let host := Ipaddr.V6.to_string host in
            op_gtgteq
              (log
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Listening on address " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          "Listening on address %s" % string))
                      (t event "signer_listening" % string)) (s host_name host)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (RPC_server.launch (Some host) None Media_type.all_media_types
                    mode dir) (fun _server => fst (Lwt.wait tt)))) hosts)
        Lwt.choose)
    (fun function_parameter =>
      match function_parameter with
      | Unix_error Unix.EADDRINUSE "bind" % string "" % string =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Port already in use." % string
              CamlinternalFormatBasics.End_of_format)
            "Port already in use." % string)
      | exn => Lwt._return (error_exn exn)
      end).

Definition run_https {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (host : string) (port : Z) (cert : string) (key : string)
  (magic_bytes : option (list Z)) (check_high_watermark : bool)
  (require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  op_gtgteq
    (Lwt_utils_unix.getaddrinfo true host (OCaml.Stdlib.string_of_int port))
    (fun function_parameter =>
      match function_parameter with
      | [] =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Cannot resolve listening address: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Cannot resolve listening address: %S" % string) host
      | points =>
        let hosts := fst (List.split points) in
        op_gtgteq
          (log
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Accepting HTTPS requests on port " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          CamlinternalFormatBasics.End_of_format))
                      "Accepting HTTPS requests on port %d" % string))
                  (t event "accepting_https_requests" % string))
                (s port_number port)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            let mode :=
              (* ❌ Variants not supported *)
              variant in
            run cctxt hosts magic_bytes check_high_watermark require_auth mode)
      end).

Definition run_http {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (host : string) (port : Z) (magic_bytes : option (list Z))
  (check_high_watermark : bool) (require_auth : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  op_gtgteq
    (Lwt_utils_unix.getaddrinfo true host (OCaml.Stdlib.string_of_int port))
    (fun function_parameter =>
      match function_parameter with
      | [] =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Cannot resolve listening address: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Cannot resolve listening address: %S" % string) host
      | points =>
        let hosts := fst (List.split points) in
        op_gtgteq
          (log
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Accepting HTTP requests on port " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          CamlinternalFormatBasics.End_of_format))
                      "Accepting HTTP requests on port %d" % string))
                  (t event "accepting_http_requests" % string))
                (s port_number port)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            let mode :=
              (* ❌ Variants not supported *)
              variant in
            run cctxt hosts magic_bytes check_high_watermark require_auth mode)
      end).

src/bin_signer/main_signer.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "signer.main"
end)

let default_tcp_host =
  match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" with
  | None ->
      "localhost"
  | Some host ->
      host

let default_tcp_port =
  match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
  | None ->
      "7732"
  | Some port ->
      port

let default_https_host =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" with
  | None ->
      "localhost"
  | Some host ->
      host

let default_https_port =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
  | None ->
      "443"
  | Some port ->
      port

let default_http_host =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" with
  | None ->
      "localhost"
  | Some host ->
      host

let default_http_port =
  match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
  | None ->
      "6732"
  | Some port ->
      port

open Clic

let group =
  {Clic.name = "signer"; title = "Commands specific to the signing daemon"}

let magic_bytes_arg =
  Clic.arg
    ~doc:"values allowed for the magic bytes, defaults to any"
    ~short:'M'
    ~long:"magic-bytes"
    ~placeholder:"0xHH,0xHH,..."
    (Clic.parameter (fun _ s ->
         try
           return
             (List.map
                (fun s ->
                  let b = int_of_string s in
                  if b < 0 || b > 255 then raise Exit else b)
                (String.split ',' s))
         with _ ->
           failwith
             "Bad format for magic bytes, a series of numbers is expected, \
              separated by commas."))

let high_watermark_switch =
  Clic.switch
    ~doc:
      "high watermark restriction\n\
       Stores the highest level signed for blocks and endorsements for each \
       address, and forbids to sign a level that is inferior or equal \
       afterwards, except for the exact same input data."
    ~short:'W'
    ~long:"check-high-watermark"
    ()

let pidfile_arg =
  arg
    ~doc:"write process id in file"
    ~short:'P'
    ~long:"pidfile"
    ~placeholder:"filename"
    (parameter (fun _ s -> return s))

let may_setup_pidfile = function
  | None ->
      return_unit
  | Some pidfile ->
      trace (failure "Failed to create the pidfile: %s" pidfile)
      @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile

let commands base_dir require_auth : Client_context.full command list =
  Tezos_signer_backends_unix.Ledger.commands ()
  @ Client_keys_commands.commands None
  @ [ command
        ~group
        ~desc:"Launch a signer daemon over a TCP socket."
        (args5
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"listening address or host name"
              ~short:'a'
              ~long:"address"
              ~placeholder:"host|address"
              ~default:default_tcp_host
              (parameter (fun _ s -> return s)))
           (default_arg
              ~doc:"listening TCP port or service name"
              ~short:'p'
              ~long:"port"
              ~placeholder:"port number"
              ~default:default_tcp_port
              (parameter (fun _ s -> return s))))
        (prefixes ["launch"; "socket"; "signer"] @@ stop)
        (fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Socket_daemon.run
            cctxt
            (Tcp (host, port, [AI_SOCKTYPE SOCK_STREAM]))
            ?magic_bytes
            ~check_high_watermark
            ~require_auth
          >>=? fun _ -> return_unit);
      command
        ~group
        ~desc:"Launch a signer daemon over a local Unix socket."
        (args4
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"path to the local socket file"
              ~short:'s'
              ~long:"socket"
              ~placeholder:"path"
              ~default:(Filename.concat base_dir "socket")
              (parameter (fun _ s -> return s))))
        (prefixes ["launch"; "local"; "signer"] @@ stop)
        (fun (pidfile, magic_bytes, check_high_watermark, path) cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Socket_daemon.run
            cctxt
            (Unix path)
            ?magic_bytes
            ~check_high_watermark
            ~require_auth
          >>=? fun _ -> return_unit);
      command
        ~group
        ~desc:"Launch a signer daemon over HTTP."
        (args5
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"listening address or host name"
              ~short:'a'
              ~long:"address"
              ~placeholder:"host|address"
              ~default:default_http_host
              (parameter (fun _ s -> return s)))
           (default_arg
              ~doc:"listening HTTP port"
              ~short:'p'
              ~long:"port"
              ~placeholder:"port number"
              ~default:default_http_port
              (parameter (fun _ x ->
                   try return (int_of_string x)
                   with Failure _ -> failwith "Invalid port %s" x))))
        (prefixes ["launch"; "http"; "signer"] @@ stop)
        (fun (pidfile, magic_bytes, check_high_watermark, host, port) cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Http_daemon.run_http
            cctxt
            ~host
            ~port
            ?magic_bytes
            ~check_high_watermark
            ~require_auth);
      command
        ~group
        ~desc:"Launch a signer daemon over HTTPS."
        (args5
           pidfile_arg
           magic_bytes_arg
           high_watermark_switch
           (default_arg
              ~doc:"listening address or host name"
              ~short:'a'
              ~long:"address"
              ~placeholder:"host|address"
              ~default:default_https_host
              (parameter (fun _ s -> return s)))
           (default_arg
              ~doc:"listening HTTPS port"
              ~short:'p'
              ~long:"port"
              ~placeholder:"port number"
              ~default:default_https_port
              (parameter (fun _ x ->
                   try return (int_of_string x)
                   with Failure _ -> failwith "Invalid port %s" x))))
        ( prefixes ["launch"; "https"; "signer"]
        @@ param
             ~name:"cert"
             ~desc:"path to the TLS certificate"
             (parameter (fun _ s ->
                  if not (Sys.file_exists s) then
                    failwith "No such TLS certificate file %s" s
                  else return s))
        @@ param
             ~name:"key"
             ~desc:"path to the TLS key"
             (parameter (fun _ s ->
                  if not (Sys.file_exists s) then
                    failwith "No such TLS key file %s" s
                  else return s))
        @@ stop )
        (fun (pidfile, magic_bytes, check_high_watermark, host, port)
             cert
             key
             cctxt ->
          may_setup_pidfile pidfile
          >>=? fun () ->
          Tezos_signer_backends.Encrypted.decrypt_all cctxt
          >>=? fun () ->
          Http_daemon.run_https
            cctxt
            ~host
            ~port
            ~cert
            ~key
            ?magic_bytes
            ~check_high_watermark
            ~require_auth);
      command
        ~group
        ~desc:"Authorize a given public key to perform signing requests."
        (args1
           (arg
              ~doc:"an optional name for the key (defaults to the hash)"
              ~short:'N'
              ~long:"name"
              ~placeholder:"name"
              (parameter (fun _ s -> return s))))
        ( prefixes ["add"; "authorized"; "key"]
        @@ param
             ~name:"pk"
             ~desc:"full public key (Base58 encoded)"
             (parameter (fun _ s ->
                  Lwt.return (Signature.Public_key.of_b58check s)))
        @@ stop )
        (fun name key cctxt ->
          let pkh = Signature.Public_key.hash key in
          let name =
            match name with
            | Some name ->
                name
            | None ->
                Signature.Public_key_hash.to_b58check pkh
          in
          Handler.Authorized_key.add ~force:false cctxt name key) ]

let home = try Sys.getenv "HOME" with Not_found -> "/root"

let default_base_dir = Filename.concat home ".tezos-signer"

let string_parameter () : (string, _) parameter =
  parameter (fun _ x -> return x)

let base_dir_arg () =
  arg
    ~long:"base-dir"
    ~short:'d'
    ~placeholder:"path"
    ~doc:
      ( "signer data directory\n\
         The directory where the Tezos client will store all its data.\n\
         By default: '" ^ default_base_dir ^ "'." )
    (string_parameter ())

let require_auth_arg () =
  switch
    ~long:"require-authentication"
    ~short:'A'
    ~doc:"Require a signature from the caller to sign."
    ()

let password_filename_arg () =
  arg
    ~long:"password-file"
    ~short:'f'
    ~placeholder:"filename"
    ~doc:"Absolute path of the password file"
    (string_parameter ())

let global_options () =
  args3 (base_dir_arg ()) (require_auth_arg ()) (password_filename_arg ())

module C = struct
  type t = string option * bool * string option

  let global_options = global_options

  let parse_config_args ctx argv =
    Clic.parse_global_options (global_options ()) ctx argv
    >>=? fun ((base_dir, require_auth, password_filename), remaining) ->
    return
      ( {
          Client_config.default_parsed_config_args with
          base_dir;
          require_auth;
          password_filename;
        },
        remaining )

  let default_chain = Client_config.default_chain

  let default_block = Client_config.default_block

  let default_base_dir = default_base_dir

  let other_registrations = None

  let clic_commands ~base_dir ~config_commands:_ ~builtin_commands:_
      ~other_commands ~require_auth =
    commands base_dir require_auth @ other_commands

  let logger = Some (RPC_client_unix.full_logger Format.err_formatter)
end

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module C)
    ~select_commands:(fun _ _ -> return_nil)
src/bin_signer/main_signer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition default_tcp_host : string :=
  match Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string with
  | None => "localhost" % string
  | Some host => host
  end.

Definition default_tcp_port : string :=
  match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" % string with
  | None => "7732" % string
  | Some port => port
  end.

Definition default_https_host : string :=
  match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string with
  | None => "localhost" % string
  | Some host => host
  end.

Definition default_https_port : string :=
  match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" % string with
  | None => "443" % string
  | Some port => port
  end.

Definition default_http_host : string :=
  match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string with
  | None => "localhost" % string
  | Some host => host
  end.

Definition default_http_port : string :=
  match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" % string with
  | None => "6732" % string
  | Some port => port
  end.

Import Clic.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "signer" % string;
    Clic.title := "Commands specific to the signing daemon" % string |}.

Definition magic_bytes_arg
  : Tezos_base__TzPervasives.Clic.arg (option (list Z))
    Tezos_client_base.Client_context.full :=
  Clic.arg "values allowed for the magic bytes, defaults to any" % string
    (Some "M" % char) "magic-bytes" % string "0xHH,0xHH,..." % string
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try
            (_return
              (List.map
                (fun s =>
                  let b := OCaml.Stdlib.int_of_string s in
                  if orb (OCaml.Stdlib.lt b 0) (OCaml.Stdlib.gt b 255) then
                    Stdlib.raise Exit
                  else
                    b) (String.split "," % char None None s))))).

Definition high_watermark_switch
  : Tezos_base__TzPervasives.Clic.arg bool Tezos_client_base.Client_context.full :=
  Clic.switch
    "high watermark restriction
Stores the highest level signed for blocks and endorsements for each address, and forbids to sign a level that is inferior or equal afterwards, except for the exact same input data."
      % string (Some "W" % char) "check-high-watermark" % string tt.

Definition pidfile_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_base.Client_context.full :=
  arg "write process id in file" % string (Some "P" % char) "pidfile" % string
    "filename" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s => _return s)).

Definition may_setup_pidfile (function_parameter : option string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | None => return_unit
  | Some pidfile =>
    apply
      (trace
        (failure
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Failed to create the pidfile: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Failed to create the pidfile: %s" % string) pidfile))
      (Lwt_lock_file.create None (Some true) pidfile)
  end.

Definition commands (base_dir : string) (require_auth : bool)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  OCaml.Stdlib.app (Tezos_signer_backends_unix.Ledger.commands tt)
    (OCaml.Stdlib.app (Client_keys_commands.commands None)
      (cons
        (command (Some group)
          "Launch a signer daemon over a TCP socket." % string
          (args5 pidfile_arg magic_bytes_arg high_watermark_switch
            (default_arg "listening address or host name" % string
              (Some "a" % char) "address" % string "host|address" % string
              default_tcp_host
              (parameter None
                (fun function_parameter =>
                  let '_ := function_parameter in
                  fun s => _return s)))
            (default_arg "listening TCP port or service name" % string
              (Some "p" % char) "port" % string "port number" % string
              default_tcp_port
              (parameter None
                (fun function_parameter =>
                  let '_ := function_parameter in
                  fun s => _return s))))
          (apply
            (prefixes
              (cons "launch" % string
                (cons "socket" % string (cons "signer" % string [])))) stop)
          (fun function_parameter =>
            let '(pidfile, magic_bytes, check_high_watermark, host, port) :=
              function_parameter in
            fun cctxt =>
              op_gtgteqquestion (may_setup_pidfile pidfile)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (Socket_daemon.run cctxt
                          (Tezos_stdlib_unix.Lwt_utils_unix.Socket.Tcp host port
                            (cons (Unix.AI_SOCKTYPE Unix.SOCK_STREAM) []))
                          magic_bytes check_high_watermark require_auth)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          return_unit)))))
        (cons
          (command (Some group)
            "Launch a signer daemon over a local Unix socket." % string
            (args4 pidfile_arg magic_bytes_arg high_watermark_switch
              (default_arg "path to the local socket file" % string
                (Some "s" % char) "socket" % string "path" % string
                (Filename.concat base_dir "socket" % string)
                (parameter None
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    fun s => _return s))))
            (apply
              (prefixes
                (cons "launch" % string
                  (cons "local" % string (cons "signer" % string [])))) stop)
            (fun function_parameter =>
              let '(pidfile, magic_bytes, check_high_watermark, path) :=
                function_parameter in
              fun cctxt =>
                op_gtgteqquestion (may_setup_pidfile pidfile)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion
                      (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (Socket_daemon.run cctxt
                            (Tezos_stdlib_unix.Lwt_utils_unix.Socket.Unix path)
                            magic_bytes check_high_watermark require_auth)
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            return_unit)))))
          (cons
            (command (Some group) "Launch a signer daemon over HTTP." % string
              (args5 pidfile_arg magic_bytes_arg high_watermark_switch
                (default_arg "listening address or host name" % string
                  (Some "a" % char) "address" % string "host|address" % string
                  default_http_host
                  (parameter None
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      fun s => _return s)))
                (default_arg "listening HTTP port" % string (Some "p" % char)
                  "port" % string "port number" % string default_http_port
                  (parameter None
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      fun x =>
                        (* ❌ Try-with are not handled *)
                        try (_return (OCaml.Stdlib.int_of_string x))))))
              (apply
                (prefixes
                  (cons "launch" % string
                    (cons "http" % string (cons "signer" % string [])))) stop)
              (fun function_parameter =>
                let '(pidfile, magic_bytes, check_high_watermark, host, port) :=
                  function_parameter in
                fun cctxt =>
                  op_gtgteqquestion (may_setup_pidfile pidfile)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Http_daemon.run_http cctxt host port magic_bytes
                            check_high_watermark require_auth))))
            (cons
              (command (Some group)
                "Launch a signer daemon over HTTPS." % string
                (args5 pidfile_arg magic_bytes_arg high_watermark_switch
                  (default_arg "listening address or host name" % string
                    (Some "a" % char) "address" % string "host|address" % string
                    default_https_host
                    (parameter None
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        fun s => _return s)))
                  (default_arg "listening HTTPS port" % string (Some "p" % char)
                    "port" % string "port number" % string default_https_port
                    (parameter None
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        fun x =>
                          (* ❌ Try-with are not handled *)
                          try (_return (OCaml.Stdlib.int_of_string x))))))
                (apply
                  (prefixes
                    (cons "launch" % string
                      (cons "https" % string (cons "signer" % string []))))
                  (apply
                    (param "cert" % string
                      "path to the TLS certificate" % string
                      (parameter None
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          fun s =>
                            if negb (Sys.file_exists s) then
                              failwith
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "No such TLS certificate file " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.End_of_format))
                                  "No such TLS certificate file %s" % string) s
                            else
                              _return s)))
                    (apply
                      (param "key" % string "path to the TLS key" % string
                        (parameter None
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            fun s =>
                              if negb (Sys.file_exists s) then
                                failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "No such TLS key file " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "No such TLS key file %s" % string) s
                              else
                                _return s))) stop)))
                (fun function_parameter =>
                  let
                    '(pidfile, magic_bytes, check_high_watermark, host, port) :=
                    function_parameter in
                  fun cert =>
                    fun key =>
                      fun cctxt =>
                        op_gtgteqquestion (may_setup_pidfile pidfile)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Tezos_signer_backends.Encrypted.decrypt_all cctxt)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                Http_daemon.run_https cctxt host port cert key
                                  magic_bytes check_high_watermark require_auth))))
              (cons
                (command (Some group)
                  "Authorize a given public key to perform signing requests." %
                    string
                  (args1
                    (arg
                      "an optional name for the key (defaults to the hash)" %
                        string (Some "N" % char) "name" % string "name" % string
                      (parameter None
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          fun s => _return s))))
                  (apply
                    (prefixes
                      (cons "add" % string
                        (cons "authorized" % string (cons "key" % string []))))
                    (apply
                      (param "pk" % string
                        "full public key (Base58 encoded)" % string
                        (parameter None
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            fun s =>
                              Lwt._return (Signature.Public_key.of_b58check s))))
                      stop))
                  (fun name =>
                    fun key =>
                      fun cctxt =>
                        let pkh := Signature.Public_key.hash key in
                        let name :=
                          match name with
                          | Some name => name
                          | None => Signature.Public_key_hash.to_b58check pkh
                          end in
                        Handler.Authorized_key.add false cctxt name key)) [])))))).

Definition home : string :=
  (* ❌ Try-with are not handled *)
  try (Sys.getenv "HOME" % string).

Definition default_base_dir : string :=
  Filename.concat home ".tezos-signer" % string.

Definition string_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter string A :=
  let 'tt := function_parameter in
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun x => _return x).

Definition base_dir_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  let 'tt := function_parameter in
  arg
    (String.append
      "signer data directory
The directory where the Tezos client will store all its data.
By default: '"
        % string (String.append default_base_dir "'." % string))
    (Some "d" % char) "base-dir" % string "path" % string (string_parameter tt).

Definition require_auth_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  let 'tt := function_parameter in
  switch "Require a signature from the caller to sign." % string
    (Some "A" % char) "require-authentication" % string tt.

Definition password_filename_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  let 'tt := function_parameter in
  arg "Absolute path of the password file" % string (Some "f" % char)
    "password-file" % string "filename" % string (string_parameter tt).

Definition global_options {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.options
    ((option string) * bool * (option string)) A :=
  let 'tt := function_parameter in
  args3 (base_dir_arg tt) (require_auth_arg tt) (password_filename_arg tt).

Module C.
  Definition t := (option string) * bool * (option string).
  
  Definition global_options {A : Type}
    : unit ->
      Tezos_base__TzPervasives.Clic.options
        ((option string) * bool * (option string)) A := global_options.
  
  Definition parse_config_args {A : Type} (ctx : A) (argv : list string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_client_base_unix.Client_config.parsed_config_args * (list string))) :=
    op_gtgteqquestion (Clic.parse_global_options (global_options tt) ctx argv)
      (fun function_parameter =>
        let '((base_dir, require_auth, password_filename), remaining) :=
          function_parameter in
        _return
          ((* ❌ Record substitution not handled *)
          record_substitution, remaining)).
  
  Definition default_chain : variant := Client_config.default_chain.
  
  Definition default_block : variant := Client_config.default_block.
  
  Definition default_base_dir : string := default_base_dir.
  
  Definition other_registrations {A : Type} : option A := None.
  
  Definition clic_commands {A B : Type}
    (base_dir : string) (function_parameter : A)
    : B ->
      (list
        (Tezos_base__TzPervasives.Clic.command
          Tezos_client_base.Client_context.full)) ->
        bool ->
          list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full) :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      fun other_commands =>
        fun require_auth =>
          OCaml.Stdlib.app (commands base_dir require_auth) other_commands.
  
  Definition logger
    : option Tezos_rpc_http_client_unix.RPC_client_unix.logger :=
    Some (RPC_client_unix.full_logger Format.err_formatter).
End C.



src/bin_signer/signer_logging.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "client.signer"
end)

let host_name = Tag.def ~doc:"Host name" "host" Format.pp_print_text

let service_name = Tag.def ~doc:"Service name" "service" Format.pp_print_text

let port_number = Tag.def ~doc:"Port number" "port" Format.pp_print_int

let magic_byte = Tag.def ~doc:"Magic byte" "magic_byte" Format.pp_print_int

let num_bytes = Tag.def ~doc:"Number of bytes" "num_bytes" Format.pp_print_int

let unix_socket_path =
  Tag.def ~doc:"UNIX socket file path" "unix_socket" Format.pp_print_text
src/bin_signer/signer_logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition host_name : Tag.def string :=
  Tag.def (Some "Host name" % string) "host" % string Format.pp_print_text.

Definition service_name : Tag.def string :=
  Tag.def (Some "Service name" % string) "service" % string Format.pp_print_text.

Definition port_number : Tag.def Z :=
  Tag.def (Some "Port number" % string) "port" % string Format.pp_print_int.

Definition magic_byte : Tag.def Z :=
  Tag.def (Some "Magic byte" % string) "magic_byte" % string Format.pp_print_int.

Definition num_bytes : Tag.def Z :=
  Tag.def (Some "Number of bytes" % string) "num_bytes" % string
    Format.pp_print_int.

Definition unix_socket_path : Tag.def string :=
  Tag.def (Some "UNIX socket file path" % string) "unix_socket" % string
    Format.pp_print_text.

src/bin_signer/socket_daemon.ml 56 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Signer_logging
open Signer_messages

let log = lwt_log_notice

let handle_client ?magic_bytes ~check_high_watermark ~require_auth cctxt fd =
  Lwt_utils_unix.Socket.recv fd Request.encoding
  >>=? function
  | Sign req ->
      let encoding = result_encoding Sign.Response.encoding in
      Handler.sign cctxt req ?magic_bytes ~check_high_watermark ~require_auth
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Deterministic_nonce req ->
      let encoding = result_encoding Deterministic_nonce.Response.encoding in
      Handler.deterministic_nonce cctxt req ~require_auth
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Deterministic_nonce_hash req ->
      let encoding =
        result_encoding Deterministic_nonce_hash.Response.encoding
      in
      Handler.deterministic_nonce_hash cctxt req ~require_auth
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Supports_deterministic_nonces req ->
      let encoding =
        result_encoding Supports_deterministic_nonces.Response.encoding
      in
      Handler.supports_deterministic_nonces cctxt req
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Public_key pkh ->
      let encoding = result_encoding Public_key.Response.encoding in
      Handler.public_key cctxt pkh
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit
  | Authorized_keys ->
      let encoding = result_encoding Authorized_keys.Response.encoding in
      ( if require_auth then
        Handler.Authorized_key.load cctxt
        >>=? fun keys ->
        return
          (Authorized_keys.Response.Authorized_keys
             (keys |> List.split |> snd |> List.map Signature.Public_key.hash))
      else return Authorized_keys.Response.No_authentication )
      >>= fun res ->
      Lwt_utils_unix.Socket.send fd encoding res
      >>= fun _ -> Lwt_unix.close fd >>= fun () -> return_unit

let run (cctxt : #Client_context.wallet) path ?magic_bytes
    ~check_high_watermark ~require_auth =
  let open Lwt_utils_unix.Socket in
  ( match path with
  | Tcp (host, service, _opts) ->
      log
        Tag.DSL.(
          fun f ->
            f "Accepting TCP requests on %s:%s"
            -% t event "accepting_tcp_requests"
            -% s host_name host -% s service_name service)
  | Unix path ->
      ListLabels.iter
        Sys.[sigint; sigterm]
        ~f:(fun signal ->
          Sys.set_signal
            signal
            (Signal_handle
               (fun _ ->
                 Format.printf "Removing the local socket file and quitting.@." ;
                 Unix.unlink path ;
                 exit 0))) ;
      log
        Tag.DSL.(
          fun f ->
            f "Accepting UNIX requests on %s"
            -% t event "accepting_unix_requests"
            -% s unix_socket_path path) )
  >>= fun () ->
  bind path
  >>=? fun fds ->
  let rec loop fd =
    Lwt_unix.accept fd
    >>= fun (cfd, _) ->
    Lwt.async (fun () ->
        protect
          ~on_error:(function
            | Exn End_of_file :: _ ->
                return_unit
            | errs ->
                Lwt.return_error errs)
          (fun () ->
            handle_client
              ?magic_bytes
              ~check_high_watermark
              ~require_auth
              cctxt
              cfd)) ;
    loop fd
  in
  Lwt_list.map_p loop fds >>= return
src/bin_signer/socket_daemon.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Signer_logging.

Import Signer_messages.

Definition log {A : Type}
  : Tezos_base__TzPervasives.Internal_event.Legacy_logging.log A (Lwt.t unit) :=
  lwt_log_notice.

Definition handle_client {B a : Type}
  (magic_bytes : option (list Z)) (check_high_watermark : bool)
  (require_auth : bool)
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (fd : Lwt_unix.file_descr)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (Lwt_utils_unix.Socket.recv fd Request.encoding)
    (fun function_parameter =>
      match function_parameter with
      | Tezos_signer_services.Signer_messages.Request.Sign req =>
        let encoding := result_encoding Sign.Response.encoding in
        op_gtgteq
          (Handler.sign cctxt req magic_bytes check_high_watermark require_auth)
          (fun res =>
            op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq (Lwt_unix.close fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      | Tezos_signer_services.Signer_messages.Request.Deterministic_nonce req =>
        let encoding := result_encoding Deterministic_nonce.Response.encoding in
        op_gtgteq (Handler.deterministic_nonce cctxt req require_auth)
          (fun res =>
            op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq (Lwt_unix.close fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      |
        Tezos_signer_services.Signer_messages.Request.Deterministic_nonce_hash
          req =>
        let encoding :=
          result_encoding Deterministic_nonce_hash.Response.encoding in
        op_gtgteq (Handler.deterministic_nonce_hash cctxt req require_auth)
          (fun res =>
            op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq (Lwt_unix.close fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      |
        Tezos_signer_services.Signer_messages.Request.Supports_deterministic_nonces
          req =>
        let encoding :=
          result_encoding Supports_deterministic_nonces.Response.encoding in
        op_gtgteq (Handler.supports_deterministic_nonces cctxt req)
          (fun res =>
            op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq (Lwt_unix.close fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      | Tezos_signer_services.Signer_messages.Request.Public_key pkh =>
        let encoding := result_encoding Public_key.Response.encoding in
        op_gtgteq (Handler.public_key cctxt pkh)
          (fun res =>
            op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq (Lwt_unix.close fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      | Tezos_signer_services.Signer_messages.Request.Authorized_keys =>
        let encoding := result_encoding Authorized_keys.Response.encoding in
        op_gtgteq
          (if require_auth then
            op_gtgteqquestion (Handler.Authorized_key.load cctxt)
              (fun keys =>
                _return
                  (Tezos_signer_services.Signer_messages.Authorized_keys.Response.Authorized_keys
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply keys List.split) snd)
                      (List.map Signature.Public_key.hash))))
          else
            _return
              Tezos_signer_services.Signer_messages.Authorized_keys.Response.No_authentication)
          (fun res =>
            op_gtgteq (Lwt_utils_unix.Socket.send fd encoding res)
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq (Lwt_unix.close fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      end).

Definition run {B C a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (path : Tezos_stdlib_unix.Lwt_utils_unix.Socket.addr)
  (magic_bytes : option (list Z)) (check_high_watermark : bool)
  (require_auth : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult (list C)) :=
  op_gtgteq
    match path with
    | Tezos_stdlib_unix.Lwt_utils_unix.Socket.Tcp host service _opts =>
      log
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Accepting TCP requests on " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal ":" % char
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format))))
                    "Accepting TCP requests on %s:%s" % string))
                (t event "accepting_tcp_requests" % string)) (s host_name host))
            (s service_name service))
    | Tezos_stdlib_unix.Lwt_utils_unix.Socket.Unix path =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        ListLabels.iter
          (fun signal =>
            Sys.set_signal signal
              (Stdlib.Sys.Signal_handle
                (fun function_parameter =>
                  let '_ := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Format.printf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Removing the local socket file and quitting." %
                            string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))
                        "Removing the local socket file and quitting.@." %
                          string) in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := Unix.unlink path in
                  Stdlib.exit 0))) (cons sigint (cons sigterm [])) in
      log
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Accepting UNIX requests on " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "Accepting UNIX requests on %s" % string))
              (t event "accepting_unix_requests" % string))
            (s unix_socket_path path))
    end
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (bind None path)
        (fun fds =>
          let fix loop {D : Type} (fd : Lwt_unix.file_descr) : Lwt.t D :=
            op_gtgteq (Lwt_unix.accept fd)
              (fun function_parameter =>
                let '(cfd, _) := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Lwt.async
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      protect
                        (Some
                          (fun function_parameter =>
                            match function_parameter with
                            |
                              cons
                                (Tezos_base__TzPervasives.Exn OCaml.End_of_file)
                                _ => return_unit
                            | errs => Lwt.return_error errs
                            end)) None
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          handle_client magic_bytes check_high_watermark
                            require_auth cctxt cfd)) in
                loop fd) in
          op_gtgteq (Lwt_list.map_p loop fds) _return)).

src/bin_validation/main_validator.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () = Pervasives.exit (Lwt_main.run @@ Validator.main ())
src/bin_validation/main_validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/bin_validation/validator.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

let load_protocol proto protocol_root =
  if Registered_protocol.mem proto then return_unit
  else
    let cmxs_file =
      protocol_root
      // Protocol_hash.to_short_b58check proto
      // Format.asprintf "protocol_%a" Protocol_hash.pp proto
    in
    try
      Dynlink.loadfile_private (cmxs_file ^ ".cmxs") ;
      return_unit
    with Dynlink.Error err ->
      Format.ksprintf
        (fun msg ->
          fail
            Block_validator_errors.(
              Validation_process_failed (Protocol_dynlink_failure msg)))
        "Cannot load file: %s. (Expected location: %s.)"
        (Dynlink.error_message err)
        cmxs_file

let inconsistent_handshake msg =
  Block_validator_errors.(
    Validation_process_failed (Inconsistent_handshake msg))

let run stdin stdout =
  External_validation.recv stdin Data_encoding.Variable.bytes
  >>= fun magic ->
  fail_when
    (not (Bytes.equal magic External_validation.magic))
    (inconsistent_handshake "bad magic")
  >>=? fun () ->
  External_validation.recv stdin External_validation.parameters_encoding
  >>= fun {context_root; protocol_root; sandbox_parameters} ->
  let genesis_block = ref Block_hash.zero in
  let genesis_time = ref Time.Protocol.epoch in
  let genesis_protocol = ref Protocol_hash.zero in
  let sandbox_param =
    Option.map ~f:(fun p -> ("sandbox_parameter", p)) sandbox_parameters
  in
  let patch_context ctxt =
    ( match sandbox_param with
    | None ->
        Lwt.return ctxt
    | Some (key, json) ->
        Tezos_storage.Context.set
          ctxt
          [key]
          (Data_encoding.Binary.to_bytes_exn Data_encoding.json json) )
    >>= fun ctxt ->
    match Registered_protocol.get !genesis_protocol with
    | None ->
        assert false (* FIXME error *)
    | Some proto -> (
        let module Proto = (val proto) in
        let ctxt = Shell_context.wrap_disk_context ctxt in
        Proto.init
          ctxt
          {
            level = 0l;
            proto_level = 0;
            predecessor = !genesis_block;
            timestamp = !genesis_time;
            validation_passes = 0;
            operations_hash = Operation_list_list_hash.empty;
            fitness = [];
            context = Context_hash.zero;
          }
        >>= function
        | Error _ ->
            assert false (* FIXME error *)
        | Ok {context; _} ->
            let context = Shell_context.unwrap_disk_context context in
            Lwt.return context )
  in
  Context.init ~patch_context context_root
  >>= fun context_index ->
  let rec loop () =
    External_validation.recv stdin External_validation.request_encoding
    >>= (function
          | External_validation.Validate
              { chain_id;
                block_header;
                predecessor_block_header;
                operations;
                max_operations_ttl } ->
              Error_monad.protect (fun () ->
                  let pred_context_hash =
                    predecessor_block_header.shell.context
                  in
                  Context.checkout context_index pred_context_hash
                  >>= function
                  | Some context ->
                      return context
                  | None ->
                      fail
                        (Block_validator_errors.Failed_to_checkout_context
                           pred_context_hash))
              >>=? (fun predecessor_context ->
                     Context.get_protocol predecessor_context
                     >>= fun protocol_hash ->
                     load_protocol protocol_hash protocol_root
                     >>=? fun () ->
                     Block_validation.apply
                       chain_id
                       ~max_operations_ttl
                       ~predecessor_block_header
                       ~predecessor_context
                       ~block_header
                       operations
                     >>= function
                     | Error
                         [ Block_validator_errors.Unavailable_protocol
                             {protocol; _} ] as err -> (
                         (* If `next_protocol` is missing, try to load it *)
                         load_protocol protocol protocol_root
                         >>= function
                         | Error _ ->
                             Lwt.return err
                         | Ok () ->
                             Block_validation.apply
                               chain_id
                               ~max_operations_ttl
                               ~predecessor_block_header
                               ~predecessor_context
                               ~block_header
                               operations )
                     | result ->
                         Lwt.return result)
              >>= fun res ->
              External_validation.send
                stdout
                (Error_monad.result_encoding Block_validation.result_encoding)
                res
          | External_validation.Commit_genesis
              {chain_id; time; genesis_hash; protocol} ->
              genesis_time := time ;
              genesis_block := genesis_hash ;
              genesis_protocol := protocol ;
              Error_monad.protect (fun () ->
                  Context.commit_genesis
                    context_index
                    ~chain_id
                    ~time
                    ~protocol
                  >>= fun commit -> return commit)
              >>= fun commit ->
              External_validation.send
                stdout
                (Error_monad.result_encoding Context_hash.encoding)
                commit
          | External_validation.Init ->
              External_validation.send
                stdout
                (Error_monad.result_encoding Data_encoding.empty)
                (Ok ())
          | External_validation.Fork_test_chain {context_hash; forked_header}
            -> (
              Context.checkout context_index context_hash
              >>= function
              | Some ctxt ->
                  Block_validation.init_test_chain ctxt forked_header
                  >>= (function
                        | Error
                            [ Block_validator_errors.Missing_test_protocol
                                protocol ] ->
                            load_protocol protocol protocol_root
                            >>=? fun () ->
                            Block_validation.init_test_chain ctxt forked_header
                        | result ->
                            Lwt.return result)
                  >>= fun result ->
                  External_validation.send
                    stdout
                    (Error_monad.result_encoding Block_header.encoding)
                    result
              | None ->
                  External_validation.send
                    stdout
                    (Error_monad.result_encoding Data_encoding.empty)
                    (error
                       (Block_validator_errors.Failed_to_checkout_context
                          context_hash)) )
          | External_validation.Terminate ->
              Lwt_io.flush_all () >>= fun () -> exit 0)
    >>= fun () -> loop ()
  in
  loop ()

let main () =
  let stdin = Lwt_io.of_fd ~mode:Input Lwt_unix.stdin in
  let stdout = Lwt_io.of_fd ~mode:Output Lwt_unix.stdout in
  Lwt.catch
    (fun () -> run stdin stdout >>=? fun () -> return 0)
    (fun e -> Lwt.return (error_exn e))
  >>= function
  | Ok v ->
      Lwt.return v
  | Error _ as errs ->
      External_validation.send
        stdout
        (Error_monad.result_encoding Data_encoding.unit)
        errs
      >>= fun () -> Lwt.return 1
src/bin_validation/validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition load_protocol
  (proto : Tezos_base__TzPervasives.Protocol_hash.t) (protocol_root : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Registered_protocol.mem proto then
    return_unit
  else
    let cmxs_file :=
      op_divdiv
        (op_divdiv protocol_root (Protocol_hash.to_short_b58check proto))
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "protocol_" % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
          Protocol_hash.pp proto) in
    (* ❌ Try-with are not handled *)
    try
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (let _ :=
        Dynlink.loadfile_private (String.append cmxs_file ".cmxs" % string) in
      return_unit).

Definition inconsistent_handshake (msg : string)
  : Tezos_base__TzPervasives.error :=
  Tezos_base__TzPervasives.Validation_process_failed
    (Tezos_shell_services.Block_validator_errors.Inconsistent_handshake msg).

Definition run {A : Type}
  (stdin : Lwt_io.input_channel) (stdout : Lwt_io.output_channel)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  op_gtgteq (External_validation.recv stdin Data_encoding.Variable.bytes)
    (fun magic =>
      op_gtgteqquestion
        (fail_when (negb (Stdlib.Bytes.equal magic External_validation.magic))
          (inconsistent_handshake "bad magic" % string))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (External_validation.recv stdin
              External_validation.parameters_encoding)
            (fun function_parameter =>
              let '{|
                context_root := context_root;
                  protocol_root := protocol_root;
                  sandbox_parameters := sandbox_parameters
                  |} := function_parameter in
              let genesis_block := Stdlib.ref Block_hash.zero in
              let genesis_time := Stdlib.ref Time.Protocol.epoch in
              let genesis_protocol := Stdlib.ref Protocol_hash.zero in
              let sandbox_param :=
                Option.map (fun p => ("sandbox_parameter" % string, p))
                  sandbox_parameters in
              let patch_context (ctxt : Tezos_storage.Context.context)
                : Lwt.t Tezos_storage.Context.t :=
                op_gtgteq
                  match sandbox_param with
                  | None => Lwt._return ctxt
                  | Some (key, json) =>
                    Tezos_storage.Context.set ctxt (cons key [])
                      (Data_encoding.Binary.to_bytes_exn Data_encoding.json json)
                  end
                  (fun ctxt =>
                    match
                      Registered_protocol.get
                        (Stdlib.op_exclamation genesis_protocol) with
                    | None =>
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    | Some proto =>
                      let Proto := projT2 proto in
                      let ctxt := Shell_context.wrap_disk_context ctxt in
                      op_gtgteq
                        (Proto.(Tezos_protocol_updater__Registered_protocol.T.init)
                          ctxt
                          {|
                            level :=
                              (* ❌ Constant of type int32 is converted to int *)
                              0; proto_level := 0;
                            predecessor := Stdlib.op_exclamation genesis_block;
                            timestamp := Stdlib.op_exclamation genesis_time;
                            validation_passes := 0;
                            operations_hash := Operation_list_list_hash.empty;
                            fitness := []; context := Context_hash.zero |})
                        (fun function_parameter =>
                          match function_parameter with
                          | Stdlib.Error _ =>
                            (* ❌ Assert instruction is not handled. *)
                            assert false
                          | Stdlib.Ok {| context := context |} =>
                            let context :=
                              Shell_context.unwrap_disk_context context in
                            Lwt._return context
                          end)
                    end) in
              op_gtgteq
                (Context.init (Some patch_context) None None context_root)
                (fun context_index =>
                  let fix loop {B : Type} (function_parameter : unit)
                    : Lwt.t B :=
                    let 'tt := function_parameter in
                    op_gtgteq
                      (op_gtgteq
                        (External_validation.recv stdin
                          External_validation.request_encoding)
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_validation.External_validation.Validate {|
                              chain_id := chain_id;
                                block_header := block_header;
                                predecessor_block_header :=
                                  predecessor_block_header;
                                operations := operations;
                                max_operations_ttl := max_operations_ttl
                                |} =>
                            op_gtgteq
                              (op_gtgteqquestion
                                (Error_monad.protect None None
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    let pred_context_hash :=
                                      context (shell predecessor_block_header)
                                      in
                                    op_gtgteq
                                      (Context.checkout context_index
                                        pred_context_hash)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | Some context => _return context
                                        | None =>
                                          fail
                                            (Tezos_base__TzPervasives.Failed_to_checkout_context
                                              pred_context_hash)
                                        end)))
                                (fun predecessor_context =>
                                  op_gtgteq
                                    (Context.get_protocol predecessor_context)
                                    (fun protocol_hash =>
                                      op_gtgteqquestion
                                        (load_protocol protocol_hash
                                          protocol_root)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (Block_validation.apply chain_id
                                              max_operations_ttl
                                              predecessor_block_header
                                              predecessor_context block_header
                                              operations)
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                (Stdlib.Error
                                                  (cons
                                                    (Tezos_base__TzPervasives.Unavailable_protocol
                                                      {| protocol := protocol |})
                                                    [])) as err =>
                                                op_gtgteq
                                                  (load_protocol protocol
                                                    protocol_root)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | Stdlib.Error _ =>
                                                      Lwt._return err
                                                    | Stdlib.Ok tt =>
                                                      Block_validation.apply
                                                        chain_id
                                                        max_operations_ttl
                                                        predecessor_block_header
                                                        predecessor_context
                                                        block_header operations
                                                    end)
                                              | result => Lwt._return result
                                              end)))))
                              (fun res =>
                                External_validation.send stdout
                                  (Error_monad.result_encoding
                                    Block_validation.result_encoding) res)
                          |
                            Tezos_validation.External_validation.Commit_genesis
                              {|
                              chain_id := chain_id;
                                genesis_hash := genesis_hash;
                                time := time;
                                protocol := protocol
                                |} =>
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := Stdlib.op_coloneq genesis_time time in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              Stdlib.op_coloneq genesis_block genesis_hash in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := Stdlib.op_coloneq genesis_protocol protocol
                              in
                            op_gtgteq
                              (Error_monad.protect None None
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (Context.commit_genesis context_index
                                      chain_id time protocol)
                                    (fun commit => _return commit)))
                              (fun commit =>
                                External_validation.send stdout
                                  (Error_monad.result_encoding
                                    Context_hash.encoding) commit)
                          | Tezos_validation.External_validation.Init =>
                            External_validation.send stdout
                              (Error_monad.result_encoding Data_encoding.empty)
                              (Stdlib.Ok tt)
                          |
                            Tezos_validation.External_validation.Fork_test_chain
                              {|
                              context_hash := context_hash;
                                forked_header := forked_header
                                |} =>
                            op_gtgteq
                              (Context.checkout context_index context_hash)
                              (fun function_parameter =>
                                match function_parameter with
                                | Some ctxt =>
                                  op_gtgteq
                                    (op_gtgteq
                                      (Block_validation.init_test_chain ctxt
                                        forked_header)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          Stdlib.Error
                                            (cons
                                              (Tezos_base__TzPervasives.Missing_test_protocol
                                                protocol) []) =>
                                          op_gtgteqquestion
                                            (load_protocol protocol
                                              protocol_root)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              Block_validation.init_test_chain
                                                ctxt forked_header)
                                        | result => Lwt._return result
                                        end))
                                    (fun result =>
                                      External_validation.send stdout
                                        (Error_monad.result_encoding
                                          Block_header.encoding) result)
                                | None =>
                                  External_validation.send stdout
                                    (Error_monad.result_encoding
                                      Data_encoding.empty)
                                    (error
                                      (Tezos_base__TzPervasives.Failed_to_checkout_context
                                        context_hash))
                                end)
                          | Tezos_validation.External_validation.Terminate =>
                            op_gtgteq (Lwt_io.flush_all tt)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                Stdlib.exit 0)
                          end))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        loop tt) in
                  loop tt)))).

Definition main (function_parameter : unit) : Lwt.t Z :=
  let 'tt := function_parameter in
  let stdin := Lwt_io.of_fd None None Lwt_io.Input Lwt_unix.stdin in
  let stdout := Lwt_io.of_fd None None Lwt_io.Output Lwt_unix.stdout in
  op_gtgteq
    (Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion (run stdin stdout)
          (fun function_parameter =>
            let 'tt := function_parameter in
            _return 0)) (fun e => Lwt._return (error_exn e)))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok v => Lwt._return v
      | (Stdlib.Error _) as errs =>
        op_gtgteq
          (External_validation.send stdout
            (Error_monad.result_encoding Data_encoding.unit) errs)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt._return 1)
      end).

src/lib_base/base_logging.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "base"
end)

let pp_exn_trace ppf backtrace =
  if String.length backtrace <> 0 then
    Format.fprintf
      ppf
      "@,Backtrace:@,  @[<h>%a@]"
      Format.pp_print_text
      backtrace

let pid =
  Tag.def
    ~doc:"unix process ID where problem occurred"
    "pid"
    Format.pp_print_int

let exn_trace =
  Tag.def ~doc:"backtrace from native Ocaml exception" "exn_trace" pp_exn_trace
src/lib_base/base_logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition pp_exn_trace (ppf : Stdlib.Format.formatter) (backtrace : string)
  : unit :=
  if nequiv_decb (OCaml.String.length backtrace) 0 then
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@," % string 0 0)
          (CamlinternalFormatBasics.String_literal "Backtrace:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "  " % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<h>" % string
                        CamlinternalFormatBasics.End_of_format) "<h>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))))
        "@,Backtrace:@,  @[<h>%a@]" % string) Format.pp_print_text backtrace
  else
    tt.

Definition pid : Tag.def Z :=
  Tag.def (Some "unix process ID where problem occurred" % string)
    "pid" % string Format.pp_print_int.

Definition exn_trace : Tag.def string :=
  Tag.def (Some "backtrace from native Ocaml exception" % string)
    "exn_trace" % string pp_exn_trace.

src/lib_base/block_header.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type shell_header = {
  level : Int32.t;
  proto_level : int;
  (* uint8 *)
  predecessor : Block_hash.t;
  timestamp : Time.Protocol.t;
  validation_passes : int;
  (* uint8 *)
  operations_hash : Operation_list_list_hash.t;
  fitness : Fitness.t;
  context : Context_hash.t;
}

let shell_header_encoding =
  let open Data_encoding in
  def
    "block_header.shell"
    ~title:"Shell header"
    ~description:
      "Block header's shell-related content. It contains information such as \
       the block level, its predecessor and timestamp."
  @@ conv
       (fun { level;
              proto_level;
              predecessor;
              timestamp;
              validation_passes;
              operations_hash;
              fitness;
              context } ->
         ( level,
           proto_level,
           predecessor,
           timestamp,
           validation_passes,
           operations_hash,
           fitness,
           context ))
       (fun ( level,
              proto_level,
              predecessor,
              timestamp,
              validation_passes,
              operations_hash,
              fitness,
              context ) ->
         {
           level;
           proto_level;
           predecessor;
           timestamp;
           validation_passes;
           operations_hash;
           fitness;
           context;
         })
       (obj8
          (req "level" int32)
          (req "proto" uint8)
          (req "predecessor" Block_hash.encoding)
          (req "timestamp" Time.Protocol.encoding)
          (req "validation_pass" uint8)
          (req "operations_hash" Operation_list_list_hash.encoding)
          (req "fitness" Fitness.encoding)
          (req "context" Context_hash.encoding))

type t = {shell : shell_header; protocol_data : Bytes.t}

include Compare.Make (struct
  type nonrec t = t

  let compare b1 b2 =
    let ( >> ) x y = if x = 0 then y () else x in
    let rec list compare xs ys =
      match (xs, ys) with
      | ([], []) ->
          0
      | (_ :: _, []) ->
          -1
      | ([], _ :: _) ->
          1
      | (x :: xs, y :: ys) ->
          compare x y >> fun () -> list compare xs ys
    in
    Block_hash.compare b1.shell.predecessor b2.shell.predecessor
    >> fun () ->
    compare b1.protocol_data b2.protocol_data
    >> fun () ->
    Operation_list_list_hash.compare
      b1.shell.operations_hash
      b2.shell.operations_hash
    >> fun () ->
    Time.Protocol.compare b1.shell.timestamp b2.shell.timestamp
    >> fun () -> list compare b1.shell.fitness b2.shell.fitness
end)

let encoding =
  let open Data_encoding in
  def
    "block_header"
    ~title:"Block header"
    ~description:
      "Block header. It contains both shell and protocol specific data."
  @@ conv
       (fun {shell; protocol_data} -> (shell, protocol_data))
       (fun (shell, protocol_data) -> {shell; protocol_data})
       (merge_objs
          shell_header_encoding
          (obj1 (req "protocol_data" Variable.bytes)))

let bounded_encoding ?max_size () =
  match max_size with
  | None ->
      encoding
  | Some max_size ->
      Data_encoding.check_size max_size encoding

let pp ppf op =
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b

let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b

let to_b58check v = Base58.safe_encode (Bytes.to_string (to_bytes v))

let of_b58check b =
  Option.apply (Base58.safe_decode b) ~f:(fun s ->
      Data_encoding.Binary.of_bytes encoding (Bytes.of_string s))

let hash block = Block_hash.hash_bytes [to_bytes block]

let hash_raw bytes = Block_hash.hash_bytes [bytes]

let forced_protocol_upgrades : (Int32.t * Protocol_hash.t) list =
  [ (* nothing *) ]

let voted_protocol_overrides : (Protocol_hash.t * Protocol_hash.t) list =
  List.map
    (fun (a, b) ->
      (Protocol_hash.of_b58check_exn a, Protocol_hash.of_b58check_exn b))
    [ (* nothing *) ]

module LevelMap = Map.Make (struct
  type t = Int32.t

  let compare = Int32.compare
end)

let get_forced_protocol_upgrade =
  let table =
    List.fold_left
      (fun map (level, hash) -> LevelMap.add level hash map)
      LevelMap.empty
      forced_protocol_upgrades
  in
  fun ~level -> LevelMap.find_opt level table

let get_voted_protocol_overrides proto_hash =
  List.assoc_opt proto_hash voted_protocol_overrides

let () =
  Data_encoding.Registration.register shell_header_encoding ;
  Data_encoding.Registration.register encoding
src/lib_base/block_header.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record shell_header := {
  level : Stdlib.Int32.t;
  proto_level : Z;
  predecessor : Tezos_crypto.Block_hash.t;
  timestamp : Tezos_base.Time.Protocol.t;
  validation_passes : Z;
  operations_hash : Tezos_crypto.Operation_list_list_hash.t;
  fitness : Tezos_base.Fitness.t;
  context : Tezos_crypto.Context_hash.t }.

Definition shell_header_encoding
  : Tezos_data_encoding.Data_encoding.encoding shell_header :=
  apply
    (def "block_header.shell" % string (Some "Shell header" % string)
      (Some
        "Block header's shell-related content. It contains information such as the block level, its predecessor and timestamp."
          % string))
    (conv
      (fun function_parameter =>
        let '{|
          level := level;
            proto_level := proto_level;
            predecessor := predecessor;
            timestamp := timestamp;
            validation_passes := validation_passes;
            operations_hash := operations_hash;
            fitness := fitness;
            context := context
            |} := function_parameter in
        (level, proto_level, predecessor, timestamp, validation_passes,
          operations_hash, fitness, context))
      (fun function_parameter =>
        let
          '(level, proto_level, predecessor, timestamp, validation_passes,
            operations_hash, fitness, context) := function_parameter in
        {| level := level; proto_level := proto_level;
          predecessor := predecessor; timestamp := timestamp;
          validation_passes := validation_passes;
          operations_hash := operations_hash; fitness := fitness;
          context := context |}) None
      (obj8 (req None None "level" % string int32)
        (req None None "proto" % string uint8)
        (req None None "predecessor" % string Block_hash.encoding)
        (req None None "timestamp" % string Time.Protocol.encoding)
        (req None None "validation_pass" % string uint8)
        (req None None "operations_hash" % string
          Operation_list_list_hash.encoding)
        (req None None "fitness" % string Fitness.encoding)
        (req None None "context" % string Context_hash.encoding))).

Record t := {
  shell : shell_header;
  protocol_data : Stdlib.Bytes.t }.

(* ❌ Structure item `include` not handled. *)
include

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (def "block_header" % string (Some "Block header" % string)
      (Some
        "Block header. It contains both shell and protocol specific data." %
          string))
    (conv
      (fun function_parameter =>
        let '{| shell := shell; protocol_data := protocol_data |} :=
          function_parameter in
        (shell, protocol_data))
      (fun function_parameter =>
        let '(shell, protocol_data) := function_parameter in
        {| shell := shell; protocol_data := protocol_data |}) None
      (merge_objs shell_header_encoding
        (obj1 (req None None "protocol_data" % string Variable.bytes)))).

Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  let 'tt := function_parameter in
  match max_size with
  | None => encoding
  | Some max_size => Data_encoding.check_size max_size encoding
  end.

Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op).

Definition to_bytes (v : t) : Stdlib.Bytes.t :=
  Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
  Data_encoding.Binary.of_bytes encoding b.

Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
  Data_encoding.Binary.of_bytes_exn encoding b.

Definition to_b58check (v : t) : string :=
  Base58.safe_encode None (Stdlib.Bytes.to_string (to_bytes v)).

Definition of_b58check (b : string) : option t :=
  Option.apply
    (fun s => Data_encoding.Binary.of_bytes encoding (Stdlib.Bytes.of_string s))
    (Base58.safe_decode None b).

Definition hash (block : t) : Tezos_crypto.Block_hash.t :=
  Block_hash.hash_bytes None (cons (to_bytes block) []).

Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Block_hash.t :=
  Block_hash.hash_bytes None (cons string []).

Definition forced_protocol_upgrades
  : list (Stdlib.Int32.t * Tezos_crypto.Protocol_hash.t) := [].

Definition voted_protocol_overrides
  : list (Tezos_crypto.Protocol_hash.t * Tezos_crypto.Protocol_hash.t) :=
  List.map
    (fun function_parameter =>
      let '(a, b) := function_parameter in
      ((Protocol_hash.of_b58check_exn a), (Protocol_hash.of_b58check_exn b))) [].

(* ❌ Applications of functors are not handled. *)
functor_application

Definition get_forced_protocol_upgrade
  : LevelMap.key -> option Tezos_crypto.Protocol_hash.t :=
  let table :=
    Stdlib.List.fold_left
      (fun map =>
        fun function_parameter =>
          let '(level, hash) := function_parameter in
          LevelMap.add level hash map) LevelMap.empty forced_protocol_upgrades
    in
  fun level => LevelMap.find_opt level table.

Definition get_voted_protocol_overrides
  (proto_hash : Tezos_crypto.Protocol_hash.t)
  : option Tezos_crypto.Protocol_hash.t :=
  Stdlib.List.assoc_opt proto_hash voted_protocol_overrides.



src/lib_base/block_locator.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = raw

and raw = Block_header.t * Block_hash.t list

let raw x = x

let pp ppf (hd, h_lst) =
  let repeats = 10 in
  let coef = 2 in
  (* list of hashes *)
  let rec pp_hash_list ppf (h_lst, acc, d, r) =
    match h_lst with
    | [] ->
        Format.fprintf ppf ""
    | hd :: tl ->
        let new_d = if r > 1 then d else d * coef in
        let new_r = if r > 1 then r - 1 else repeats in
        Format.fprintf
          ppf
          "%a (%i)\n%a"
          Block_hash.pp
          hd
          acc
          pp_hash_list
          (tl, acc - d, new_d, new_r)
  in
  Format.fprintf
    ppf
    "%a (head)\n%a"
    Block_hash.pp
    (Block_header.hash hd)
    pp_hash_list
    (h_lst, -1, 1, repeats - 1)

let pp_short ppf (hd, h_lst) =
  Format.fprintf
    ppf
    "head: %a, %d predecessors"
    Block_hash.pp
    (Block_header.hash hd)
    (List.length h_lst)

let encoding =
  let open Data_encoding in
  def "block_locator" ~description:"A sparse block locator à la Bitcoin"
  @@ obj2
       (req "current_head" (dynamic_size Block_header.encoding))
       (req "history" (Variable.list Block_hash.encoding))

let bounded_encoding ?max_header_size ?max_length () =
  let open Data_encoding in
  obj2
    (req
       "current_head"
       (dynamic_size
          (Block_header.bounded_encoding ?max_size:max_header_size ())))
    (req "history" (Variable.list ?max_length Block_hash.encoding))

type seed = {sender_id : P2p_peer.Id.t; receiver_id : P2p_peer.Id.t}

(* Random generator for locator steps.

   We draw steps by sequence of 10. The first sequence's steps are of
   length 1 (consecutive). The second sequence's steps are of a random
   length between 1 and 2. The third sequence's steps are of a random
   length between 2 and 4, and so on...

   The sequence is deterministic for a given triple of sender,
   receiver and block hash. *)
module Step : sig
  type state

  val init : seed -> Block_hash.t -> state

  val next : state -> int * state
end = struct
  (* (step, counter, seed) .
     The seed is stored in a bigstring and should be mlocked *)
  type state = Int32.t * int * Bigstring.t

  let update st b = Hacl.Hash.SHA256.update st (Bigstring.of_bytes b)

  let init seed head =
    let open Hacl.Hash in
    let st = SHA256.init () in
    List.iter
      (update st)
      [ P2p_peer.Id.to_bytes seed.sender_id;
        P2p_peer.Id.to_bytes seed.receiver_id;
        Block_hash.to_bytes head ] ;
    (1l, 9, SHA256.finish st)

  let draw seed n =
    ( Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n,
      Hacl.Hash.SHA256.digest seed )

  let next (step, counter, seed) =
    let (random_gap, seed) =
      if step <= 1l then (0l, seed)
      else draw seed (Int32.succ (Int32.div step 2l))
    in
    let new_state =
      if counter = 0 then (Int32.mul step 2l, 9, seed)
      else (step, counter - 1, seed)
    in
    (Int32.to_int (Int32.sub step random_gap), new_state)
end

let estimated_length seed (head, hist) =
  let rec loop acc state = function
    | [] ->
        acc
    | _ :: hist ->
        let (step, state) = Step.next state in
        loop (acc + step) state hist
  in
  let state = Step.init seed (Block_header.hash head) in
  let (step, state) = Step.next state in
  loop step state hist

let fold ~f ~init (head, hist) seed =
  let rec loop state acc = function
    | [] | [_] ->
        acc
    | block :: (pred :: rem as hist) ->
        let (step, state) = Step.next state in
        let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
        loop state acc hist
  in
  let head = Block_header.hash head in
  let state = Step.init seed head in
  loop state init (head :: hist)

type step = {
  block : Block_hash.t;
  predecessor : Block_hash.t;
  step : int;
  strict_step : bool;
}

let pp_step ppf step =
  Format.fprintf ppf "%d%s" step.step (if step.strict_step then "" else " max")

let to_steps seed locator =
  fold locator seed ~init:[] ~f:(fun acc ~block ~pred ~step ~strict_step ->
      {block; predecessor = pred; step; strict_step} :: acc)

let fold_truncate ~f ~init ~save_point ~limit (head, hist) seed =
  let rec loop state step_sum acc = function
    | [] | [_] ->
        acc
    | block :: (pred :: rem as hist) ->
        let (step, state) = Step.next state in
        let new_step_sum = step + step_sum in
        if new_step_sum >= limit then
          f acc ~block ~pred:save_point ~step ~strict_step:false
        else
          let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
          loop state new_step_sum acc hist
  in
  let hash = Block_header.hash head in
  let initial_state = Step.init seed hash in
  loop initial_state 0 init (hash :: hist)

let to_steps_truncate ~limit ~save_point seed locator =
  fold_truncate
    locator
    seed
    ~init:[]
    ~save_point
    ~limit
    ~f:(fun acc ~block ~pred ~step ~strict_step ->
      {block; predecessor = pred; step; strict_step} :: acc)

let compute ~get_predecessor ~caboose ~size block_hash header seed =
  let rec loop acc size state current_block_hash =
    if size = 0 then Lwt.return acc
    else
      let (step, state) = Step.next state in
      get_predecessor current_block_hash step
      >>= function
      | None ->
          if Block_hash.equal caboose current_block_hash then Lwt.return acc
          else Lwt.return (caboose :: acc)
      | Some predecessor ->
          loop (predecessor :: acc) (pred size) state predecessor
  in
  if size <= 0 then Lwt.return (header, [])
  else
    let initial_state = Step.init seed block_hash in
    loop [] size initial_state block_hash
    >>= fun hist -> Lwt.return (header, List.rev hist)

type validity = Unknown | Known_valid | Known_invalid

let unknown_prefix ~is_known locator =
  let (head, history) = locator in
  let rec loop hist acc =
    match hist with
    | [] ->
        Lwt.return (Unknown, locator)
    | h :: t -> (
        is_known h
        >>= function
        | Known_valid ->
            Lwt.return (Known_valid, (head, List.rev (h :: acc)))
        | Known_invalid ->
            Lwt.return (Known_invalid, (head, List.rev (h :: acc)))
        | Unknown ->
            loop t (h :: acc) )
  in
  is_known (Block_header.hash head)
  >>= function
  | Known_valid ->
      Lwt.return (Known_valid, (head, []))
  | Known_invalid ->
      Lwt.return (Known_invalid, (head, []))
  | Unknown ->
      loop history []

let () = Data_encoding.Registration.register ~pp:pp_short encoding
src/lib_base/block_locator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Reserved Notation "'t".
Reserved Notation "'raw".



where "'t" := ( 'raw)

and "'raw" := ( Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)).

Definition t := 't.
Definition raw := 'raw.

Definition raw {A : Type} (x : A) : A := x.

Definition pp
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : unit :=
  let '(hd, h_lst) := function_parameter in
  let repeats := 10 in
  let coef := 2 in
  let fix pp_hash_list
    (ppf : Stdlib.Format.formatter) (function_parameter :
    (list Tezos_crypto.Block_hash.t) * Z * Z * Z) : unit :=
    let '(h_lst, acc, d, r) := function_parameter in
    match h_lst with
    | [] =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
          "" % string)
    | cons hd tl =>
      let new_d :=
        if OCaml.Stdlib.gt r 1 then
          d
        else
          Z.mul d coef in
      let new_r :=
        if OCaml.Stdlib.gt r 1 then
          Z.sub r 1
        else
          repeats in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " (" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ")
" % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "%a (%i)
%a" % string) Block_hash.pp hd acc pp_hash_list
        (tl, (Z.sub acc d), new_d, new_r)
    end in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha
        (CamlinternalFormatBasics.String_literal " (head)
" % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)))
      "%a (head)
%a" % string) Block_hash.pp (Block_header.hash hd) pp_hash_list
    (h_lst, (-1), 1, (Z.sub repeats 1)).

Definition pp_short {A : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter : Tezos_base.Block_header.t * (list A)) : unit :=
  let '(hd, h_lst) := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "head: " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal ", " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " predecessors" % string
                CamlinternalFormatBasics.End_of_format)))))
      "head: %a, %d predecessors" % string) Block_hash.pp (Block_header.hash hd)
    (OCaml.List.length h_lst).

Definition encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
  apply
    (let arg :=
      def "block_locator" % string
        (* ❌ expected an argument *)
        expected_argument (Some "A sparse block locator à la Bitcoin" % string)
      in
    fun eta => arg None eta)
    (obj2
      (req None None "current_head" % string
        (dynamic_size None Block_header.encoding))
      (req None None "history" % string (Variable.list None Block_hash.encoding))).

Definition bounded_encoding
  (max_header_size : option Z) (max_length : option Z)
  (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) :=
  let 'tt := function_parameter in
  obj2
    (req None None "current_head" % string
      (dynamic_size None (Block_header.bounded_encoding max_header_size tt)))
    (req None None "history" % string
      (Variable.list max_length Block_hash.encoding)).

Record seed := {
  sender_id : Tezos_base.P2p_peer.Id.t;
  receiver_id : Tezos_base.P2p_peer.Id.t }.

Module Step.
  Definition state := Stdlib.Int32.t * Z * Bigstring.t.
  
  Definition update
    (st : Hacl.Hash.SHA256.(Hacl.S.Hash.state)) (b : Stdlib.Bytes.t) : unit :=
    Hacl.Hash.SHA256.(Hacl.S.Hash.update) st (Bigstring.of_bytes b).
  
  Definition init (seed : seed) (head : Tezos_crypto.Block_hash.t)
    : int32 * Z * Bigstring.t :=
    let st := Hacl.Hash.SHA256.(Hacl.Hash.S.init) tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Stdlib.List.iter (update st)
        (cons (P2p_peer.Id.to_bytes (sender_id seed))
          (cons (P2p_peer.Id.to_bytes (receiver_id seed))
            (cons (Block_hash.to_bytes head) []))) in
    ((* ❌ Constant of type int32 is converted to int *)
    1, 9, (Hacl.Hash.SHA256.(Hacl.Hash.S.finish) st)).
  
  Definition draw (seed : Bigstring.t) (n : int32) : int32 * Bigstring.t :=
    ((Int32.rem (TzEndian.get_int32 (Bigstring.to_bytes seed) 0) n),
      (Hacl.Hash.SHA256.(Hacl.S.Hash.digest) seed)).
  
  Definition next (function_parameter : int32 * Z * Bigstring.t)
    : Z * (int32 * Z * Bigstring.t) :=
    let '(step, counter, seed) := function_parameter in
    let '(random_gap, seed) :=
      if
        OCaml.Stdlib.le step
          (* ❌ Constant of type int32 is converted to int *)
          1 then
        ((* ❌ Constant of type int32 is converted to int *)
        0, seed)
      else
        draw seed
          (Int32.succ
            (Int32.div step
              (* ❌ Constant of type int32 is converted to int *)
              2)) in
    let new_state :=
      if equiv_decb counter 0 then
        ((Int32.mul step
          (* ❌ Constant of type int32 is converted to int *)
          2), 9, seed)
      else
        (step, (Z.sub counter 1), seed) in
    ((Int32.to_int (Int32.sub step random_gap)), new_state).
End Step.

Definition estimated_length {A : Type}
  (seed : seed) (function_parameter : Tezos_base.Block_header.t * (list A))
  : Z :=
  let '(head, hist) := function_parameter in
  let fix loop {B : Type}
    (acc : Z) (state : Step.state) (function_parameter : list B) : Z :=
    match function_parameter with
    | [] => acc
    | cons _ hist =>
      let '(step, state) := Step.next state in
      loop (Z.add acc step) state hist
    end in
  let state := Step.init seed (Block_header.hash head) in
  let '(step, state) := Step.next state in
  loop step state hist.

Definition fold {A : Type}
  (f :
    A ->
      Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
  (init : A)
  (function_parameter :
    Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
  let '(head, hist) := function_parameter in
  fun seed =>
    let fix loop
      (state : Step.state) (acc : A) (function_parameter :
      list Tezos_crypto.Block_hash.t) : A :=
      match function_parameter with
      | [] | cons _ [] => acc
      | cons block ((cons pred rem) as hist) =>
        let '(step, state) := Step.next state in
        let acc := f acc block pred step (nequiv_decb rem []) in
        loop state acc hist
      end in
    let head := Block_header.hash head in
    let state := Step.init seed head in
    loop state init (cons head hist).

Record step := {
  block : Tezos_crypto.Block_hash.t;
  predecessor : Tezos_crypto.Block_hash.t;
  step : Z;
  strict_step : bool }.

Definition pp_step (ppf : Stdlib.Format.formatter) (step : step) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
        CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.No_precision
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format)) "%d%s" % string) (step step)
    (if strict_step step then
      "" % string
    else
      " max" % string).

Definition to_steps
  (seed : seed)
  (locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
  : list step :=
  fold
    (fun acc =>
      fun block =>
        fun pred =>
          fun step =>
            fun strict_step =>
              cons
                {| block := block; predecessor := pred; step := step;
                  strict_step := strict_step |} acc) [] locator seed.

Definition fold_truncate {A : Type}
  (f :
    A ->
      Tezos_crypto.Block_hash.t -> Tezos_crypto.Block_hash.t -> Z -> bool -> A)
  (init : A) (save_point : Tezos_crypto.Block_hash.t) (limit : Z)
  (function_parameter :
    Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t)) : seed -> A :=
  let '(head, hist) := function_parameter in
  fun seed =>
    let fix loop
      (state : Step.state) (step_sum : Z) (acc : A) (function_parameter :
      list Tezos_crypto.Block_hash.t) : A :=
      match function_parameter with
      | [] | cons _ [] => acc
      | cons block ((cons pred rem) as hist) =>
        let '(step, state) := Step.next state in
        let new_step_sum := Z.add step step_sum in
        if OCaml.Stdlib.ge new_step_sum limit then
          f acc block save_point step false
        else
          let acc := f acc block pred step (nequiv_decb rem []) in
          loop state new_step_sum acc hist
      end in
    let hash := Block_header.hash head in
    let initial_state := Step.init seed hash in
    loop initial_state 0 init (cons hash hist).

Definition to_steps_truncate
  (limit : Z) (save_point : Tezos_crypto.Block_hash.t) (seed : seed)
  (locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
  : list step :=
  fold_truncate
    (fun acc =>
      fun block =>
        fun pred =>
          fun step =>
            fun strict_step =>
              cons
                {| block := block; predecessor := pred; step := step;
                  strict_step := strict_step |} acc) [] save_point limit locator
    seed.

Definition compute {A : Type}
  (get_predecessor :
    Tezos_crypto.Block_hash.t -> Z -> Lwt.t (option Tezos_crypto.Block_hash.t))
  (caboose : Tezos_crypto.Block_hash.t) (size : Z)
  (block_hash : Tezos_crypto.Block_hash.t) (header : A) (seed : seed)
  : Lwt.t (A * (list Tezos_crypto.Block_hash.t)) :=
  let fix loop
    (acc : list Tezos_crypto.Block_hash.t) (size : Z) (state : Step.state)
    (current_block_hash : Tezos_crypto.Block_hash.t)
    : Lwt.t (list Tezos_crypto.Block_hash.t) :=
    if equiv_decb size 0 then
      Lwt._return acc
    else
      let '(step, state) := Step.next state in
      op_gtgteq (get_predecessor current_block_hash step)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            if Block_hash.equal caboose current_block_hash then
              Lwt._return acc
            else
              Lwt._return (cons caboose acc)
          | Some predecessor =>
            loop (cons predecessor acc) (Z.pred size) state predecessor
          end) in
  if OCaml.Stdlib.le size 0 then
    Lwt._return (header, [])
  else
    let initial_state := Step.init seed block_hash in
    op_gtgteq (loop [] size initial_state block_hash)
      (fun hist => Lwt._return (header, (List.rev hist))).

Inductive validity : Type :=
| Unknown : validity
| Known_valid : validity
| Known_invalid : validity.

Definition unknown_prefix
  (is_known : Tezos_crypto.Block_hash.t -> Lwt.t validity)
  (locator : Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))
  : Lwt.t
    (validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
  let '(head, history) := locator in
  let fix loop
    (hist : list Tezos_crypto.Block_hash.t) (acc :
    list Tezos_crypto.Block_hash.t)
    : Lwt.t
      (validity * (Tezos_base.Block_header.t * (list Tezos_crypto.Block_hash.t))) :=
    match hist with
    | [] => Lwt._return (Unknown, locator)
    | cons h t =>
      op_gtgteq (is_known h)
        (fun function_parameter =>
          match function_parameter with
          | Known_valid =>
            Lwt._return (Known_valid, (head, (List.rev (cons h acc))))
          | Known_invalid =>
            Lwt._return (Known_invalid, (head, (List.rev (cons h acc))))
          | Unknown => loop t (cons h acc)
          end)
    end in
  op_gtgteq (is_known (Block_header.hash head))
    (fun function_parameter =>
      match function_parameter with
      | Known_valid => Lwt._return (Known_valid, (head, []))
      | Known_invalid => Lwt._return (Known_invalid, (head, []))
      | Unknown => loop history []
      end).



src/lib_base/distributed_db_version.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Distributed_db protocol version. *)

type name = string

let pp_name = Format.pp_print_string

let name_encoding =
  let open Data_encoding in
  def
    "distributed_db_version.name"
    ~description:"A name for the distributed DB protocol"
    string

let chain_name = "TEZOS"

let sandboxed_chain_name = "SANDBOXED_TEZOS"

type t = int

let pp = Format.pp_print_int

let encoding =
  let open Data_encoding in
  def
    "distributed_db_version"
    ~description:"A version number for the distributed DB protocol"
    uint16

let zero = 0

let () =
  Data_encoding.Registration.register ~pp:pp_name name_encoding ;
  Data_encoding.Registration.register ~pp encoding
src/lib_base/distributed_db_version.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition name := string.

Definition pp_name : Stdlib.Format.formatter -> string -> unit :=
  Format.pp_print_string.

Definition name_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
  def "distributed_db_version.name" % string None
    (Some "A name for the distributed DB protocol" % string) string.

Definition chain_name : string := "TEZOS" % string.

Definition sandboxed_chain_name : string := "SANDBOXED_TEZOS" % string.

Definition t := Z.

Definition pp : Stdlib.Format.formatter -> Z -> unit := Format.pp_print_int.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
  def "distributed_db_version" % string None
    (Some "A version number for the distributed DB protocol" % string) uint16.

Definition zero : Z := 0.



src/lib_base/fitness.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Bytes.t list

include Compare.Make (struct
  type nonrec t = t

  (* Fitness comparison:
       - shortest lists are smaller ;
       - lexicographical order for lists of the same length. *)
  let compare_bytes b1 b2 =
    let len1 = Bytes.length b1 in
    let len2 = Bytes.length b2 in
    let c = compare len1 len2 in
    if c <> 0 then c
    else
      let rec compare_byte b1 b2 pos len =
        if pos = len then 0
        else
          let c = compare (Bytes.get b1 pos) (Bytes.get b2 pos) in
          if c <> 0 then c else compare_byte b1 b2 (pos + 1) len
      in
      compare_byte b1 b2 0 len1

  let compare f1 f2 =
    let rec compare_rec f1 f2 =
      match (f1, f2) with
      | ([], []) ->
          0
      | (i1 :: f1, i2 :: f2) ->
          let i = compare_bytes i1 i2 in
          if i = 0 then compare_rec f1 f2 else i
      | (_, _) ->
          assert false
    in
    let len = compare (List.length f1) (List.length f2) in
    if len = 0 then compare_rec f1 f2 else len
end)

let rec pp fmt = function
  | [] ->
      ()
  | [f] ->
      Format.fprintf fmt "%a" Hex.pp (Hex.of_bytes f)
  | f1 :: f ->
      Format.fprintf fmt "%a::%a" Hex.pp (Hex.of_bytes f1) pp f

let encoding =
  let open Data_encoding in
  def
    "fitness"
    ~title:"Block fitness"
    ~description:
      "The fitness, or score, of a block, that allow the Tezos to decide \
       which chain is the best. A fitness value is a list of byte sequences. \
       They are compared as follows: shortest lists are smaller; lists of the \
       same length are compared according to the lexicographical order."
  @@ splitted ~json:(list bytes) ~binary:(list (def "fitness.elem" bytes))

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b
src/lib_base/fitness.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := list Stdlib.Bytes.t.

(* ❌ Structure item `include` not handled. *)
include

Fixpoint pp (fmt : Stdlib.Format.formatter) (function_parameter : list string)
  : unit :=
  match function_parameter with
  | [] => tt
  | cons f [] =>
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Hex.pp (Hex.of_bytes None f)
  | cons f1 f =>
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal "::" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a::%a" % string)
      Hex.pp (Hex.of_bytes None f1) pp f
  end.

Definition encoding
  : Tezos_data_encoding.Data_encoding.encoding (list Stdlib.Bytes.t) :=
  apply
    (def "fitness" % string (Some "Block fitness" % string)
      (Some
        "The fitness, or score, of a block, that allow the Tezos to decide which chain is the best. A fitness value is a list of byte sequences. They are compared as follows: shortest lists are smaller; lists of the same length are compared according to the lexicographical order."
          % string))
    (splitted (list None bytes)
      (list None (def "fitness.elem" % string None None bytes))).

Definition to_bytes (v : list Stdlib.Bytes.t) : Stdlib.Bytes.t :=
  Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option (list Stdlib.Bytes.t) :=
  Data_encoding.Binary.of_bytes encoding b.

src/lib_base/mempool.ml 5 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {known_valid : Operation_hash.t list; pending : Operation_hash.Set.t}

type mempool = t

let encoding =
  let open Data_encoding in
  def
    "mempool"
    ~description:
      "A batch of operation. This format is used to gossip operations between \
       peers."
  @@ conv
       (fun {known_valid; pending} -> (known_valid, pending))
       (fun (known_valid, pending) -> {known_valid; pending})
       (obj2
          (req "known_valid" (list Operation_hash.encoding))
          (req "pending" (dynamic_size Operation_hash.Set.encoding)))

let bounded_encoding ?max_operations () =
  match max_operations with
  | None ->
      encoding
  | Some max_operations ->
      Data_encoding.check_size
        (8 + (max_operations * Operation_hash.size))
        encoding

let empty = {known_valid = []; pending = Operation_hash.Set.empty}

let () = Data_encoding.Registration.register encoding
src/lib_base/mempool.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  known_valid : list Tezos_crypto.Operation_hash.t;
  pending : Tezos_crypto.Operation_hash.Set.t }.

Definition mempool := t.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "mempool" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "A batch of operation. This format is used to gossip operations between peers."
            % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{| known_valid := known_valid; pending := pending |} :=
          function_parameter in
        (known_valid, pending))
      (fun function_parameter =>
        let '(known_valid, pending) := function_parameter in
        {| known_valid := known_valid; pending := pending |}) None
      (obj2
        (req None None "known_valid" % string
          (list None Operation_hash.encoding))
        (req None None "pending" % string
          (dynamic_size None Operation_hash.Set.encoding)))).

Definition bounded_encoding
  (max_operations : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  let 'tt := function_parameter in
  match max_operations with
  | None => encoding
  | Some max_operations =>
    Data_encoding.check_size
      (Z.add 8 (Z.mul max_operations Operation_hash.size)) encoding
  end.

Definition empty : t :=
  {| known_valid := []; pending := Operation_hash.Set.empty |}.



src/lib_base/network_version.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  chain_name : Distributed_db_version.name;
  distributed_db_version : Distributed_db_version.t;
  p2p_version : P2p_version.t;
}

let pp ppf {chain_name; distributed_db_version; p2p_version} =
  Format.fprintf
    ppf
    "%a.%a (p2p: %a)"
    Distributed_db_version.pp_name
    chain_name
    Distributed_db_version.pp
    distributed_db_version
    P2p_version.pp
    p2p_version

let encoding =
  let open Data_encoding in
  def
    "network_version"
    ~description:
      "A version number for the network protocol (includes distributed DB \
       version and p2p version)"
  @@ conv
       (fun {chain_name; distributed_db_version; p2p_version} ->
         (chain_name, distributed_db_version, p2p_version))
       (fun (chain_name, distributed_db_version, p2p_version) ->
         {chain_name; distributed_db_version; p2p_version})
       (obj3
          (req "chain_name" Distributed_db_version.name_encoding)
          (req "distributed_db_version" Distributed_db_version.encoding)
          (req "p2p_version" P2p_version.encoding))

let greatest = function
  | [] ->
      raise (Invalid_argument "Network_version.greatest")
  | h :: t ->
      List.fold_left max h t

let announced ~chain_name ~distributed_db_versions ~p2p_versions =
  assert (distributed_db_versions <> []) ;
  assert (p2p_versions <> []) ;
  {
    chain_name;
    distributed_db_version = greatest distributed_db_versions;
    p2p_version = greatest p2p_versions;
  }

let may_select_version accepted_versions remote_version =
  let best_local_version = greatest accepted_versions in
  if best_local_version <= remote_version then Some best_local_version
  else if List.mem remote_version accepted_versions then Some remote_version
  else None

let select ~chain_name ~distributed_db_versions ~p2p_versions remote =
  assert (distributed_db_versions <> []) ;
  assert (p2p_versions <> []) ;
  if chain_name <> remote.chain_name then None
  else
    let open Option in
    may_select_version distributed_db_versions remote.distributed_db_version
    >>= fun distributed_db_version ->
    may_select_version p2p_versions remote.p2p_version
    >>= fun p2p_version ->
    some {chain_name; distributed_db_version; p2p_version}

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/network_version.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  chain_name : Tezos_base.Distributed_db_version.name;
  distributed_db_version : Tezos_base.Distributed_db_version.t;
  p2p_version : Tezos_base.P2p_version.t }.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  let '{|
    chain_name := chain_name;
      distributed_db_version := distributed_db_version;
      p2p_version := p2p_version
      |} := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha
        (CamlinternalFormatBasics.Char_literal "." % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " (p2p: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))))
      "%a.%a (p2p: %a)" % string) Distributed_db_version.pp_name chain_name
    Distributed_db_version.pp distributed_db_version P2p_version.pp p2p_version.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "network_version" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "A version number for the network protocol (includes distributed DB version and p2p version)"
            % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{|
          chain_name := chain_name;
            distributed_db_version := distributed_db_version;
            p2p_version := p2p_version
            |} := function_parameter in
        (chain_name, distributed_db_version, p2p_version))
      (fun function_parameter =>
        let '(chain_name, distributed_db_version, p2p_version) :=
          function_parameter in
        {| chain_name := chain_name;
          distributed_db_version := distributed_db_version;
          p2p_version := p2p_version |}) None
      (obj3
        (req None None "chain_name" % string
          Distributed_db_version.name_encoding)
        (req None None "distributed_db_version" % string
          Distributed_db_version.encoding)
        (req None None "p2p_version" % string P2p_version.encoding))).

Definition greatest {A : Type} (function_parameter : list A) : A :=
  match function_parameter with
  | [] =>
    Stdlib.raise (OCaml.Invalid_argument "Network_version.greatest" % string)
  | cons h t => Stdlib.List.fold_left OCaml.Stdlib.max h t
  end.

Definition announced
  (chain_name : Tezos_base.Distributed_db_version.name)
  (distributed_db_versions : list Tezos_base.Distributed_db_version.t)
  (p2p_versions : list Tezos_base.P2p_version.t) : t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (nequiv_decb distributed_db_versions []) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (nequiv_decb p2p_versions []) in
  {| chain_name := chain_name;
    distributed_db_version := greatest distributed_db_versions;
    p2p_version := greatest p2p_versions |}.

Definition may_select_version {A : Type}
  (accepted_versions : list A) (remote_version : A) : option A :=
  let best_local_version := greatest accepted_versions in
  if OCaml.Stdlib.le best_local_version remote_version then
    Some best_local_version
  else
    if Stdlib.List.mem remote_version accepted_versions then
      Some remote_version
    else
      None.

Definition select
  (chain_name : Tezos_base.Distributed_db_version.name)
  (distributed_db_versions : list Tezos_base.Distributed_db_version.t)
  (p2p_versions : list Tezos_base.P2p_version.t) (remote : t) : option t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (nequiv_decb distributed_db_versions []) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (nequiv_decb p2p_versions []) in
  if nequiv_decb chain_name (chain_name remote) then
    None
  else
    op_gtgteq
      (may_select_version distributed_db_versions
        (distributed_db_version remote))
      (fun distributed_db_version =>
        op_gtgteq (may_select_version p2p_versions (p2p_version remote))
          (fun p2p_version =>
            some
              {| chain_name := chain_name;
                distributed_db_version := distributed_db_version;
                p2p_version := p2p_version |})).



src/lib_base/operation.ml 13 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type shell_header = {branch : Block_hash.t}

let shell_header_encoding =
  let open Data_encoding in
  def "operation.shell_header" ~description:"An operation's shell header."
  @@ conv
       (fun {branch} -> branch)
       (fun branch -> {branch})
       (obj1 (req "branch" Block_hash.encoding))

type t = {shell : shell_header; proto : Bytes.t}

include Compare.Make (struct
  type nonrec t = t

  let compare o1 o2 =
    let ( >> ) x y = if x = 0 then y () else x in
    Block_hash.compare o1.shell.branch o1.shell.branch
    >> fun () -> Bytes.compare o1.proto o2.proto
end)

let encoding =
  let open Data_encoding in
  def
    "operation"
    ~description:
      "An operation. The shell_header part indicates a block an operation is \
       meant to apply on top of. The proto part is protocol-specific and \
       appears as a binary blob."
  @@ conv
       (fun {shell; proto} -> (shell, proto))
       (fun (shell, proto) -> {shell; proto})
       (merge_objs shell_header_encoding (obj1 (req "data" Variable.bytes)))

let bounded_encoding ?max_size () =
  match max_size with
  | None ->
      encoding
  | Some max_size ->
      Data_encoding.check_size max_size encoding

let bounded_list_encoding ?max_length ?max_size ?max_operation_size ?max_pass
    () =
  let open Data_encoding in
  let op_encoding = bounded_encoding ?max_size:max_operation_size () in
  let op_list_encoding =
    match max_size with
    | None ->
        Variable.list ?max_length (dynamic_size op_encoding)
    | Some max_size ->
        check_size
          max_size
          (Variable.list ?max_length (dynamic_size op_encoding))
  in
  obj2
    (req
       "operation_hashes_path"
       (Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
    (req "operations" op_list_encoding)

let bounded_hash_list_encoding ?max_length ?max_pass () =
  let open Data_encoding in
  obj2
    (req
       "operation_hashes_path"
       (Operation_list_list_hash.bounded_path_encoding ?max_length:max_pass ()))
    (req "operation_hashes" (Variable.list ?max_length Operation_hash.encoding))

let pp fmt op =
  Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op)

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b

let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b

let hash op = Operation_hash.hash_bytes [to_bytes op]

let hash_raw bytes = Operation_hash.hash_bytes [bytes]

let () =
  Data_encoding.Registration.register ~pp encoding ;
  Data_encoding.Registration.register shell_header_encoding
src/lib_base/operation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record shell_header := {
  branch : Tezos_crypto.Block_hash.t }.

Definition shell_header_encoding
  : Tezos_data_encoding.Data_encoding.encoding shell_header :=
  apply
    (let arg :=
      def "operation.shell_header" % string
        (* ❌ expected an argument *)
        expected_argument (Some "An operation's shell header." % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{| branch := branch |} := function_parameter in
        branch) (fun branch => {| branch := branch |}) None
      (obj1 (req None None "branch" % string Block_hash.encoding))).

Record t := {
  shell : shell_header;
  proto : Stdlib.Bytes.t }.

(* ❌ Structure item `include` not handled. *)
include

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "operation" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "An operation. The shell_header part indicates a block an operation is meant to apply on top of. The proto part is protocol-specific and appears as a binary blob."
            % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{| shell := shell; proto := proto |} := function_parameter in
        (shell, proto))
      (fun function_parameter =>
        let '(shell, proto) := function_parameter in
        {| shell := shell; proto := proto |}) None
      (merge_objs shell_header_encoding
        (obj1 (req None None "data" % string Variable.bytes)))).

Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  let 'tt := function_parameter in
  match max_size with
  | None => encoding
  | Some max_size => Data_encoding.check_size max_size encoding
  end.

Definition bounded_list_encoding
  (max_length : option Z) (max_size : option Z) (max_operation_size : option Z)
  (max_pass : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_crypto.Operation_list_list_hash.path * (list t)) :=
  let 'tt := function_parameter in
  let op_encoding := bounded_encoding max_operation_size tt in
  let op_list_encoding :=
    match max_size with
    | None => Variable.list max_length (dynamic_size None op_encoding)
    | Some max_size =>
      check_size max_size
        (Variable.list max_length (dynamic_size None op_encoding))
    end in
  obj2
    (req None None "operation_hashes_path" % string
      (Operation_list_list_hash.bounded_path_encoding max_pass tt))
    (req None None "operations" % string op_list_encoding).

Definition bounded_hash_list_encoding
  (max_length : option Z) (max_pass : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_crypto.Operation_list_list_hash.path *
      (list Tezos_crypto.Operation_hash.t)) :=
  let 'tt := function_parameter in
  obj2
    (req None None "operation_hashes_path" % string
      (Operation_list_list_hash.bounded_path_encoding max_pass tt))
    (req None None "operation_hashes" % string
      (Variable.list max_length Operation_hash.encoding)).

Definition pp (fmt : Stdlib.Format.formatter) (op : t) : unit :=
  Data_encoding.Json.pp fmt (Data_encoding.Json.construct encoding op).

Definition to_bytes (v : t) : Stdlib.Bytes.t :=
  Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
  Data_encoding.Binary.of_bytes encoding b.

Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
  Data_encoding.Binary.of_bytes_exn encoding b.

Definition hash (op : t) : Tezos_crypto.Operation_hash.t :=
  Operation_hash.hash_bytes None (cons (to_bytes op) []).

Definition hash_raw (bytes : Stdlib.Bytes.t) : Tezos_crypto.Operation_hash.t :=
  Operation_hash.hash_bytes None (cons string []).



src/lib_base/p2p_addr.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Ipaddr.V6.t

let encoding =
  let open Data_encoding in
  def "p2p_address" ~description:"An address for locating peers."
  @@ splitted
       ~json:(conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn string)
       ~binary:(conv Ipaddr.V6.to_octets Ipaddr.V6.of_octets_exn string)

type port = int

let pp ppf addr =
  match Ipaddr.v4_of_v6 addr with
  | Some addr ->
      Format.fprintf ppf "%a" Ipaddr.V4.pp addr
  | None ->
      Format.fprintf ppf "[%a]" Ipaddr.V6.pp addr

let of_string_opt str =
  match Ipaddr.of_string str with
  | Ok (Ipaddr.V4 addr) ->
      Some (Ipaddr.v6_of_v4 addr)
  | Ok (V6 addr) ->
      Some addr
  | Error (`Msg _) ->
      None

let of_string_exn str =
  match of_string_opt str with
  | None ->
      Pervasives.failwith "P2p_addr.of_string"
  | Some t ->
      t

let to_string saddr = Format.asprintf "%a" pp saddr

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_addr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Ipaddr.V6.t.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ipaddr.V6.t :=
  apply
    (let arg :=
      def "p2p_address" % string
        (* ❌ expected an argument *)
        expected_argument (Some "An address for locating peers." % string) in
    fun eta => arg None eta)
    (splitted (conv Ipaddr.V6.to_string Ipaddr.V6.of_string_exn None string)
      (conv Ipaddr.V6.to_octets
        (let arg := Ipaddr.V6.of_octets_exn in
        fun eta => arg None eta) None string)).

Definition port := Z.

Definition pp (ppf : Stdlib.Format.formatter) (addr : Ipaddr.V6.t) : unit :=
  match Ipaddr.v4_of_v6 addr with
  | Some addr =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Ipaddr.V4.pp addr
  | None =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%a]" % string)
      Ipaddr.V6.pp addr
  end.

Definition of_string_opt (str : string) : option Ipaddr.V6.t :=
  match Ipaddr.of_string str with
  | Stdlib.Ok (Ipaddr.V4 addr) => Some (Ipaddr.v6_of_v4 addr)
  | Stdlib.Ok (Ipaddr.V6 addr) => Some addr
  | Stdlib.Error (Msg _) => None
  end.

Definition of_string_exn (str : string) : Ipaddr.V6.t :=
  match of_string_opt str with
  | None => Pervasives.failwith "P2p_addr.of_string" % string
  | Some t => t
  end.

Definition to_string (saddr : Ipaddr.V6.t) : string :=
  Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string) pp saddr.



src/lib_base/p2p_connection.ml 54 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = struct
  (* A net point (address x port). *)
  type t = P2p_addr.t * P2p_addr.port option

  let compare (a1, p1) (a2, p2) =
    match Ipaddr.V6.compare a1 a2 with 0 -> Pervasives.compare p1 p2 | x -> x

  let equal p1 p2 = compare p1 p2 = 0

  let hash = Hashtbl.hash

  let pp ppf (addr, port) =
    match port with
    | None ->
        Format.fprintf ppf "[%a]:??" Ipaddr.V6.pp addr
    | Some port ->
        Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port

  let pp_opt ppf = function
    | None ->
        Format.pp_print_string ppf "none"
    | Some point ->
        pp ppf point

  let to_string t = Format.asprintf "%a" pp t

  let is_local (addr, _) = Ipaddr.V6.is_private addr

  let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr

  let of_point (addr, port) = (addr, Some port)

  let to_point = function
    | (_, None) ->
        None
    | (addr, Some port) ->
        Some (addr, port)

  let to_point_exn = function
    | (_, None) ->
        invalid_arg "to_point_exn"
    | (addr, Some port) ->
        (addr, port)

  let encoding =
    let open Data_encoding in
    def
      "p2p_connection.id"
      ~description:
        "The identifier for a p2p connection. It includes an address and a \
         port number."
    @@ obj2 (req "addr" P2p_addr.encoding) (opt "port" uint16)
end

module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)

module Info = struct
  type 'meta t = {
    incoming : bool;
    peer_id : P2p_peer_id.t;
    id_point : Id.t;
    remote_socket_port : P2p_addr.port;
    announced_version : Network_version.t;
    private_node : bool;
    local_metadata : 'meta;
    remote_metadata : 'meta;
  }

  let encoding metadata_encoding =
    let open Data_encoding in
    conv
      (fun { incoming;
             peer_id;
             id_point;
             remote_socket_port;
             announced_version;
             private_node;
             local_metadata;
             remote_metadata } ->
        ( incoming,
          peer_id,
          id_point,
          remote_socket_port,
          announced_version,
          private_node,
          local_metadata,
          remote_metadata ))
      (fun ( incoming,
             peer_id,
             id_point,
             remote_socket_port,
             announced_version,
             private_node,
             local_metadata,
             remote_metadata ) ->
        {
          incoming;
          peer_id;
          id_point;
          remote_socket_port;
          announced_version;
          private_node;
          local_metadata;
          remote_metadata;
        })
      (obj8
         (req "incoming" bool)
         (req "peer_id" P2p_peer_id.encoding)
         (req "id_point" Id.encoding)
         (req "remote_socket_port" uint16)
         (req "announced_version" Network_version.encoding)
         (req "private" bool)
         (req "local_metadata" metadata_encoding)
         (req "remote_metadata" metadata_encoding))

  let pp pp_meta ppf
      { incoming;
        id_point = (remote_addr, remote_port);
        remote_socket_port;
        peer_id;
        announced_version;
        private_node;
        local_metadata = _;
        remote_metadata } =
    let point =
      match remote_port with
      | None ->
          (remote_addr, remote_socket_port)
      | Some port ->
          (remote_addr, port)
    in
    Format.fprintf
      ppf
      "%s %a %a (%a) %s%a"
      (if incoming then "↘" else "↗")
      P2p_peer_id.pp
      peer_id
      P2p_point.Id.pp
      point
      Network_version.pp
      announced_version
      (if private_node then " private" else "")
      pp_meta
      remote_metadata
end

module P2p_event = struct
  (** Pool-level events *)

  type t =
    | Too_few_connections
    | Too_many_connections
    | New_point of P2p_point.Id.t
    | New_peer of P2p_peer_id.t
    | Gc_points
    | Gc_peer_ids
    | Incoming_connection of P2p_point.Id.t
    | Outgoing_connection of P2p_point.Id.t
    | Authentication_failed of P2p_point.Id.t
    | Accepting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
    | Rejecting_request of P2p_point.Id.t * Id.t * P2p_peer_id.t
    | Request_rejected of P2p_point.Id.t * (Id.t * P2p_peer_id.t) option
    | Connection_established of Id.t * P2p_peer_id.t
    | Swap_request_received of {source : P2p_peer_id.t}
    | Swap_ack_received of {source : P2p_peer_id.t}
    | Swap_request_sent of {source : P2p_peer_id.t}
    | Swap_ack_sent of {source : P2p_peer_id.t}
    | Swap_request_ignored of {source : P2p_peer_id.t}
    | Swap_success of {source : P2p_peer_id.t}
    | Swap_failure of {source : P2p_peer_id.t}
    | Disconnection of P2p_peer_id.t
    | External_disconnection of P2p_peer_id.t

  let pp ppf (event : t) =
    match event with
    | Too_few_connections ->
        Format.pp_print_string ppf "Too_few_connections"
    | Too_many_connections ->
        Format.pp_print_string ppf "Too_many_connections"
    | New_point p ->
        Format.pp_print_string ppf "New_point " ;
        P2p_point.Id.pp ppf p
    | New_peer p ->
        Format.pp_print_string ppf "New_peer " ;
        P2p_peer_id.pp ppf p
    | Gc_points ->
        Format.pp_print_string ppf "Gc_points"
    | Gc_peer_ids ->
        Format.pp_print_string ppf "Gc_peer_ids"
    | Incoming_connection p ->
        Format.pp_print_string ppf "Incoming_connection " ;
        P2p_point.Id.pp ppf p
    | Outgoing_connection p ->
        Format.pp_print_string ppf "Outgoing_connection " ;
        P2p_point.Id.pp ppf p
    | Authentication_failed p ->
        Format.pp_print_string ppf "Authentication_failed " ;
        P2p_point.Id.pp ppf p
    | Accepting_request (pi, _, _) ->
        Format.pp_print_string ppf "Accepting_request " ;
        P2p_point.Id.pp ppf pi
    | Rejecting_request (pi, _, _) ->
        Format.pp_print_string ppf "Rejecting_request " ;
        P2p_point.Id.pp ppf pi
    | Request_rejected (pi, _) ->
        Format.pp_print_string ppf "Request_rejected " ;
        P2p_point.Id.pp ppf pi
    | Connection_established (_, pi) ->
        Format.pp_print_string ppf "Connection_established " ;
        P2p_peer_id.pp ppf pi
    | Swap_request_received {source} ->
        Format.pp_print_string ppf "Swap_request_received " ;
        P2p_peer_id.pp ppf source
    | Swap_ack_received {source} ->
        Format.pp_print_string ppf "Swap_ack_received " ;
        P2p_peer_id.pp ppf source
    | Swap_request_sent {source} ->
        Format.pp_print_string ppf "Swap_request_sent " ;
        P2p_peer_id.pp ppf source
    | Swap_ack_sent {source} ->
        Format.pp_print_string ppf "Swap_ack_sent " ;
        P2p_peer_id.pp ppf source
    | Swap_request_ignored {source} ->
        Format.pp_print_string ppf "Swap_request_ignored " ;
        P2p_peer_id.pp ppf source
    | Swap_success {source} ->
        Format.pp_print_string ppf "Swap_success " ;
        P2p_peer_id.pp ppf source
    | Swap_failure {source} ->
        Format.pp_print_string ppf "Swap_failure " ;
        P2p_peer_id.pp ppf source
    | Disconnection source ->
        Format.pp_print_string ppf "Disconnection " ;
        P2p_peer_id.pp ppf source
    | External_disconnection source ->
        Format.pp_print_string ppf "External_disconnection " ;
        P2p_peer_id.pp ppf source

  let encoding =
    let open Data_encoding in
    let branch_encoding name obj =
      conv
        (fun x -> ((), x))
        (fun ((), x) -> x)
        (merge_objs (obj1 (req "event" (constant name))) obj)
    in
    def
      "p2p_connection.pool_event"
      ~description:
        "An event that may happen during maintenance of and other operations \
         on the p2p connection pool. Typically, it includes connection \
         errors, peer swaps, etc."
    @@ union
         ~tag_size:`Uint8
         [ case
             (Tag 0)
             ~title:"Too_few_connections"
             (branch_encoding "too_few_connections" empty)
             (function Too_few_connections -> Some () | _ -> None)
             (fun () -> Too_few_connections);
           case
             (Tag 1)
             ~title:"Too_many_connections"
             (branch_encoding "too_many_connections" empty)
             (function Too_many_connections -> Some () | _ -> None)
             (fun () -> Too_many_connections);
           case
             (Tag 2)
             ~title:"New_point"
             (branch_encoding
                "new_point"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function New_point p -> Some p | _ -> None)
             (fun p -> New_point p);
           case
             (Tag 3)
             ~title:"New_peer"
             (branch_encoding
                "new_peer"
                (obj1 (req "peer_id" P2p_peer_id.encoding)))
             (function New_peer p -> Some p | _ -> None)
             (fun p -> New_peer p);
           case
             (Tag 4)
             ~title:"Incoming_connection"
             (branch_encoding
                "incoming_connection"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function Incoming_connection p -> Some p | _ -> None)
             (fun p -> Incoming_connection p);
           case
             (Tag 5)
             ~title:"Outgoing_connection"
             (branch_encoding
                "outgoing_connection"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function Outgoing_connection p -> Some p | _ -> None)
             (fun p -> Outgoing_connection p);
           case
             (Tag 6)
             ~title:"Authentication_failed"
             (branch_encoding
                "authentication_failed"
                (obj1 (req "point" P2p_point.Id.encoding)))
             (function Authentication_failed p -> Some p | _ -> None)
             (fun p -> Authentication_failed p);
           case
             (Tag 7)
             ~title:"Accepting_request"
             (branch_encoding
                "accepting_request"
                (obj3
                   (req "point" P2p_point.Id.encoding)
                   (req "id_point" Id.encoding)
                   (req "peer_id" P2p_peer_id.encoding)))
             (function
               | Accepting_request (p, id_p, g) ->
                   Some (p, id_p, g)
               | _ ->
                   None)
             (fun (p, id_p, g) -> Accepting_request (p, id_p, g));
           case
             (Tag 8)
             ~title:"Rejecting_request"
             (branch_encoding
                "rejecting_request"
                (obj3
                   (req "point" P2p_point.Id.encoding)
                   (req "id_point" Id.encoding)
                   (req "peer_id" P2p_peer_id.encoding)))
             (function
               | Rejecting_request (p, id_p, g) ->
                   Some (p, id_p, g)
               | _ ->
                   None)
             (fun (p, id_p, g) -> Rejecting_request (p, id_p, g));
           case
             (Tag 9)
             ~title:"Request_rejected"
             (branch_encoding
                "request_rejected"
                (obj2
                   (req "point" P2p_point.Id.encoding)
                   (opt "identity" (tup2 Id.encoding P2p_peer_id.encoding))))
             (function Request_rejected (p, id) -> Some (p, id) | _ -> None)
             (fun (p, id) -> Request_rejected (p, id));
           case
             (Tag 10)
             ~title:"Connection_established"
             (branch_encoding
                "connection_established"
                (obj2
                   (req "id_point" Id.encoding)
                   (req "peer_id" P2p_peer_id.encoding)))
             (function
               | Connection_established (id_p, g) -> Some (id_p, g) | _ -> None)
             (fun (id_p, g) -> Connection_established (id_p, g));
           case
             (Tag 11)
             ~title:"Disconnection"
             (branch_encoding
                "disconnection"
                (obj1 (req "peer_id" P2p_peer_id.encoding)))
             (function Disconnection g -> Some g | _ -> None)
             (fun g -> Disconnection g);
           case
             (Tag 12)
             ~title:"External_disconnection"
             (branch_encoding
                "external_disconnection"
                (obj1 (req "peer_id" P2p_peer_id.encoding)))
             (function External_disconnection g -> Some g | _ -> None)
             (fun g -> External_disconnection g);
           case
             (Tag 13)
             ~title:"Gc_points"
             (branch_encoding "gc_points" empty)
             (function Gc_points -> Some () | _ -> None)
             (fun () -> Gc_points);
           case
             (Tag 14)
             ~title:"Gc_peer_ids"
             (branch_encoding "gc_peer_ids" empty)
             (function Gc_peer_ids -> Some () | _ -> None)
             (fun () -> Gc_peer_ids);
           case
             (Tag 15)
             ~title:"Swap_request_received"
             (branch_encoding
                "swap_request_received"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function
               | Swap_request_received {source} -> Some source | _ -> None)
             (fun source -> Swap_request_received {source});
           case
             (Tag 16)
             ~title:"Swap_ack_received"
             (branch_encoding
                "swap_ack_received"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_ack_received {source} -> Some source | _ -> None)
             (fun source -> Swap_ack_received {source});
           case
             (Tag 17)
             ~title:"Swap_request_sent"
             (branch_encoding
                "swap_request_sent"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_request_sent {source} -> Some source | _ -> None)
             (fun source -> Swap_request_sent {source});
           case
             (Tag 18)
             ~title:"Swap_ack_sent"
             (branch_encoding
                "swap_ack_sent"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_ack_sent {source} -> Some source | _ -> None)
             (fun source -> Swap_ack_sent {source});
           case
             (Tag 19)
             ~title:"Swap_request_ignored"
             (branch_encoding
                "swap_request_ignored"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function
               | Swap_request_ignored {source} -> Some source | _ -> None)
             (fun source -> Swap_request_ignored {source});
           case
             (Tag 20)
             ~title:"Swap_success"
             (branch_encoding
                "swap_success"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_success {source} -> Some source | _ -> None)
             (fun source -> Swap_success {source});
           case
             (Tag 21)
             ~title:"Swap_failure"
             (branch_encoding
                "swap_failure"
                (obj1 (req "source" P2p_peer_id.encoding)))
             (function Swap_failure {source} -> Some source | _ -> None)
             (fun source -> Swap_failure {source}) ]
end

let () =
  Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
  Data_encoding.Registration.register ~pp:P2p_event.pp P2p_event.encoding
src/lib_base/p2p_connection.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Id.
  Definition t := Tezos_base.P2p_addr.t * (option Tezos_base.P2p_addr.port).
  
  Definition compare {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : (Ipaddr.V6.t * A) -> Z :=
    let '(a1, p1) := function_parameter in
    fun function_parameter =>
      let '(a2, p2) := function_parameter in
      match Ipaddr.V6.compare a1 a2 with
      | 0 => Pervasives.compare p1 p2
      | x => x
      end.
  
  Definition equal {A : Type} (p1 : Ipaddr.V6.t * A) (p2 : Ipaddr.V6.t * A)
    : bool := equiv_decb (compare p1 p2) 0.
  
  Definition hash {A : Type} : A -> Z := Hashtbl.hash.
  
  Definition pp
    (ppf : Stdlib.Format.formatter)
    (function_parameter : Ipaddr.V6.t * (option Z)) : unit :=
    let '(addr, port) := function_parameter in
    match port with
    | None =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal "]:??" % string
                CamlinternalFormatBasics.End_of_format))) "[%a]:??" % string)
        Ipaddr.V6.pp addr
    | Some port =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal "]:" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format)))) "[%a]:%d" % string)
        Ipaddr.V6.pp addr port
    end.
  
  Definition pp_opt
    (ppf : Stdlib.Format.formatter)
    (function_parameter : option (Ipaddr.V6.t * (option Z))) : unit :=
    match function_parameter with
    | None => Format.pp_print_string ppf "none" % string
    | Some point => pp ppf point
    end.
  
  Definition to_string (t : Ipaddr.V6.t * (option Z)) : string :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) pp t.
  
  Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    let '(addr, _) := function_parameter in
    Ipaddr.V6.is_private addr.
  
  Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    let '(addr, _) := function_parameter in
    apply negb (Ipaddr.V6.is_private addr).
  
  Definition of_point {A B : Type} (function_parameter : A * B)
    : A * (option B) :=
    let '(addr, port) := function_parameter in
    (addr, (Some port)).
  
  Definition to_point {A B : Type} (function_parameter : A * (option B))
    : option (A * B) :=
    match function_parameter with
    | (_, None) => None
    | (addr, Some port) => Some (addr, port)
    end.
  
  Definition to_point_exn {A B : Type} (function_parameter : A * (option B))
    : A * B :=
    match function_parameter with
    | (_, None) => OCaml.Stdlib.invalid_arg "to_point_exn" % string
    | (addr, Some port) => (addr, port)
    end.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.encoding
      (Tezos_base.P2p_addr.t * (option Z)) :=
    apply
      (let arg :=
        def "p2p_connection.id" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "The identifier for a p2p connection. It includes an address and a port number."
              % string) in
      fun eta => arg None eta)
      (obj2 (req None None "addr" % string P2p_addr.encoding)
        (opt None None "port" % string uint16)).
End Id.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Module Info.
  Record t {meta : Type} := {
    incoming : bool;
    peer_id : Tezos_base.P2p_peer_id.t;
    id_point : Id.t;
    remote_socket_port : Tezos_base.P2p_addr.port;
    announced_version : Tezos_base.Network_version.t;
    private_node : bool;
    local_metadata : meta;
    remote_metadata : meta }.
  Arguments t : clear implicits.
  
  Definition encoding {A : Type}
    (metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
    : Tezos_data_encoding.Data_encoding.encoding (t A) :=
    conv
      (fun function_parameter =>
        let '{|
          incoming := incoming;
            peer_id := peer_id;
            id_point := id_point;
            remote_socket_port := remote_socket_port;
            announced_version := announced_version;
            private_node := private_node;
            local_metadata := local_metadata;
            remote_metadata := remote_metadata
            |} := function_parameter in
        (incoming, peer_id, id_point, remote_socket_port, announced_version,
          private_node, local_metadata, remote_metadata))
      (fun function_parameter =>
        let
          '(incoming, peer_id, id_point, remote_socket_port, announced_version,
            private_node, local_metadata, remote_metadata) := function_parameter
          in
        {| incoming := incoming; peer_id := peer_id; id_point := id_point;
          remote_socket_port := remote_socket_port;
          announced_version := announced_version; private_node := private_node;
          local_metadata := local_metadata; remote_metadata := remote_metadata
          |}) None
      (obj8 (req None None "incoming" % string bool)
        (req None None "peer_id" % string P2p_peer_id.encoding)
        (req None None "id_point" % string Id.encoding)
        (req None None "remote_socket_port" % string uint16)
        (req None None "announced_version" % string Network_version.encoding)
        (req None None "private" % string bool)
        (req None None "local_metadata" % string metadata_encoding)
        (req None None "remote_metadata" % string metadata_encoding)).
  
  Definition pp {A : Type}
    (pp_meta : Stdlib.Format.formatter -> A -> unit)
    (ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
    let '{|
      incoming := incoming;
        peer_id := peer_id;
        id_point := (remote_addr, remote_port);
        remote_socket_port := remote_socket_port;
        announced_version := announced_version;
        private_node := private_node;
        local_metadata := _;
        remote_metadata := remote_metadata
        |} := function_parameter in
    let point :=
      match remote_port with
      | None => (remote_addr, remote_socket_port)
      | Some port => (remote_addr, port)
      end in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal " " % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal " " % char
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal ") " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))))))))
        "%s %a %a (%a) %s%a" % string)
      (if incoming then
        "↘" % string
      else
        "↗" % string) P2p_peer_id.pp peer_id P2p_point.Id.pp point
      Network_version.pp announced_version
      (if private_node then
        " private" % string
      else
        "" % string) pp_meta remote_metadata.
End Info.

Module P2p_event.
  Inductive t : Type :=
  | Too_few_connections : t
  | Too_many_connections : t
  | New_point : Tezos_base.P2p_point.Id.t -> t
  | New_peer : Tezos_base.P2p_peer_id.t -> t
  | Gc_points : t
  | Gc_peer_ids : t
  | Incoming_connection : Tezos_base.P2p_point.Id.t -> t
  | Outgoing_connection : Tezos_base.P2p_point.Id.t -> t
  | Authentication_failed : Tezos_base.P2p_point.Id.t -> t
  | Accepting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
    Tezos_base.P2p_peer_id.t -> t
  | Rejecting_request : Tezos_base.P2p_point.Id.t -> Id.t ->
    Tezos_base.P2p_peer_id.t -> t
  | Request_rejected : Tezos_base.P2p_point.Id.t ->
    (option (Id.t * Tezos_base.P2p_peer_id.t)) -> t
  | Connection_established : Id.t -> Tezos_base.P2p_peer_id.t -> t
  | Swap_request_received : Tezos_base.P2p_peer_id.t -> t
  | Swap_ack_received : Tezos_base.P2p_peer_id.t -> t
  | Swap_request_sent : Tezos_base.P2p_peer_id.t -> t
  | Swap_ack_sent : Tezos_base.P2p_peer_id.t -> t
  | Swap_request_ignored : Tezos_base.P2p_peer_id.t -> t
  | Swap_success : Tezos_base.P2p_peer_id.t -> t
  | Swap_failure : Tezos_base.P2p_peer_id.t -> t
  | Disconnection : Tezos_base.P2p_peer_id.t -> t
  | External_disconnection : Tezos_base.P2p_peer_id.t -> t.
  
  Definition pp (ppf : Stdlib.Format.formatter) (event : t) : unit :=
    match event with
    | Too_few_connections =>
      Format.pp_print_string ppf "Too_few_connections" % string
    | Too_many_connections =>
      Format.pp_print_string ppf "Too_many_connections" % string
    | New_point p =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "New_point " % string in
      P2p_point.Id.pp ppf p
    | New_peer p =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "New_peer " % string in
      P2p_peer_id.pp ppf p
    | Gc_points => Format.pp_print_string ppf "Gc_points" % string
    | Gc_peer_ids => Format.pp_print_string ppf "Gc_peer_ids" % string
    | Incoming_connection p =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Incoming_connection " % string in
      P2p_point.Id.pp ppf p
    | Outgoing_connection p =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Outgoing_connection " % string in
      P2p_point.Id.pp ppf p
    | Authentication_failed p =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Authentication_failed " % string in
      P2p_point.Id.pp ppf p
    | Accepting_request pi _ _ =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Accepting_request " % string in
      P2p_point.Id.pp ppf pi
    | Rejecting_request pi _ _ =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Rejecting_request " % string in
      P2p_point.Id.pp ppf pi
    | Request_rejected pi _ =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Request_rejected " % string in
      P2p_point.Id.pp ppf pi
    | Connection_established _ pi =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Connection_established " % string in
      P2p_peer_id.pp ppf pi
    | Swap_request_received {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_request_received " % string in
      P2p_peer_id.pp ppf source
    | Swap_ack_received {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_ack_received " % string in
      P2p_peer_id.pp ppf source
    | Swap_request_sent {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_request_sent " % string in
      P2p_peer_id.pp ppf source
    | Swap_ack_sent {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_ack_sent " % string in
      P2p_peer_id.pp ppf source
    | Swap_request_ignored {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_request_ignored " % string in
      P2p_peer_id.pp ppf source
    | Swap_success {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_success " % string in
      P2p_peer_id.pp ppf source
    | Swap_failure {| source := source |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Swap_failure " % string in
      P2p_peer_id.pp ppf source
    | Disconnection source =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "Disconnection " % string in
      P2p_peer_id.pp ppf source
    | External_disconnection source =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_string ppf "External_disconnection " % string in
      P2p_peer_id.pp ppf source
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    let branch_encoding {A : Type}
      (name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
      : Tezos_data_encoding.Data_encoding.encoding A :=
      conv (fun x => (tt, x))
        (fun function_parameter =>
          let '(tt, x) := function_parameter in
          x) None
        (merge_objs (obj1 (req None None "event" % string (constant name))) obj)
      in
    apply
      (let arg :=
        def "p2p_connection.pool_event" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "An event that may happen during maintenance of and other operations on the p2p connection pool. Typically, it includes connection errors, peer swaps, etc."
              % string) in
      fun eta => arg None eta)
      (union
        (Some
          (* ❌ Variants not supported *)
          variant)
        (cons
          (case "Too_few_connections" % string None
            (Tezos_data_encoding.Data_encoding.Tag 0)
            (branch_encoding "too_few_connections" % string empty)
            (fun function_parameter =>
              match function_parameter with
              | Too_few_connections => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Too_few_connections))
          (cons
            (case "Too_many_connections" % string None
              (Tezos_data_encoding.Data_encoding.Tag 1)
              (branch_encoding "too_many_connections" % string empty)
              (fun function_parameter =>
                match function_parameter with
                | Too_many_connections => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Too_many_connections))
            (cons
              (case "New_point" % string None
                (Tezos_data_encoding.Data_encoding.Tag 2)
                (branch_encoding "new_point" % string
                  (obj1 (req None None "point" % string P2p_point.Id.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | New_point p => Some p
                  | _ => None
                  end) (fun p => New_point p))
              (cons
                (case "New_peer" % string None
                  (Tezos_data_encoding.Data_encoding.Tag 3)
                  (branch_encoding "new_peer" % string
                    (obj1
                      (req None None "peer_id" % string P2p_peer_id.encoding)))
                  (fun function_parameter =>
                    match function_parameter with
                    | New_peer p => Some p
                    | _ => None
                    end) (fun p => New_peer p))
                (cons
                  (case "Incoming_connection" % string None
                    (Tezos_data_encoding.Data_encoding.Tag 4)
                    (branch_encoding "incoming_connection" % string
                      (obj1
                        (req None None "point" % string P2p_point.Id.encoding)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Incoming_connection p => Some p
                      | _ => None
                      end) (fun p => Incoming_connection p))
                  (cons
                    (case "Outgoing_connection" % string None
                      (Tezos_data_encoding.Data_encoding.Tag 5)
                      (branch_encoding "outgoing_connection" % string
                        (obj1
                          (req None None "point" % string P2p_point.Id.encoding)))
                      (fun function_parameter =>
                        match function_parameter with
                        | Outgoing_connection p => Some p
                        | _ => None
                        end) (fun p => Outgoing_connection p))
                    (cons
                      (case "Authentication_failed" % string None
                        (Tezos_data_encoding.Data_encoding.Tag 6)
                        (branch_encoding "authentication_failed" % string
                          (obj1
                            (req None None "point" % string
                              P2p_point.Id.encoding)))
                        (fun function_parameter =>
                          match function_parameter with
                          | Authentication_failed p => Some p
                          | _ => None
                          end) (fun p => Authentication_failed p))
                      (cons
                        (case "Accepting_request" % string None
                          (Tezos_data_encoding.Data_encoding.Tag 7)
                          (branch_encoding "accepting_request" % string
                            (obj3
                              (req None None "point" % string
                                P2p_point.Id.encoding)
                              (req None None "id_point" % string Id.encoding)
                              (req None None "peer_id" % string
                                P2p_peer_id.encoding)))
                          (fun function_parameter =>
                            match function_parameter with
                            | Accepting_request p id_p g => Some (p, id_p, g)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            let '(p, id_p, g) := function_parameter in
                            Accepting_request p id_p g))
                        (cons
                          (case "Rejecting_request" % string None
                            (Tezos_data_encoding.Data_encoding.Tag 8)
                            (branch_encoding "rejecting_request" % string
                              (obj3
                                (req None None "point" % string
                                  P2p_point.Id.encoding)
                                (req None None "id_point" % string Id.encoding)
                                (req None None "peer_id" % string
                                  P2p_peer_id.encoding)))
                            (fun function_parameter =>
                              match function_parameter with
                              | Rejecting_request p id_p g => Some (p, id_p, g)
                              | _ => None
                              end)
                            (fun function_parameter =>
                              let '(p, id_p, g) := function_parameter in
                              Rejecting_request p id_p g))
                          (cons
                            (case "Request_rejected" % string None
                              (Tezos_data_encoding.Data_encoding.Tag 9)
                              (branch_encoding "request_rejected" % string
                                (obj2
                                  (req None None "point" % string
                                    P2p_point.Id.encoding)
                                  (opt None None "identity" % string
                                    (tup2 Id.encoding P2p_peer_id.encoding))))
                              (fun function_parameter =>
                                match function_parameter with
                                | Request_rejected p id => Some (p, id)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                let '(p, id) := function_parameter in
                                Request_rejected p id))
                            (cons
                              (case "Connection_established" % string None
                                (Tezos_data_encoding.Data_encoding.Tag 10)
                                (branch_encoding
                                  "connection_established" % string
                                  (obj2
                                    (req None None "id_point" % string
                                      Id.encoding)
                                    (req None None "peer_id" % string
                                      P2p_peer_id.encoding)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Connection_established id_p g =>
                                    Some (id_p, g)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  let '(id_p, g) := function_parameter in
                                  Connection_established id_p g))
                              (cons
                                (case "Disconnection" % string None
                                  (Tezos_data_encoding.Data_encoding.Tag 11)
                                  (branch_encoding "disconnection" % string
                                    (obj1
                                      (req None None "peer_id" % string
                                        P2p_peer_id.encoding)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Disconnection g => Some g
                                    | _ => None
                                    end) (fun g => Disconnection g))
                                (cons
                                  (case "External_disconnection" % string None
                                    (Tezos_data_encoding.Data_encoding.Tag 12)
                                    (branch_encoding
                                      "external_disconnection" % string
                                      (obj1
                                        (req None None "peer_id" % string
                                          P2p_peer_id.encoding)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | External_disconnection g => Some g
                                      | _ => None
                                      end) (fun g => External_disconnection g))
                                  (cons
                                    (case "Gc_points" % string None
                                      (Tezos_data_encoding.Data_encoding.Tag 13)
                                      (branch_encoding "gc_points" % string
                                        empty)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | Gc_points => Some tt
                                        | _ => None
                                        end)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        Gc_points))
                                    (cons
                                      (case "Gc_peer_ids" % string None
                                        (Tezos_data_encoding.Data_encoding.Tag
                                          14)
                                        (branch_encoding "gc_peer_ids" % string
                                          empty)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | Gc_peer_ids => Some tt
                                          | _ => None
                                          end)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          Gc_peer_ids))
                                      (cons
                                        (case "Swap_request_received" % string
                                          None
                                          (Tezos_data_encoding.Data_encoding.Tag
                                            15)
                                          (branch_encoding
                                            "swap_request_received" % string
                                            (obj1
                                              (req None None "source" % string
                                                P2p_peer_id.encoding)))
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Swap_request_received {|
                                                source := source |} =>
                                              Some source
                                            | _ => None
                                            end)
                                          (fun source =>
                                            Swap_request_received
                                              {| source := source |}))
                                        (cons
                                          (case "Swap_ack_received" % string
                                            None
                                            (Tezos_data_encoding.Data_encoding.Tag
                                              16)
                                            (branch_encoding
                                              "swap_ack_received" % string
                                              (obj1
                                                (req None None "source" % string
                                                  P2p_peer_id.encoding)))
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                Swap_ack_received {|
                                                  source := source |} =>
                                                Some source
                                              | _ => None
                                              end)
                                            (fun source =>
                                              Swap_ack_received
                                                {| source := source |}))
                                          (cons
                                            (case "Swap_request_sent" % string
                                              None
                                              (Tezos_data_encoding.Data_encoding.Tag
                                                17)
                                              (branch_encoding
                                                "swap_request_sent" % string
                                                (obj1
                                                  (req None None
                                                    "source" % string
                                                    P2p_peer_id.encoding)))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                |
                                                  Swap_request_sent {|
                                                    source := source |} =>
                                                  Some source
                                                | _ => None
                                                end)
                                              (fun source =>
                                                Swap_request_sent
                                                  {| source := source |}))
                                            (cons
                                              (case "Swap_ack_sent" % string
                                                None
                                                (Tezos_data_encoding.Data_encoding.Tag
                                                  18)
                                                (branch_encoding
                                                  "swap_ack_sent" % string
                                                  (obj1
                                                    (req None None
                                                      "source" % string
                                                      P2p_peer_id.encoding)))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  |
                                                    Swap_ack_sent {|
                                                      source := source |} =>
                                                    Some source
                                                  | _ => None
                                                  end)
                                                (fun source =>
                                                  Swap_ack_sent
                                                    {| source := source |}))
                                              (cons
                                                (case
                                                  "Swap_request_ignored" %
                                                    string None
                                                  (Tezos_data_encoding.Data_encoding.Tag
                                                    19)
                                                  (branch_encoding
                                                    "swap_request_ignored" %
                                                      string
                                                    (obj1
                                                      (req None None
                                                        "source" % string
                                                        P2p_peer_id.encoding)))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Swap_request_ignored {|
                                                        source := source |}
                                                      => Some source
                                                    | _ => None
                                                    end)
                                                  (fun source =>
                                                    Swap_request_ignored
                                                      {| source := source |}))
                                                (cons
                                                  (case "Swap_success" % string
                                                    None
                                                    (Tezos_data_encoding.Data_encoding.Tag
                                                      20)
                                                    (branch_encoding
                                                      "swap_success" % string
                                                      (obj1
                                                        (req None None
                                                          "source" % string
                                                          P2p_peer_id.encoding)))
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        Swap_success {|
                                                          source := source
                                                            |} => Some source
                                                      | _ => None
                                                      end)
                                                    (fun source =>
                                                      Swap_success
                                                        {| source := source |}))
                                                  (cons
                                                    (case
                                                      "Swap_failure" % string
                                                      None
                                                      (Tezos_data_encoding.Data_encoding.Tag
                                                        21)
                                                      (branch_encoding
                                                        "swap_failure" % string
                                                        (obj1
                                                          (req None None
                                                            "source" % string
                                                            P2p_peer_id.encoding)))
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        |
                                                          Swap_failure {|
                                                            source := source
                                                              |} => Some source
                                                        | _ => None
                                                        end)
                                                      (fun source =>
                                                        Swap_failure
                                                          {| source := source |}))
                                                    []))))))))))))))))))))))).
End P2p_event.



src/lib_base/p2p_identity.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  peer_id : P2p_peer.Id.t;
  public_key : Crypto_box.public_key;
  secret_key : Crypto_box.secret_key;
  proof_of_work_stamp : Crypto_box.nonce;
}

let encoding =
  let open Data_encoding in
  def
    "p2p_identity"
    ~description:
      "The identity of a peer. This includes cryptographic keys as well as a \
       proof-of-work."
  @@ conv
       (fun {peer_id; public_key; secret_key; proof_of_work_stamp} ->
         (Some peer_id, public_key, secret_key, proof_of_work_stamp))
       (fun (peer_id_opt, public_key, secret_key, proof_of_work_stamp) ->
         let peer_id =
           match peer_id_opt with
           | Some peer_id ->
               peer_id
           | None ->
               Tezos_crypto.Crypto_box.hash public_key
         in
         {peer_id; public_key; secret_key; proof_of_work_stamp})
       (obj4
          (opt "peer_id" P2p_peer_id.encoding)
          (req "public_key" Crypto_box.public_key_encoding)
          (req "secret_key" Crypto_box.secret_key_encoding)
          (req "proof_of_work_stamp" Crypto_box.nonce_encoding))

let generate_with_bound ?max target =
  let (secret_key, public_key, peer_id) = Crypto_box.random_keypair () in
  let proof_of_work_stamp =
    Crypto_box.generate_proof_of_work ?max public_key target
  in
  {peer_id; public_key; secret_key; proof_of_work_stamp}

let generate target = generate_with_bound target

let () = Data_encoding.Registration.register encoding
src/lib_base/p2p_identity.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  peer_id : Tezos_base.P2p_peer.Id.t;
  public_key : Tezos_crypto.Crypto_box.public_key;
  secret_key : Tezos_crypto.Crypto_box.secret_key;
  proof_of_work_stamp : Tezos_crypto.Crypto_box.nonce }.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "p2p_identity" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "The identity of a peer. This includes cryptographic keys as well as a proof-of-work."
            % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{|
          peer_id := peer_id;
            public_key := public_key;
            secret_key := secret_key;
            proof_of_work_stamp := proof_of_work_stamp
            |} := function_parameter in
        ((Some peer_id), public_key, secret_key, proof_of_work_stamp))
      (fun function_parameter =>
        let '(peer_id_opt, public_key, secret_key, proof_of_work_stamp) :=
          function_parameter in
        let peer_id :=
          match peer_id_opt with
          | Some peer_id => peer_id
          | None => Tezos_crypto.Crypto_box.hash public_key
          end in
        {| peer_id := peer_id; public_key := public_key;
          secret_key := secret_key; proof_of_work_stamp := proof_of_work_stamp
          |}) None
      (obj4 (opt None None "peer_id" % string P2p_peer_id.encoding)
        (req None None "public_key" % string Crypto_box.public_key_encoding)
        (req None None "secret_key" % string Crypto_box.secret_key_encoding)
        (req None None "proof_of_work_stamp" % string Crypto_box.nonce_encoding))).

Definition generate_with_bound
  (max : option Z) (target : Tezos_crypto.Crypto_box.target) : t :=
  let '(secret_key, public_key, peer_id) := Crypto_box.random_keypair tt in
  let proof_of_work_stamp :=
    Crypto_box.generate_proof_of_work max public_key target in
  {| peer_id := peer_id; public_key := public_key; secret_key := secret_key;
    proof_of_work_stamp := proof_of_work_stamp |}.

Definition generate (target : Tezos_crypto.Crypto_box.target) : t :=
  generate_with_bound None target.



src/lib_base/p2p_peer.ml 37 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = P2p_peer_id
module Table = Id.Table
module Error_table = Id.Error_table
module Map = Id.Map
module Set = Id.Set

module Filter = struct
  type t = Accepted | Running | Disconnected

  let rpc_arg =
    RPC_arg.make
      ~name:"p2p.point.state_filter"
      ~destruct:(function
        | "accepted" ->
            Ok Accepted
        | "running" ->
            Ok Running
        | "disconnected" ->
            Ok Disconnected
        | s ->
            Error (Format.asprintf "Invalid state: %s" s))
      ~construct:(function
        | Accepted ->
            "accepted"
        | Running ->
            "running"
        | Disconnected ->
            "disconnected")
      ()
end

module State = struct
  type t = Accepted | Running | Disconnected

  let pp_digram ppf = function
    | Accepted ->
        Format.fprintf ppf "⚎"
    | Running ->
        Format.fprintf ppf "⚌"
    | Disconnected ->
        Format.fprintf ppf "⚏"

  let encoding =
    let open Data_encoding in
    def
      "p2p_peer.state"
      ~description:
        "The state a peer connection can be in: accepted (when the connection \
         is being established), running (when the connection is already \
         established), disconnected (otherwise)."
    @@ string_enum
         [ ("accepted", Accepted);
           ("running", Running);
           ("disconnected", Disconnected) ]

  let raw_filter (f : Filter.t) (s : t) =
    match (f, s) with
    | (Accepted, Accepted) ->
        true
    | (Accepted, (Running | Disconnected))
    | ((Running | Disconnected), Accepted) ->
        false
    | (Running, Running) ->
        true
    | (Disconnected, Disconnected) ->
        true
    | (Running, Disconnected) | (Disconnected, Running) ->
        false

  let filter filters state = List.exists (fun f -> raw_filter f state) filters
end

module Info = struct
  type ('peer_meta, 'conn_meta) t = {
    score : float;
    trusted : bool;
    conn_metadata : 'conn_meta option;
    peer_metadata : 'peer_meta;
    state : State.t;
    id_point : P2p_connection.Id.t option;
    stat : P2p_stat.t;
    last_failed_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_rejected_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_established_connection : (P2p_connection.Id.t * Time.System.t) option;
    last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
    last_seen : (P2p_connection.Id.t * Time.System.t) option;
    last_miss : (P2p_connection.Id.t * Time.System.t) option;
  }

  let encoding peer_metadata_encoding conn_metadata_encoding =
    let open Data_encoding in
    conv
      (fun { score;
             trusted;
             conn_metadata;
             peer_metadata;
             state;
             id_point;
             stat;
             last_failed_connection;
             last_rejected_connection;
             last_established_connection;
             last_disconnection;
             last_seen;
             last_miss } ->
        ( (score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
          ( last_failed_connection,
            last_rejected_connection,
            last_established_connection,
            last_disconnection,
            last_seen,
            last_miss ) ))
      (fun ( ( score,
               trusted,
               conn_metadata,
               peer_metadata,
               state,
               id_point,
               stat ),
             ( last_failed_connection,
               last_rejected_connection,
               last_established_connection,
               last_disconnection,
               last_seen,
               last_miss ) ) ->
        {
          score;
          trusted;
          conn_metadata;
          peer_metadata;
          state;
          id_point;
          stat;
          last_failed_connection;
          last_rejected_connection;
          last_established_connection;
          last_disconnection;
          last_seen;
          last_miss;
        })
      (merge_objs
         (obj7
            (req "score" float)
            (req "trusted" bool)
            (opt "conn_metadata" conn_metadata_encoding)
            (req "peer_metadata" peer_metadata_encoding)
            (req "state" State.encoding)
            (opt "reachable_at" P2p_connection.Id.encoding)
            (req "stat" P2p_stat.encoding))
         (obj6
            (opt
               "last_failed_connection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_rejected_connection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_established_connection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_disconnection"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_seen"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))
            (opt
               "last_miss"
               (tup2 P2p_connection.Id.encoding Time.System.encoding))))
end

module Pool_event = struct
  type kind =
    | Accepting_request
    | Rejecting_request
    | Request_rejected
    | Connection_established
    | Disconnection
    | External_disconnection

  let kind_encoding =
    Data_encoding.string_enum
      [ ("incoming_request", Accepting_request);
        ("rejecting_request", Rejecting_request);
        ("request_rejected", Request_rejected);
        ("connection_established", Connection_established);
        ("disconnection", Disconnection);
        ("external_disconnection", External_disconnection) ]

  type t = {
    kind : kind;
    timestamp : Time.System.t;
    point : P2p_connection.Id.t;
  }

  let encoding =
    let open Data_encoding in
    def
      "p2p_peer.pool_event"
      ~description:
        "An event that may happen during maintenance of and other operations \
         on the connection to a specific peer."
    @@ conv
         (fun {kind; timestamp; point = (addr, port)} ->
           (kind, timestamp, addr, port))
         (fun (kind, timestamp, addr, port) ->
           {kind; timestamp; point = (addr, port)})
         (obj4
            (req "kind" kind_encoding)
            (req "timestamp" Time.System.encoding)
            (req "addr" P2p_addr.encoding)
            (opt "port" uint16))
end

let () =
  Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
  Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_peer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Filter.
  Inductive t : Type :=
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
    RPC_arg.make None "p2p.point.state_filter" % string
      (fun function_parameter =>
        match function_parameter with
        | "accepted" % string => Stdlib.Ok Accepted
        | "running" % string => Stdlib.Ok Running
        | "disconnected" % string => Stdlib.Ok Disconnected
        | s =>
          Stdlib.Error
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Invalid state: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "Invalid state: %s" % string) s)
        end)
      (fun function_parameter =>
        match function_parameter with
        | Accepted => "accepted" % string
        | Running => "running" % string
        | Disconnected => "disconnected" % string
        end) tt.
End Filter.

Module State.
  Inductive t : Type :=
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Accepted =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚎" % string
            CamlinternalFormatBasics.End_of_format) "⚎" % string)
    | Running =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚌" % string
            CamlinternalFormatBasics.End_of_format) "⚌" % string)
    | Disconnected =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚏" % string
            CamlinternalFormatBasics.End_of_format) "⚏" % string)
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        def "p2p_peer.state" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "The state a peer connection can be in: accepted (when the connection is being established), running (when the connection is already established), disconnected (otherwise)."
              % string) in
      fun eta => arg None eta)
      (string_enum
        (cons ("accepted" % string, Accepted)
          (cons ("running" % string, Running)
            (cons ("disconnected" % string, Disconnected) [])))).
  
  Definition raw_filter (f : Filter.t) (s : t) : bool :=
    match (f, s) with
    | (Filter.Accepted, Accepted) => true
    |
      (Filter.Accepted, Running | Disconnected) |
        (Filter.Running | Filter.Disconnected, Accepted) => false
    | (Filter.Running, Running) => true
    | (Filter.Disconnected, Disconnected) => true
    | (Filter.Running, Disconnected) | (Filter.Disconnected, Running) => false
    end.
  
  Definition filter (filters : list Filter.t) (state : t) : bool :=
    Stdlib.List._exists (fun f => raw_filter f state) filters.
End State.

Module Info.
  Record t {peer_meta conn_meta : Type} := {
    score : Z;
    trusted : bool;
    conn_metadata : option conn_meta;
    peer_metadata : peer_meta;
    state : State.t;
    id_point : option Tezos_base.P2p_connection.Id.t;
    stat : Tezos_base.P2p_stat.t;
    last_failed_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_rejected_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_established_connection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_disconnection :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_seen :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t);
    last_miss :
      option (Tezos_base.P2p_connection.Id.t * Tezos_base.Time.System.t) }.
  Arguments t : clear implicits.
  
  Definition encoding {A B : Type}
    (peer_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding A)
    (conn_metadata_encoding : Tezos_data_encoding.Data_encoding.encoding B)
    : Tezos_data_encoding.Data_encoding.encoding (t A B) :=
    conv
      (fun function_parameter =>
        let '{|
          score := score;
            trusted := trusted;
            conn_metadata := conn_metadata;
            peer_metadata := peer_metadata;
            state := state;
            id_point := id_point;
            stat := stat;
            last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection;
            last_seen := last_seen;
            last_miss := last_miss
            |} := function_parameter in
        ((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
          (last_failed_connection, last_rejected_connection,
            last_established_connection, last_disconnection, last_seen,
            last_miss)))
      (fun function_parameter =>
        let
          '((score, trusted, conn_metadata, peer_metadata, state, id_point, stat),
            (last_failed_connection, last_rejected_connection,
              last_established_connection, last_disconnection, last_seen,
              last_miss)) := function_parameter in
        {| score := score; trusted := trusted; conn_metadata := conn_metadata;
          peer_metadata := peer_metadata; state := state; id_point := id_point;
          stat := stat; last_failed_connection := last_failed_connection;
          last_rejected_connection := last_rejected_connection;
          last_established_connection := last_established_connection;
          last_disconnection := last_disconnection; last_seen := last_seen;
          last_miss := last_miss |}) None
      (merge_objs
        (obj7 (req None None "score" % string float)
          (req None None "trusted" % string bool)
          (opt None None "conn_metadata" % string conn_metadata_encoding)
          (req None None "peer_metadata" % string peer_metadata_encoding)
          (req None None "state" % string State.encoding)
          (opt None None "reachable_at" % string P2p_connection.Id.encoding)
          (req None None "stat" % string P2p_stat.encoding))
        (obj6
          (opt None None "last_failed_connection" % string
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
          (opt None None "last_rejected_connection" % string
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
          (opt None None "last_established_connection" % string
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
          (opt None None "last_disconnection" % string
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
          (opt None None "last_seen" % string
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
          (opt None None "last_miss" % string
            (tup2 P2p_connection.Id.encoding Time.System.encoding)))).
End Info.

Module Pool_event.
  Inductive kind : Type :=
  | Accepting_request : kind
  | Rejecting_request : kind
  | Request_rejected : kind
  | Connection_established : kind
  | Disconnection : kind
  | External_disconnection : kind.
  
  Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
    Data_encoding.string_enum
      (cons ("incoming_request" % string, Accepting_request)
        (cons ("rejecting_request" % string, Rejecting_request)
          (cons ("request_rejected" % string, Request_rejected)
            (cons ("connection_established" % string, Connection_established)
              (cons ("disconnection" % string, Disconnection)
                (cons
                  ("external_disconnection" % string, External_disconnection) [])))))).
  
  Record t := {
    kind : kind;
    timestamp : Tezos_base.Time.System.t;
    point : Tezos_base.P2p_connection.Id.t }.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        def "p2p_peer.pool_event" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "An event that may happen during maintenance of and other operations on the connection to a specific peer."
              % string) in
      fun eta => arg None eta)
      (conv
        (fun function_parameter =>
          let '{|
            kind := kind; timestamp := timestamp; point := (addr, port) |} :=
            function_parameter in
          (kind, timestamp, addr, port))
        (fun function_parameter =>
          let '(kind, timestamp, addr, port) := function_parameter in
          {| kind := kind; timestamp := timestamp; point := (addr, port) |})
        None
        (obj4 (req None None "kind" % string kind_encoding)
          (req None None "timestamp" % string Time.System.encoding)
          (req None None "addr" % string P2p_addr.encoding)
          (opt None None "port" % string uint16))).
End Pool_event.



src/lib_base/p2p_peer_id.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Crypto_box.Public_key_hash

let rpc_arg =
  RPC_arg.like
    rpc_arg
    ~descr:"A cryptographic node identity (Base58Check-encoded)"
    "peer_id"

let pp_source ppf = function
  | None ->
      ()
  | Some peer ->
      Format.fprintf ppf " from peer %a" pp peer

module Logging = struct
  include Internal_event.Legacy_logging.Make_semantic (struct
    let name = "node.distributed_db.p2p_peer_id"
  end)

  let mk_tag pp = Tag.def ~doc:"P2P peer ID" "p2p_peer_id" pp

  let tag = mk_tag pp_short

  let tag_opt =
    mk_tag (fun ppf -> function None -> () | Some peer -> pp_short ppf peer)

  let tag_source =
    Tag.def
      ~doc:"Peer which provided information"
      "p2p_peer_id_source"
      pp_source
end
src/lib_base/p2p_peer_id.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
  RPC_arg.like rpc_arg
    (Some "A cryptographic node identity (Base58Check-encoded)" % string)
    "peer_id" % string.

Definition pp_source
  (ppf : Stdlib.Format.formatter) (function_parameter : option t) : unit :=
  match function_parameter with
  | None => tt
  | Some peer =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal " from peer " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        " from peer %a" % string) pp peer
  end.

Module Logging.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition mk_tag {A : Type} (pp : Stdlib.Format.formatter -> A -> unit)
    : Tag.def A :=
    Tag.def (Some "P2P peer ID" % string) "p2p_peer_id" % string pp.
  
  Definition tag : Tag.def t := mk_tag pp_short.
  
  Definition tag_opt : Tag.def (option t) :=
    mk_tag
      (fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | None => tt
          | Some peer => pp_short ppf peer
          end).
  
  Definition tag_source : Tag.def (option t) :=
    Tag.def (Some "Peer which provided information" % string)
      "p2p_peer_id_source" % string pp_source.
End Logging.

src/lib_base/p2p_point.ml 33 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Id = struct
  (* A net point (address x port). *)
  type t = P2p_addr.t * P2p_addr.port

  let compare (a1, p1) (a2, p2) =
    match Ipaddr.V6.compare a1 a2 with 0 -> p1 - p2 | x -> x

  let equal p1 p2 = compare p1 p2 = 0

  let hash = Hashtbl.hash

  let pp ppf (addr, port) =
    match Ipaddr.v4_of_v6 addr with
    | Some addr ->
        Format.fprintf ppf "%a:%d" Ipaddr.V4.pp addr port
    | None ->
        Format.fprintf ppf "[%a]:%d" Ipaddr.V6.pp addr port

  let pp_opt ppf = function
    | None ->
        Format.pp_print_string ppf "none"
    | Some point ->
        pp ppf point

  let pp_list ppf point_list =
    Format.pp_print_list ~pp_sep:Format.pp_print_space pp ppf point_list

  let is_local (addr, _) = Ipaddr.V6.is_private addr

  let is_global (addr, _) = not @@ Ipaddr.V6.is_private addr

  let check_port port =
    if
      TzString.mem_char port '[' || TzString.mem_char port ']'
      || TzString.mem_char port ':'
    then invalid_arg "Utils.parse_addr_port (invalid character in port)"

  let parse_addr_port s =
    let len = String.length s in
    if len = 0 then ("", "")
    else if s.[0] = '[' then (
      (* inline IPv6 *)
      match String.rindex_opt s ']' with
      | None ->
          invalid_arg "Utils.parse_addr_port (missing ']')"
      | Some pos ->
          let addr = String.sub s 1 (pos - 1) in
          let port =
            if pos = len - 1 then ""
            else if s.[pos + 1] <> ':' then
              invalid_arg "Utils.parse_addr_port (unexpected char after ']')"
            else String.sub s (pos + 2) (len - pos - 2)
          in
          check_port port ; (addr, port) )
    else
      match String.rindex_opt s ']' with
      | Some _pos ->
          invalid_arg "Utils.parse_addr_port (unexpected char ']')"
      | None -> (
        match String.index s ':' with
        | exception _ ->
            (s, "")
        | pos -> (
          match String.index_from s (pos + 1) ':' with
          | exception _ ->
              let addr = String.sub s 0 pos in
              let port = String.sub s (pos + 1) (len - pos - 1) in
              check_port port ; (addr, port)
          | _pos ->
              invalid_arg
                "Utils.parse_addr_port: IPv6 addresses must be bracketed" ) )

  let of_string_exn ?default_port str =
    let (addr, port) = parse_addr_port str in
    let port =
      if port = "" then
        Option.unopt_exn
          (Invalid_argument "P2p_point.of_string_exn: no port")
          default_port
      else int_of_string port
    in
    if port < 0 && port > (1 lsl 16) - 1 then
      invalid_arg "port must be between 0 and 65535" ;
    match Ipaddr.of_string_exn addr with
    | V4 addr ->
        (Ipaddr.v6_of_v4 addr, port)
    | V6 addr ->
        (addr, port)

  let of_string ?default_port str =
    try Ok (of_string_exn ?default_port str) with
    | Invalid_argument s ->
        Error s
    | Failure s ->
        Error s
    | _ ->
        Error "P2p_point.of_string"

  let to_string saddr = Format.asprintf "%a" pp saddr

  let encoding =
    let open Data_encoding in
    def "p2p_point.id" ~description:"Identifier for a peer point"
    @@ conv to_string of_string_exn string

  let rpc_arg =
    RPC_arg.make
      ~name:"point"
      ~descr:"A network point (ipv4:port or [ipv6]:port)."
      ~destruct:of_string
      ~construct:to_string
      ()
end

module Map = Map.Make (Id)
module Set = Set.Make (Id)
module Table = Hashtbl.Make (Id)

module Filter = struct
  type t = Requested | Accepted | Running | Disconnected

  let rpc_arg =
    RPC_arg.make
      ~name:"p2p.point.state_filter"
      ~destruct:(function
        | "requested" ->
            Ok Requested
        | "accepted" ->
            Ok Accepted
        | "running" ->
            Ok Running
        | "disconnected" ->
            Ok Disconnected
        | s ->
            Error (Format.asprintf "Invalid state: %s" s))
      ~construct:(function
        | Requested ->
            "requested"
        | Accepted ->
            "accepted"
        | Running ->
            "running"
        | Disconnected ->
            "disconnected")
      ()
end

module State = struct
  type t =
    | Requested
    | Accepted of P2p_peer_id.t
    | Running of P2p_peer_id.t
    | Disconnected

  let of_p2p_peer_id = function
    | Requested ->
        None
    | Accepted pi ->
        Some pi
    | Running pi ->
        Some pi
    | Disconnected ->
        None

  let of_peerid_state state pi =
    match (state, pi) with
    | (Requested, _) ->
        Requested
    | (Accepted _, Some pi) ->
        Accepted pi
    | (Running _, Some pi) ->
        Running pi
    | (Disconnected, _) ->
        Disconnected
    | _ ->
        invalid_arg "state_of_state_peerid"

  let pp_digram ppf = function
    | Requested ->
        Format.fprintf ppf "⚎"
    | Accepted _ ->
        Format.fprintf ppf "⚍"
    | Running _ ->
        Format.fprintf ppf "⚌"
    | Disconnected ->
        Format.fprintf ppf "⚏"

  let encoding =
    let open Data_encoding in
    let branch_encoding name obj =
      conv
        (fun x -> ((), x))
        (fun ((), x) -> x)
        (merge_objs (obj1 (req "event_kind" (constant name))) obj)
    in
    def
      "p2p_point.state"
      ~description:
        "The state a connection to a peer point can be in: requested \
         (connection open from here), accepted (handshake), running \
         (connection already established), disconnected (no connection)."
    @@ union
         ~tag_size:`Uint8
         [ case
             (Tag 0)
             ~title:"Requested"
             (branch_encoding "requested" empty)
             (function Requested -> Some () | _ -> None)
             (fun () -> Requested);
           case
             (Tag 1)
             ~title:"Accepted"
             (branch_encoding
                "accepted"
                (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
             (function Accepted p2p_peer_id -> Some p2p_peer_id | _ -> None)
             (fun p2p_peer_id -> Accepted p2p_peer_id);
           case
             (Tag 2)
             ~title:"Running"
             (branch_encoding
                "running"
                (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
             (function Running p2p_peer_id -> Some p2p_peer_id | _ -> None)
             (fun p2p_peer_id -> Running p2p_peer_id);
           case
             (Tag 3)
             ~title:"Disconnected"
             (branch_encoding "disconnected" empty)
             (function Disconnected -> Some () | _ -> None)
             (fun () -> Disconnected) ]

  let raw_filter (f : Filter.t) (s : t) =
    match (f, s) with
    | (Requested, Requested) ->
        true
    | (Requested, (Accepted _ | Running _ | Disconnected))
    | ((Accepted | Running | Disconnected), Requested) ->
        false
    | (Accepted, Accepted _) ->
        true
    | (Accepted, (Running _ | Disconnected))
    | ((Running | Disconnected), Accepted _) ->
        false
    | (Running, Running _) ->
        true
    | (Disconnected, Disconnected) ->
        true
    | (Running, Disconnected) | (Disconnected, Running _) ->
        false

  let filter filters state = List.exists (fun f -> raw_filter f state) filters
end

module Info = struct
  type t = {
    trusted : bool;
    greylisted_until : Time.System.t;
    state : State.t;
    last_failed_connection : Time.System.t option;
    last_rejected_connection : (P2p_peer_id.t * Time.System.t) option;
    last_established_connection : (P2p_peer_id.t * Time.System.t) option;
    last_disconnection : (P2p_peer_id.t * Time.System.t) option;
    last_seen : (P2p_peer_id.t * Time.System.t) option;
    last_miss : Time.System.t option;
  }

  let encoding =
    let open Data_encoding in
    def
      "p2p_point.info"
      ~description:
        "Information about a peer point. Includes flags, state, and records \
         about past events."
    @@ conv
         (fun { trusted;
                greylisted_until;
                state;
                last_failed_connection;
                last_rejected_connection;
                last_established_connection;
                last_disconnection;
                last_seen;
                last_miss } ->
           let p2p_peer_id = State.of_p2p_peer_id state in
           ( trusted,
             greylisted_until,
             state,
             p2p_peer_id,
             last_failed_connection,
             last_rejected_connection,
             last_established_connection,
             last_disconnection,
             last_seen,
             last_miss ))
         (fun ( trusted,
                greylisted_until,
                state,
                p2p_peer_id,
                last_failed_connection,
                last_rejected_connection,
                last_established_connection,
                last_disconnection,
                last_seen,
                last_miss ) ->
           let state = State.of_peerid_state state p2p_peer_id in
           {
             trusted;
             greylisted_until;
             state;
             last_failed_connection;
             last_rejected_connection;
             last_established_connection;
             last_disconnection;
             last_seen;
             last_miss;
           })
         (obj10
            (req "trusted" bool)
            (dft "greylisted_until" Time.System.encoding Time.System.epoch)
            (req "state" State.encoding)
            (opt "p2p_peer_id" P2p_peer_id.encoding)
            (opt "last_failed_connection" Time.System.encoding)
            (opt
               "last_rejected_connection"
               (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt
               "last_established_connection"
               (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt
               "last_disconnection"
               (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt "last_seen" (tup2 P2p_peer_id.encoding Time.System.encoding))
            (opt "last_miss" Time.System.encoding))
end

module Pool_event = struct
  type kind =
    | Outgoing_request
    | Accepting_request of P2p_peer_id.t
    | Rejecting_request of P2p_peer_id.t
    | Request_rejected of P2p_peer_id.t option
    | Connection_established of P2p_peer_id.t
    | Disconnection of P2p_peer_id.t
    | External_disconnection of P2p_peer_id.t

  let kind_encoding =
    let open Data_encoding in
    let branch_encoding name obj =
      conv
        (fun x -> ((), x))
        (fun ((), x) -> x)
        (merge_objs (obj1 (req "event_kind" (constant name))) obj)
    in
    union
      ~tag_size:`Uint8
      [ case
          (Tag 0)
          ~title:"Outgoing_request"
          (branch_encoding "outgoing_request" empty)
          (function Outgoing_request -> Some () | _ -> None)
          (fun () -> Outgoing_request);
        case
          (Tag 1)
          ~title:"Accepting_request"
          (branch_encoding
             "accepting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Accepting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Accepting_request p2p_peer_id);
        case
          (Tag 2)
          ~title:"Rejecting_request"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Rejecting_request p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Rejecting_request p2p_peer_id);
        case
          (Tag 3)
          ~title:"Rejecting_rejected"
          (branch_encoding
             "request_rejected"
             (obj1 (opt "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Request_rejected p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Request_rejected p2p_peer_id);
        case
          (Tag 4)
          ~title:"Connection_established"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Connection_established p2p_peer_id ->
                Some p2p_peer_id
            | _ ->
                None)
          (fun p2p_peer_id -> Connection_established p2p_peer_id);
        case
          (Tag 5)
          ~title:"Disconnection"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | Disconnection p2p_peer_id -> Some p2p_peer_id | _ -> None)
          (fun p2p_peer_id -> Disconnection p2p_peer_id);
        case
          (Tag 6)
          ~title:"External_disconnection"
          (branch_encoding
             "rejecting_request"
             (obj1 (req "p2p_peer_id" P2p_peer_id.encoding)))
          (function
            | External_disconnection p2p_peer_id ->
                Some p2p_peer_id
            | _ ->
                None)
          (fun p2p_peer_id -> External_disconnection p2p_peer_id) ]

  type t = kind Time.System.stamped

  let encoding =
    Data_encoding.def
      "p2p_point.pool_event"
      ~description:
        "Events happening during maintenance of and operations on a peer \
         point pool (such as connections, disconnections, connection \
         requests)."
    @@ Time.System.stamped_encoding kind_encoding
end

let () =
  Data_encoding.Registration.register ~pp:Id.pp Id.encoding ;
  Data_encoding.Registration.register ~pp:State.pp_digram State.encoding ;
  Data_encoding.Registration.register Info.encoding ;
  Data_encoding.Registration.register Pool_event.encoding
src/lib_base/p2p_point.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Id.
  Definition t := Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port.
  
  Definition compare (function_parameter : Ipaddr.V6.t * Z)
    : (Ipaddr.V6.t * Z) -> Z :=
    let '(a1, p1) := function_parameter in
    fun function_parameter =>
      let '(a2, p2) := function_parameter in
      match Ipaddr.V6.compare a1 a2 with
      | 0 => Z.sub p1 p2
      | x => x
      end.
  
  Definition equal (p1 : Ipaddr.V6.t * Z) (p2 : Ipaddr.V6.t * Z) : bool :=
    equiv_decb (compare p1 p2) 0.
  
  Definition hash {A : Type} : A -> Z := Hashtbl.hash.
  
  Definition pp
    (ppf : Stdlib.Format.formatter) (function_parameter : Ipaddr.V6.t * Z)
    : unit :=
    let '(addr, port) := function_parameter in
    match Ipaddr.v4_of_v6 addr with
    | Some addr =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal ":" % char
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format))) "%a:%d" % string)
        Ipaddr.V4.pp addr port
    | None =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal "]:" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format)))) "[%a]:%d" % string)
        Ipaddr.V6.pp addr port
    end.
  
  Definition pp_opt
    (ppf : Stdlib.Format.formatter)
    (function_parameter : option (Ipaddr.V6.t * Z)) : unit :=
    match function_parameter with
    | None => Format.pp_print_string ppf "none" % string
    | Some point => pp ppf point
    end.
  
  Definition pp_list
    (ppf : Stdlib.Format.formatter) (point_list : list (Ipaddr.V6.t * Z))
    : unit :=
    Format.pp_print_list (Some Format.pp_print_space) pp ppf point_list.
  
  Definition is_local {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    let '(addr, _) := function_parameter in
    Ipaddr.V6.is_private addr.
  
  Definition is_global {A : Type} (function_parameter : Ipaddr.V6.t * A)
    : bool :=
    let '(addr, _) := function_parameter in
    apply negb (Ipaddr.V6.is_private addr).
  
  Definition check_port (port : string) : unit :=
    if
      orb (TzString.mem_char port "[" % char)
        (orb (TzString.mem_char port "]" % char)
          (TzString.mem_char port ":" % char)) then
      OCaml.Stdlib.invalid_arg
        "Utils.parse_addr_port (invalid character in port)" % string
    else
      tt.
  
  Definition parse_addr_port (s : string) : string * string :=
    let len := OCaml.String.length s in
    if equiv_decb len 0 then
      ("" % string, "" % string)
    else
      if equiv_decb (Stdlib.String.get s 0) "[" % char then
        match Stdlib.String.rindex_opt s "]" % char with
        | None =>
          OCaml.Stdlib.invalid_arg
            "Utils.parse_addr_port (missing ']')" % string
        | Some pos =>
          let addr := Stdlib.String.sub s 1 (Z.sub pos 1) in
          let port :=
            if equiv_decb pos (Z.sub len 1) then
              "" % string
            else
              if nequiv_decb (Stdlib.String.get s (Z.add pos 1)) ":" % char then
                OCaml.Stdlib.invalid_arg
                  "Utils.parse_addr_port (unexpected char after ']')" % string
              else
                Stdlib.String.sub s (Z.add pos 2) (Z.sub (Z.sub len pos) 2) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := check_port port in
          (addr, port)
        end
      else
        match Stdlib.String.rindex_opt s "]" % char with
        | Some _pos =>
          OCaml.Stdlib.invalid_arg
            "Utils.parse_addr_port (unexpected char ']')" % string
        | None =>
          let 'pos := Stdlib.String.index s ":" % char in
          let '_pos := Stdlib.String.index_from s (Z.add pos 1) ":" % char in
          OCaml.Stdlib.invalid_arg
            "Utils.parse_addr_port: IPv6 addresses must be bracketed" % string
        end.
  
  Definition of_string_exn (default_port : option Z) (str : string)
    : Ipaddr.V6.t * Z :=
    let '(addr, port) := parse_addr_port str in
    let port :=
      if equiv_decb port "" % string then
        Option.unopt_exn
          (OCaml.Invalid_argument "P2p_point.of_string_exn: no port" % string)
          default_port
      else
        OCaml.Stdlib.int_of_string port in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if
        andb (OCaml.Stdlib.lt port 0)
          (OCaml.Stdlib.gt port (Z.sub (Z.shiftl 1 16) 1)) then
        OCaml.Stdlib.invalid_arg "port must be between 0 and 65535" % string
      else
        tt in
    match Ipaddr.of_string_exn addr with
    | Ipaddr.V4 addr => ((Ipaddr.v6_of_v4 addr), port)
    | Ipaddr.V6 addr => (addr, port)
    end.
  
  Definition of_string (default_port : option Z) (str : string)
    : sum (Ipaddr.V6.t * Z) string :=
    (* ❌ Try-with are not handled *)
    try (Stdlib.Ok (of_string_exn default_port str)).
  
  Definition to_string (saddr : Ipaddr.V6.t * Z) : string :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) pp saddr.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.encoding (Ipaddr.V6.t * Z) :=
    apply
      (let arg :=
        def "p2p_point.id" % string
          (* ❌ expected an argument *)
          expected_argument (Some "Identifier for a peer point" % string) in
      fun eta => arg None eta)
      (conv to_string
        (let arg := of_string_exn in
        fun eta => arg None eta) None string).
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg (Ipaddr.V6.t * Z) :=
    RPC_arg.make (Some "A network point (ipv4:port or [ipv6]:port)." % string)
      "point" % string
      (let arg := of_string in
      fun eta => arg None eta) to_string tt.
End Id.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Module Filter.
  Inductive t : Type :=
  | Requested : t
  | Accepted : t
  | Running : t
  | Disconnected : t.
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg t :=
    RPC_arg.make None "p2p.point.state_filter" % string
      (fun function_parameter =>
        match function_parameter with
        | "requested" % string => Stdlib.Ok Requested
        | "accepted" % string => Stdlib.Ok Accepted
        | "running" % string => Stdlib.Ok Running
        | "disconnected" % string => Stdlib.Ok Disconnected
        | s =>
          Stdlib.Error
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Invalid state: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))
                "Invalid state: %s" % string) s)
        end)
      (fun function_parameter =>
        match function_parameter with
        | Requested => "requested" % string
        | Accepted => "accepted" % string
        | Running => "running" % string
        | Disconnected => "disconnected" % string
        end) tt.
End Filter.

Module State.
  Inductive t : Type :=
  | Requested : t
  | Accepted : Tezos_base.P2p_peer_id.t -> t
  | Running : Tezos_base.P2p_peer_id.t -> t
  | Disconnected : t.
  
  Definition of_p2p_peer_id (function_parameter : t)
    : option Tezos_base.P2p_peer_id.t :=
    match function_parameter with
    | Requested => None
    | Accepted pi => Some pi
    | Running pi => Some pi
    | Disconnected => None
    end.
  
  Definition of_peerid_state (state : t) (pi : option Tezos_base.P2p_peer_id.t)
    : t :=
    match (state, pi) with
    | (Requested, _) => Requested
    | (Accepted _, Some pi) => Accepted pi
    | (Running _, Some pi) => Running pi
    | (Disconnected, _) => Disconnected
    | _ => OCaml.Stdlib.invalid_arg "state_of_state_peerid" % string
    end.
  
  Definition pp_digram (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Requested =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚎" % string
            CamlinternalFormatBasics.End_of_format) "⚎" % string)
    | Accepted _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚍" % string
            CamlinternalFormatBasics.End_of_format) "⚍" % string)
    | Running _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚌" % string
            CamlinternalFormatBasics.End_of_format) "⚌" % string)
    | Disconnected =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "⚏" % string
            CamlinternalFormatBasics.End_of_format) "⚏" % string)
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    let branch_encoding {A : Type}
      (name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
      : Tezos_data_encoding.Data_encoding.encoding A :=
      conv (fun x => (tt, x))
        (fun function_parameter =>
          let '(tt, x) := function_parameter in
          x) None
        (merge_objs (obj1 (req None None "event_kind" % string (constant name)))
          obj) in
    apply
      (let arg :=
        def "p2p_point.state" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "The state a connection to a peer point can be in: requested (connection open from here), accepted (handshake), running (connection already established), disconnected (no connection)."
              % string) in
      fun eta => arg None eta)
      (union
        (Some
          (* ❌ Variants not supported *)
          variant)
        (cons
          (case "Requested" % string None
            (Tezos_data_encoding.Data_encoding.Tag 0)
            (branch_encoding "requested" % string empty)
            (fun function_parameter =>
              match function_parameter with
              | Requested => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Requested))
          (cons
            (case "Accepted" % string None
              (Tezos_data_encoding.Data_encoding.Tag 1)
              (branch_encoding "accepted" % string
                (obj1
                  (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Accepted p2p_peer_id => Some p2p_peer_id
                | _ => None
                end) (fun p2p_peer_id => Accepted p2p_peer_id))
            (cons
              (case "Running" % string None
                (Tezos_data_encoding.Data_encoding.Tag 2)
                (branch_encoding "running" % string
                  (obj1
                    (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Running p2p_peer_id => Some p2p_peer_id
                  | _ => None
                  end) (fun p2p_peer_id => Running p2p_peer_id))
              (cons
                (case "Disconnected" % string None
                  (Tezos_data_encoding.Data_encoding.Tag 3)
                  (branch_encoding "disconnected" % string empty)
                  (fun function_parameter =>
                    match function_parameter with
                    | Disconnected => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Disconnected)) []))))).
  
  Definition raw_filter (f : Filter.t) (s : t) : bool :=
    match (f, s) with
    | (Filter.Requested, Requested) => true
    |
      (Filter.Requested, Accepted _ | Running _ | Disconnected) |
        (Filter.Accepted | Filter.Running | Filter.Disconnected, Requested) =>
      false
    | (Filter.Accepted, Accepted _) => true
    |
      (Filter.Accepted, Running _ | Disconnected) |
        (Filter.Running | Filter.Disconnected, Accepted _) => false
    | (Filter.Running, Running _) => true
    | (Filter.Disconnected, Disconnected) => true
    | (Filter.Running, Disconnected) | (Filter.Disconnected, Running _) => false
    end.
  
  Definition filter (filters : list Filter.t) (state : t) : bool :=
    Stdlib.List._exists (fun f => raw_filter f state) filters.
End State.

Module Info.
  Record t := {
    trusted : bool;
    greylisted_until : Tezos_base.Time.System.t;
    state : State.t;
    last_failed_connection : option Tezos_base.Time.System.t;
    last_rejected_connection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_established_connection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_disconnection :
      option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_seen : option (Tezos_base.P2p_peer_id.t * Tezos_base.Time.System.t);
    last_miss : option Tezos_base.Time.System.t }.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg :=
        def "p2p_point.info" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "Information about a peer point. Includes flags, state, and records about past events."
              % string) in
      fun eta => arg None eta)
      (conv
        (fun function_parameter =>
          let '{|
            trusted := trusted;
              greylisted_until := greylisted_until;
              state := state;
              last_failed_connection := last_failed_connection;
              last_rejected_connection := last_rejected_connection;
              last_established_connection := last_established_connection;
              last_disconnection := last_disconnection;
              last_seen := last_seen;
              last_miss := last_miss
              |} := function_parameter in
          let p2p_peer_id := State.of_p2p_peer_id state in
          (trusted, greylisted_until, state, p2p_peer_id,
            last_failed_connection, last_rejected_connection,
            last_established_connection, last_disconnection, last_seen,
            last_miss))
        (fun function_parameter =>
          let
            '(trusted, greylisted_until, state, p2p_peer_id,
              last_failed_connection, last_rejected_connection,
              last_established_connection, last_disconnection, last_seen,
              last_miss) := function_parameter in
          let state := State.of_peerid_state state p2p_peer_id in
          {| trusted := trusted; greylisted_until := greylisted_until;
            state := state; last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection; last_seen := last_seen;
            last_miss := last_miss |}) None
        (obj10 (req None None "trusted" % string bool)
          (dft None None "greylisted_until" % string Time.System.encoding
            Time.System.epoch) (req None None "state" % string State.encoding)
          (opt None None "p2p_peer_id" % string P2p_peer_id.encoding)
          (opt None None "last_failed_connection" % string Time.System.encoding)
          (opt None None "last_rejected_connection" % string
            (tup2 P2p_peer_id.encoding Time.System.encoding))
          (opt None None "last_established_connection" % string
            (tup2 P2p_peer_id.encoding Time.System.encoding))
          (opt None None "last_disconnection" % string
            (tup2 P2p_peer_id.encoding Time.System.encoding))
          (opt None None "last_seen" % string
            (tup2 P2p_peer_id.encoding Time.System.encoding))
          (opt None None "last_miss" % string Time.System.encoding))).
End Info.

Module Pool_event.
  Inductive kind : Type :=
  | Outgoing_request : kind
  | Accepting_request : Tezos_base.P2p_peer_id.t -> kind
  | Rejecting_request : Tezos_base.P2p_peer_id.t -> kind
  | Request_rejected : (option Tezos_base.P2p_peer_id.t) -> kind
  | Connection_established : Tezos_base.P2p_peer_id.t -> kind
  | Disconnection : Tezos_base.P2p_peer_id.t -> kind
  | External_disconnection : Tezos_base.P2p_peer_id.t -> kind.
  
  Definition kind_encoding : Tezos_data_encoding.Data_encoding.encoding kind :=
    let branch_encoding {A : Type}
      (name : string) (obj : Tezos_data_encoding.Data_encoding.encoding A)
      : Tezos_data_encoding.Data_encoding.encoding A :=
      conv (fun x => (tt, x))
        (fun function_parameter =>
          let '(tt, x) := function_parameter in
          x) None
        (merge_objs (obj1 (req None None "event_kind" % string (constant name)))
          obj) in
    union
      (Some
        (* ❌ Variants not supported *)
        variant)
      (cons
        (case "Outgoing_request" % string None
          (Tezos_data_encoding.Data_encoding.Tag 0)
          (branch_encoding "outgoing_request" % string empty)
          (fun function_parameter =>
            match function_parameter with
            | Outgoing_request => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Outgoing_request))
        (cons
          (case "Accepting_request" % string None
            (Tezos_data_encoding.Data_encoding.Tag 1)
            (branch_encoding "accepting_request" % string
              (obj1 (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
            (fun function_parameter =>
              match function_parameter with
              | Accepting_request p2p_peer_id => Some p2p_peer_id
              | _ => None
              end) (fun p2p_peer_id => Accepting_request p2p_peer_id))
          (cons
            (case "Rejecting_request" % string None
              (Tezos_data_encoding.Data_encoding.Tag 2)
              (branch_encoding "rejecting_request" % string
                (obj1
                  (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Rejecting_request p2p_peer_id => Some p2p_peer_id
                | _ => None
                end) (fun p2p_peer_id => Rejecting_request p2p_peer_id))
            (cons
              (case "Rejecting_rejected" % string None
                (Tezos_data_encoding.Data_encoding.Tag 3)
                (branch_encoding "request_rejected" % string
                  (obj1
                    (opt None None "p2p_peer_id" % string P2p_peer_id.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Request_rejected p2p_peer_id => Some p2p_peer_id
                  | _ => None
                  end) (fun p2p_peer_id => Request_rejected p2p_peer_id))
              (cons
                (case "Connection_established" % string None
                  (Tezos_data_encoding.Data_encoding.Tag 4)
                  (branch_encoding "rejecting_request" % string
                    (obj1
                      (req None None "p2p_peer_id" % string P2p_peer_id.encoding)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Connection_established p2p_peer_id => Some p2p_peer_id
                    | _ => None
                    end) (fun p2p_peer_id => Connection_established p2p_peer_id))
                (cons
                  (case "Disconnection" % string None
                    (Tezos_data_encoding.Data_encoding.Tag 5)
                    (branch_encoding "rejecting_request" % string
                      (obj1
                        (req None None "p2p_peer_id" % string
                          P2p_peer_id.encoding)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Disconnection p2p_peer_id => Some p2p_peer_id
                      | _ => None
                      end) (fun p2p_peer_id => Disconnection p2p_peer_id))
                  (cons
                    (case "External_disconnection" % string None
                      (Tezos_data_encoding.Data_encoding.Tag 6)
                      (branch_encoding "rejecting_request" % string
                        (obj1
                          (req None None "p2p_peer_id" % string
                            P2p_peer_id.encoding)))
                      (fun function_parameter =>
                        match function_parameter with
                        | External_disconnection p2p_peer_id => Some p2p_peer_id
                        | _ => None
                        end)
                      (fun p2p_peer_id => External_disconnection p2p_peer_id))
                    []))))))).
  
  Definition t := Tezos_base.Time.System.stamped kind.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.encoding
      (Tezos_base.Time.System.stamped kind) :=
    apply
      (let arg :=
        Data_encoding.def "p2p_point.pool_event" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "Events happening during maintenance of and operations on a peer point pool (such as connections, disconnections, connection requests)."
              % string) in
      fun eta => arg None eta) (Time.System.stamped_encoding kind_encoding).
End Pool_event.



src/lib_base/p2p_stat.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  total_sent : int64;
  total_recv : int64;
  current_inflow : int;
  current_outflow : int;
}

let empty =
  {total_sent = 0L; total_recv = 0L; current_inflow = 0; current_outflow = 0}

let print_size ppf sz =
  let ratio n = float_of_int sz /. float_of_int (1 lsl n) in
  if sz < 1 lsl 10 then Format.fprintf ppf "%d B" sz
  else if sz < 1 lsl 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
  else Format.fprintf ppf "%.2f MiB" (ratio 20)

let print_size64 ppf sz =
  let open Int64 in
  let ratio n = to_float sz /. float_of_int (1 lsl n) in
  if sz < shift_left 1L 10 then Format.fprintf ppf "%Ld B" sz
  else if sz < shift_left 1L 20 then Format.fprintf ppf "%.2f kiB" (ratio 10)
  else if sz < shift_left 1L 30 then Format.fprintf ppf "%.2f MiB" (ratio 20)
  else if sz < shift_left 1L 40 then Format.fprintf ppf "%.2f GiB" (ratio 30)
  else Format.fprintf ppf "%.2f TiB" (ratio 40)

let pp ppf stat =
  Format.fprintf
    ppf
    "↗ %a (%a/s) ↘ %a (%a/s)"
    print_size64
    stat.total_sent
    print_size
    stat.current_outflow
    print_size64
    stat.total_recv
    print_size
    stat.current_inflow

let encoding =
  let open Data_encoding in
  def "p2p_stat" ~description:"Statistics about the p2p network."
  @@ conv
       (fun {total_sent; total_recv; current_inflow; current_outflow} ->
         (total_sent, total_recv, current_inflow, current_outflow))
       (fun (total_sent, total_recv, current_inflow, current_outflow) ->
         {total_sent; total_recv; current_inflow; current_outflow})
       (obj4
          (req "total_sent" int64)
          (req "total_recv" int64)
          (req "current_inflow" int31)
          (req "current_outflow" int31))

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_stat.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  total_sent : int64;
  total_recv : int64;
  current_inflow : Z;
  current_outflow : Z }.

Definition empty : t :=
  {|
    total_sent :=
      (* ❌ Constant of type int64 is converted to int *)
      0;
    total_recv :=
      (* ❌ Constant of type int64 is converted to int *)
      0; current_inflow := 0; current_outflow := 0 |}.

Definition print_size (ppf : Stdlib.Format.formatter) (sz : Z) : unit :=
  let ratio (n : Z) : Z :=
    Stdlib.op_divpoint (Stdlib.float_of_int sz)
      (Stdlib.float_of_int (Z.shiftl 1 n)) in
  if OCaml.Stdlib.lt sz (Z.shiftl 1 10) then
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal " B" % string
            CamlinternalFormatBasics.End_of_format)) "%d B" % string) sz
  else
    if OCaml.Stdlib.lt sz (Z.shiftl 1 20) then
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Lit_precision 2)
            (CamlinternalFormatBasics.String_literal " kiB" % string
              CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
        (ratio 10)
    else
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Lit_precision 2)
            (CamlinternalFormatBasics.String_literal " MiB" % string
              CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
        (ratio 20).

Definition print_size64 (ppf : Stdlib.Format.formatter) (sz : int64) : unit :=
  let ratio (n : Z) : Z :=
    Stdlib.op_divpoint (to_float sz) (Stdlib.float_of_int (Z.shiftl 1 n)) in
  if
    OCaml.Stdlib.lt sz
      (shift_left
        (* ❌ Constant of type int64 is converted to int *)
        1 10) then
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal " B" % string
            CamlinternalFormatBasics.End_of_format)) "%Ld B" % string) sz
  else
    if
      OCaml.Stdlib.lt sz
        (shift_left
          (* ❌ Constant of type int64 is converted to int *)
          1 20) then
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Lit_precision 2)
            (CamlinternalFormatBasics.String_literal " kiB" % string
              CamlinternalFormatBasics.End_of_format)) "%.2f kiB" % string)
        (ratio 10)
    else
      if
        OCaml.Stdlib.lt sz
          (shift_left
            (* ❌ Constant of type int64 is converted to int *)
            1 30) then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Lit_precision 2)
              (CamlinternalFormatBasics.String_literal " MiB" % string
                CamlinternalFormatBasics.End_of_format)) "%.2f MiB" % string)
          (ratio 20)
      else
        if
          OCaml.Stdlib.lt sz
            (shift_left
              (* ❌ Constant of type int64 is converted to int *)
              1 40) then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Lit_precision 2)
                (CamlinternalFormatBasics.String_literal " GiB" % string
                  CamlinternalFormatBasics.End_of_format)) "%.2f GiB" % string)
            (ratio 30)
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Lit_precision 2)
                (CamlinternalFormatBasics.String_literal " TiB" % string
                  CamlinternalFormatBasics.End_of_format)) "%.2f TiB" % string)
            (ratio 40).

Definition pp (ppf : Stdlib.Format.formatter) (stat : t) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "↗ " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal " (" % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal "/s) ↘ " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal "/s)" % string
                        CamlinternalFormatBasics.End_of_format)))))))))
      "↗ %a (%a/s) ↘ %a (%a/s)" % string) print_size64 (total_sent stat)
    print_size (current_outflow stat) print_size64 (total_recv stat) print_size
    (current_inflow stat).

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "p2p_stat" % string
        (* ❌ expected an argument *)
        expected_argument (Some "Statistics about the p2p network." % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{|
          total_sent := total_sent;
            total_recv := total_recv;
            current_inflow := current_inflow;
            current_outflow := current_outflow
            |} := function_parameter in
        (total_sent, total_recv, current_inflow, current_outflow))
      (fun function_parameter =>
        let '(total_sent, total_recv, current_inflow, current_outflow) :=
          function_parameter in
        {| total_sent := total_sent; total_recv := total_recv;
          current_inflow := current_inflow; current_outflow := current_outflow
          |}) None
      (obj4 (req None None "total_sent" % string int64)
        (req None None "total_recv" % string int64)
        (req None None "current_inflow" % string int31)
        (req None None "current_outflow" % string int31))).



src/lib_base/p2p_version.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int

let pp = Format.pp_print_int

let encoding =
  let open Data_encoding in
  def "p2p_version" ~description:"A version number for the p2p layer." uint16

let zero = 0

let supported = [zero]

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/p2p_version.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Z.

Definition pp : Stdlib.Format.formatter -> Z -> unit := Format.pp_print_int.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
  def "p2p_version" % string None
    (Some "A version number for the p2p layer." % string) uint16.

Definition zero : Z := 0.

Definition supported : list Z := cons zero [].



src/lib_base/preapply_result.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'error t = {
  applied : (Operation_hash.t * Operation.t) list;
  refused : (Operation.t * 'error list) Operation_hash.Map.t;
  branch_refused : (Operation.t * 'error list) Operation_hash.Map.t;
  branch_delayed : (Operation.t * 'error list) Operation_hash.Map.t;
}

let empty =
  {
    applied = [];
    refused = Operation_hash.Map.empty;
    branch_refused = Operation_hash.Map.empty;
    branch_delayed = Operation_hash.Map.empty;
  }

let map f r =
  {
    applied = r.applied;
    refused = Operation_hash.Map.map f r.refused;
    branch_refused = Operation_hash.Map.map f r.branch_refused;
    branch_delayed = Operation_hash.Map.map f r.branch_delayed;
  }

let encoding error_encoding =
  let open Data_encoding in
  let operation_encoding =
    merge_objs
      (obj1 (req "hash" Operation_hash.encoding))
      (dynamic_size Operation.encoding)
  in
  let refused_encoding =
    merge_objs
      (obj1 (req "hash" Operation_hash.encoding))
      (merge_objs
         (dynamic_size Operation.encoding)
         (obj1 (req "error" error_encoding)))
  in
  let build_list map = Operation_hash.Map.bindings map in
  let build_map list =
    List.fold_right
      (fun (k, e) m -> Operation_hash.Map.add k e m)
      list
      Operation_hash.Map.empty
  in
  conv
    (fun {applied; refused; branch_refused; branch_delayed} ->
      ( applied,
        build_list refused,
        build_list branch_refused,
        build_list branch_delayed ))
    (fun (applied, refused, branch_refused, branch_delayed) ->
      let refused = build_map refused in
      let branch_refused = build_map branch_refused in
      let branch_delayed = build_map branch_delayed in
      {applied; refused; branch_refused; branch_delayed})
    (obj4
       (req "applied" (list operation_encoding))
       (req "refused" (list refused_encoding))
       (req "branch_refused" (list refused_encoding))
       (req "branch_delayed" (list refused_encoding)))

let operations t =
  let ops =
    List.fold_left
      (fun acc (h, op) -> Operation_hash.Map.add h op acc)
      Operation_hash.Map.empty
      t.applied
  in
  let ops =
    Operation_hash.Map.fold
      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
      t.branch_delayed
      ops
  in
  let ops =
    Operation_hash.Map.fold
      (fun h (op, _err) acc -> Operation_hash.Map.add h op acc)
      t.branch_refused
      ops
  in
  ops
src/lib_base/preapply_result.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t {error : Type} := {
  applied : list (Tezos_crypto.Operation_hash.t * Tezos_base.Operation.t);
  refused :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
  branch_refused :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error));
  branch_delayed :
    Tezos_crypto.Operation_hash.Map.t (Tezos_base.Operation.t * (list error)) }.
Arguments t : clear implicits.

Definition empty {A : Type} : t A :=
  {| applied := []; refused := Operation_hash.Map.empty;
    branch_refused := Operation_hash.Map.empty;
    branch_delayed := Operation_hash.Map.empty |}.

Definition map {A B : Type}
  (f : (Tezos_base.Operation.t * (list A)) -> Tezos_base.Operation.t * (list B))
  (r : t A) : t B :=
  {| applied := applied r; refused := Operation_hash.Map.map f (refused r);
    branch_refused := Operation_hash.Map.map f (branch_refused r);
    branch_delayed := Operation_hash.Map.map f (branch_delayed r) |}.

Definition encoding {A : Type}
  (error_encoding : Tezos_data_encoding.Data_encoding.encoding (list A))
  : Tezos_data_encoding.Data_encoding.encoding (t A) :=
  let operation_encoding :=
    merge_objs (obj1 (req None None "hash" % string Operation_hash.encoding))
      (dynamic_size None Operation.encoding) in
  let refused_encoding :=
    merge_objs (obj1 (req None None "hash" % string Operation_hash.encoding))
      (merge_objs (dynamic_size None Operation.encoding)
        (obj1 (req None None "error" % string error_encoding))) in
  let build_list {B : Type} (map : Tezos_crypto.Operation_hash.Map.t B)
    : list (Tezos_crypto.Operation_hash.Map.key * B) :=
    Operation_hash.Map.bindings map in
  let build_map {B : Type}
    (list : list (Tezos_crypto.Operation_hash.Map.key * B))
    : Tezos_crypto.Operation_hash.Map.t B :=
    Stdlib.List.fold_right
      (fun function_parameter =>
        let '(k, e) := function_parameter in
        fun m => Operation_hash.Map.add k e m) list Operation_hash.Map.empty in
  conv
    (fun function_parameter =>
      let '{|
        applied := applied;
          refused := refused;
          branch_refused := branch_refused;
          branch_delayed := branch_delayed
          |} := function_parameter in
      (applied, (build_list refused), (build_list branch_refused),
        (build_list branch_delayed)))
    (fun function_parameter =>
      let '(applied, refused, branch_refused, branch_delayed) :=
        function_parameter in
      let refused := build_map refused in
      let branch_refused := build_map branch_refused in
      let branch_delayed := build_map branch_delayed in
      {| applied := applied; refused := refused;
        branch_refused := branch_refused; branch_delayed := branch_delayed |})
    None
    (obj4 (req None None "applied" % string (list None operation_encoding))
      (req None None "refused" % string (list None refused_encoding))
      (req None None "branch_refused" % string (list None refused_encoding))
      (req None None "branch_delayed" % string (list None refused_encoding))).

Definition operations {A : Type} (t : t A)
  : Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t :=
  let ops :=
    Stdlib.List.fold_left
      (fun acc =>
        fun function_parameter =>
          let '(h, op) := function_parameter in
          Operation_hash.Map.add h op acc) Operation_hash.Map.empty (applied t)
    in
  let ops :=
    Operation_hash.Map.fold
      (fun h =>
        fun function_parameter =>
          let '(op, _err) := function_parameter in
          fun acc => Operation_hash.Map.add h op acc) (branch_delayed t) ops in
  let ops :=
    Operation_hash.Map.fold
      (fun h =>
        fun function_parameter =>
          let '(op, _err) := function_parameter in
          fun acc => Operation_hash.Map.add h op acc) (branch_refused t) ops in
  ops.

src/lib_base/protocol.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {expected_env : env_version; components : component list}

and component = {
  name : string;
  interface : string option;
  implementation : string;
}

and env_version = V1

include Compare.Make (struct
  type nonrec t = t

  let compare = Pervasives.compare
end)

let component_encoding =
  let open Data_encoding in
  conv
    (fun {name; interface; implementation} ->
      (name, interface, implementation))
    (fun (name, interface, implementation) ->
      {name; interface; implementation})
    (obj3
       (req "name" string)
       (opt "interface" string)
       (req "implementation" string))

let env_version_encoding =
  let open Data_encoding in
  conv
    (function V1 -> 0)
    (function 0 -> V1 | _ -> failwith "unexpected environment version")
    int16

let encoding =
  let open Data_encoding in
  def
    "protocol"
    ~description:
      "The environment a protocol relies on and the components a protocol is \
       made of."
  @@ conv
       (fun {expected_env; components} -> (expected_env, components))
       (fun (expected_env, components) -> {expected_env; components})
       (obj2
          (req "expected_env_version" env_version_encoding)
          (req "components" (list component_encoding)))

let bounded_encoding ?max_size () =
  match max_size with
  | None ->
      encoding
  | Some max_size ->
      Data_encoding.check_size max_size encoding

let pp ppf op =
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op)

let env_version_to_string = function V1 -> "V1"

let pp_ocaml_component ppf {name; interface; implementation} =
  Format.fprintf
    ppf
    "@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]"
    name
    (fun ppf -> function None -> Format.fprintf ppf "None" | Some s ->
          Format.fprintf ppf "Some %S" s)
    interface
    implementation

let pp_ocaml ppf {expected_env; components} =
  Format.fprintf
    ppf
    "@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]"
    (env_version_to_string expected_env)
    (Format.pp_print_list
       ~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
       pp_ocaml_component)
    components

let to_bytes v = Data_encoding.Binary.to_bytes_exn encoding v

let of_bytes b = Data_encoding.Binary.of_bytes encoding b

let of_bytes_exn b = Data_encoding.Binary.of_bytes_exn encoding b

let hash proto = Protocol_hash.hash_bytes [to_bytes proto]

let hash_raw proto = Protocol_hash.hash_bytes [proto]

module Meta = struct
  type t = {
    hash : Protocol_hash.t option;
    expected_env_version : env_version option;
    modules : string list;
  }

  let encoding =
    let open Data_encoding in
    def "protocol.meta"
    (* FIXME: add ~description argument *)
    @@ conv
         (fun {hash; expected_env_version; modules} ->
           (hash, expected_env_version, modules))
         (fun (hash, expected_env_version, modules) ->
           {hash; expected_env_version; modules})
    @@ obj3
         (opt
            "hash"
            ~description:"Used to force the hash of the protocol"
            Protocol_hash.encoding)
         (opt "expected_env_version" env_version_encoding)
         (req
            "modules"
            ~description:"Modules comprising the protocol"
            (list string))
end

let () =
  Data_encoding.Registration.register ~pp:pp_ocaml encoding ;
  Data_encoding.Registration.register Meta.encoding
src/lib_base/protocol.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive env_version : Type :=
| V1 : env_version.

(* ❌ Structure item `include` not handled. *)
include

Definition component_encoding
  : Tezos_data_encoding.Data_encoding.encoding component :=
  conv
    (fun function_parameter =>
      let '{|
        name := name;
          interface := interface;
          implementation := implementation
          |} := function_parameter in
      (name, interface, implementation))
    (fun function_parameter =>
      let '(name, interface, implementation) := function_parameter in
      {| name := name; interface := interface; implementation := implementation
        |}) None
    (obj3 (req None None "name" % string string)
      (opt None None "interface" % string string)
      (req None None "implementation" % string string)).

Definition env_version_encoding
  : Tezos_data_encoding.Data_encoding.encoding env_version :=
  conv
    (fun function_parameter =>
      let 'V1 := function_parameter in
      0)
    (fun function_parameter =>
      match function_parameter with
      | 0 => V1
      | _ => OCaml.Stdlib.failwith "unexpected environment version" % string
      end) None int16.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "protocol" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "The environment a protocol relies on and the components a protocol is made of."
            % string) in
    fun eta => arg None eta)
    (conv
      (fun function_parameter =>
        let '{| expected_env := expected_env; components := components |} :=
          function_parameter in
        (expected_env, components))
      (fun function_parameter =>
        let '(expected_env, components) := function_parameter in
        {| expected_env := expected_env; components := components |}) None
      (obj2 (req None None "expected_env_version" % string env_version_encoding)
        (req None None "components" % string (list None component_encoding)))).

Definition bounded_encoding (max_size : option Z) (function_parameter : unit)
  : Tezos_data_encoding.Data_encoding.encoding t :=
  let 'tt := function_parameter in
  match max_size with
  | None => encoding
  | Some max_size => Data_encoding.check_size max_size encoding
  end.

Definition pp (ppf : Stdlib.Format.formatter) (op : t) : unit :=
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding op).

Definition env_version_to_string (function_parameter : env_version) : string :=
  let 'V1 := function_parameter in
  "V1" % string.

Definition pp_ocaml_component
  (ppf : Stdlib.Format.formatter) (function_parameter : component) : unit :=
  let '{|
    name := name;
      interface := interface;
      implementation := implementation
      |} := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.Char_literal "{" % char
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 1>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
            (CamlinternalFormatBasics.String_literal " name = " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal
                      "interface = " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal " ;" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "implementation = " % string
                              (CamlinternalFormatBasics.Caml_string
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " ;" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Char_literal
                                        "}" % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))))))))))
      "@[{@[<v 1> name = %S ;@ interface = %a ;@ implementation = %S ;@]@ }@]" %
        string) name
    (fun ppf =>
      fun function_parameter =>
        match function_parameter with
        | None =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "None" % string
                CamlinternalFormatBasics.End_of_format) "None" % string)
        | Some s =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Some " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format)) "Some %S" % string) s
        end) interface implementation.

Definition pp_ocaml (ppf : Stdlib.Format.formatter) (function_parameter : t)
  : unit :=
  let '{| expected_env := expected_env; components := components |} :=
    function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.Char_literal "{" % char
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 1>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
            (CamlinternalFormatBasics.String_literal " expected_env = " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal
                      "components = [" % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v>" % string))
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.String_literal
                              "] ;" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Char_literal
                                    "}" % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format))))))))))))))))
      "@[{@[<v 1> expected_env = %s ;@ components = [@[<v>%a@]] ;@]@ }@]" %
        string) (env_version_to_string expected_env)
    (Format.pp_print_list
      (Some
        (fun ppf =>
          fun function_parameter =>
            let 'tt := function_parameter in
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal " ;" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    CamlinternalFormatBasics.End_of_format)) " ;@ " % string)))
      pp_ocaml_component) components.

Definition to_bytes (v : t) : Stdlib.Bytes.t :=
  Data_encoding.Binary.to_bytes_exn encoding v.

Definition of_bytes (b : Stdlib.Bytes.t) : option t :=
  Data_encoding.Binary.of_bytes encoding b.

Definition of_bytes_exn (b : Stdlib.Bytes.t) : t :=
  Data_encoding.Binary.of_bytes_exn encoding b.

Definition hash (proto : t) : Tezos_crypto.Protocol_hash.t :=
  Protocol_hash.hash_bytes None (cons (to_bytes proto) []).

Definition hash_raw (proto : Stdlib.Bytes.t) : Tezos_crypto.Protocol_hash.t :=
  Protocol_hash.hash_bytes None (cons proto []).

Module Meta.
  Record t := {
    hash : option Tezos_crypto.Protocol_hash.t;
    expected_env_version : option env_version;
    modules : list string }.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    apply
      (let arg := def "protocol.meta" % string in
      fun eta => arg None None eta)
      (apply
        (let arg :=
          conv
            (fun function_parameter =>
              let '{|
                hash := hash;
                  expected_env_version := expected_env_version;
                  modules := modules
                  |} := function_parameter in
              (hash, expected_env_version, modules))
            (fun function_parameter =>
              let '(hash, expected_env_version, modules) := function_parameter
                in
              {| hash := hash; expected_env_version := expected_env_version;
                modules := modules |}) in
        fun eta => arg None eta)
        (obj3
          (opt None (Some "Used to force the hash of the protocol" % string)
            "hash" % string Protocol_hash.encoding)
          (opt None None "expected_env_version" % string env_version_encoding)
          (req None (Some "Modules comprising the protocol" % string)
            "modules" % string (list None string)))).
End Meta.



src/lib_base/s.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type T = sig
  type t

  include Compare.S with type t := t

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t

  val to_bytes : t -> Bytes.t

  val of_bytes : Bytes.t -> t option
end

module type HASHABLE = sig
  include T

  type hash

  val hash : t -> hash

  val hash_raw : Bytes.t -> hash
end

module type SET = sig
  type elt

  type t

  val empty : t

  val is_empty : t -> bool

  val mem : elt -> t -> bool

  val add : elt -> t -> t

  val singleton : elt -> t

  val remove : elt -> t -> t

  val union : t -> t -> t

  val inter : t -> t -> t

  val diff : t -> t -> t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val subset : t -> t -> bool

  val iter : (elt -> unit) -> t -> unit

  val map : (elt -> elt) -> t -> t

  val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a

  val for_all : (elt -> bool) -> t -> bool

  val exists : (elt -> bool) -> t -> bool

  val filter : (elt -> bool) -> t -> t

  val partition : (elt -> bool) -> t -> t * t

  val cardinal : t -> int

  val elements : t -> elt list

  val min_elt_opt : t -> elt option

  val max_elt_opt : t -> elt option

  val choose_opt : t -> elt option

  val split : elt -> t -> t * bool * t

  val find_opt : elt -> t -> elt option

  val find_first_opt : (elt -> bool) -> t -> elt option

  val find_last_opt : (elt -> bool) -> t -> elt option

  val of_list : elt list -> t
end

module type MAP = sig
  type key

  type +'a t

  val empty : 'a t

  val is_empty : 'a t -> bool

  val mem : key -> 'a t -> bool

  val add : key -> 'a -> 'a t -> 'a t

  val update : key -> ('a option -> 'a option) -> 'a t -> 'a t

  val singleton : key -> 'a -> 'a t

  val remove : key -> 'a t -> 'a t

  val merge :
    (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t

  val union : (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t

  val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int

  val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool

  val iter : (key -> 'a -> unit) -> 'a t -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val for_all : (key -> 'a -> bool) -> 'a t -> bool

  val exists : (key -> 'a -> bool) -> 'a t -> bool

  val filter : (key -> 'a -> bool) -> 'a t -> 'a t

  val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t

  val cardinal : 'a t -> int

  val bindings : 'a t -> (key * 'a) list

  val min_binding_opt : 'a t -> (key * 'a) option

  val max_binding_opt : 'a t -> (key * 'a) option

  val choose_opt : 'a t -> (key * 'a) option

  val split : key -> 'a t -> 'a t * 'a option * 'a t

  val find_opt : key -> 'a t -> 'a option

  val find_first_opt : (key -> bool) -> 'a t -> (key * 'a) option

  val find_last_opt : (key -> bool) -> 'a t -> (key * 'a) option

  val map : ('a -> 'b) -> 'a t -> 'b t

  val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
end
src/lib_base/s.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module T.
  Record signature {t : Type} := {
    t := t;
    include;
    pp : Stdlib.Format.formatter -> t -> unit;
    encoding : Tezos_data_encoding.Data_encoding.t t;
    to_bytes : t -> Stdlib.Bytes.t;
    of_bytes : Stdlib.Bytes.t -> option t;
  }.
  Arguments signature : clear implicits.
End T.

Module HASHABLE.
  Record signature {t hash : Type} := {
    include;
    hash := hash;
    hash : t -> hash;
    hash_raw : Stdlib.Bytes.t -> hash;
  }.
  Arguments signature : clear implicits.
End HASHABLE.

Module SET.
  Record signature {elt t : Type} := {
    elt := elt;
    t := t;
    empty : t;
    is_empty : t -> bool;
    mem : elt -> t -> bool;
    add : elt -> t -> t;
    singleton : elt -> t;
    remove : elt -> t -> t;
    union : t -> t -> t;
    inter : t -> t -> t;
    diff : t -> t -> t;
    compare : t -> t -> Z;
    equal : t -> t -> bool;
    subset : t -> t -> bool;
    iter : (elt -> unit) -> t -> unit;
    map : (elt -> elt) -> t -> t;
    fold : forall {a : Type}, (elt -> a -> a) -> t -> a -> a;
    for_all : (elt -> bool) -> t -> bool;
    _exists : (elt -> bool) -> t -> bool;
    filter : (elt -> bool) -> t -> t;
    partition : (elt -> bool) -> t -> t * t;
    cardinal : t -> Z;
    elements : t -> list elt;
    min_elt_opt : t -> option elt;
    max_elt_opt : t -> option elt;
    choose_opt : t -> option elt;
    split : elt -> t -> t * bool * t;
    find_opt : elt -> t -> option elt;
    find_first_opt : (elt -> bool) -> t -> option elt;
    find_last_opt : (elt -> bool) -> t -> option elt;
    of_list : (list elt) -> t;
  }.
  Arguments signature : clear implicits.
End SET.

Module MAP.
  Record signature {key t : Type} := {
    key := key;
    polymorphic_abstract_type;
    empty : forall {a : Type}, t a;
    is_empty : forall {a : Type}, (t a) -> bool;
    mem : forall {a : Type}, key -> (t a) -> bool;
    add : forall {a : Type}, key -> a -> (t a) -> t a;
    update : forall {a : Type}, key -> ((option a) -> option a) -> (t a) -> t a;
    singleton : forall {a : Type}, key -> a -> t a;
    remove : forall {a : Type}, key -> (t a) -> t a;
    merge : forall {a b c : Type}, (key -> (option a) -> (option b) -> option c)
      -> (t a) -> (t b) -> t c;
    union : forall {a : Type}, (key -> a -> a -> option a) ->
      (t a) -> (t a) -> t a;
    compare : forall {a : Type}, (a -> a -> Z) -> (t a) -> (t a) -> Z;
    equal : forall {a : Type}, (a -> a -> bool) -> (t a) -> (t a) -> bool;
    iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
    fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    for_all : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
    _exists : forall {a : Type}, (key -> a -> bool) -> (t a) -> bool;
    filter : forall {a : Type}, (key -> a -> bool) -> (t a) -> t a;
    partition : forall {a : Type}, (key -> a -> bool) -> (t a) -> (t a) * (t a);
    cardinal : forall {a : Type}, (t a) -> Z;
    bindings : forall {a : Type}, (t a) -> list (key * a);
    min_binding_opt : forall {a : Type}, (t a) -> option (key * a);
    max_binding_opt : forall {a : Type}, (t a) -> option (key * a);
    choose_opt : forall {a : Type}, (t a) -> option (key * a);
    split : forall {a : Type}, key -> (t a) -> (t a) * (option a) * (t a);
    find_opt : forall {a : Type}, key -> (t a) -> option a;
    find_first_opt : forall {a : Type}, (key -> bool) ->
      (t a) -> option (key * a);
    find_last_opt : forall {a : Type}, (key -> bool) ->
      (t a) -> option (key * a);
    map : forall {a b : Type}, (a -> b) -> (t a) -> t b;
    mapi : forall {a b : Type}, (key -> a -> b) -> (t a) -> t b;
  }.
  Arguments signature : clear implicits.
End MAP.

src/lib_base/test_chain_status.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t =
  | Not_running
  | Forking of {protocol : Protocol_hash.t; expiration : Time.Protocol.t}
  | Running of {
      chain_id : Chain_id.t;
      genesis : Block_hash.t;
      protocol : Protocol_hash.t;
      expiration : Time.Protocol.t;
    }

let encoding =
  let open Data_encoding in
  def
    "test_chain_status"
    ~description:
      "The status of the test chain: not_running (there is no test chain at \
       the moment), forking (the test chain is being setup), running (the \
       test chain is running)."
  @@ union
       [ case
           (Tag 0)
           ~title:"Not_running"
           (obj1 (req "status" (constant "not_running")))
           (function Not_running -> Some () | _ -> None)
           (fun () -> Not_running);
         case
           (Tag 1)
           ~title:"Forking"
           (obj3
              (req "status" (constant "forking"))
              (req "protocol" Protocol_hash.encoding)
              (req "expiration" Time.Protocol.encoding))
           (function
             | Forking {protocol; expiration} ->
                 Some ((), protocol, expiration)
             | _ ->
                 None)
           (fun ((), protocol, expiration) -> Forking {protocol; expiration});
         case
           (Tag 2)
           ~title:"Running"
           (obj5
              (req "status" (constant "running"))
              (req "chain_id" Chain_id.encoding)
              (req "genesis" Block_hash.encoding)
              (req "protocol" Protocol_hash.encoding)
              (req "expiration" Time.Protocol.encoding))
           (function
             | Running {chain_id; genesis; protocol; expiration} ->
                 Some ((), chain_id, genesis, protocol, expiration)
             | _ ->
                 None)
           (fun ((), chain_id, genesis, protocol, expiration) ->
             Running {chain_id; genesis; protocol; expiration}) ]

let pp ppf = function
  | Not_running ->
      Format.fprintf ppf "@[<v 2>Not running@]"
  | Forking {protocol; expiration} ->
      Format.fprintf
        ppf
        "@[<v 2>Forking %a (expires %a)@]"
        Protocol_hash.pp
        protocol
        Time.System.pp_hum
        (Time.System.of_protocol_exn expiration)
  | Running {chain_id; genesis; protocol; expiration} ->
      Format.fprintf
        ppf
        "@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]"
        Protocol_hash.pp
        protocol
        Block_hash.pp
        genesis
        Chain_id.pp
        chain_id
        Time.System.pp_hum
        (Time.System.of_protocol_exn expiration)

let () = Data_encoding.Registration.register ~pp encoding
src/lib_base/test_chain_status.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Not_running : t
| Forking : Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t
| Running : Tezos_crypto.Chain_id.t -> Tezos_crypto.Block_hash.t ->
  Tezos_crypto.Protocol_hash.t -> Tezos_base.Time.Protocol.t -> t.

Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
  apply
    (let arg :=
      def "test_chain_status" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "The status of the test chain: not_running (there is no test chain at the moment), forking (the test chain is being setup), running (the test chain is running)."
            % string) in
    fun eta => arg None eta)
    (union None
      (cons
        (case "Not_running" % string None
          (Tezos_data_encoding.Data_encoding.Tag 0)
          (obj1
            (req None None "status" % string (constant "not_running" % string)))
          (fun function_parameter =>
            match function_parameter with
            | Not_running => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Not_running))
        (cons
          (case "Forking" % string None
            (Tezos_data_encoding.Data_encoding.Tag 1)
            (obj3
              (req None None "status" % string (constant "forking" % string))
              (req None None "protocol" % string Protocol_hash.encoding)
              (req None None "expiration" % string Time.Protocol.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Forking {| protocol := protocol; expiration := expiration |} =>
                Some (tt, protocol, expiration)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, protocol, expiration) := function_parameter in
              Forking {| protocol := protocol; expiration := expiration |}))
          (cons
            (case "Running" % string None
              (Tezos_data_encoding.Data_encoding.Tag 2)
              (obj5
                (req None None "status" % string (constant "running" % string))
                (req None None "chain_id" % string Chain_id.encoding)
                (req None None "genesis" % string Block_hash.encoding)
                (req None None "protocol" % string Protocol_hash.encoding)
                (req None None "expiration" % string Time.Protocol.encoding))
              (fun function_parameter =>
                match function_parameter with
                |
                  Running {|
                    chain_id := chain_id;
                      genesis := genesis;
                      protocol := protocol;
                      expiration := expiration
                      |} => Some (tt, chain_id, genesis, protocol, expiration)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, chain_id, genesis, protocol, expiration) :=
                  function_parameter in
                Running
                  {| chain_id := chain_id; genesis := genesis;
                    protocol := protocol; expiration := expiration |})) [])))).

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Not_running =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Not running" % string
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format)))
        "@[<v 2>Not running@]" % string)
  | Forking {| protocol := protocol; expiration := expiration |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Forking " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " (expires " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))))
        "@[<v 2>Forking %a (expires %a)@]" % string) Protocol_hash.pp protocol
      Time.System.pp_hum (Time.System.of_protocol_exn expiration)
  |
    Running {|
      chain_id := chain_id;
        genesis := genesis;
        protocol := protocol;
        expiration := expiration
        |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Running " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.String_literal "Genesis: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "Net id: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "Expiration: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format)))))))))))))
        "@[<v 2>Running %a@ Genesis: %a@ Net id: %a@ Expiration: %a@]" % string)
      Protocol_hash.pp protocol Block_hash.pp genesis Chain_id.pp chain_id
      Time.System.pp_hum (Time.System.of_protocol_exn expiration)
  end.



src/lib_base/time.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Protocol = struct
  type t = int64

  let epoch = 0L

  let diff = Int64.sub

  let add = Int64.add

  let of_ptime t =
    let (days, ps) = Ptime.Span.to_d_ps (Ptime.to_span t) in
    let s_days = Int64.mul (Int64.of_int days) 86_400L in
    Int64.add s_days (Int64.div ps 1_000_000_000_000L)

  let to_ptime t =
    let days = Int64.to_int (Int64.div t 86_400L) in
    let ps = Int64.mul (Int64.rem t 86_400L) 1_000_000_000_000L in
    match Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
    | None ->
        invalid_arg "Time.Protocol.to_ptime"
    | Some ptime ->
        ptime

  let of_notation s =
    match Ptime.of_rfc3339 s with
    | Ok (t, _, _) ->
        Some (of_ptime t)
    | Error _ ->
        None

  let of_notation_exn s =
    match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
    | Error (`Msg msg) ->
        invalid_arg ("Time.Protocol.of_notation: " ^ msg)
    | Ok (t, _, _) ->
        of_ptime t

  let to_notation t = Ptime.to_rfc3339 ~frac_s:0 ~tz_offset_s:0 (to_ptime t)

  let of_seconds x = x

  let to_seconds x = x

  let rfc_encoding =
    let open Data_encoding in
    def
      "timestamp.rfc"
      ~title:"RFC 3339 formatted timestamp"
      ~description:"A date in RFC 3339 notation."
    @@ conv
         to_notation
         (fun s ->
           match of_notation s with
           | Some s ->
               s
           | None ->
               Data_encoding.Json.cannot_destruct "Time.Protocol.of_notation")
         string

  let encoding =
    let open Data_encoding in
    def
      "timestamp.protocol"
      ~description:
        "A timestamp as seen by the protocol: second-level precision, epoch \
         based."
    @@ splitted
         ~binary:int64
         ~json:
           (union
              [ case
                  Json_only
                  ~title:"RFC encoding"
                  rfc_encoding
                  (fun i -> Some i)
                  (fun i -> i);
                case
                  Json_only
                  ~title:"Second since epoch"
                  int64
                  (fun _ -> None)
                  (fun i -> i) ])

  let rpc_arg =
    RPC_arg.make
      ~name:(Format.asprintf "date")
      ~descr:(Format.asprintf "A date in seconds from epoch")
      ~destruct:(fun s ->
        if s = "none" || s = "epoch" then Ok epoch
        else
          match Int64.of_string s with
          | t ->
              Ok t
          | exception _ ->
              Error (Format.asprintf "failed to parse time (epoch): %S" s))
      ~construct:Int64.to_string
      ()

  let pp_hum ppf t = Ptime.pp_rfc3339 () ppf (to_ptime t)

  include Compare.Make (Int64)
end

module System = struct
  type t = Ptime.t

  let epoch = Ptime.epoch

  module Span = struct
    type t = Ptime.Span.t

    let multiply_exn f s =
      let open Ptime.Span in
      Option.unopt_exn
        (Failure "Time.System.Span.multiply_exn")
        (of_float_s (f *. Ptime.Span.to_float_s s))

    let of_seconds_exn f =
      match Ptime.Span.of_float_s f with
      | None ->
          invalid_arg "Time.System.Span.of_seconds_exn"
      | Some s ->
          s

    let encoding =
      let open Data_encoding in
      def
        "timespan.system"
        ~description:"A span of time, as seen by the local computer."
      @@ conv
           Ptime.Span.to_float_s
           (fun f ->
             match Ptime.Span.of_float_s f with
             | None ->
                 invalid_arg "Time.System.Span.encoding"
             | Some s ->
                 s)
           float

    let rpc_arg =
      RPC_arg.make
        ~name:(Format.asprintf "timespan")
        ~descr:(Format.asprintf "A span of time in seconds")
        ~destruct:(fun s ->
          match Ptime.Span.of_float_s (float_of_string s) with
          | Some t ->
              Ok t
          | None ->
              Error (Format.asprintf "failed to parse timespan: %S" s)
          | exception _ ->
              Error (Format.asprintf "failed to parse timespan: %S" s))
        ~construct:(fun s -> string_of_float (Ptime.Span.to_float_s s))
        ()
  end

  let of_seconds_opt x =
    let days = Int64.to_int (Int64.div x 86_400L) in
    let ps = Int64.mul (Int64.rem x 86_400L) 1_000_000_000_000L in
    Option.apply ~f:Ptime.of_span (Ptime.Span.of_d_ps (days, ps))

  let of_seconds_exn x =
    match of_seconds_opt x with
    | Some t ->
        t
    | None ->
        invalid_arg "Time.of_seconds"

  let to_seconds x =
    let (days, ps) = Ptime.(Span.to_d_ps (to_span x)) in
    let s_days = Int64.mul (Int64.of_int days) 86_400L in
    Int64.add s_days (Int64.div ps 1_000_000_000_000L)

  let of_protocol_exn = of_seconds_exn

  let of_protocol_opt = of_seconds_opt

  let to_protocol = to_seconds

  let of_notation_opt s =
    match Ptime.of_rfc3339 s with Ok (t, _, _) -> Some t | Error _ -> None

  let of_notation_exn s =
    match Ptime.(rfc3339_error_to_msg (of_rfc3339 s)) with
    | Ok (t, _, _) ->
        t
    | Error (`Msg msg) ->
        invalid_arg ("Time.of_notation: " ^ msg)

  let to_notation t = Ptime.to_rfc3339 t

  let rfc_encoding =
    let open Data_encoding in
    def
      "timestamp.rfc"
      ~title:"RFC 3339 formatted timestamp"
      ~description:"A date in RFC 3339 notation."
    @@ conv
         to_notation
         (fun s ->
           match of_notation_opt s with
           | Some s ->
               s
           | None ->
               Data_encoding.Json.cannot_destruct "Time.of_notation")
         string

  let encoding =
    let open Data_encoding in
    let binary = conv to_seconds of_seconds_exn int64 in
    let json =
      union
        [ case
            Json_only
            ~title:"RFC encoding"
            rfc_encoding
            (fun i -> Some i)
            (fun i -> i);
          case
            Json_only
            ~title:"Second since epoch"
            int64
            (fun _ -> None)
            (fun i -> of_seconds_exn i) ]
    in
    def
      "timestamp.system"
      ~description:
        "A timestamp as seen by the underlying, local computer: \
         subsecond-level precision, epoch or rfc3339 based."
    @@ splitted ~binary ~json

  let rpc_arg =
    RPC_arg.make
      ~name:(Format.asprintf "date")
      ~descr:(Format.asprintf "A date in seconds from epoch")
      ~destruct:(fun s ->
        if s = "none" || s = "epoch" then Ok Ptime.epoch
        else
          match of_notation_opt s with
          | Some t ->
              Ok t
          | None -> (
            match of_seconds_exn (Int64.of_string s) with
            | t ->
                Ok t
            | exception _ ->
                Error (Format.asprintf "failed to parse time (epoch): %S" s) ))
      ~construct:to_notation
      ()

  let pp_hum ppf t = Ptime.pp_rfc3339 () ppf t

  type 'a stamped = {data : 'a; stamp : Ptime.t}

  let stamped_encoding arg_encoding =
    let open Data_encoding in
    conv
      (fun {stamp; data} -> (stamp, data))
      (fun (stamp, data) -> {stamp; data})
      (tup2 encoding arg_encoding)

  let pp_stamped pp fmt {data; stamp} =
    Format.fprintf fmt "%a(%a)" pp data pp_hum stamp

  let stamp ~time data = {data; stamp = time}

  let recent a1 a2 =
    match (a1, a2) with
    | (None, None) ->
        None
    | (None, (Some _ as a)) | ((Some _ as a), None) ->
        a
    | (Some (_, t1), Some (_, t2)) ->
        if Ptime.compare t1 t2 < 0 then a2 else a1

  let hash t = Int64.to_int (to_seconds t)

  include Compare.Make (Ptime)
  module Set = Set.Make (Ptime)
  module Map = Map.Make (Ptime)

  module Table = Hashtbl.Make (struct
    include Ptime

    let hash = hash
  end)
end

let () =
  Data_encoding.Registration.register ~pp:Protocol.pp_hum Protocol.encoding ;
  Data_encoding.Registration.register ~pp:System.pp_hum System.encoding ;
  Data_encoding.Registration.register System.Span.encoding
src/lib_base/time.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Protocol.
  Definition t := int64.
  
  Definition epoch : int64 :=
    (* ❌ Constant of type int64 is converted to int *)
    0.
  
  Definition diff : int64 -> int64 -> int64 := Int64.sub.
  
  Definition add : int64 -> int64 -> int64 := Int64.add.
  
  Definition of_ptime (t : Ptime.t) : int64 :=
    let '(days, ps) := Ptime.Span.to_d_ps (Ptime.to_span t) in
    let s_days :=
      Int64.mul (Int64.of_int days)
        (* ❌ Constant of type int64 is converted to int *)
        86400 in
    Int64.add s_days
      (Int64.div ps
        (* ❌ Constant of type int64 is converted to int *)
        1000000000000).
  
  Definition to_ptime (t : int64) : Ptime.t :=
    let days :=
      Int64.to_int
        (Int64.div t
          (* ❌ Constant of type int64 is converted to int *)
          86400) in
    let ps :=
      Int64.mul
        (Int64.rem t
          (* ❌ Constant of type int64 is converted to int *)
          86400)
        (* ❌ Constant of type int64 is converted to int *)
        1000000000000 in
    match Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)) with
    | None => OCaml.Stdlib.invalid_arg "Time.Protocol.to_ptime" % string
    | Some ptime => ptime
    end.
  
  Definition of_notation (s : string) : option int64 :=
    match Ptime.of_rfc3339 None None None s with
    | Stdlib.Ok (t, _, _) => Some (of_ptime t)
    | Stdlib.Error _ => None
    end.
  
  Definition of_notation_exn (s : string) : int64 :=
    match rfc3339_error_to_msg (of_rfc3339 None None None s) with
    | Stdlib.Error (Msg msg) =>
      OCaml.Stdlib.invalid_arg
        (String.append "Time.Protocol.of_notation: " % string msg)
    | Stdlib.Ok (t, _, _) => of_ptime t
    end.
  
  Definition to_notation (t : int64) : string :=
    Ptime.to_rfc3339 None (Some 0) (Some 0) (to_ptime t).
  
  Definition of_seconds {A : Type} (x : A) : A := x.
  
  Definition to_seconds {A : Type} (x : A) : A := x.
  
  Definition rfc_encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
    apply
      (def "timestamp.rfc" % string
        (Some "RFC 3339 formatted timestamp" % string)
        (Some "A date in RFC 3339 notation." % string))
      (conv to_notation
        (fun s =>
          match of_notation s with
          | Some s => s
          | None =>
            Data_encoding.Json.cannot_destruct
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Time.Protocol.of_notation" % string
                  CamlinternalFormatBasics.End_of_format)
                "Time.Protocol.of_notation" % string)
          end) None string).
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding int64 :=
    apply
      (let arg :=
        def "timestamp.protocol" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "A timestamp as seen by the protocol: second-level precision, epoch based."
              % string) in
      fun eta => arg None eta)
      (splitted
        (union None
          (cons
            (case "RFC encoding" % string None
              Tezos_data_encoding.Data_encoding.Json_only rfc_encoding
              (fun i => Some i) (fun i => i))
            (cons
              (case "Second since epoch" % string None
                Tezos_data_encoding.Data_encoding.Json_only int64
                (fun function_parameter =>
                  let '_ := function_parameter in
                  None) (fun i => i)) []))) int64).
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg int64 :=
    RPC_arg.make
      (Some
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "A date in seconds from epoch" % string
              CamlinternalFormatBasics.End_of_format)
            "A date in seconds from epoch" % string)))
      (Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "date" % string
            CamlinternalFormatBasics.End_of_format) "date" % string))
      (fun s =>
        if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
          then
          Stdlib.Ok epoch
        else
          let 't := Int64.of_string s in
          Stdlib.Ok t) Int64.to_string tt.
  
  Definition pp_hum (ppf : Stdlib.Format.formatter) (t : int64) : unit :=
    Ptime.pp_rfc3339 None None None tt ppf (to_ptime t).
  
  (* ❌ Structure item `include` not handled. *)
  include
End Protocol.

Module System.
  Definition t := Ptime.t.
  
  Definition epoch : Ptime.t := Ptime.epoch.
  
  Module Span.
    Definition t := Ptime.Span.t.
    
    Definition multiply_exn (f : Z) (s : Ptime.span) : Ptime.span :=
      Option.unopt_exn (OCaml.Failure "Time.System.Span.multiply_exn" % string)
        (of_float_s (Stdlib.op_starpoint f (Ptime.Span.to_float_s s))).
    
    Definition of_seconds_exn (f : Z) : Ptime.span :=
      match Ptime.Span.of_float_s f with
      | None =>
        OCaml.Stdlib.invalid_arg "Time.System.Span.of_seconds_exn" % string
      | Some s => s
      end.
    
    Definition encoding
      : Tezos_data_encoding.Data_encoding.encoding Ptime.span :=
      apply
        (let arg :=
          def "timespan.system" % string
            (* ❌ expected an argument *)
            expected_argument
            (Some "A span of time, as seen by the local computer." % string) in
        fun eta => arg None eta)
        (conv Ptime.Span.to_float_s
          (fun f =>
            match Ptime.Span.of_float_s f with
            | None =>
              OCaml.Stdlib.invalid_arg "Time.System.Span.encoding" % string
            | Some s => s
            end) None float).
    
    Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.span :=
      RPC_arg.make
        (Some
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "A span of time in seconds" % string
                CamlinternalFormatBasics.End_of_format)
              "A span of time in seconds" % string)))
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "timespan" % string
              CamlinternalFormatBasics.End_of_format) "timespan" % string))
        (fun s =>
          match Ptime.Span.of_float_s (Stdlib.float_of_string s) with
          | Some t => Stdlib.Ok t
          | None =>
            Stdlib.Error
              (Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "failed to parse timespan: " % string
                    (CamlinternalFormatBasics.Caml_string
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format))
                  "failed to parse timespan: %S" % string) s)
          end) (fun s => Stdlib.string_of_float (Ptime.Span.to_float_s s)) tt.
  End Span.
  
  Definition of_seconds_opt (x : int64) : option Ptime.t :=
    let days :=
      Int64.to_int
        (Int64.div x
          (* ❌ Constant of type int64 is converted to int *)
          86400) in
    let ps :=
      Int64.mul
        (Int64.rem x
          (* ❌ Constant of type int64 is converted to int *)
          86400)
        (* ❌ Constant of type int64 is converted to int *)
        1000000000000 in
    Option.apply Ptime.of_span (Ptime.Span.of_d_ps (days, ps)).
  
  Definition of_seconds_exn (x : int64) : Ptime.t :=
    match of_seconds_opt x with
    | Some t => t
    | None => OCaml.Stdlib.invalid_arg "Time.of_seconds" % string
    end.
  
  Definition to_seconds (x : Ptime.t) : int64 :=
    let '(days, ps) := Span.to_d_ps (to_span x) in
    let s_days :=
      Int64.mul (Int64.of_int days)
        (* ❌ Constant of type int64 is converted to int *)
        86400 in
    Int64.add s_days
      (Int64.div ps
        (* ❌ Constant of type int64 is converted to int *)
        1000000000000).
  
  Definition of_protocol_exn : int64 -> Ptime.t := of_seconds_exn.
  
  Definition of_protocol_opt : int64 -> option Ptime.t := of_seconds_opt.
  
  Definition to_protocol : Ptime.t -> int64 := to_seconds.
  
  Definition of_notation_opt (s : string) : option Ptime.t :=
    match Ptime.of_rfc3339 None None None s with
    | Stdlib.Ok (t, _, _) => Some t
    | Stdlib.Error _ => None
    end.
  
  Definition of_notation_exn (s : string) : Ptime.t :=
    match rfc3339_error_to_msg (of_rfc3339 None None None s) with
    | Stdlib.Ok (t, _, _) => t
    | Stdlib.Error (Msg msg) =>
      OCaml.Stdlib.invalid_arg (String.append "Time.of_notation: " % string msg)
    end.
  
  Definition to_notation (t : Ptime.t) : string :=
    Ptime.to_rfc3339 None None None t.
  
  Definition rfc_encoding
    : Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
    apply
      (def "timestamp.rfc" % string
        (Some "RFC 3339 formatted timestamp" % string)
        (Some "A date in RFC 3339 notation." % string))
      (conv to_notation
        (fun s =>
          match of_notation_opt s with
          | Some s => s
          | None =>
            Data_encoding.Json.cannot_destruct
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Time.of_notation" % string
                  CamlinternalFormatBasics.End_of_format)
                "Time.of_notation" % string)
          end) None string).
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding Ptime.t :=
    let binary := conv to_seconds of_seconds_exn None int64 in
    let json :=
      union None
        (cons
          (case "RFC encoding" % string None
            Tezos_data_encoding.Data_encoding.Json_only rfc_encoding
            (fun i => Some i) (fun i => i))
          (cons
            (case "Second since epoch" % string None
              Tezos_data_encoding.Data_encoding.Json_only int64
              (fun function_parameter =>
                let '_ := function_parameter in
                None) (fun i => of_seconds_exn i)) [])) in
    apply
      (let arg :=
        def "timestamp.system" % string
          (* ❌ expected an argument *)
          expected_argument
          (Some
            "A timestamp as seen by the underlying, local computer: subsecond-level precision, epoch or rfc3339 based."
              % string) in
      fun eta => arg None eta) (splitted json binary).
  
  Definition rpc_arg : Tezos_rpc.RPC_arg.arg Ptime.t :=
    RPC_arg.make
      (Some
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "A date in seconds from epoch" % string
              CamlinternalFormatBasics.End_of_format)
            "A date in seconds from epoch" % string)))
      (Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "date" % string
            CamlinternalFormatBasics.End_of_format) "date" % string))
      (fun s =>
        if orb (equiv_decb s "none" % string) (equiv_decb s "epoch" % string)
          then
          Stdlib.Ok Ptime.epoch
        else
          match of_notation_opt s with
          | Some t => Stdlib.Ok t
          | None =>
            let 't := of_seconds_exn (Int64.of_string s) in
            Stdlib.Ok t
          end) to_notation tt.
  
  Definition pp_hum (ppf : Stdlib.Format.formatter) (t : Ptime.t) : unit :=
    Ptime.pp_rfc3339 None None None tt ppf t.
  
  Record stamped {a : Type} := {
    data : a;
    stamp : Ptime.t }.
  Arguments stamped : clear implicits.
  
  Definition stamped_encoding {A : Type}
    (arg_encoding : Tezos_data_encoding.Data_encoding.encoding A)
    : Tezos_data_encoding.Data_encoding.encoding (stamped A) :=
    conv
      (fun function_parameter =>
        let '{| data := data; stamp := stamp |} := function_parameter in
        (stamp, data))
      (fun function_parameter =>
        let '(stamp, data) := function_parameter in
        {| data := data; stamp := stamp |}) None (tup2 encoding arg_encoding).
  
  Definition pp_stamped {A : Type}
    (pp : Stdlib.Format.formatter -> A -> unit) (fmt : Stdlib.Format.formatter)
    (function_parameter : stamped A) : unit :=
    let '{| data := data; stamp := stamp |} := function_parameter in
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))) "%a(%a)" % string) pp
      data pp_hum stamp.
  
  Definition stamp {A : Type} (time : Ptime.t) (data : A) : stamped A :=
    {| data := data; stamp := time |}.
  
  Definition recent {A : Type}
    (a1 : option (A * Ptime.t)) (a2 : option (A * Ptime.t))
    : option (A * Ptime.t) :=
    match (a1, a2) with
    | (None, None) => None
    | (None, (Some _) as a) | ((Some _) as a, None) => a
    | (Some (_, t1), Some (_, t2)) =>
      if OCaml.Stdlib.lt (Ptime.compare t1 t2) 0 then
        a2
      else
        a1
    end.
  
  Definition hash (t : Ptime.t) : Z := Int64.to_int (to_seconds t).
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End System.



src/lib_base/tzPervasives.ml 32 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Tezos_stdlib
module Error_monad = Tezos_error_monad.Error_monad
include Tezos_rpc
include Tezos_clic
include Tezos_crypto
include Tezos_micheline
module Data_encoding = Tezos_data_encoding.Data_encoding

module List = struct
  include List
  include Tezos_stdlib.TzList
end

module String = struct
  include String
  include Tezos_stdlib.TzString
end

module Time = Time
module Fitness = Fitness
module Block_header = Block_header
module Operation = Operation
module Protocol = Protocol
module Test_chain_status = Test_chain_status
module Preapply_result = Preapply_result
module Block_locator = Block_locator
module Mempool = Mempool
module P2p_addr = P2p_addr
module P2p_identity = P2p_identity
module P2p_peer = P2p_peer
module P2p_point = P2p_point
module P2p_connection = P2p_connection
module P2p_stat = P2p_stat
module P2p_version = P2p_version
module Distributed_db_version = Distributed_db_version
module Network_version = Network_version
include Utils.Infix
include Error_monad
module Internal_event = Internal_event
src/lib_base/tzPervasives.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ This kind of module is not handled. *)
unhandled_module

Module List.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End List.

Module String.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End String.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ This kind of module is not handled. *)
unhandled_module

src/lib_base/unix/protocol_files.ml 7 errors
open Error_monad

let name = "TEZOS_PROTOCOL"

open Protocol

let ( // ) = Filename.concat

let to_file ~dir:dirname ?hash ?env_version modules =
  let config_file =
    Data_encoding.Json.construct
      Meta.encoding
      {hash; expected_env_version = env_version; modules}
  in
  Lwt_utils_unix.Json.write_file (dirname // name) config_file

let of_file ~dir:dirname =
  Lwt_utils_unix.Json.read_file (dirname // name)
  >>=? fun json -> return (Data_encoding.Json.destruct Meta.encoding json)

let find_component dirname module_name =
  let name_lowercase = String.uncapitalize_ascii module_name in
  let implementation = (dirname // name_lowercase) ^ ".ml" in
  let interface = implementation ^ "i" in
  match (Sys.file_exists implementation, Sys.file_exists interface) with
  | (false, _) ->
      Pervasives.failwith @@ "Not such file: " ^ implementation
  | (true, false) ->
      Lwt_utils_unix.read_file implementation
      >|= fun implementation ->
      {name = module_name; interface = None; implementation}
  | _ ->
      Lwt_utils_unix.read_file interface
      >>= fun interface ->
      Lwt_utils_unix.read_file implementation
      >|= fun implementation ->
      {name = module_name; interface = Some interface; implementation}

let read_dir dir =
  of_file ~dir
  >>=? fun meta ->
  Lwt_list.map_p (find_component dir) meta.modules
  >>= fun components ->
  let expected_env =
    match meta.expected_env_version with None -> V1 | Some v -> v
  in
  return (meta.hash, {expected_env; components})

open Lwt.Infix

let create_files dir units =
  Lwt_utils_unix.remove_dir dir
  >>= fun () ->
  Lwt_utils_unix.create_dir dir
  >>= fun () ->
  Lwt_list.map_s
    (fun {name; interface; implementation} ->
      let name = String.lowercase_ascii name in
      let ml = dir // (name ^ ".ml") in
      let mli = dir // (name ^ ".mli") in
      Lwt_utils_unix.create_file ml implementation
      >>= fun () ->
      match interface with
      | None ->
          Lwt.return [ml]
      | Some content ->
          Lwt_utils_unix.create_file mli content
          >>= fun () -> Lwt.return [mli; ml])
    units
  >>= fun files ->
  let files = List.concat files in
  Lwt.return files

let write_dir dir ?hash (p : t) =
  create_files dir p.components
  >>= fun _files ->
  to_file
    ~dir
    ?hash
    ~env_version:p.expected_env
    (List.map (fun {name; _} -> String.capitalize_ascii name) p.components)
src/lib_base/unix/protocol_files.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Definition name : string := "TEZOS_PROTOCOL" % string.

Import Protocol.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition to_file
  (dirname : string) (hash : option Tezos_crypto.Protocol_hash.t)
  (env_version : option Tezos_base__Protocol.env_version)
  (modules : list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let config_file :=
    Data_encoding.Json.construct Meta.encoding
      {| hash := hash; expected_env_version := env_version; modules := modules
        |} in
  Lwt_utils_unix.Json.write_file (op_divdiv dirname name) config_file.

Definition of_file (dirname : string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Tezos_base.Protocol.Meta.t) :=
  op_gtgteqquestion (Lwt_utils_unix.Json.read_file (op_divdiv dirname name))
    (fun json => _return (Data_encoding.Json.destruct Meta.encoding json)).

Definition find_component (dirname : string) (module_name : string)
  : Lwt.t Tezos_base.Protocol.component :=
  let name_lowercase := Stdlib.String.uncapitalize_ascii module_name in
  let implementation :=
    String.append (op_divdiv dirname name_lowercase) ".ml" % string in
  let interface := String.append implementation "i" % string in
  match ((Sys.file_exists implementation), (Sys.file_exists interface)) with
  | (false, _) =>
    apply Pervasives.failwith
      (String.append "Not such file: " % string implementation)
  | (true, false) =>
    op_gtpipeeq (Lwt_utils_unix.read_file implementation)
      (fun implementation =>
        {| name := module_name; interface := None;
          implementation := implementation |})
  | _ =>
    op_gtgteq (Lwt_utils_unix.read_file interface)
      (fun interface =>
        op_gtpipeeq (Lwt_utils_unix.read_file implementation)
          (fun implementation =>
            {| name := module_name; interface := Some interface;
              implementation := implementation |}))
  end.

Definition read_dir (dir : string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((option Tezos_crypto.Protocol_hash.t) * Tezos_base.Protocol.t)) :=
  op_gtgteqquestion (of_file dir)
    (fun meta =>
      op_gtgteq (Lwt_list.map_p (find_component dir) (modules meta))
        (fun components =>
          let expected_env :=
            match expected_env_version meta with
            | None => Tezos_base.Protocol.V1
            | Some v => v
            end in
          _return
            ((hash meta),
              {| expected_env := expected_env; components := components |}))).

Import Lwt.Infix.

Definition create_files
  (dir : string) (units : list Tezos_base.Protocol.component)
  : Lwt.t (list string) :=
  op_gtgteq (Lwt_utils_unix.remove_dir dir)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_utils_unix.create_dir None dir)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (Lwt_list.map_s
              (fun function_parameter =>
                let '{|
                  name := name;
                    interface := interface;
                    implementation := implementation
                    |} := function_parameter in
                let name := Stdlib.String.lowercase_ascii name in
                let ml := op_divdiv dir (String.append name ".ml" % string) in
                let mli := op_divdiv dir (String.append name ".mli" % string) in
                op_gtgteq (Lwt_utils_unix.create_file None ml implementation)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    match interface with
                    | None => Lwt._return (cons ml [])
                    | Some content =>
                      op_gtgteq (Lwt_utils_unix.create_file None mli content)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Lwt._return (cons mli (cons ml [])))
                    end)) units)
            (fun files =>
              let files := Stdlib.List.concat files in
              Lwt._return files))).

Definition write_dir
  (dir : string) (hash : option Tezos_crypto.Protocol_hash.t)
  (p : Tezos_base.Protocol.t)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  op_gtgteq (create_files dir (components p))
    (fun _files =>
      to_file dir hash (Some (expected_env p))
        (List.map
          (fun function_parameter =>
            let '{| name := name |} := function_parameter in
            Stdlib.String.capitalize_ascii name) (components p))).

src/lib_clic/unix/scriptable.ml 7 errors
open Error_monad

type output_format = Rows of {separator : string; escape : [`No | `OCaml]}

let rows separator escape = Rows {separator; escape}

let tsv = rows "\t" `No

let csv = rows "," `OCaml

let clic_arg () =
  let open Clic in
  arg
    ~doc:"Make the output script-friendly"
    ~long:"for-script"
    ~placeholder:"FORMAT"
    (parameter (fun _ spec ->
         match String.lowercase_ascii spec with
         | "tsv" ->
             return tsv
         | "csv" ->
             return csv
         | other ->
             failwith
               "Cannot recognize format %S, please try 'TSV' or 'CSV'"
               other))

let fprintf_lwt chan fmt =
  Format.kasprintf
    (fun s ->
      protect (fun () -> Lwt_io.write chan s >>= fun () -> return_unit))
    fmt

let output ?(channel = Lwt_io.stdout) how_option ~for_human ~for_script =
  match how_option with
  | None ->
      for_human ()
  | Some (Rows {separator; escape}) ->
      let open Format in
      iter_s
        (fun row ->
          fprintf_lwt
            channel
            "%a@."
            (pp_print_list
               ~pp_sep:(fun fmt () -> pp_print_string fmt separator)
               (fun fmt cell ->
                 match escape with
                 | `OCaml ->
                     fprintf fmt "%S" cell
                 | `No ->
                     pp_print_string fmt cell))
            row)
        (for_script ())
      >>=? fun () ->
      protect (fun () -> Lwt_io.flush channel >>= fun () -> return_unit)

let output_for_human how_option for_human =
  output how_option ~for_human ~for_script:(fun () -> [])

let output_row ?channel how_option ~for_human ~for_script =
  output ?channel how_option ~for_human ~for_script:(fun () -> [for_script ()])
src/lib_clic/unix/scriptable.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Inductive output_format : Type :=
| Rows : string -> variant -> output_format.

Definition rows (separator : string) (escape : variant) : output_format :=
  Rows {| separator := separator; escape := escape |}.

Definition tsv : output_format :=
  rows "	" % string
    (* ❌ Variants not supported *)
    variant.

Definition csv : output_format :=
  rows "," % string
    (* ❌ Variants not supported *)
    variant.

Definition clic_arg {A : Type} (function_parameter : unit)
  : Tezos_clic.Clic.arg (option output_format) A :=
  let 'tt := function_parameter in
  arg "Make the output script-friendly" % string None "for-script" % string
    "FORMAT" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun spec =>
          match Stdlib.String.lowercase_ascii spec with
          | "tsv" % string => _return tsv
          | "csv" % string => _return csv
          | other =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Cannot recognize format " % string
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      ", please try 'TSV' or 'CSV'" % string
                      CamlinternalFormatBasics.End_of_format)))
                "Cannot recognize format %S, please try 'TSV' or 'CSV'" % string)
              other
          end)).

Definition fprintf_lwt {A : Type}
  (chan : Lwt_io.output_channel)
  (fmt :
    Stdlib.format4 A Stdlib.Format.formatter unit
      (Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))) : A :=
  Format.kasprintf
    (fun s =>
      protect None None
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Lwt_io.write chan s)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit))) fmt.

Definition output (op_staroptstar : option Lwt_io.output_channel)
  : (option output_format) ->
    (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)) ->
      (unit -> list (list string)) ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let channel :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Lwt_io.stdout
    end in
  fun how_option =>
    fun for_human =>
      fun for_script =>
        match how_option with
        | None => for_human tt
        | Some (Rows {| separator := separator; escape := escape |}) =>
          op_gtgteqquestion
            (iter_s
              (fun row =>
                fprintf_lwt channel
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Flush_newline
                        CamlinternalFormatBasics.End_of_format)) "%a@." % string)
                  (pp_print_list
                    (Some
                      (fun fmt =>
                        fun function_parameter =>
                          let 'tt := function_parameter in
                          pp_print_string fmt separator))
                    (fun fmt =>
                      fun cell =>
                        match escape with
                        | OCaml =>
                          fprintf fmt
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Caml_string
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format)
                              "%S" % string) cell
                        | No => pp_print_string fmt cell
                        end)) row) (for_script tt))
            (fun function_parameter =>
              let 'tt := function_parameter in
              protect None None
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq (Lwt_io.flush channel)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit)))
        end.

Definition output_for_human
  (how_option : option output_format)
  (for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  output None how_option for_human
    (fun function_parameter =>
      let 'tt := function_parameter in
      []).

Definition output_row
  (channel : option Lwt_io.output_channel) (how_option : option output_format)
  (for_human : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
  (for_script : unit -> list string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  output channel how_option for_human
    (fun function_parameter =>
      let 'tt := function_parameter in
      cons (for_script tt) []).

src/lib_client_base/client_aliases.ml 192 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Local Storage for Configuration *)

open Lwt.Infix
open Clic

module type Entity = sig
  type t

  val encoding : t Data_encoding.t

  val of_source : string -> t tzresult Lwt.t

  val to_source : t -> string tzresult Lwt.t

  val name : string
end

module type Alias = sig
  type t

  type fresh_param

  val load : #Client_context.wallet -> (string * t) list tzresult Lwt.t

  val set : #Client_context.wallet -> (string * t) list -> unit tzresult Lwt.t

  val find : #Client_context.wallet -> string -> t tzresult Lwt.t

  val find_opt : #Client_context.wallet -> string -> t option tzresult Lwt.t

  val rev_find : #Client_context.wallet -> t -> string option tzresult Lwt.t

  val name : #Client_context.wallet -> t -> string tzresult Lwt.t

  val mem : #Client_context.wallet -> string -> bool tzresult Lwt.t

  val add :
    force:bool -> #Client_context.wallet -> string -> t -> unit tzresult Lwt.t

  val del : #Client_context.wallet -> string -> unit tzresult Lwt.t

  val update : #Client_context.wallet -> string -> t -> unit tzresult Lwt.t

  val of_source : string -> t tzresult Lwt.t

  val to_source : t -> string tzresult Lwt.t

  val alias_parameter :
    unit -> (string * t, #Client_context.wallet) Clic.parameter

  val alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'b)) Clic.params ->
    (string * t -> 'a, 'b) Clic.params

  val fresh_alias_param :
    ?name:string ->
    ?desc:string ->
    ('a, (< .. > as 'obj)) Clic.params ->
    (fresh_param -> 'a, 'obj) Clic.params

  val force_switch : unit -> (bool, _) arg

  val of_fresh :
    #Client_context.wallet -> bool -> fresh_param -> string tzresult Lwt.t

  val source_param :
    ?name:string ->
    ?desc:string ->
    ('a, (#Client_context.wallet as 'obj)) Clic.params ->
    (t -> 'a, 'obj) Clic.params

  val source_arg :
    ?long:string ->
    ?placeholder:string ->
    ?doc:string ->
    unit ->
    (t option, (#Client_context.wallet as 'obj)) Clic.arg

  val autocomplete : #Client_context.wallet -> string list tzresult Lwt.t
end

module Alias (Entity : Entity) = struct
  open Client_context

  let wallet_encoding : (string * Entity.t) list Data_encoding.encoding =
    let open Data_encoding in
    list (obj2 (req "name" string) (req "value" Entity.encoding))

  let load (wallet : #wallet) =
    wallet#load Entity.name ~default:[] wallet_encoding

  let set (wallet : #wallet) entries =
    wallet#write Entity.name entries wallet_encoding

  let autocomplete wallet =
    load wallet
    >>= function
    | Error _ -> return_nil | Ok list -> return (List.map fst list)

  let find_opt (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    try return_some (List.assoc name list) with Not_found -> return_none

  let find (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    try return (List.assoc name list)
    with Not_found -> failwith "no %s alias named %s" Entity.name name

  let rev_find (wallet : #wallet) v =
    load wallet
    >>=? fun list ->
    try return_some (List.find (fun (_, v') -> v = v') list |> fst)
    with Not_found -> return_none

  let mem (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    try
      ignore (List.assoc name list) ;
      return_true
    with Not_found -> return_false

  let add ~force (wallet : #wallet) name value =
    let keep = ref false in
    load wallet
    >>=? fun list ->
    ( if force then return_unit
    else
      iter_s
        (fun (n, v) ->
          if n = name && v = value then (
            keep := true ;
            return_unit )
          else if n = name && v <> value then
            failwith
              "another %s is already aliased as %s, use --force to update"
              Entity.name
              n
          else if n <> name && v = value then
            failwith
              "this %s is already aliased as %s, use --force to insert \
               duplicate"
              Entity.name
              n
          else return_unit)
        list )
    >>=? fun () ->
    let list = List.filter (fun (n, _) -> n <> name) list in
    let list = (name, value) :: list in
    if !keep then return_unit
    else wallet#write Entity.name list wallet_encoding

  let del (wallet : #wallet) name =
    load wallet
    >>=? fun list ->
    let list = List.filter (fun (n, _) -> n <> name) list in
    wallet#write Entity.name list wallet_encoding

  let update (wallet : #wallet) name value =
    load wallet
    >>=? fun list ->
    let list =
      List.map (fun (n, v) -> (n, if n = name then value else v)) list
    in
    wallet#write Entity.name list wallet_encoding

  include Entity

  let alias_parameter () =
    parameter ~autocomplete (fun cctxt s ->
        find cctxt s >>=? fun v -> return (s, v))

  let alias_param ?(name = "name")
      ?(desc = "existing " ^ Entity.name ^ " alias") next =
    param ~name ~desc (alias_parameter ()) next

  type fresh_param = Fresh of string

  let of_fresh (wallet : #wallet) force (Fresh s) =
    load wallet
    >>=? fun list ->
    ( if force then return_unit
    else
      iter_s
        (fun (n, v) ->
          if n = s then
            Entity.to_source v
            >>=? fun value ->
            failwith
              "@[<v 2>The %s alias %s already exists.@,\
               The current value is %s.@,\
               Use --force to update@]"
              Entity.name
              n
              value
          else return_unit)
        list )
    >>=? fun () -> return s

  let fresh_alias_param ?(name = "new")
      ?(desc = "new " ^ Entity.name ^ " alias") next =
    param
      ~name
      ~desc
      (parameter (fun (_ : < .. >) s -> return @@ Fresh s))
      next

  let parse_source_string cctxt s =
    match String.split ~limit:1 ':' s with
    | ["alias"; alias] ->
        find cctxt alias
    | ["text"; text] ->
        of_source text
    | ["file"; path] ->
        cctxt#read_file path >>=? of_source
    | _ -> (
        find cctxt s
        >>= function
        | Ok v ->
            return v
        | Error a_errs -> (
            cctxt#read_file s >>=? of_source
            >>= function
            | Ok v ->
                return v
            | Error r_errs -> (
                of_source s
                >>= function
                | Ok v ->
                    return v
                | Error s_errs ->
                    let all_errs = List.flatten [a_errs; r_errs; s_errs] in
                    Lwt.return_error all_errs ) ) )

  let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =
    let desc =
      Format.asprintf
        "%s\n\
         Can be a %s name, a file or a raw %s literal. If the parameter is \
         not the name of an existing %s, the client will look for a file \
         containing a %s, and if it does not exist, the argument will be read \
         as a raw %s.\n\
         Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
        desc
        Entity.name
        Entity.name
        Entity.name
        Entity.name
        Entity.name
    in
    param ~name ~desc (parameter parse_source_string) next

  let source_arg ?(long = "source " ^ Entity.name) ?(placeholder = "src")
      ?(doc = "") () =
    let doc =
      Format.asprintf
        "%s\n\
         Can be a %s name, a file or a raw %s literal. If the parameter is \
         not the name of an existing %s, the client will look for a file \
         containing a %s, and if it does not exist, the argument will be read \
         as a raw %s.\n\
         Use 'alias:name', 'file:path' or 'text:literal' to disable autodetect."
        doc
        Entity.name
        Entity.name
        Entity.name
        Entity.name
        Entity.name
    in
    arg ~long ~placeholder ~doc (parameter parse_source_string)

  let force_switch () =
    Clic.switch
      ~long:"force"
      ~short:'f'
      ~doc:("overwrite existing " ^ Entity.name)
      ()

  let name (wallet : #wallet) d =
    rev_find wallet d
    >>=? function None -> Entity.to_source d | Some name -> return name
end
src/lib_client_base/client_aliases.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Clic.

Module Entity.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
    of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    name : string;
  }.
  Arguments signature : clear implicits.
End Entity.

Module Alias.
  Record signature {t fresh_param : Type} := {
    t := t;
    fresh_param := fresh_param;
    load : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * t)));
    set : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) ->
      (list (string * t)) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    find_opt : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t));
    rev_find : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option string));
    name : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    mem : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult bool);
    add : forall {_ a : Type}, bool ->
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
        * _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    del : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    update : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> string -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    of_source : string -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    to_source : t -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    alias_parameter : forall {_ a : Type}, unit ->
      Tezos_base__TzPervasives.Clic.parameter (string * t)
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
          * _);
    alias_param : forall {a b : Type}, (option string) ->
      (option string) ->
        (Tezos_base__TzPervasives.Clic.params a
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    b))))) * b)) ->
          Tezos_base__TzPervasives.Clic.params ((string * t) -> a)
            (((option (Lwt_stream.t string)) *
              ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
                      * b))))) * b);
    fresh_alias_param : forall {a obj : Type}, (option string) ->
      (option string) ->
        (Tezos_base__TzPervasives.Clic.params a (obj)) ->
          Tezos_base__TzPervasives.Clic.params (fresh_param -> a) (obj);
    force_switch : forall {_ : Type}, unit ->
      Tezos_base__TzPervasives.Clic.arg bool _;
    of_fresh : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) ->
      bool -> fresh_param -> Lwt.t (Tezos_base__TzPervasives.tzresult string);
    source_param : forall {a obj : Type}, (option string) ->
      (option string) ->
        (Tezos_base__TzPervasives.Clic.params a
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    obj))))) * obj)) ->
          Tezos_base__TzPervasives.Clic.params (t -> a)
            (((option (Lwt_stream.t string)) *
              ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
                      * obj))))) * obj);
    source_arg : forall {a obj : Type}, (option string) ->
      (option string) ->
        (option string) ->
          unit ->
            Tezos_base__TzPervasives.Clic.arg (option t)
              (((option (Lwt_stream.t string)) *
                ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                  ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                      (((string ->
                        a ->
                          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                            Lwt.t (Tezos_base__TzPervasives.tzresult unit)) *
                        (a)) * obj))))) * obj);
    autocomplete : forall {_ a : Type}, (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * _)))))
      * _) -> Lwt.t (Tezos_base__TzPervasives.tzresult (list string));
  }.
  Arguments signature : clear implicits.
End Alias.

(* ❌ Functors are not handled. *)
functor

src/lib_client_base/client_confirmations.ml 130 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let in_block operation_hash operations =
  let exception Found of int * int in
  try
    List.iteri
      (fun i ops ->
        List.iteri
          (fun j op ->
            if Operation_hash.equal operation_hash op then raise (Found (i, j)))
          ops)
      operations ;
    None
  with Found (i, j) -> Some (i, j)

type operation_status =
  | Confirmed of (Block_hash.t * int * int)
  | Pending
  | Still_not_found

let wait_for_operation_inclusion (ctxt : #Client_context.full) ~chain
    ?(predecessors = 10) ?(confirmations = 1) ?branch operation_hash =
  let exception WrapError of error list in
  let exception Outdated of Operation_hash.t in
  (* Table of known blocks:
     - None: if neither the block or its predecessors contains the operation
     - (Some ((hash, i, j), n)):
          if the `hash` contains the operation in list `i` at position `j`
          and if `hash` denotes the `n-th` predecessors of the block. *)
  let blocks : ((Block_hash.t * int * int) * int) option Block_hash.Table.t =
    Block_hash.Table.create confirmations
  in
  (* Fetch _all_ the 'unknown' predecessors af a block. *)
  let fetch_predecessors (hash, header) =
    let rec loop acc (_hash, header) =
      let predecessor = header.Block_header.predecessor in
      if Block_hash.Table.mem blocks predecessor then return acc
      else
        Chain_services.Blocks.Header.shell_header
          ctxt
          ~chain
          ~block:(`Hash (predecessor, 0))
          ()
        >>=? fun shell ->
        let block = (predecessor, shell) in
        loop (block :: acc) block
    in
    loop [(hash, header.Block_header.shell)] (hash, header.shell)
    >>= function
    | Ok blocks ->
        Lwt.return blocks
    | Error err ->
        ctxt#warning
          "Error while fetching block (ignored): %a"
          pp_print_error
          err
        >>= fun () ->
        (* Will be retried when a new head arrives *)
        Lwt.return_nil
  in
  (* Check whether a block as enough confirmations. This function
     assumes that the block predecessor has been processed already. *)
  let process hash header =
    let block = `Hash (hash, 0) in
    let predecessor = header.Tezos_base.Block_header.predecessor in
    match Block_hash.Table.find blocks predecessor with
    | Some (block_with_op, n) ->
        ctxt#answer
          "Operation received %d confirmations as of block: %a"
          (n + 1)
          Block_hash.pp
          hash
        >>= fun () ->
        Block_hash.Table.add blocks hash (Some (block_with_op, n + 1)) ;
        if n + 1 < confirmations then return Pending
        else return (Confirmed block_with_op)
    | None -> (
        Shell_services.Blocks.Operation_hashes.operation_hashes
          ctxt
          ~chain
          ~block
          ()
        >>=? fun operations ->
        match in_block operation_hash operations with
        | None ->
            Block_hash.Table.add blocks hash None ;
            return Still_not_found
        | Some (i, j) ->
            ctxt#answer
              "Operation found in block: %a (pass: %d, offset: %d)"
              Block_hash.pp
              hash
              i
              j
            >>= fun () ->
            Block_hash.Table.add blocks hash (Some ((hash, i, j), 0)) ;
            if confirmations <= 0 then return (Confirmed (hash, i, j))
            else return Pending )
  in
  (* Checks if the given branch is considered alive.*)
  let check_branch_alive () =
    match branch with
    | Some branch_hash -> (
        Shell_services.Blocks.live_blocks ctxt ~chain ~block:(`Head 0) ()
        >>= function
        | Ok live_blocks ->
            if Block_hash.Set.mem branch_hash live_blocks then Lwt.return_unit
            else
              ctxt#error
                "The operation %a is outdated and may never be included in \
                 the chain.@,\
                 We recommand to use an external block explorer."
                Operation_hash.pp
                operation_hash
              >>= fun () -> Lwt.fail (Outdated operation_hash)
        | Error err ->
            Lwt.fail (WrapError err) )
    | None ->
        Lwt.return_unit
  in
  Shell_services.Monitor.heads ctxt chain
  >>=? fun (stream, stop) ->
  Lwt_stream.get stream
  >>= function
  | None ->
      assert false
  | Some (head, _) ->
      let rec loop n =
        if n >= 0 then
          (*Search for the operation in the n head predecessors*)
          let block = `Hash (head, n) in
          Shell_services.Blocks.hash ctxt ~chain ~block ()
          >>=? fun hash ->
          Shell_services.Blocks.Header.shell_header ctxt ~chain ~block ()
          >>=? fun shell ->
          process hash shell
          >>=? function
          | Confirmed block ->
              stop () ; return block
          | Pending | Still_not_found ->
              loop (n - 1)
        else
          (*Search for the operation in new heads*)
          Lwt.catch
            (fun () ->
              (*Fetching potential unknown blocks from potential new heads*)
              let stream = Lwt_stream.map_list_s fetch_predecessors stream in
              Lwt_stream.find_s
                (fun (hash, header) ->
                  process hash header
                  >>= function
                  | Ok Pending ->
                      Lwt.return_false
                  | Ok Still_not_found ->
                      check_branch_alive () >>= fun () -> Lwt.return_false
                  | Ok (Confirmed _) ->
                      Lwt.return_true
                  | Error err ->
                      Lwt.fail (WrapError err))
                stream
              >>= return)
            (function
              | WrapError e -> Lwt.return_error e | exn -> Lwt.fail exn)
          >>=? function
          | None ->
              failwith "..."
          | Some (hash, _) -> (
              stop () ;
              match Block_hash.Table.find_opt blocks hash with
              | None | Some None ->
                  assert false
              | Some (Some (hash, _)) ->
                  return hash )
      in
      ( match branch with
      | Some branch_hash ->
          Shell_services.Blocks.Header.shell_header
            ctxt
            ~chain
            ~block:(`Hash (branch_hash, 0))
            ()
          >>=? fun branch_header ->
          let branch_level = branch_header.Block_header.level in
          Shell_services.Blocks.Header.shell_header
            ctxt
            ~chain
            ~block:(`Hash (head, 0))
            ()
          >>=? fun head_shell ->
          let head_level = head_shell.Block_header.level in
          return Int32.(to_int (sub head_level branch_level))
      | None ->
          return predecessors )
      >>=? fun block_hook ->
      Block_services.Empty.hash
        ctxt
        ~chain
        ~block:(`Hash (head, block_hook + 1))
        ()
      >>=? fun oldest ->
      Block_hash.Table.add blocks oldest None ;
      loop block_hook

let lookup_operation_in_previous_block ctxt chain operation_hash i =
  Block_services.Empty.hash ctxt ~block:(`Head i) ()
  >>=? fun block ->
  Shell_services.Blocks.Operation_hashes.operation_hashes
    ctxt
    ~chain
    ~block:(`Hash (block, 0))
    ()
  >>=? fun operations ->
  match in_block operation_hash operations with
  | None ->
      return_none
  | Some (a, b) ->
      return_some (block, a, b)

let lookup_operation_in_previous_blocks (ctxt : #Client_context.full) ~chain
    ~predecessors operation_hash =
  let rec loop i =
    if i = predecessors + 1 then return_none
    else
      lookup_operation_in_previous_block ctxt chain operation_hash i
      >>=? function
      | None -> loop (i + 1) | Some (block, a, b) -> return_some (block, a, b)
  in
  loop 0

let wait_for_bootstrapped (ctxt : #Client_context.full) =
  let display = ref false in
  Lwt.async (fun () ->
      ctxt#sleep 0.3
      >>= fun () ->
      if not !display then (
        ctxt#answer
          "Waiting for the node to be bootstrapped before injection..."
        >>= fun () ->
        display := true ;
        Lwt.return_unit )
      else Lwt.return_unit) ;
  Monitor_services.bootstrapped ctxt
  >>=? fun (stream, _stop) ->
  Lwt_stream.iter_s
    (fun (hash, time) ->
      if !display then
        ctxt#message
          "Current head: %a (timestamp: %a, validation: %a)"
          Block_hash.pp_short
          hash
          Time.System.pp_hum
          (Time.System.of_protocol_exn time)
          Time.System.pp_hum
          (ctxt#now ())
      else Lwt.return_unit)
    stream
  >>= fun () ->
  display := true ;
  ctxt#answer "Node is bootstrapped, ready for injecting operations."
  >>= fun () -> return_unit
src/lib_client_base/client_confirmations.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition in_block
  (operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
  (operations : list (list Tezos_base__TzPervasives.Operation_hash.t))
  : option (Z * Z) :=
  (* ❌ Let of exception is not handled *)
  let_exception.

Inductive operation_status : Type :=
| Confirmed : (Tezos_base__TzPervasives.Block_hash.t * Z * Z) ->
  operation_status
| Pending : operation_status
| Still_not_found : operation_status.

Definition wait_for_operation_inclusion {F G I a b i o p q : Type}
  (ctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (chain : Tezos_shell_services__Block_services.chain)
  (op_staroptstar : option Z)
  : (option Z) ->
    (option Tezos_base__TzPervasives.Block_hash.Set.elt) ->
      Tezos_base__TzPervasives.Operation_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Block_hash.t * Z * Z)) :=
  let predecessors :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 10
    end in
  fun op_staroptstar =>
    let confirmations :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => 1
      end in
    fun branch =>
      fun operation_hash =>
        (* ❌ Let of exception is not handled *)
        let_exception.

Definition lookup_operation_in_previous_block {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (chain : Tezos_shell_services__Block_services.chain)
  (operation_hash : Tezos_base__TzPervasives.Operation_hash.t) (i : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
  op_gtgteqquestion
    (Block_services.Empty.hash ctxt None
      (Some
        (* ❌ Variants not supported *)
        variant) tt)
    (fun block =>
      op_gtgteqquestion
        (Shell_services.Blocks.Operation_hashes.operation_hashes ctxt
          (Some chain)
          (Some
            (* ❌ Variants not supported *)
            variant) tt)
        (fun operations =>
          match in_block operation_hash operations with
          | None => return_none
          | Some (a, b) => return_some (block, a, b)
          end)).

Definition lookup_operation_in_previous_blocks {F G I a b i o p q : Type}
  (ctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (chain : Tezos_shell_services__Block_services.chain)
  (predecessors : Z)
  (operation_hash : Tezos_base__TzPervasives.Operation_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
  let fix loop (i : Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option (Tezos_base__TzPervasives.Block_hash.t * Z * Z))) :=
    if equiv_decb i (Z.add predecessors 1) then
      return_none
    else
      op_gtgteqquestion
        (lookup_operation_in_previous_block ctxt chain operation_hash i)
        (fun function_parameter =>
          match function_parameter with
          | None => loop (Z.add i 1)
          | Some (block, a, b) => return_some (block, a, b)
          end) in
  loop 0.

Definition wait_for_bootstrapped {F G I a b i o p q : Type}
  (ctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let display := Stdlib.ref false in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Lwt.async
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (* ❌ Float constant 0.3 is approximated by the integer 0 *)
            0)
          (fun function_parameter =>
            let 'tt := function_parameter in
            if negb (Stdlib.op_exclamation display) then
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Waiting for the node to be bootstrapped before injection..."
                        % string CamlinternalFormatBasics.End_of_format)
                    "Waiting for the node to be bootstrapped before injection..."
                      % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := Stdlib.op_coloneq display true in
                  Lwt.return_unit)
            else
              Lwt.return_unit)) in
  op_gtgteqquestion (Monitor_services.bootstrapped ctxt)
    (fun function_parameter =>
      let '(stream, _stop) := function_parameter in
      op_gtgteq
        (Lwt_stream.iter_s
          (fun function_parameter =>
            let '(hash, time) := function_parameter in
            if Stdlib.op_exclamation display then
              (* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Current head: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        " (timestamp: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            ", validation: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                CamlinternalFormatBasics.End_of_format)))))))
                  "Current head: %a (timestamp: %a, validation: %a)" % string)
                Block_hash.pp_short hash Time.System.pp_hum
                (Time.System.of_protocol_exn time) Time.System.pp_hum
                ((* ❌ Sending method message is not handled *)
                send tt)
            else
              Lwt.return_unit) stream)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Stdlib.op_coloneq display true in
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Node is bootstrapped, ready for injecting operations." %
                    string CamlinternalFormatBasics.End_of_format)
                "Node is bootstrapped, ready for injecting operations." % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit))).

src/lib_client_base/client_context.ml 26 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('a, 'b) lwt_format = ('a, Format.formatter, unit, 'b Lwt.t) format4

class type printer =
  object
    method error : ('a, 'b) lwt_format -> 'a

    method warning : ('a, unit) lwt_format -> 'a

    method message : ('a, unit) lwt_format -> 'a

    method answer : ('a, unit) lwt_format -> 'a

    method log : string -> ('a, unit) lwt_format -> 'a
  end

class type prompter =
  object
    method prompt : ('a, string tzresult) lwt_format -> 'a

    method prompt_password : ('a, Bigstring.t tzresult) lwt_format -> 'a
  end

class type io =
  object
    inherit printer

    inherit prompter
  end

class simple_printer log =
  let message x = Format.kasprintf (fun msg -> log "stdout" msg) x in
  object
    method error : type a b. (a, b) lwt_format -> a =
      Format.kasprintf (fun msg -> Lwt.fail (Failure msg))

    method warning : type a. (a, unit) lwt_format -> a =
      Format.kasprintf (fun msg -> log "stderr" msg)

    method message : type a. (a, unit) lwt_format -> a = message

    method answer : type a. (a, unit) lwt_format -> a = message

    method log : type a. string -> (a, unit) lwt_format -> a =
      fun name -> Format.kasprintf (fun msg -> log name msg)
  end

class type wallet =
  object
    method load_passwords : string Lwt_stream.t option

    method read_file : string -> string tzresult Lwt.t

    method with_lock : (unit -> 'a Lwt.t) -> 'a Lwt.t

    method load :
      string -> default:'a -> 'a Data_encoding.encoding -> 'a tzresult Lwt.t

    method write :
      string -> 'a -> 'a Data_encoding.encoding -> unit tzresult Lwt.t
  end

class type chain =
  object
    method chain : Shell_services.chain
  end

class type block =
  object
    method block : Shell_services.block

    method confirmations : int option
  end

class type io_wallet =
  object
    inherit printer

    inherit prompter

    inherit wallet
  end

class type io_rpcs =
  object
    inherit printer

    inherit prompter

    inherit RPC_context.json
  end

class type ui =
  object
    method sleep : float -> unit Lwt.t

    method now : unit -> Ptime.t
  end

class type full =
  object
    inherit printer

    inherit prompter

    inherit wallet

    inherit RPC_context.json

    inherit chain

    inherit block

    inherit ui
  end

class proxy_context (obj : full) =
  object
    method load_passwords = obj#load_passwords

    method read_file = obj#read_file

    method base = obj#base

    method chain = obj#chain

    method block = obj#block

    method confirmations = obj#confirmations

    method answer : type a. (a, unit) lwt_format -> a = obj#answer

    method call_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
          'q -> 'i -> 'o tzresult Lwt.t =
      obj#call_service

    method call_streamed_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
          on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
          (unit -> unit) tzresult Lwt.t =
      obj#call_streamed_service

    method error : type a b. (a, b) lwt_format -> a = obj#error

    method generic_json_call = obj#generic_json_call

    method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t = obj#with_lock

    method load : type a.
        string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
      obj#load

    method log : type a. string -> (a, unit) lwt_format -> a = obj#log

    method message : type a. (a, unit) lwt_format -> a = obj#message

    method warning : type a. (a, unit) lwt_format -> a = obj#warning

    method write : type a.
        string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
      obj#write

    method prompt : type a. (a, string tzresult) lwt_format -> a = obj#prompt

    method prompt_password : type a. (a, Bigstring.t tzresult) lwt_format -> a
        =
      obj#prompt_password

    method sleep : float -> unit Lwt.t = obj#sleep

    method now : unit -> Ptime.t = obj#now
  end

let log _ _ = Lwt.return_unit

let null_printer : #printer = new simple_printer log
src/lib_client_base/client_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition lwt_format (a b : Type) :=
  Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t b).

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class` not handled. *)
class

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class` not handled. *)
class

Definition log {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    Lwt.return_unit.

Definition null_printer {a b : Type}
  : ((((lwt_format a b) -> a) * (a * b)) *
    ((((lwt_format a unit) -> a) * (a)) *
      ((((lwt_format a unit) -> a) * (a)) *
        ((((lwt_format a unit) -> a) * (a)) *
          (((string -> (lwt_format a unit) -> a) * (a)) * nil))))) * nil :=
  (* ❌ Creation of new objects is not handled *)
  new log.

src/lib_client_base/client_keys.ml 113 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Unregistered_key_scheme of string

type error += Invalid_uri of Uri.t

let () =
  register_error_kind
    `Permanent
    ~id:"cli.unregistered_key_scheme"
    ~title:"Unregistered key scheme"
    ~description:
      "A key has been provided with an unregistered scheme (no corresponding \
       plugin)"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "No matching plugin for key scheme %s" s)
    Data_encoding.(obj1 (req "value" string))
    (function Unregistered_key_scheme s -> Some s | _ -> None)
    (fun s -> Unregistered_key_scheme s) ;
  register_error_kind
    `Permanent
    ~id:"cli.key.invalid_uri"
    ~title:"Invalid key uri"
    ~description:"A key has been provided with an invalid uri."
    ~pp:(fun ppf s -> Format.fprintf ppf "Cannot parse the key uri: %s" s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_uri s -> Some (Uri.to_string s) | _ -> None)
    (fun s -> Invalid_uri (Uri.of_string s))

module Public_key_hash = struct
  include Client_aliases.Alias (struct
    type t = Signature.Public_key_hash.t

    let encoding = Signature.Public_key_hash.encoding

    let of_source s = Lwt.return (Signature.Public_key_hash.of_b58check s)

    let to_source p = return (Signature.Public_key_hash.to_b58check p)

    let name = "public key hash"
  end)
end

module Logging = struct
  let tag = Tag.def ~doc:"Identity" "pk_alias" Format.pp_print_text
end

let uri_encoding = Data_encoding.(conv Uri.to_string Uri.of_string string)

type pk_uri = Uri.t

let make_pk_uri (x : Uri.t) : pk_uri =
  match Uri.scheme x with
  | None ->
      Pervasives.failwith "PK_URI needs a scheme"
  | Some _ ->
      x

type sk_uri = Uri.t

let make_sk_uri (x : Uri.t) : sk_uri =
  match Uri.scheme x with
  | None ->
      Pervasives.failwith "SK_URI needs a scheme"
  | Some _ ->
      x

let pk_uri_parameter () =
  Clic.parameter (fun _ s ->
      try return (make_pk_uri @@ Uri.of_string s)
      with Failure s -> failwith "Error while parsing URI: %s" s)

let pk_uri_param ?name ?desc params =
  let name = Option.unopt ~default:"uri" name in
  let desc =
    Option.unopt
      ~default:
        "public key\n\
         Varies from one scheme to the other.\n\
         Use command `list signing schemes` for more information."
      desc
  in
  Clic.param ~name ~desc (pk_uri_parameter ()) params

let sk_uri_parameter () =
  Clic.parameter (fun _ s ->
      try return (make_sk_uri @@ Uri.of_string s)
      with Failure s -> failwith "Error while parsing URI: %s" s)

let sk_uri_param ?name ?desc params =
  let name = Option.unopt ~default:"uri" name in
  let desc =
    Option.unopt
      ~default:
        "secret key\n\
         Varies from one scheme to the other.\n\
         Use command `list signing schemes` for more information."
      desc
  in
  Clic.param ~name ~desc (sk_uri_parameter ()) params

module Secret_key = Client_aliases.Alias (struct
  let name = "secret_key"

  type t = Uri.t

  let of_source s = return (Uri.of_string s)

  let to_source t = return (Uri.to_string t)

  let encoding = uri_encoding
end)

module Public_key = Client_aliases.Alias (struct
  let name = "public_key"

  type t = Uri.t * Signature.Public_key.t option

  let of_source s = return (Uri.of_string s, None)

  let to_source (t, _) = return (Uri.to_string t)

  let encoding =
    let open Data_encoding in
    union
      [ case
          Json_only
          ~title:"Locator_only"
          uri_encoding
          (function (uri, None) -> Some uri | (_, Some _) -> None)
          (fun uri -> (uri, None));
        case
          Json_only
          ~title:"Locator_and_full_key"
          (obj2
             (req "locator" uri_encoding)
             (req "key" Signature.Public_key.encoding))
          (function (uri, Some key) -> Some (uri, key) | (_, None) -> None)
          (fun (uri, key) -> (uri, Some key)) ]
end)

module type SIGNER = sig
  val scheme : string

  val title : string

  val description : string

  val neuterize : sk_uri -> pk_uri tzresult Lwt.t

  val import_secret_key :
    io:Client_context.io_wallet ->
    pk_uri ->
    (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
    Lwt.t

  val public_key : pk_uri -> Signature.Public_key.t tzresult Lwt.t

  val public_key_hash :
    pk_uri ->
    (Signature.Public_key_hash.t * Signature.Public_key.t option) tzresult
    Lwt.t

  val sign :
    ?watermark:Signature.watermark ->
    sk_uri ->
    Bytes.t ->
    Signature.t tzresult Lwt.t

  val deterministic_nonce : sk_uri -> Bytes.t -> Bigstring.t tzresult Lwt.t

  val deterministic_nonce_hash : sk_uri -> Bytes.t -> Bytes.t tzresult Lwt.t

  val supports_deterministic_nonces : sk_uri -> bool tzresult Lwt.t
end

let signers_table : (string, (module SIGNER)) Hashtbl.t = Hashtbl.create 13

let register_signer signer =
  let module Signer = (val signer : SIGNER) in
  Hashtbl.replace signers_table Signer.scheme signer

let find_signer_for_key ~scheme =
  match Hashtbl.find_opt signers_table scheme with
  | None ->
      fail (Unregistered_key_scheme scheme)
  | Some signer ->
      return signer

let registered_signers () : (string * (module SIGNER)) list =
  Hashtbl.fold (fun k v acc -> (k, v) :: acc) signers_table []

type error += Signature_mismatch of sk_uri

let () =
  register_error_kind
    `Permanent
    ~id:"cli.signature_mismatch"
    ~title:"Signature mismatch"
    ~description:"The signer produced an invalid signature"
    ~pp:(fun ppf sk ->
      Format.fprintf
        ppf
        "The signer for %a produced an invalid signature"
        Uri.pp_hum
        sk)
    Data_encoding.(obj1 (req "locator" uri_encoding))
    (function Signature_mismatch sk -> Some sk | _ -> None)
    (fun sk -> Signature_mismatch sk)

let with_scheme_signer (uri : Uri.t) (f : (module SIGNER) -> 'a) : 'a =
  match Uri.scheme uri with
  | None ->
      assert false
  | Some scheme ->
      find_signer_for_key ~scheme >>=? fun signer -> f signer

let neuterize sk_uri =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.neuterize sk_uri)

let public_key pk_uri =
  with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
      Signer.public_key pk_uri)

let public_key_hash pk_uri =
  with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
      Signer.public_key_hash pk_uri)

let import_secret_key ~io pk_uri =
  with_scheme_signer pk_uri (fun (module Signer : SIGNER) ->
      Signer.import_secret_key ~io pk_uri)

let sign cctxt ?watermark sk_uri buf =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.sign ?watermark sk_uri buf
      >>=? fun signature ->
      Signer.neuterize sk_uri
      >>=? fun pk_uri ->
      Secret_key.rev_find cctxt sk_uri
      >>=? (function
             | None ->
                 public_key pk_uri
             | Some name -> (
                 Public_key.find cctxt name
                 >>=? function
                 | (_, None) ->
                     public_key pk_uri
                     >>=? fun pk ->
                     Public_key.update cctxt name (pk_uri, Some pk)
                     >>=? fun () -> return pk
                 | (_, Some pubkey) ->
                     return pubkey ))
      >>=? fun pubkey ->
      fail_unless
        (Signature.check ?watermark pubkey signature buf)
        (Signature_mismatch sk_uri)
      >>=? fun () -> return signature)

let append cctxt ?watermark loc buf =
  sign cctxt ?watermark loc buf
  >>|? fun signature -> Signature.concat buf signature

let check ?watermark pk_uri signature buf =
  public_key pk_uri
  >>=? fun pk -> return (Signature.check ?watermark pk signature buf)

let deterministic_nonce sk_uri data =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.deterministic_nonce sk_uri data)

let deterministic_nonce_hash sk_uri data =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.deterministic_nonce_hash sk_uri data)

let supports_deterministic_nonces sk_uri =
  with_scheme_signer sk_uri (fun (module Signer : SIGNER) ->
      Signer.supports_deterministic_nonces sk_uri)

let register_key cctxt ?(force = false) (public_key_hash, pk_uri, sk_uri)
    ?public_key name =
  Public_key.add ~force cctxt name (pk_uri, public_key)
  >>=? fun () ->
  Secret_key.add ~force cctxt name sk_uri
  >>=? fun () ->
  Public_key_hash.add ~force cctxt name public_key_hash
  >>=? fun () -> return_unit

let raw_get_key (cctxt : #Client_context.wallet) pkh =
  Public_key_hash.rev_find cctxt pkh
  >>=? (function
         | None ->
             failwith "no keys for the source contract manager"
         | Some n ->
             Secret_key.find_opt cctxt n
             >>=? fun sk_uri ->
             Public_key.find_opt cctxt n
             >>=? (function
                    | None ->
                        return_none
                    | Some (_, Some pk) ->
                        return_some pk
                    | Some (pk_uri, None) ->
                        public_key pk_uri
                        >>=? fun pk ->
                        Public_key.update cctxt n (pk_uri, Some pk)
                        >>=? fun () -> return_some pk)
             >>=? fun pk -> return (n, pk, sk_uri))
  >>= function
  | (Ok (_, None, None) | Error _) as initial_result -> (
      (* try to lookup for a remote key *)
      find_signer_for_key ~scheme:"remote"
      >>=? (fun signer ->
             let module Signer = (val signer : SIGNER) in
             let path = Signature.Public_key_hash.to_b58check pkh in
             let uri = Uri.make ~scheme:Signer.scheme ~path () in
             Signer.public_key uri
             >>=? fun pk -> return (path, Some pk, Some uri))
      >>= function
      | Error _ ->
          Lwt.return initial_result
      | Ok _ as success ->
          Lwt.return success )
  | Ok _ as success ->
      Lwt.return success

let get_key cctxt pkh =
  raw_get_key cctxt pkh
  >>=? function
  | (pkh, Some pk, Some sk) ->
      return (pkh, pk, sk)
  | (_pkh, _pk, None) ->
      failwith "Unknown secret key for %a" Signature.Public_key_hash.pp pkh
  | (_pkh, None, _sk) ->
      failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh

let get_public_key cctxt pkh =
  raw_get_key cctxt pkh
  >>=? function
  | (pkh, Some pk, _sk) ->
      return (pkh, pk)
  | (_pkh, None, _sk) ->
      failwith "Unknown public key for %a" Signature.Public_key_hash.pp pkh

let get_keys (cctxt : #Client_context.wallet) =
  Secret_key.load cctxt
  >>=? fun sks ->
  Lwt_list.filter_map_s
    (fun (name, sk_uri) ->
      Public_key_hash.find cctxt name
      >>=? (fun pkh ->
             Public_key.find cctxt name
             >>=? (function
                    | (_, Some pk) ->
                        return pk
                    | (pk_uri, None) ->
                        public_key pk_uri
                        >>=? fun pk ->
                        Public_key.update cctxt name (pk_uri, Some pk)
                        >>=? fun () -> return pk)
             >>=? fun pk -> return (name, pkh, pk, sk_uri))
      >>= function Ok r -> Lwt.return_some r | Error _ -> Lwt.return_none)
    sks
  >>= fun keys -> return keys

let list_keys cctxt =
  Public_key_hash.load cctxt
  >>=? fun l ->
  map_s
    (fun (name, pkh) ->
      raw_get_key cctxt pkh
      >>= function
      | Ok (_name, pk, sk_uri) ->
          return (name, pkh, pk, sk_uri)
      | Error _ ->
          return (name, pkh, None, None))
    l

let alias_keys cctxt name =
  Public_key_hash.find cctxt name
  >>=? fun pkh ->
  raw_get_key cctxt pkh
  >>= function
  | Ok (_name, pk, sk_uri) ->
      return_some (pkh, pk, sk_uri)
  | Error _ ->
      return_none

let force_switch () =
  Clic.switch ~long:"force" ~short:'f' ~doc:"overwrite existing keys" ()
src/lib_client_base/client_keys.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Module Public_key_hash.
  (* ❌ Structure item `include` not handled. *)
  include
End Public_key_hash.

Module Logging.
  Definition tag : Tezos_base__TzPervasives.Tag.def string :=
    Tag.def (Some "Identity" % string) "pk_alias" % string Format.pp_print_text.
End Logging.

Definition uri_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Uri.t :=
  conv Uri.to_string Uri.of_string None string.

Definition pk_uri := Uri.t.

Definition make_pk_uri (x : Uri.t) : pk_uri :=
  match Uri.scheme x with
  | None => Pervasives.failwith "PK_URI needs a scheme" % string
  | Some _ => x
  end.

Definition sk_uri := Uri.t.

Definition make_sk_uri (x : Uri.t) : sk_uri :=
  match Uri.scheme x with
  | None => Pervasives.failwith "SK_URI needs a scheme" % string
  | Some _ => x
  end.

Definition pk_uri_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter pk_uri A :=
  let 'tt := function_parameter in
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        (* ❌ Try-with are not handled *)
        try (_return (apply make_pk_uri (Uri.of_string s)))).

Definition pk_uri_param {A B : Type}
  (name : option string) (desc : option string)
  (params : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params (pk_uri -> A) B :=
  let name := Option.unopt "uri" % string name in
  let desc :=
    Option.unopt
      "public key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
        % string desc in
  Clic.param name desc (pk_uri_parameter tt) params.

Definition sk_uri_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter sk_uri A :=
  let 'tt := function_parameter in
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        (* ❌ Try-with are not handled *)
        try (_return (apply make_sk_uri (Uri.of_string s)))).

Definition sk_uri_param {A B : Type}
  (name : option string) (desc : option string)
  (params : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params (sk_uri -> A) B :=
  let name := Option.unopt "uri" % string name in
  let desc :=
    Option.unopt
      "secret key
Varies from one scheme to the other.
Use command `list signing schemes` for more information."
        % string desc in
  Clic.param name desc (sk_uri_parameter tt) params.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Module SIGNER.
  Record signature := {
    scheme : string;
    title : string;
    description : string;
    neuterize : sk_uri -> Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri);
    import_secret_key : Tezos_client_base.Client_context.io_wallet ->
      pk_uri ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
              (option Tezos_base__TzPervasives.Signature.Public_key.t)));
    public_key : pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Signature.Public_key.t);
    public_key_hash : pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
            (option Tezos_base__TzPervasives.Signature.Public_key.t)));
    sign : (option Tezos_base__TzPervasives.Signature.watermark) ->
      sk_uri ->
        Stdlib.Bytes.t ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Signature.t);
    deterministic_nonce : sk_uri ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t);
    deterministic_nonce_hash : sk_uri ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
    supports_deterministic_nonces : sk_uri ->
      Lwt.t (Tezos_base__TzPervasives.tzresult bool);
  }.
End SIGNER.

Definition signers_table
  : Stdlib.Hashtbl.t string {_ : unit & SIGNER.signature } :=
  Hashtbl.create None 13.

Definition register_signer (signer : {_ : unit & SIGNER.signature }) : unit :=
  let Signer := projT2 signer in
  Hashtbl.replace signers_table Signer.(SIGNER.scheme) signer.

Definition find_signer_for_key (scheme : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult {_ : unit & SIGNER.signature }) :=
  match Hashtbl.find_opt signers_table scheme with
  | None => fail (Tezos_base__TzPervasives.Unregistered_key_scheme scheme)
  | Some signer => _return signer
  end.

Definition registered_signers (function_parameter : unit)
  : list (string * {_ : unit & SIGNER.signature }) :=
  let 'tt := function_parameter in
  Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) signers_table [].

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition with_scheme_signer {A : Type}
  (uri : Uri.t)
  (f :
    {_ : unit & SIGNER.signature } ->
      Lwt.t (Tezos_base__TzPervasives.tzresult A))
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  match Uri.scheme uri with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some scheme =>
    op_gtgteqquestion (find_signer_for_key scheme) (fun signer => f signer)
  end.

Definition neuterize (sk_uri : sk_uri)
  : Lwt.t (Tezos_base__TzPervasives.tzresult pk_uri) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.neuterize) sk_uri).

Definition public_key (pk_uri : pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Public_key.t) :=
  with_scheme_signer pk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.public_key) pk_uri).

Definition public_key_hash (pk_uri : pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  with_scheme_signer pk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.public_key_hash) pk_uri).

Definition import_secret_key
  (io : Tezos_client_base.Client_context.io_wallet) (pk_uri : pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  with_scheme_signer pk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.import_secret_key) io pk_uri).

Definition sign {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (sk_uri : sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      op_gtgteqquestion (Signer.(SIGNER.sign) watermark sk_uri buf)
        (fun signature =>
          op_gtgteqquestion (Signer.(SIGNER.neuterize) sk_uri)
            (fun pk_uri =>
              op_gtgteqquestion
                (op_gtgteqquestion (Secret_key.rev_find cctxt sk_uri)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => public_key pk_uri
                    | Some name =>
                      op_gtgteqquestion (Public_key.find cctxt name)
                        (fun function_parameter =>
                          match function_parameter with
                          | (_, None) =>
                            op_gtgteqquestion (public_key pk_uri)
                              (fun pk =>
                                op_gtgteqquestion
                                  (Public_key.update cctxt name
                                    (pk_uri, (Some pk)))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    _return pk))
                          | (_, Some pubkey) => _return pubkey
                          end)
                    end))
                (fun pubkey =>
                  op_gtgteqquestion
                    (fail_unless
                      (Signature.check watermark pubkey signature buf)
                      (Tezos_base__TzPervasives.Signature_mismatch sk_uri))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return signature))))).

Definition append {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (loc : sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  op_gtgtpipequestion (sign cctxt watermark loc buf)
    (fun signature => Signature.concat buf signature).

Definition check
  (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (pk_uri : pk_uri) (signature : Tezos_base__TzPervasives.Signature.t)
  (buf : Stdlib.Bytes.t) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  op_gtgteqquestion (public_key pk_uri)
    (fun pk => _return (Signature.check watermark pk signature buf)).

Definition deterministic_nonce (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.deterministic_nonce) sk_uri data).

Definition deterministic_nonce_hash (sk_uri : sk_uri) (data : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.deterministic_nonce_hash) sk_uri data).

Definition supports_deterministic_nonces (sk_uri : sk_uri)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  with_scheme_signer sk_uri
    (fun Signer =>
      let Signer := projT2 Signer in
      Signer.(SIGNER.supports_deterministic_nonces) sk_uri).

Definition register_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (op_staroptstar : option bool)
  : (Public_key_hash.t * Uri.t * Secret_key.t) ->
    (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
      string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let force :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun function_parameter =>
    let '(public_key_hash, pk_uri, sk_uri) := function_parameter in
    fun public_key =>
      fun name =>
        op_gtgteqquestion (Public_key.add force cctxt name (pk_uri, public_key))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (Secret_key.add force cctxt name sk_uri)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (Public_key_hash.add force cctxt name public_key_hash)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit))).

Definition raw_get_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Public_key_hash.t)
  : Lwt.t
    (sum
      (string * (option Tezos_base__TzPervasives.Signature.Public_key.t) *
        (option Secret_key.t)) Tezos_base__TzPervasives.trace) :=
  op_gtgteq
    (op_gtgteqquestion (Public_key_hash.rev_find cctxt pkh)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "no keys for the source contract manager" % string
                CamlinternalFormatBasics.End_of_format)
              "no keys for the source contract manager" % string)
        | Some n =>
          op_gtgteqquestion (Secret_key.find_opt cctxt n)
            (fun sk_uri =>
              op_gtgteqquestion
                (op_gtgteqquestion (Public_key.find_opt cctxt n)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => return_none
                    | Some (_, Some pk) => return_some pk
                    | Some (pk_uri, None) =>
                      op_gtgteqquestion (public_key pk_uri)
                        (fun pk =>
                          op_gtgteqquestion
                            (Public_key.update cctxt n (pk_uri, (Some pk)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_some pk))
                    end)) (fun pk => _return (n, pk, sk_uri)))
        end))
    (fun function_parameter =>
      match function_parameter with
      | (Stdlib.Ok (_, None, None) | Stdlib.Error _) as initial_result =>
        op_gtgteq
          (op_gtgteqquestion (find_signer_for_key "remote" % string)
            (fun signer =>
              let Signer := projT2 signer in
              let path := Signature.Public_key_hash.to_b58check pkh in
              let uri :=
                Uri.make (Some Signer.(SIGNER.scheme)) None None None
                  (Some path) None None tt in
              op_gtgteqquestion (Signer.(SIGNER.public_key) uri)
                (fun pk => _return (path, (Some pk), (Some uri)))))
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error _ => Lwt._return initial_result
            | (Stdlib.Ok _) as success => Lwt._return success
            end)
      | (Stdlib.Ok _) as success => Lwt._return success
      end).

Definition get_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (string * Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t)) :=
  op_gtgteqquestion (raw_get_key cctxt pkh)
    (fun function_parameter =>
      match function_parameter with
      | (pkh, Some pk, Some sk) => _return (pkh, pk, sk)
      | (_pkh, _pk, None) =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown secret key for " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unknown secret key for %a" % string) Signature.Public_key_hash.pp
          pkh
      | (_pkh, None, _sk) =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown public key for " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unknown public key for %a" % string) Signature.Public_key_hash.pp
          pkh
      end).

Definition get_public_key {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (pkh : Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (string * Tezos_base__TzPervasives.Signature.Public_key.t)) :=
  op_gtgteqquestion (raw_get_key cctxt pkh)
    (fun function_parameter =>
      match function_parameter with
      | (pkh, Some pk, _sk) => _return (pkh, pk)
      | (_pkh, None, _sk) =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown public key for " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unknown public key for %a" % string) Signature.Public_key_hash.pp
          pkh
      end).

Definition get_keys {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (string * Public_key_hash.t *
          Tezos_base__TzPervasives.Signature.Public_key.t * Secret_key.t))) :=
  op_gtgteqquestion (Secret_key.load cctxt)
    (fun sks =>
      op_gtgteq
        (Lwt_list.filter_map_s
          (fun function_parameter =>
            let '(name, sk_uri) := function_parameter in
            op_gtgteq
              (op_gtgteqquestion (Public_key_hash.find cctxt name)
                (fun pkh =>
                  op_gtgteqquestion
                    (op_gtgteqquestion (Public_key.find cctxt name)
                      (fun function_parameter =>
                        match function_parameter with
                        | (_, Some pk) => _return pk
                        | (pk_uri, None) =>
                          op_gtgteqquestion (public_key pk_uri)
                            (fun pk =>
                              op_gtgteqquestion
                                (Public_key.update cctxt name
                                  (pk_uri, (Some pk)))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  _return pk))
                        end)) (fun pk => _return (name, pkh, pk, sk_uri))))
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok r => Lwt.return_some r
                | Stdlib.Error _ => Lwt.return_none
                end)) sks) (fun keys => _return keys)).

Definition list_keys {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (string * Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t) *
          (option Secret_key.t)))) :=
  op_gtgteqquestion (Public_key_hash.load cctxt)
    (fun l =>
      map_s
        (fun function_parameter =>
          let '(name, pkh) := function_parameter in
          op_gtgteq (raw_get_key cctxt pkh)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok (_name, pk, sk_uri) => _return (name, pkh, pk, sk_uri)
              | Stdlib.Error _ => _return (name, pkh, None, None)
              end)) l).

Definition alias_keys {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (name : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t) *
          (option Secret_key.t)))) :=
  op_gtgteqquestion (Public_key_hash.find cctxt name)
    (fun pkh =>
      op_gtgteq (raw_get_key cctxt pkh)
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok (_name, pk, sk_uri) => return_some (pkh, pk, sk_uri)
          | Stdlib.Error _ => return_none
          end)).

Definition force_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  let 'tt := function_parameter in
  Clic.switch "overwrite existing keys" % string (Some "f" % char)
    "force" % string tt.

src/lib_client_base_unix/client_config.ml 323 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Configuration and Arguments Parsing *)

type error += Invalid_chain_argument of string

type error += Invalid_block_argument of string

type error += Invalid_protocol_argument of string

type error += Invalid_port_arg of string

type error += Invalid_remote_signer_argument of string

type error += Invalid_wait_arg of string

let () =
  register_error_kind
    `Branch
    ~id:"badChainArgument"
    ~title:"Bad Chain Argument"
    ~description:"Chain argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Value %s is not a value chain reference." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_chain_argument s -> Some s | _ -> None)
    (fun s -> Invalid_chain_argument s) ;
  register_error_kind
    `Branch
    ~id:"badBlockArgument"
    ~title:"Bad Block Argument"
    ~description:"Block argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Value %s is not a value block reference." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_block_argument s -> Some s | _ -> None)
    (fun s -> Invalid_block_argument s) ;
  register_error_kind
    `Branch
    ~id:"badProtocolArgument"
    ~title:"Bad Protocol Argument"
    ~description:"Protocol argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Value %s does not correspond to any known protocol."
        s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_protocol_argument s -> Some s | _ -> None)
    (fun s -> Invalid_protocol_argument s) ;
  register_error_kind
    `Branch
    ~id:"invalidPortArgument"
    ~title:"Bad Port Argument"
    ~description:"Port argument could not be parsed"
    ~pp:(fun ppf s -> Format.fprintf ppf "Value %s is not a valid TCP port." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_port_arg s -> Some s | _ -> None)
    (fun s -> Invalid_port_arg s) ;
  register_error_kind
    `Branch
    ~id:"invalid_remote_signer_argument"
    ~title:"Unexpected URI of remote signer"
    ~description:"The remote signer argument could not be parsed"
    ~pp:(fun ppf s -> Format.fprintf ppf "Value '%s' is not a valid URI." s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_remote_signer_argument s -> Some s | _ -> None)
    (fun s -> Invalid_remote_signer_argument s) ;
  register_error_kind
    `Branch
    ~id:"invalidWaitArgument"
    ~title:"Bad Wait Argument"
    ~description:"Wait argument could not be parsed"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Value %s is not a valid number of confirmation, nor 'none'."
        s)
    Data_encoding.(obj1 (req "value" string))
    (function Invalid_wait_arg s -> Some s | _ -> None)
    (fun s -> Invalid_wait_arg s)

let home = try Sys.getenv "HOME" with Not_found -> "/root"

let default_base_dir = Filename.concat home ".tezos-client"

let default_chain = `Main

let default_block = `Head 0

let ( // ) = Filename.concat

module Cfg_file = struct
  type t = {
    base_dir : string;
    node_addr : string;
    node_port : int;
    tls : bool;
    web_port : int;
    remote_signer : Uri.t option;
    confirmations : int option;
    password_filename : string option;
  }

  let default =
    {
      base_dir = default_base_dir;
      node_addr = "localhost";
      node_port = 8732;
      tls = false;
      web_port = 8080;
      remote_signer = None;
      confirmations = Some 0;
      password_filename = None;
    }

  open Data_encoding

  let encoding =
    conv
      (fun { base_dir;
             node_addr;
             node_port;
             tls;
             web_port;
             remote_signer;
             confirmations;
             password_filename } ->
        ( base_dir,
          Some node_addr,
          Some node_port,
          Some tls,
          Some web_port,
          remote_signer,
          confirmations,
          password_filename ))
      (fun ( base_dir,
             node_addr,
             node_port,
             tls,
             web_port,
             remote_signer,
             confirmations,
             password_filename ) ->
        let node_addr = Option.unopt ~default:default.node_addr node_addr in
        let node_port = Option.unopt ~default:default.node_port node_port in
        let tls = Option.unopt ~default:default.tls tls in
        let web_port = Option.unopt ~default:default.web_port web_port in
        {
          base_dir;
          node_addr;
          node_port;
          tls;
          web_port;
          remote_signer;
          confirmations;
          password_filename;
        })
      (obj8
         (req "base_dir" string)
         (opt "node_addr" string)
         (opt "node_port" int16)
         (opt "tls" bool)
         (opt "web_port" int16)
         (opt "remote_signer" RPC_encoding.uri_encoding)
         (opt "confirmations" int8)
         (opt "password_filename" string))

  let from_json json = Data_encoding.Json.destruct encoding json

  let read fp =
    Lwt_utils_unix.Json.read_file fp >>=? fun json -> return (from_json json)

  let write out cfg =
    Lwt_utils_unix.Json.write_file
      out
      (Data_encoding.Json.construct encoding cfg)
end

type cli_args = {
  chain : Chain_services.chain;
  block : Shell_services.block;
  confirmations : int option;
  password_filename : string option;
  protocol : Protocol_hash.t option;
  print_timings : bool;
  log_requests : bool;
}

let default_cli_args =
  {
    chain = default_chain;
    block = default_block;
    confirmations = Some 0;
    password_filename = None;
    protocol = None;
    print_timings = false;
    log_requests = false;
  }

open Clic

let string_parameter () : (string, #Client_context.full) parameter =
  parameter (fun _ x -> return x)

let chain_parameter () =
  parameter (fun _ chain ->
      match Chain_services.parse_chain chain with
      | Error _ ->
          fail (Invalid_chain_argument chain)
      | Ok chain ->
          return chain)

let block_parameter () =
  parameter (fun _ block ->
      match Block_services.parse_block block with
      | Error _ ->
          fail (Invalid_block_argument block)
      | Ok block ->
          return block)

let wait_parameter () =
  parameter (fun _ wait ->
      match wait with
      | "no" | "none" ->
          return_none
      | _ -> (
        try
          let w = int_of_string wait in
          if 0 <= w then return_some w else fail (Invalid_wait_arg wait)
        with _ -> fail (Invalid_wait_arg wait) ))

let protocol_parameter () =
  parameter (fun _ arg ->
      try
        let (hash, _commands) =
          List.find
            (fun (hash, _commands) ->
              String.has_prefix ~prefix:arg (Protocol_hash.to_b58check hash))
            (Client_commands.get_versions ())
        in
        return_some hash
      with Not_found -> fail (Invalid_protocol_argument arg))

(* Command-line only args (not in config file) *)
let base_dir_arg () =
  arg
    ~long:"base-dir"
    ~short:'d'
    ~placeholder:"path"
    ~doc:
      ( "client data directory\n\
         The directory where the Tezos client will store all its data.\n\
         By default: '" ^ default_base_dir ^ "'." )
    (string_parameter ())

let config_file_arg () =
  arg
    ~long:"config-file"
    ~short:'c'
    ~placeholder:"path"
    ~doc:"configuration file"
    (string_parameter ())

let timings_switch () =
  switch ~long:"timings" ~short:'t' ~doc:"show RPC request times" ()

let chain_arg () =
  default_arg
    ~long:"chain"
    ~placeholder:"hash|tag"
    ~doc:
      "chain on which to apply contextual commands (possible tags are 'main' \
       and 'test')"
    ~default:(Chain_services.to_string default_cli_args.chain)
    (chain_parameter ())

let block_arg () =
  default_arg
    ~long:"block"
    ~short:'b'
    ~placeholder:"hash|tag"
    ~doc:
      "block on which to apply contextual commands (possible tags are 'head' \
       and 'genesis')"
    ~default:(Block_services.to_string default_cli_args.block)
    (block_parameter ())

let wait_arg () =
  arg
    ~long:"wait"
    ~short:'w'
    ~placeholder:"none|<int>"
    ~doc:
      "how many confirmation blocks before to consider an operation as included"
    (wait_parameter ())

let protocol_arg () =
  arg
    ~long:"protocol"
    ~short:'p'
    ~placeholder:"hash"
    ~doc:"use commands of a specific protocol"
    (protocol_parameter ())

let log_requests_switch () =
  switch ~long:"log-requests" ~short:'l' ~doc:"log all requests to the node" ()

(* Command-line args which can be set in config file as well *)
let addr_arg () =
  arg
    ~long:"addr"
    ~short:'A'
    ~placeholder:"IP addr|host"
    ~doc:"IP address of the node"
    (string_parameter ())

let port_arg () =
  arg
    ~long:"port"
    ~short:'P'
    ~placeholder:"number"
    ~doc:"RPC port of the node"
    (parameter (fun _ x ->
         try return (int_of_string x)
         with Failure _ -> fail (Invalid_port_arg x)))

let tls_switch () =
  switch ~long:"tls" ~short:'S' ~doc:"use TLS to connect to node." ()

let remote_signer_arg () =
  arg
    ~long:"remote-signer"
    ~short:'R'
    ~placeholder:"uri"
    ~doc:"URI of the remote signer"
    (parameter (fun _ x -> Tezos_signer_backends_unix.Remote.parse_base_uri x))

let password_filename_arg () =
  arg
    ~long:"password-filename"
    ~short:'f'
    ~placeholder:"filename"
    ~doc:"path to the password filename"
    (string_parameter ())

let read_config_file config_file =
  Lwt_utils_unix.Json.read_file config_file
  >>=? fun cfg_json ->
  try return @@ Cfg_file.from_json cfg_json
  with exn ->
    failwith
      "Can't parse the configuration file: %s@,%a"
      config_file
      (fun ppf exn -> Json_encoding.print_error ppf exn)
      exn

let default_config_file_name = "config"

let commands config_file cfg =
  let open Clic in
  let group =
    {
      Clic.name = "config";
      title = "Commands for editing and viewing the client's config file";
    }
  in
  [ command
      ~group
      ~desc:"Show the config file."
      no_options
      (fixed ["config"; "show"])
      (fun () (cctxt : #Client_context.full) ->
        let pp_cfg ppf cfg =
          Format.fprintf
            ppf
            "%a"
            Data_encoding.Json.pp
            (Data_encoding.Json.construct Cfg_file.encoding cfg)
        in
        if not @@ Sys.file_exists config_file then
          cctxt#warning
            "@[<v 2>Warning: no config file at %s,@,\
             displaying the default configuration.@]"
            config_file
          >>= fun () -> cctxt#warning "%a@," pp_cfg Cfg_file.default >>= return
        else
          read_config_file config_file
          >>=? fun cfg -> cctxt#message "%a@," pp_cfg cfg >>= return);
    command
      ~group
      ~desc:"Reset the config file to the factory defaults."
      no_options
      (fixed ["config"; "reset"])
      (fun () _cctxt -> Cfg_file.(write config_file default));
    command
      ~group
      ~desc:
        "Update the config based on the current cli values.\n\
         Loads the current configuration (default or as specified with \
         `-config-file`), applies alterations from other command line \
         arguments (such as the node's address, etc.), and overwrites the \
         updated configuration file."
      no_options
      (fixed ["config"; "update"])
      (fun () _cctxt -> Cfg_file.(write config_file cfg));
    command
      ~group
      ~desc:
        "Create a config file based on the current CLI values.\n\
         If the `-file` option is not passed, this will initialize the \
         default config file, based on default parameters, altered by other \
         command line options (such as the node's address, etc.).\n\
         Otherwise, it will create a new config file, based on the default \
         parameters (or the the ones specified with `-config-file`), altered \
         by other command line options.\n\
         The command will always fail if the file already exists."
      (args1
         (default_arg
            ~long:"output"
            ~short:'o'
            ~placeholder:"path"
            ~doc:"path at which to create the file"
            ~default:(cfg.base_dir // default_config_file_name)
            (parameter (fun _ctx str -> return str))))
      (fixed ["config"; "init"])
      (fun config_file _cctxt ->
        if not (Sys.file_exists config_file) then
          Cfg_file.(write config_file cfg)
          (* Should be default or command would have failed *)
        else failwith "Config file already exists at location") ]

let global_options () =
  args13
    (base_dir_arg ())
    (config_file_arg ())
    (timings_switch ())
    (chain_arg ())
    (block_arg ())
    (wait_arg ())
    (protocol_arg ())
    (log_requests_switch ())
    (addr_arg ())
    (port_arg ())
    (tls_switch ())
    (remote_signer_arg ())
    (password_filename_arg ())

type parsed_config_args = {
  parsed_config_file : Cfg_file.t option;
  parsed_args : cli_args option;
  config_commands : Client_context.full command list;
  base_dir : string option;
  require_auth : bool;
  password_filename : string option;
}

let default_parsed_config_args =
  {
    parsed_config_file = None;
    parsed_args = None;
    config_commands = [];
    base_dir = None;
    require_auth = false;
    password_filename = None;
  }

let parse_config_args (ctx : #Client_context.full) argv =
  parse_global_options (global_options ()) ctx argv
  >>=? fun ( ( base_dir,
               config_file,
               timings,
               chain,
               block,
               confirmations,
               protocol,
               log_requests,
               node_addr,
               node_port,
               tls,
               remote_signer,
               password_filename ),
             remaining ) ->
  ( match base_dir with
  | None ->
      let base_dir = default_base_dir in
      unless (Sys.file_exists base_dir) (fun () ->
          Lwt_utils_unix.create_dir base_dir >>= return)
      >>=? fun () -> return base_dir
  | Some dir ->
      if not (Sys.file_exists dir) then
        failwith
          "Specified -base-dir does not exist. Please create the directory \
           and try again."
      else if Sys.is_directory dir then return dir
      else failwith "Specified -base-dir must be a directory" )
  >>=? fun base_dir ->
  ( match config_file with
  | None ->
      return @@ (base_dir // default_config_file_name)
  | Some config_file ->
      if Sys.file_exists config_file then return config_file
      else
        failwith
          "Config file specified in option does not exist. Use `client config \
           init` to create one." )
  >>=? fun config_file ->
  let config_dir = Filename.dirname config_file in
  let protocol = match protocol with None -> None | Some p -> p in
  ( if not (Sys.file_exists config_file) then
    return {Cfg_file.default with base_dir}
  else read_config_file config_file )
  >>=? fun cfg ->
  let tls = cfg.tls || tls in
  let node_addr = Option.unopt ~default:cfg.node_addr node_addr in
  let node_port = Option.unopt ~default:cfg.node_port node_port in
  Tezos_signer_backends_unix.Remote.read_base_uri_from_env ()
  >>=? fun remote_signer_env ->
  let remote_signer =
    Option.first_some
      remote_signer
      (Option.first_some remote_signer_env cfg.remote_signer)
  in
  let confirmations = Option.unopt ~default:cfg.confirmations confirmations in
  let cfg =
    {
      cfg with
      tls;
      node_port;
      node_addr;
      remote_signer;
      confirmations;
      password_filename;
    }
  in
  if Sys.file_exists base_dir && not (Sys.is_directory base_dir) then (
    Format.eprintf "%s is not a directory.@." base_dir ;
    exit 1 ) ;
  if Sys.file_exists config_dir && not (Sys.is_directory config_dir) then (
    Format.eprintf "%s is not a directory.@." config_dir ;
    exit 1 ) ;
  Lwt_utils_unix.create_dir config_dir
  >>= fun () ->
  return
    ( {
        default_parsed_config_args with
        parsed_config_file = Some cfg;
        parsed_args =
          Some
            {
              chain;
              block;
              confirmations;
              print_timings = timings;
              log_requests;
              password_filename;
              protocol;
            };
        config_commands = commands config_file cfg;
      },
      remaining )

type t =
  string option
  * string option
  * bool
  * Shell_services.chain
  * Shell_services.block
  * int option option
  * Protocol_hash.t option option
  * bool
  * string option
  * int option
  * bool
  * Uri.t option
  * string option

module type Remote_params = sig
  val authenticate :
    Signature.public_key_hash list -> Bytes.t -> Signature.t tzresult Lwt.t

  val logger : RPC_client_unix.logger
end

let other_registrations : (_ -> (module Remote_params) -> _) option =
  Some
    (fun parsed_config_file (module Remote_params) ->
      Option.iter parsed_config_file.Cfg_file.remote_signer ~f:(fun signer ->
          Client_keys.register_signer
            ( module Tezos_signer_backends_unix.Remote.Make
                       (RPC_client_unix)
                       (struct
                         let default = signer

                         include Remote_params
                       end) )))

let clic_commands ~base_dir:_ ~config_commands ~builtin_commands
    ~other_commands ~require_auth:_ =
  config_commands @ builtin_commands @ other_commands

let logger = None
src/lib_client_base_unix/client_config.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition home : string :=
  (* ❌ Try-with are not handled *)
  try (Sys.getenv "HOME" % string).

Definition default_base_dir : string :=
  Filename.concat home ".tezos-client" % string.

Definition default_chain : variant :=
  (* ❌ Variants not supported *)
  variant.

Definition default_block : variant :=
  (* ❌ Variants not supported *)
  variant.

Definition op_divdiv : string -> string -> string := Filename.concat.

Module Cfg_file.
  Record t := {
    base_dir : string;
    node_addr : string;
    node_port : Z;
    tls : bool;
    web_port : Z;
    remote_signer : option Uri.t;
    confirmations : option Z;
    password_filename : option string }.
  
  Definition default : t :=
    {| base_dir := default_base_dir; node_addr := "localhost" % string;
      node_port := 8732; tls := false; web_port := 8080; remote_signer := None;
      confirmations := Some 0; password_filename := None |}.
  
  Import Data_encoding.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    conv
      (fun function_parameter =>
        let '{|
          base_dir := base_dir;
            node_addr := node_addr;
            node_port := node_port;
            tls := tls;
            web_port := web_port;
            remote_signer := remote_signer;
            confirmations := confirmations;
            password_filename := password_filename
            |} := function_parameter in
        (base_dir, (Some node_addr), (Some node_port), (Some tls),
          (Some web_port), remote_signer, confirmations, password_filename))
      (fun function_parameter =>
        let
          '(base_dir, node_addr, node_port, tls, web_port, remote_signer,
            confirmations, password_filename) := function_parameter in
        let node_addr := Option.unopt (node_addr default) node_addr in
        let node_port := Option.unopt (node_port default) node_port in
        let tls := Option.unopt (tls default) tls in
        let web_port := Option.unopt (web_port default) web_port in
        {| base_dir := base_dir; node_addr := node_addr; node_port := node_port;
          tls := tls; web_port := web_port; remote_signer := remote_signer;
          confirmations := confirmations; password_filename := password_filename
          |}) None
      (obj8 (req None None "base_dir" % string string)
        (opt None None "node_addr" % string string)
        (opt None None "node_port" % string int16)
        (opt None None "tls" % string bool)
        (opt None None "web_port" % string int16)
        (opt None None "remote_signer" % string RPC_encoding.uri_encoding)
        (opt None None "confirmations" % string int8)
        (opt None None "password_filename" % string string)).
  
  Definition from_json (json : Tezos_base__TzPervasives.Data_encoding.Json.json)
    : t := Data_encoding.Json.destruct encoding json.
  
  Definition read (fp : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    op_gtgteqquestion (Lwt_utils_unix.Json.read_file fp)
      (fun json => _return (from_json json)).
  
  Definition write (out : string) (cfg : t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Lwt_utils_unix.Json.write_file out
      (Data_encoding.Json.construct encoding cfg).
End Cfg_file.

Record cli_args := {
  chain : Tezos_shell_services.Chain_services.chain;
  block : Tezos_shell_services.Shell_services.block;
  confirmations : option Z;
  password_filename : option string;
  protocol : option Tezos_base__TzPervasives.Protocol_hash.t;
  print_timings : bool;
  log_requests : bool }.

Definition default_cli_args : cli_args :=
  {| chain := default_chain; block := default_block; confirmations := Some 0;
    password_filename := None; protocol := None; print_timings := false;
    log_requests := false |}.

Import Clic.

Definition string_parameter {F G I a b i o p q : Type}
  (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter string
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  let 'tt := function_parameter in
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun x => _return x).

Definition chain_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_shell_services.Chain_services.chain A :=
  let 'tt := function_parameter in
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun chain =>
        match Chain_services.parse_chain chain with
        | Stdlib.Error _ =>
          fail (Tezos_base__TzPervasives.Invalid_chain_argument chain)
        | Stdlib.Ok chain => _return chain
        end).

Definition block_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_shell_services.Block_services.block A :=
  let 'tt := function_parameter in
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun block =>
        match Block_services.parse_block block with
        | Stdlib.Error _ =>
          fail (Tezos_base__TzPervasives.Invalid_block_argument block)
        | Stdlib.Ok block => _return block
        end).

Definition wait_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter (option Z) A :=
  let 'tt := function_parameter in
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun wait =>
        match wait with
        | "no" % string | "none" % string => return_none
        | _ =>
          (* ❌ Try-with are not handled *)
          try
            (let w := OCaml.Stdlib.int_of_string wait in
            if OCaml.Stdlib.le 0 w then
              return_some w
            else
              fail (Tezos_base__TzPervasives.Invalid_wait_arg wait))
        end).

Definition protocol_parameter {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    (option Tezos_base__TzPervasives.Protocol_hash.t) A :=
  let 'tt := function_parameter in
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun arg =>
        (* ❌ Try-with are not handled *)
        try
          (let '(hash, _commands) :=
            List.find
              (fun function_parameter =>
                let '(hash, _commands) := function_parameter in
                String.has_prefix arg (Protocol_hash.to_b58check hash))
              (Client_commands.get_versions tt) in
          return_some hash)).

Definition base_dir_arg {F G I a b i o p q : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  let 'tt := function_parameter in
  arg
    (String.append
      "client data directory
The directory where the Tezos client will store all its data.
By default: '"
        % string (String.append default_base_dir "'." % string))
    (Some "d" % char) "base-dir" % string "path" % string (string_parameter tt).

Definition config_file_arg {F G I a b i o p q : Type}
  (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  let 'tt := function_parameter in
  arg "configuration file" % string (Some "c" % char) "config-file" % string
    "path" % string (string_parameter tt).

Definition timings_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  let 'tt := function_parameter in
  switch "show RPC request times" % string (Some "t" % char) "timings" % string
    tt.

Definition chain_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Chain_services.chain
    A :=
  let 'tt := function_parameter in
  default_arg
    "chain on which to apply contextual commands (possible tags are 'main' and 'test')"
      % string None "chain" % string "hash|tag" % string
    (Chain_services.to_string (chain default_cli_args)) (chain_parameter tt).

Definition block_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg Tezos_shell_services.Block_services.block
    A :=
  let 'tt := function_parameter in
  default_arg
    "block on which to apply contextual commands (possible tags are 'head' and 'genesis')"
      % string (Some "b" % char) "block" % string "hash|tag" % string
    (Block_services.to_string (block default_cli_args)) (block_parameter tt).

Definition wait_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option (option Z)) A :=
  let 'tt := function_parameter in
  arg
    "how many confirmation blocks before to consider an operation as included" %
      string (Some "w" % char) "wait" % string "none|<int>" % string
    (wait_parameter tt).

Definition protocol_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg
    (option (option Tezos_base__TzPervasives.Protocol_hash.t)) A :=
  let 'tt := function_parameter in
  arg "use commands of a specific protocol" % string (Some "p" % char)
    "protocol" % string "hash" % string (protocol_parameter tt).

Definition log_requests_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  let 'tt := function_parameter in
  switch "log all requests to the node" % string (Some "l" % char)
    "log-requests" % string tt.

Definition addr_arg {F G I a b i o p q : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  let 'tt := function_parameter in
  arg "IP address of the node" % string (Some "A" % char) "addr" % string
    "IP addr|host" % string (string_parameter tt).

Definition port_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option Z) A :=
  let 'tt := function_parameter in
  arg "RPC port of the node" % string (Some "P" % char) "port" % string
    "number" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun x =>
          (* ❌ Try-with are not handled *)
          try (_return (OCaml.Stdlib.int_of_string x)))).

Definition tls_switch {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  let 'tt := function_parameter in
  switch "use TLS to connect to node." % string (Some "S" % char) "tls" % string
    tt.

Definition remote_signer_arg {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option Uri.t) A :=
  let 'tt := function_parameter in
  arg "URI of the remote signer" % string (Some "R" % char)
    "remote-signer" % string "uri" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun x => Tezos_signer_backends_unix.Remote.parse_base_uri x)).

Definition password_filename_arg {F G I a b i o p q : Type}
  (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.arg (option string)
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  let 'tt := function_parameter in
  arg "path to the password filename" % string (Some "f" % char)
    "password-filename" % string "filename" % string (string_parameter tt).

Definition read_config_file (config_file : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Cfg_file.t) :=
  op_gtgteqquestion (Lwt_utils_unix.Json.read_file config_file)
    (fun cfg_json =>
      (* ❌ Try-with are not handled *)
      try (apply _return (Cfg_file.from_json cfg_json))).

Definition default_config_file_name : string := "config" % string.

Definition commands {F G I a b i o p q : Type}
  (config_file : string) (cfg : Cfg_file.t)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let group :=
    {| Clic.name := "config" % string;
      Clic.title :=
        "Commands for editing and viewing the client's config file" % string |}
    in
  cons
    (command (Some group) "Show the config file." % string no_options
      (fixed (cons "config" % string (cons "show" % string [])))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          let pp_cfg (ppf : Stdlib.Format.formatter) (cfg : Cfg_file.t)
            : unit :=
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              Data_encoding.Json.pp
              (Data_encoding.Json.construct Cfg_file.encoding cfg) in
          if apply negb (Sys.file_exists config_file) then
            op_gtgteq
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Warning: no config file at " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "," % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "displaying the default configuration." % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))
                  "@[<v 2>Warning: no config file at %s,@,displaying the default configuration.@]"
                    % string) config_file)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          CamlinternalFormatBasics.End_of_format))
                      "%a@," % string) pp_cfg Cfg_file.default) _return)
          else
            op_gtgteqquestion (read_config_file config_file)
              (fun cfg =>
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          CamlinternalFormatBasics.End_of_format))
                      "%a@," % string) pp_cfg cfg) _return)))
    (cons
      (command (Some group)
        "Reset the config file to the factory defaults." % string no_options
        (fixed (cons "config" % string (cons "reset" % string [])))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun _cctxt => write config_file default))
      (cons
        (command (Some group)
          "Update the config based on the current cli values.
Loads the current configuration (default or as specified with `-config-file`), applies alterations from other command line arguments (such as the node's address, etc.), and overwrites the updated configuration file."
            % string no_options
          (fixed (cons "config" % string (cons "update" % string [])))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun _cctxt => write config_file cfg))
        (cons
          (command (Some group)
            "Create a config file based on the current CLI values.
If the `-file` option is not passed, this will initialize the default config file, based on default parameters, altered by other command line options (such as the node's address, etc.).
Otherwise, it will create a new config file, based on the default parameters (or the the ones specified with `-config-file`), altered by other command line options.
The command will always fail if the file already exists."
              % string
            (args1
              (default_arg "path at which to create the file" % string
                (Some "o" % char) "output" % string "path" % string
                (op_divdiv (base_dir cfg) default_config_file_name)
                (parameter None (fun _ctx => fun str => _return str))))
            (fixed (cons "config" % string (cons "init" % string [])))
            (fun config_file =>
              fun _cctxt =>
                if negb (Sys.file_exists config_file) then
                  write config_file cfg
                else
                  failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Config file already exists at location" % string
                        CamlinternalFormatBasics.End_of_format)
                      "Config file already exists at location" % string))) []))).

Definition global_options {F G I a b i o p q : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.options
    ((option string) * (option string) * bool *
      Tezos_shell_services.Chain_services.chain *
      Tezos_shell_services.Block_services.block * (option (option Z)) *
      (option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
      (option string) * (option Z) * bool * (option Uri.t) * (option string))
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  let 'tt := function_parameter in
  args13 (base_dir_arg tt) (config_file_arg tt) (timings_switch tt)
    (chain_arg tt) (block_arg tt) (wait_arg tt) (protocol_arg tt)
    (log_requests_switch tt) (addr_arg tt) (port_arg tt) (tls_switch tt)
    (remote_signer_arg tt) (password_filename_arg tt).

Record parsed_config_args := {
  parsed_config_file : option Cfg_file.t;
  parsed_args : option cli_args;
  config_commands :
    list
      (Tezos_base__TzPervasives.Clic.command
        Tezos_client_base.Client_context.full);
  base_dir : option string;
  require_auth : bool;
  password_filename : option string }.

Definition default_parsed_config_args : parsed_config_args :=
  {| parsed_config_file := None; parsed_args := None; config_commands := [];
    base_dir := None; require_auth := false; password_filename := None |}.

Definition parse_config_args {F G I a b i o p q : Type}
  (ctx :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (argv : list string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (parsed_config_args * (list string))) :=
  op_gtgteqquestion (parse_global_options (global_options tt) ctx argv)
    (fun function_parameter =>
      let
        '((base_dir, config_file, timings, chain, block, confirmations,
          protocol, log_requests, node_addr, node_port, tls, remote_signer,
          password_filename), remaining) := function_parameter in
      op_gtgteqquestion
        match base_dir with
        | None =>
          let base_dir := default_base_dir in
          op_gtgteqquestion
            (unless (Sys.file_exists base_dir)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Lwt_utils_unix.create_dir None base_dir) _return))
            (fun function_parameter =>
              let 'tt := function_parameter in
              _return base_dir)
        | Some dir =>
          if negb (Sys.file_exists dir) then
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Specified -base-dir does not exist. Please create the directory and try again."
                    % string CamlinternalFormatBasics.End_of_format)
                "Specified -base-dir does not exist. Please create the directory and try again."
                  % string)
          else
            if Sys.is_directory dir then
              _return dir
            else
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Specified -base-dir must be a directory" % string
                    CamlinternalFormatBasics.End_of_format)
                  "Specified -base-dir must be a directory" % string)
        end
        (fun base_dir =>
          op_gtgteqquestion
            match config_file with
            | None =>
              apply _return (op_divdiv base_dir default_config_file_name)
            | Some config_file =>
              if Sys.file_exists config_file then
                _return config_file
              else
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Config file specified in option does not exist. Use `client config init` to create one."
                        % string CamlinternalFormatBasics.End_of_format)
                    "Config file specified in option does not exist. Use `client config init` to create one."
                      % string)
            end
            (fun config_file =>
              let config_dir := Filename.dirname config_file in
              let protocol :=
                match protocol with
                | None => None
                | Some p => p
                end in
              op_gtgteqquestion
                (if negb (Sys.file_exists config_file) then
                  _return
                    (* ❌ Record substitution not handled *)
                    record_substitution
                else
                  read_config_file config_file)
                (fun cfg =>
                  let tls := orb (tls cfg) tls in
                  let node_addr := Option.unopt (node_addr cfg) node_addr in
                  let node_port := Option.unopt (node_port cfg) node_port in
                  op_gtgteqquestion
                    (Tezos_signer_backends_unix.Remote.read_base_uri_from_env tt)
                    (fun remote_signer_env =>
                      let remote_signer :=
                        Option.first_some remote_signer
                          (Option.first_some remote_signer_env
                            (remote_signer cfg)) in
                      let confirmations :=
                        Option.unopt (confirmations cfg) confirmations in
                      let cfg :=
                        (* ❌ Record substitution not handled *)
                        record_substitution in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        if
                          andb (Sys.file_exists base_dir)
                            (negb (Sys.is_directory base_dir)) then
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            Format.eprintf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " is not a directory." % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format)))
                                "%s is not a directory.@." % string) base_dir in
                          Stdlib.exit 1
                        else
                          tt in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        if
                          andb (Sys.file_exists config_dir)
                            (negb (Sys.is_directory config_dir)) then
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            Format.eprintf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " is not a directory." % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format)))
                                "%s is not a directory.@." % string) config_dir
                            in
                          Stdlib.exit 1
                        else
                          tt in
                      op_gtgteq (Lwt_utils_unix.create_dir None config_dir)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          _return
                            ((* ❌ Record substitution not handled *)
                            record_substitution, remaining))))))).

Definition t :=
  (option string) * (option string) * bool *
    Tezos_shell_services.Shell_services.chain *
    Tezos_shell_services.Shell_services.block * (option (option Z)) *
    (option (option Tezos_base__TzPervasives.Protocol_hash.t)) * bool *
    (option string) * (option Z) * bool * (option Uri.t) * (option string).

Module Remote_params.
  Record signature := {
    authenticate : (list Tezos_base__TzPervasives.Signature.public_key_hash) ->
      Stdlib.Bytes.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_base__TzPervasives.Signature.t);
    logger : Tezos_rpc_http_client_unix.RPC_client_unix.logger;
  }.
End Remote_params.

Definition other_registrations
  : option (Cfg_file.t -> {_ : unit & Remote_params.signature } -> unit) :=
  Some
    (fun parsed_config_file =>
      fun Remote_params =>
        let Remote_params := projT2 Remote_params in
        Option.iter
          (fun signer =>
            Client_keys.register_signer
              (* ❌ Applications of functors are not supported for first-class module values *)
              unsupported_functor_application)
          (Cfg_file.remote_signer parsed_config_file)).

Definition clic_commands {A B C : Type} (function_parameter : A)
  : (list B) -> (list B) -> (list B) -> C -> list B :=
  let '_ := function_parameter in
  fun config_commands =>
    fun builtin_commands =>
      fun other_commands =>
        fun function_parameter =>
          let '_ := function_parameter in
          OCaml.Stdlib.app config_commands
            (OCaml.Stdlib.app builtin_commands other_commands).

Definition logger {A : Type} : option A := None.

src/lib_client_base_unix/client_context_unix.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "client.context.unix"
end)

class unix_wallet ~base_dir ~password_filename : Client_context.wallet =
  object (self)
    method load_passwords =
      match password_filename with
      | None ->
          None
      | Some filename ->
          if Sys.file_exists filename then Some (Lwt_io.lines_of_file filename)
          else None

    method read_file path =
      Lwt.catch
        (fun () ->
          Lwt_io.(with_file ~mode:Input path read)
          >>= fun content -> return content)
        (fun exn -> failwith "cannot read file (%s)" (Printexc.to_string exn))

    method private filename alias_name =
      Filename.concat
        base_dir
        (String.map (function ' ' -> '_' | c -> c) alias_name ^ "s")

    method with_lock : type a. (unit -> a Lwt.t) -> a Lwt.t =
      fun f ->
        let unlock fd =
          let fd = Lwt_unix.unix_file_descr fd in
          Unix.lockf fd Unix.F_ULOCK 0 ;
          Unix.close fd
        in
        let lock () =
          Lwt_unix.openfile
            (Filename.concat base_dir "wallet_lock")
            Lwt_unix.[O_CREAT; O_WRONLY]
            0o644
          >>= fun fd ->
          Lwt_unix.lockf fd Unix.F_LOCK 0
          >>= fun () ->
          let sighandler =
            Lwt_unix.on_signal Sys.sigint (fun _s -> unlock fd)
          in
          Lwt.return (fd, sighandler)
        in
        lock ()
        >>= fun (fd, sh) ->
        (* catch might be useless if f always uses the error monad *)
        Lwt.catch f (function e -> Lwt.return (unlock fd ; raise e))
        >>= fun res ->
        Lwt.return (unlock fd)
        >>= fun () ->
        Lwt_unix.disable_signal_handler sh ;
        Lwt.return res

    method load : type a.
        string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
      fun alias_name ~default encoding ->
        let filename = self#filename alias_name in
        if not (Sys.file_exists filename) then return default
        else
          Lwt_utils_unix.Json.read_file filename
          |> generic_trace "could not read the %s alias file" alias_name
          >>=? fun json ->
          match Data_encoding.Json.destruct encoding json with
          | exception e ->
              failwith
                "did not understand the %s alias file %s : %s"
                alias_name
                filename
                (Printexc.to_string e)
          | data ->
              return data

    method write : type a.
        string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
      fun alias_name list encoding ->
        Lwt.catch
          (fun () ->
            Lwt_utils_unix.create_dir base_dir
            >>= fun () ->
            let filename = self#filename alias_name in
            let json = Data_encoding.Json.construct encoding list in
            Lwt_utils_unix.Json.write_file filename json)
          (fun exn -> Lwt.return (error_exn exn))
        |> generic_trace "could not write the %s alias file." alias_name
  end

class unix_prompter : Client_context.prompter =
  object
    method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
        =
      Format.kasprintf (fun msg ->
          print_string msg ;
          let line = read_line () in
          return line)

    method prompt_password : type a.
        (a, Bigstring.t tzresult) Client_context.lwt_format -> a =
      Format.kasprintf (fun msg ->
          print_string msg ;
          let line = Lwt_utils_unix.getpass () in
          return (Bigstring.of_string line))
  end

class unix_logger ~base_dir : Client_context.printer =
  let startup = Format.asprintf "%a" Time.System.pp_hum (Systime_os.now ()) in
  let log channel msg =
    match channel with
    | "stdout" ->
        print_endline msg ; Lwt.return_unit
    | "stderr" ->
        prerr_endline msg ; Lwt.return_unit
    | log ->
        let ( // ) = Filename.concat in
        Lwt_utils_unix.create_dir (base_dir // "logs" // log)
        >>= fun () ->
        Lwt_io.with_file
          ~flags:Unix.[O_APPEND; O_CREAT; O_WRONLY]
          ~mode:Lwt_io.Output
          (base_dir // "logs" // log // startup)
          (fun chan -> Lwt_io.write chan msg)
  in
  object
    inherit Client_context.simple_printer log
  end

class unix_ui : Client_context.ui =
  object
    method sleep f = Lwt_unix.sleep f

    method now = Tezos_stdlib_unix.Systime_os.now
  end

class unix_full ~base_dir ~chain ~block ~confirmations ~password_filename
  ~rpc_config : Client_context.full =
  object
    inherit unix_logger ~base_dir

    inherit unix_prompter

    inherit unix_wallet ~base_dir ~password_filename

    inherit RPC_client_unix.http_ctxt rpc_config Media_type.all_media_types

    inherit unix_ui

    method chain = chain

    method block = block

    method confirmations = confirmations
  end
src/lib_client_base_unix/client_context_unix.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `class` not handled. *)
class

(* ❌ Structure item `class` not handled. *)
class

(* ❌ Structure item `class` not handled. *)
class

(* ❌ Structure item `class` not handled. *)
class

(* ❌ Structure item `class` not handled. *)
class

src/lib_client_base_unix/client_main_run.ml 114 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Command line interface - Main Program *)

open Client_context_unix

let builtin_commands =
  let open Clic in
  [ command
      ~desc:"List the protocol versions that this client understands."
      no_options
      (fixed ["list"; "understood"; "protocols"])
      (fun () (cctxt : #Client_context.full) ->
        Lwt_list.iter_s
          (fun (ver, _) -> cctxt#message "%a" Protocol_hash.pp_short ver)
          (Client_commands.get_versions ())
        >>= fun () -> return_unit) ]

module type M = sig
  type t

  val global_options : unit -> (t, Client_context_unix.unix_full) Clic.options

  val parse_config_args :
    #Tezos_client_base.Client_context.full ->
    string list ->
    (Client_config.parsed_config_args * string list) tzresult Lwt.t

  val default_chain : Chain_services.chain

  val default_block : [> `Head of int]

  val default_base_dir : string

  val other_registrations :
    (Client_config.Cfg_file.t -> (module Client_config.Remote_params) -> unit)
    option

  val clic_commands :
    base_dir:string ->
    config_commands:Tezos_client_base.Client_context.full Clic.command list ->
    builtin_commands:Tezos_client_base.Client_context.full Clic.command list ->
    other_commands:Tezos_client_base.Client_context.full Clic.command list ->
    require_auth:bool ->
    Tezos_client_base.Client_context.full Clic.command list

  val logger : RPC_client_unix.logger option
end

(* Main (lwt) entry *)
let main (module C : M) ~select_commands =
  let global_options = C.global_options () in
  let executable_name = Filename.basename Sys.executable_name in
  let (original_args, autocomplete) =
    (* for shell aliases *)
    let rec move_autocomplete_token_upfront acc = function
      | "bash_autocomplete" :: prev_arg :: cur_arg :: script :: args ->
          let args = List.rev acc @ args in
          (args, Some (prev_arg, cur_arg, script))
      | x :: rest ->
          move_autocomplete_token_upfront (x :: acc) rest
      | [] ->
          (List.rev acc, None)
    in
    match Array.to_list Sys.argv with
    | _ :: args ->
        move_autocomplete_token_upfront [] args
    | [] ->
        ([], None)
  in
  Random.self_init () ;
  ignore
    Clic.(
      setup_formatter
        Format.std_formatter
        (if Unix.isatty Unix.stdout then Ansi else Plain)
        Short) ;
  ignore
    Clic.(
      setup_formatter
        Format.err_formatter
        (if Unix.isatty Unix.stderr then Ansi else Plain)
        Short) ;
  Internal_event_unix.init ()
  >>= fun () ->
  Lwt.catch
    (fun () ->
      C.parse_config_args
        (new unix_full
           ~chain:C.default_chain
           ~block:C.default_block
           ~confirmations:None
           ~password_filename:None
           ~base_dir:C.default_base_dir
           ~rpc_config:RPC_client_unix.default_config)
        original_args
      >>=? (fun (parsed, remaining) ->
             let parsed_config_file = parsed.Client_config.parsed_config_file
             and parsed_args = parsed.Client_config.parsed_args
             and config_commands = parsed.Client_config.config_commands in
             let base_dir : string =
               match parsed.Client_config.base_dir with
               | Some p ->
                   p
               | None -> (
                 match parsed_config_file with
                 | None ->
                     C.default_base_dir
                 | Some p ->
                     p.Client_config.Cfg_file.base_dir )
             and require_auth = parsed.Client_config.require_auth in
             let rpc_config =
               let rpc_config : RPC_client_unix.config =
                 match parsed_config_file with
                 | None ->
                     RPC_client_unix.default_config
                 | Some parsed_config_file ->
                     {
                       RPC_client_unix.default_config with
                       host =
                         parsed_config_file.Client_config.Cfg_file.node_addr;
                       port =
                         parsed_config_file.Client_config.Cfg_file.node_port;
                       tls = parsed_config_file.Client_config.Cfg_file.tls;
                     }
               in
               match parsed_args with
               | Some parsed_args ->
                   if parsed_args.Client_config.print_timings then
                     let gettimeofday = Unix.gettimeofday in
                     {
                       rpc_config with
                       logger =
                         RPC_client_unix.timings_logger
                           ~gettimeofday
                           Format.err_formatter;
                     }
                   else if parsed_args.Client_config.log_requests then
                     {
                       rpc_config with
                       logger =
                         RPC_client_unix.full_logger Format.err_formatter;
                     }
                   else rpc_config
               | None ->
                   rpc_config
             in
             let client_config =
               new unix_full
                 ~chain:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.chain
                   | None ->
                       Client_config.default_chain )
                 ~block:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.block
                   | None ->
                       Client_config.default_block )
                 ~confirmations:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.confirmations
                   | None ->
                       None )
                 ~password_filename:
                   ( match parsed_args with
                   | Some p ->
                       p.Client_config.password_filename
                   | None ->
                       None )
                 ~base_dir
                 ~rpc_config
             in
             let module Remote_params = struct
               let authenticate pkhs payload =
                 Client_keys.list_keys client_config
                 >>=? fun keys ->
                 match
                   List.filter_map
                     (function
                       | (_, known_pkh, _, Some known_sk_uri)
                         when List.exists
                                (fun pkh ->
                                  Signature.Public_key_hash.equal pkh known_pkh)
                                pkhs ->
                           Some known_sk_uri
                       | _ ->
                           None)
                     keys
                 with
                 | sk_uri :: _ ->
                     Client_keys.sign client_config sk_uri payload
                 | [] ->
                     failwith
                       "remote signer expects authentication signature, but \
                        no authorized key was found in the wallet"

               let logger =
                 (* overriding the logger we might already have with the one from
             module C *)
                 match C.logger with
                 | Some logger ->
                     logger
                 | None ->
                     rpc_config.logger
             end in
             let module Http =
               Tezos_signer_backends.Http.Make
                 (RPC_client_unix)
                 (Remote_params)
             in
             let module Https =
               Tezos_signer_backends.Https.Make
                 (RPC_client_unix)
                 (Remote_params)
             in
             let module Socket =
               Tezos_signer_backends_unix.Socket.Make (Remote_params) in
             Client_keys.register_signer
               ( module Tezos_signer_backends.Encrypted.Make (struct
                 let cctxt = (client_config :> Client_context.prompter)
               end) ) ;
             Client_keys.register_signer
               (module Tezos_signer_backends.Unencrypted) ;
             Client_keys.register_signer
               (module Tezos_signer_backends_unix.Ledger.Signer_implementation) ;
             Client_keys.register_signer (module Socket.Unix) ;
             Client_keys.register_signer (module Socket.Tcp) ;
             Client_keys.register_signer (module Http) ;
             Client_keys.register_signer (module Https) ;
             ( match parsed_config_file with
             | None ->
                 ()
             | Some parsed_config_file -> (
               match C.other_registrations with
               | Some r ->
                   r parsed_config_file (module Remote_params)
               | None ->
                   () ) ) ;
             ( match parsed_args with
             | Some parsed_args ->
                 select_commands
                   (client_config :> RPC_client_unix.http_ctxt)
                   parsed_args
             | None ->
                 return_nil )
             >>=? fun other_commands ->
             let commands =
               Clic.add_manual
                 ~executable_name
                 ~global_options
                 (if Unix.isatty Unix.stdout then Clic.Ansi else Clic.Plain)
                 Format.std_formatter
                 (C.clic_commands
                    ~base_dir
                    ~config_commands
                    ~builtin_commands
                    ~other_commands
                    ~require_auth)
             in
             match autocomplete with
             | Some (prev_arg, cur_arg, script) ->
                 Clic.autocompletion
                   ~script
                   ~cur_arg
                   ~prev_arg
                   ~args:original_args
                   ~global_options
                   commands
                   client_config
                 >>=? fun completions ->
                 List.iter print_endline completions ;
                 return_unit
             | None ->
                 Clic.dispatch commands client_config remaining)
      >>= function
      | Ok () ->
          Lwt.return 0
      | Error [Clic.Help command] ->
          Clic.usage
            Format.std_formatter
            ~executable_name
            ~global_options
            (match command with None -> [] | Some c -> [c]) ;
          Lwt.return 0
      | Error errs ->
          Clic.pp_cli_errors
            Format.err_formatter
            ~executable_name
            ~global_options
            ~default:Error_monad.pp
            errs ;
          Lwt.return 1)
    (function
      | Client_commands.Version_not_found ->
          Format.eprintf
            "@{<error>@{<title>Fatal error@}@} unknown protocol version.@." ;
          Lwt.return 1
      | Failure message ->
          Format.eprintf
            "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@."
            Format.pp_print_text
            message ;
          Lwt.return 1
      | exn ->
          Format.printf
            "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@."
            Format.pp_print_text
            (Printexc.to_string exn) ;
          Lwt.return 1)
  >>= fun retcode ->
  Format.pp_print_flush Format.err_formatter () ;
  Format.pp_print_flush Format.std_formatter () ;
  Internal_event_unix.close () >>= fun () -> Lwt.return retcode

(* Where all the user friendliness starts *)
let run ?log (module M : M)
    ~(select_commands :
       RPC_client_unix.http_ctxt ->
       Client_config.cli_args ->
       Client_context.full Clic.command list tzresult Lwt.t) =
  Lwt_exit.exit_on ?log Sys.sigint ;
  Lwt_exit.exit_on ?log Sys.sigterm ;
  Pervasives.exit @@ Lwt_main.run @@ Lwt_exit.wrap_promise
  @@ main (module M) ~select_commands
src/lib_client_base_unix/client_main_run.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_context_unix.

Definition builtin_commands {F G a b i o p q : Type}
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * nil)))))))))))))))))))))
        * nil)) :=
  cons
    (command None
      "List the protocol versions that this client understands." % string
      no_options
      (fixed
        (cons "list" % string
          (cons "understood" % string (cons "protocols" % string []))))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          op_gtgteq
            (Lwt_list.iter_s
              (fun function_parameter =>
                let '(ver, _) := function_parameter in
                (* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format) "%a" % string)
                  Protocol_hash.pp_short ver) (Client_commands.get_versions tt))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit))) [].

Module M.
  Record signature {t : Type} := {
    t := t;
    global_options : unit ->
      Tezos_base__TzPervasives.Clic.options t
        Tezos_client_base_unix.Client_context_unix.unix_full;
    parse_config_args : forall {_ a b i o p q variant : Type}, (((Z ->
      Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (_ * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (_ * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * _)))))))))))))))))))))
      * _) ->
      (list string) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_client_base_unix.Client_config.parsed_config_args *
              (list string)));
    default_chain : Tezos_shell_services.Chain_services.chain;
    default_block : forall {variant : Type}, variant;
    default_base_dir : string;
    other_registrations : option
      (Tezos_client_base_unix.Client_config.Cfg_file.t ->
        {_ : unit &
          Tezos_client_base_unix.Client_config.Remote_params.signature } -> unit);
    clic_commands : string ->
      (list
        (Tezos_base__TzPervasives.Clic.command
          Tezos_client_base.Client_context.full)) ->
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full)) ->
          (list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full)) ->
            bool ->
              list
                (Tezos_base__TzPervasives.Clic.command
                  Tezos_client_base.Client_context.full);
    logger : option Tezos_rpc_http_client_unix.RPC_client_unix.logger;
  }.
  Arguments signature : clear implicits.
End M.

Definition main (C : {t : _ & M.signature t})
  : (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
    Tezos_client_base_unix.Client_config.cli_args ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full)))) -> Lwt.t Z :=
  let C := projT2 C in
  fun select_commands =>
    let global_options := C.(M.global_options) tt in
    let executable_name := Filename.basename Sys.executable_name in
    let '(original_args, autocomplete) :=
      let fix move_autocomplete_token_upfront
        (acc : list string) (function_parameter : list string)
        : (list string) * (option (string * string * string)) :=
        match function_parameter with
        |
          cons "bash_autocomplete" % string
            (cons prev_arg (cons cur_arg (cons script args))) =>
          let args := OCaml.Stdlib.app (List.rev acc) args in
          (args, (Some (prev_arg, cur_arg, script)))
        | cons x rest => move_autocomplete_token_upfront (cons x acc) rest
        | [] => ((List.rev acc), None)
        end in
      match Array.to_list Sys.argv with
      | cons _ args => move_autocomplete_token_upfront [] args
      | [] => ([], None)
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Random.self_init tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      OCaml.Stdlib.ignore
        (setup_formatter Format.std_formatter
          (if Unix.isatty Unix.stdout then
            Tezos_base__TzPervasives.Clic.Ansi
          else
            Tezos_base__TzPervasives.Clic.Plain)
          Tezos_base__TzPervasives.Clic.Short) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      OCaml.Stdlib.ignore
        (setup_formatter Format.err_formatter
          (if Unix.isatty Unix.stderr then
            Tezos_base__TzPervasives.Clic.Ansi
          else
            Tezos_base__TzPervasives.Clic.Plain)
          Tezos_base__TzPervasives.Clic.Short) in
    op_gtgteq (Internal_event_unix.init None None tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (Lwt.catch
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (op_gtgteqquestion
                  (C.(M.parse_config_args)
                    ((* ❌ Creation of new objects is not handled *)
                    new C.(M.default_base_dir) C.(M.default_chain)
                      C.(M.default_block) None None
                      RPC_client_unix.default_config) original_args)
                  (fun function_parameter =>
                    let '(parsed, remaining) := function_parameter in
                    let parsed_config_file
                      : option Tezos_client_base_unix.Client_config.Cfg_file.t :=
                      Client_config.parsed_config_file parsed
                    with parsed_args
                      : option Tezos_client_base_unix.Client_config.cli_args :=
                      Client_config.parsed_args parsed
                    with config_commands
                      : list
                        (Tezos_base__TzPervasives.Clic.command
                          Tezos_client_base.Client_context.full) :=
                      Client_config.config_commands parsed in
                    let base_dir : string :=
                      match Client_config.base_dir parsed with
                      | Some p => p
                      | None =>
                        match parsed_config_file with
                        | None => C.(M.default_base_dir)
                        | Some p => Client_config.Cfg_file.base_dir p
                        end
                      end
                    with require_auth : bool :=
                      Client_config.require_auth parsed in
                    let rpc_config :=
                      let rpc_config :=
                        match parsed_config_file with
                        | None => RPC_client_unix.default_config
                        | Some parsed_config_file =>
                          (* ❌ Record substitution not handled *)
                          record_substitution
                        end in
                      match parsed_args with
                      | Some parsed_args =>
                        if Client_config.print_timings parsed_args then
                          let gettimeofday := Unix.gettimeofday in
                          (* ❌ Record substitution not handled *)
                          record_substitution
                        else
                          if Client_config.log_requests parsed_args then
                            (* ❌ Record substitution not handled *)
                            record_substitution
                          else
                            rpc_config
                      | None => rpc_config
                      end in
                    let client_config :=
                      (* ❌ Creation of new objects is not handled *)
                      new base_dir
                        match parsed_args with
                        | Some p => Client_config.chain p
                        | None => Client_config.default_chain
                        end
                        match parsed_args with
                        | Some p => Client_config.block p
                        | None => Client_config.default_block
                        end
                        match parsed_args with
                        | Some p => Client_config.confirmations p
                        | None => None
                        end
                        match parsed_args with
                        | Some p => Client_config.password_filename p
                        | None => None
                        end rpc_config in
                    let Remote_params :=
                      existT _ unit
                        {|
                          (* ❌ This kind of definition of value for first-class modules is not handled *)
                          Tezos_client_base_unix__Client_config.Remote_params.authenticate :=
                            unhandled;
                          Tezos_client_base_unix__Client_config.Remote_params.logger :=
                            match C.(M.logger) with
                            | Some logger => logger
                            | None => logger rpc_config
                            end
                          |} in
                    let Http :=
                      (* ❌ Applications of functors are not supported for first-class module values *)
                      unsupported_functor_application in
                    let Https :=
                      (* ❌ Applications of functors are not supported for first-class module values *)
                      unsupported_functor_application in
                    let Socket :=
                      (* ❌ Applications of functors are not supported for first-class module values *)
                      unsupported_functor_application in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Client_keys.register_signer
                        (* ❌ Applications of functors are not supported for first-class module values *)
                        unsupported_functor_application in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Client_keys.register_signer
                        Tezos_signer_backends.Unencrypted in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Client_keys.register_signer
                        Tezos_signer_backends_unix.Ledger.Signer_implementation
                      in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Client_keys.register_signer Socket.Unix in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Client_keys.register_signer Socket.Tcp in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Client_keys.register_signer Http in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Client_keys.register_signer Https in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      match parsed_config_file with
                      | None => tt
                      | Some parsed_config_file =>
                        match C.(M.other_registrations) with
                        | Some r => r parsed_config_file Remote_params
                        | None => tt
                        end
                      end in
                    op_gtgteqquestion
                      match parsed_args with
                      | Some parsed_args =>
                        select_commands client_config parsed_args
                      | None => return_nil
                      end
                      (fun other_commands =>
                        let commands :=
                          Clic.add_manual executable_name global_options
                            (if Unix.isatty Unix.stdout then
                              Tezos_base__TzPervasives.Clic.Ansi
                            else
                              Tezos_base__TzPervasives.Clic.Plain)
                            Format.std_formatter
                            (C.(M.clic_commands) base_dir config_commands
                              builtin_commands other_commands require_auth) in
                        match autocomplete with
                        | Some (prev_arg, cur_arg, script) =>
                          op_gtgteqquestion
                            (Clic.autocompletion script cur_arg prev_arg
                              original_args global_options commands
                              client_config)
                            (fun completions =>
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                List.iter OCaml.Stdlib.print_endline completions
                                in
                              return_unit)
                        | None => Clic.dispatch commands client_config remaining
                        end)))
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok tt => Lwt._return 0
                  |
                    Stdlib.Error
                      (cons (Tezos_error_monad.Error_monad.Help command) []) =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Clic.usage Format.std_formatter executable_name
                        global_options
                        match command with
                        | None => []
                        | Some c => cons c []
                        end in
                    Lwt._return 0
                  | Stdlib.Error errs =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Clic.pp_cli_errors Format.err_formatter executable_name
                        global_options Error_monad.pp errs in
                    Lwt._return 1
                  end))
            (fun function_parameter =>
              match function_parameter with
              | Version_not_found =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Format.eprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<error>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<error>" % string))
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<title>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<title>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Fatal error" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_tag
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.String_literal
                                  " unknown protocol version." % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))))))
                      "@{<error>@{<title>Fatal error@}@} unknown protocol version.@."
                        % string) in
                Lwt._return 1
              | OCaml.Failure message =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Format.eprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<error>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<error>" % string))
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<title>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<title>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Fatal error" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_tag
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  (CamlinternalFormatBasics.String_literal
                                    "  " % string
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<h 0>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<h 0>" % string))
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Flush_newline
                                            CamlinternalFormatBasics.End_of_format)))))))))))
                      "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@." %
                        string) Format.pp_print_text message in
                Lwt._return 1
              | exn =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Format.printf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_tag
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<error>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<error>" % string))
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_tag
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<title>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<title>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Fatal error" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_tag
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_tag
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  (CamlinternalFormatBasics.String_literal
                                    "  " % string
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<h 0>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<h 0>" % string))
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Flush_newline
                                            CamlinternalFormatBasics.End_of_format)))))))))))
                      "@{<error>@{<title>Fatal error@}@}@.  @[<h 0>%a@]@." %
                        string) Format.pp_print_text (Printexc.to_string exn) in
                Lwt._return 1
              end))
          (fun retcode =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Format.pp_print_flush Format.err_formatter tt in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Format.pp_print_flush Format.std_formatter tt in
            op_gtgteq (Internal_event_unix.close tt)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt._return retcode))).

Definition run {A : Type}
  (log : option (string -> unit)) (M : {t : _ & M.signature t})
  : (Tezos_rpc_http_client_unix.RPC_client_unix.http_ctxt ->
    Tezos_client_base_unix.Client_config.cli_args ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list
            (Tezos_base__TzPervasives.Clic.command
              Tezos_client_base.Client_context.full)))) -> A :=
  let M := projT2 M in
  fun select_commands =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Lwt_exit.exit_on log Sys.sigint in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Lwt_exit.exit_on log Sys.sigterm in
    apply Pervasives.exit
      (apply Lwt_main.run (apply Lwt_exit.wrap_promise (main M select_commands))).

src/lib_client_commands/client_admin_commands.ml 40 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let block_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
    t

let commands () =
  let open Clic in
  let group =
    {
      name = "admin";
      title = "Commands to perform privileged operations on the node";
    }
  in
  [ command
      ~group
      ~desc:"Make the node forget its decision of rejecting blocks."
      no_options
      ( prefixes ["unmark"; "invalid"]
      @@ seq_of_param
           (block_param
              ~name:"block"
              ~desc:"blocks to remove from invalid list") )
      (fun () blocks (cctxt : #Client_context.full) ->
        iter_s
          (fun block ->
            Shell_services.Invalid_blocks.delete cctxt block
            >>=? fun () ->
            cctxt#message
              "Block %a no longer marked invalid."
              Block_hash.pp
              block
            >>= fun () -> return_unit)
          blocks);
    command
      ~group
      ~desc:"Make the node forget every decision of rejecting blocks."
      no_options
      (prefixes ["unmark"; "all"; "invalid"; "blocks"] @@ stop)
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.Invalid_blocks.list cctxt ()
        >>=? fun invalid_blocks ->
        iter_s
          (fun {Chain_services.hash; _} ->
            Shell_services.Invalid_blocks.delete cctxt hash
            >>=? fun () ->
            cctxt#message
              "Block %a no longer marked invalid."
              Block_hash.pp_short
              hash
            >>= fun () -> return_unit)
          invalid_blocks);
    command
      ~group
      ~desc:
        "Retrieve the current checkpoint and display it in a format \
         compatible with node argument `--checkpoint`."
      no_options
      (fixed ["show"; "current"; "checkpoint"])
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.Chain.checkpoint cctxt ~chain:cctxt#chain ()
        >>=? fun (block_header, save_point, caboose, history_mode) ->
        cctxt#message
          "@[<v 0>Checkpoint: %s@,\
           Checkpoint level: %ld@,\
           History mode: %a@,\
           Save point level: %ld@,\
           Caboose level: %ld@]"
          (Block_header.to_b58check block_header)
          block_header.shell.level
          History_mode.pp
          history_mode
          save_point
          caboose
        >>= fun () -> return ()) ]
src/lib_client_commands/client_admin_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition block_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Block_hash.t -> A) B :=
  Clic.param name desc
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun str => Lwt._return (Block_hash.of_b58check str))) t.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let 'tt := function_parameter in
  let group :=
    {| name := "admin" % string;
      title := "Commands to perform privileged operations on the node" % string
      |} in
  cons
    (command (Some group)
      "Make the node forget its decision of rejecting blocks." % string
      no_options
      (apply (prefixes (cons "unmark" % string (cons "invalid" % string [])))
        (seq_of_param
          (block_param "block" % string
            "blocks to remove from invalid list" % string)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun blocks =>
          fun cctxt =>
            iter_s
              (fun block =>
                op_gtgteqquestion
                  (Shell_services.Invalid_blocks.delete cctxt None block)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " no longer marked invalid." % string
                                CamlinternalFormatBasics.End_of_format)))
                          "Block %a no longer marked invalid." % string)
                        Block_hash.pp block)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit))) blocks))
    (cons
      (command (Some group)
        "Make the node forget every decision of rejecting blocks." % string
        no_options
        (apply
          (prefixes
            (cons "unmark" % string
              (cons "all" % string
                (cons "invalid" % string (cons "blocks" % string []))))) stop)
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun cctxt =>
            op_gtgteqquestion (Shell_services.Invalid_blocks.list cctxt None tt)
              (fun invalid_blocks =>
                iter_s
                  (fun function_parameter =>
                    let '{| Chain_services.hash := hash |} := function_parameter
                      in
                    op_gtgteqquestion
                      (Shell_services.Invalid_blocks.delete cctxt None hash)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Block " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " no longer marked invalid." % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Block %a no longer marked invalid." % string)
                            Block_hash.pp_short hash)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit))) invalid_blocks)))
      (cons
        (command (Some group)
          "Retrieve the current checkpoint and display it in a format compatible with node argument `--checkpoint`."
            % string no_options
          (fixed
            (cons "show" % string
              (cons "current" % string (cons "checkpoint" % string []))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun cctxt =>
              op_gtgteqquestion
                (Shell_services.Chain.checkpoint cctxt
                  (Some
                    (* ❌ Sending method message is not handled *)
                    send) tt)
                (fun function_parameter =>
                  let '(block_header, save_point, caboose, history_mode) :=
                    function_parameter in
                  op_gtgteq
                    ((* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 0>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 0>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Checkpoint: " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "Checkpoint level: " % string
                                  (CamlinternalFormatBasics.Int32
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "History mode: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@," % string 0 0)
                                            (CamlinternalFormatBasics.String_literal
                                              "Save point level: " % string
                                              (CamlinternalFormatBasics.Int32
                                                CamlinternalFormatBasics.Int_d
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@," % string 0 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Caboose level: " % string
                                                    (CamlinternalFormatBasics.Int32
                                                      CamlinternalFormatBasics.Int_d
                                                      CamlinternalFormatBasics.No_padding
                                                      CamlinternalFormatBasics.No_precision
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        CamlinternalFormatBasics.End_of_format))))))))))))))))
                        "@[<v 0>Checkpoint: %s@,Checkpoint level: %ld@,History mode: %a@,Save point level: %ld@,Caboose level: %ld@]"
                          % string) (Block_header.to_b58check block_header)
                      (level (shell block_header)) History_mode.pp history_mode
                      save_point caboose)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return tt)))) [])).

src/lib_client_commands/client_commands.ml 13 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_context

type command = full Clic.command

type network = [`Mainnet | `Alphanet | `Zeronet | `Sandbox]

exception Version_not_found

let versions = Protocol_hash.Table.create 7

let get_versions () =
  Protocol_hash.Table.fold (fun k c acc -> (k, c) :: acc) versions []

let register name commands =
  let previous =
    try Protocol_hash.Table.find versions name
    with Not_found -> fun (_network : network option) -> ([] : command list)
  in
  Protocol_hash.Table.replace versions name (fun (network : network option) ->
      commands network @ previous network)

let commands_for_version version =
  try Protocol_hash.Table.find versions version
  with Not_found -> raise Version_not_found
src/lib_client_commands/client_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_context.

Definition command :=
  Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full.

Definition network := variant.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition versions
  : Tezos_base__TzPervasives.Protocol_hash.Table.t
    ((option network) -> list command) := Protocol_hash.Table.create 7.

Definition get_versions (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Protocol_hash.Table.key *
      ((option network) -> list command)) :=
  let 'tt := function_parameter in
  Protocol_hash.Table.fold (fun k => fun c => fun acc => cons (k, c) acc)
    versions [].

Definition register
  (name : Tezos_base__TzPervasives.Protocol_hash.Table.key)
  (commands : (option network) -> list command) : unit :=
  let previous :=
    (* ❌ Try-with are not handled *)
    try (Protocol_hash.Table.find versions name) in
  Protocol_hash.Table.replace versions name
    (fun network => OCaml.Stdlib.app (commands network) (previous network)).

Definition commands_for_version
  (version : Tezos_base__TzPervasives.Protocol_hash.Table.key)
  : (option network) -> list command :=
  (* ❌ Try-with are not handled *)
  try (Protocol_hash.Table.find versions version).

src/lib_client_commands/client_event_logging_commands.ml 92 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let group =
  Clic.
    {
      name = "event-logging-framework";
      title = "Commands to inspect the event-logging framework";
    }

let date_parameter option_name build =
  let open Clic in
  parameter (fun _ s ->
      let problem fmt = Printf.ksprintf invalid_arg fmt in
      try
        if String.length s <> 8 then problem "date should be `YYYYMMDD`" ;
        String.iteri
          (fun idx -> function '0' .. '9' -> () | other ->
                problem "character %d is not a digit: '%c'." idx other)
          s ;
        let month = int_of_string (String.sub s 4 2) - 1 in
        if month < 0 then problem "The month cannot be '00'" ;
        if month > 11 then problem "The month cannot be more than '12'" ;
        let day = int_of_string (String.sub s 6 2) in
        if day > 31 then problem "The month cannot be more than '31'" ;
        let t =
          let tm =
            Unix.
              {
                tm_sec = 0;
                tm_min = 0;
                tm_hour = 0;
                tm_mday = day;
                tm_mon = month;
                tm_year = int_of_string (String.sub s 0 4) - 1900;
                tm_wday = 0;
                tm_yday = 0;
                tm_isdst = false;
              }
          in
          Unix.mktime tm |> fst
        in
        return (build t)
      with
      | Invalid_argument e ->
          failwith "In `%s %S`, %s" option_name s e
      | e ->
          failwith "Exn: %a" pp_exn e)

let flat_pp pp o =
  Format.(
    asprintf
      "%a"
      (fun fmt () ->
        pp_set_margin fmt 2_000_000 ;
        pp fmt o)
      ())

let commands () =
  let open Clic in
  let command ~desc = command ~group ~desc in
  [ command
      ~desc:"Query the events from an event sink."
      (args7
         (arg
            ~doc:"Filter on event names"
            ~long:"names"
            ~placeholder:"LIST"
            (parameter (fun _ s ->
                 try return (String.split_on_char ',' s)
                 with _ -> failwith "List of names cannot be parsed")))
         (arg
            ~doc:"Filter on event sections (use '_' for no-section)"
            ~long:"sections"
            ~placeholder:"LIST"
            (parameter (fun _ s ->
                 try
                   return
                     ( String.split_on_char ',' s
                     |> List.map (function "_" -> None | other -> Some other)
                     )
                 with _ -> failwith "List of sections cannot be parsed")))
         (arg
            ~doc:"Filter out events before DATE"
            ~long:"since"
            ~placeholder:"DATE"
            (date_parameter "--since" (fun s -> `Date (`Ge, s))))
         (arg
            ~doc:"Filter out events after DATE"
            ~long:"until"
            ~placeholder:"DATE"
            (date_parameter "--until" (fun s -> `Date (`Le, s))))
         (switch
            ~doc:"Display events as JSON instead of pretty-printing them"
            ~long:"as-json"
            ())
         (switch ~doc:"Try to display unknown events" ~long:"dump-unknown" ())
         (Scriptable.clic_arg ()))
      ( prefixes ["query"; "events"; "from"]
      @@ param
           ~name:"Sink-Name"
           ~desc:"The URI of the SINK to query"
           (parameter (fun _ s ->
                try return (Uri.of_string s)
                with _ -> failwith "Uri cannot be parsed"))
      @@ stop )
      (fun ( only_names,
             only_sections,
             since,
             until,
             as_json,
             dump_unknown,
             scriptable )
           uri
           (cctxt : #Client_context.full) ->
        let open Tezos_stdlib_unix in
        match Uri.scheme uri with
        | None | Some "unix-files" -> (
            let script_row kind date evname data () =
              [kind; date; evname; data]
            in
            Scriptable.output_for_human scriptable (fun () ->
                cctxt#message "### Events" >>= fun () -> return_unit)
            >>=? fun () ->
            let on_unknown =
              if not dump_unknown then None
              else
                Some
                  (fun path ->
                    Scriptable.output_row
                      scriptable
                      ~for_human:(fun () ->
                        cctxt#message "Unknown: %s" path
                        >>= fun () ->
                        Lwt_stream.iter_s
                          (fun line -> cctxt#message "    |%s" line)
                          (Lwt_io.lines_of_file path)
                        >>= fun () -> return_unit)
                      ~for_script:(script_row "unknown-event" "-" "-" path))
            in
            let time_query =
              match (since, until) with
              | (None, None) ->
                  None
              | (Some a, None) | (None, Some a) ->
                  Some a
              | (Some a, Some b) ->
                  Some (`And (a, b))
            in
            File_event_sink.Query.fold
              ?only_names
              ?on_unknown
              ?only_sections
              ?time_query
              uri
              ~init:()
              ~f:(fun () ~time_stamp ev ->
                let o = Internal_event.Generic.explode_event ev in
                let time_string time_value =
                  let open Unix in
                  let tm = gmtime time_value in
                  Printf.sprintf
                    "%04d%02d%02d-%02d%02d%02d-%04d"
                    (1900 + tm.tm_year)
                    (tm.tm_mon + 1)
                    tm.tm_mday
                    tm.tm_hour
                    tm.tm_min
                    tm.tm_sec
                    ( (time_value -. floor time_value) *. 10_000.
                    |> int_of_float )
                in
                let pp fmt o =
                  if as_json then Data_encoding.Json.pp fmt o#json
                  else o#pp fmt ()
                in
                Scriptable.output_row
                  scriptable
                  ~for_human:(fun () ->
                    cctxt#message
                      "@[<2>* [%s %s]@ %a@]"
                      (time_string time_stamp)
                      o#name
                      pp
                      o
                    >>= fun () -> return_unit)
                  ~for_script:(fun () ->
                    let text = flat_pp pp o in
                    script_row "event" (time_string time_stamp) o#name text ()))
            >>=? function
            | ([], ()) ->
                return_unit
            | (errors_and_warnings, ()) ->
                let open Format in
                Scriptable.output
                  scriptable
                  ~for_human:(fun () ->
                    cctxt#message
                      "### Some things were not perfect:@.@[<2>%a@]"
                      (pp_print_list
                         ~pp_sep:(fun fmt () -> fprintf fmt "@.")
                         (fun fmt item ->
                           fprintf
                             fmt
                             "* %a"
                             File_event_sink.Query.Report.pp
                             item))
                      errors_and_warnings
                    >>= fun () -> return_unit)
                  ~for_script:(fun () ->
                    let make_row e =
                      let text = flat_pp File_event_sink.Query.Report.pp e in
                      let tag =
                        match e with
                        | `Error _ ->
                            "error"
                        | `Warning _ ->
                            "warning"
                      in
                      script_row tag "-" "-" text ()
                    in
                    List.map make_row errors_and_warnings) )
        | Some other ->
            cctxt#message "URI scheme %S not handled as of now." other
            >>= fun () -> return_unit);
    command
      ~desc:
        "Display configuration/state information about the internal-event \
         logging framework."
      no_options
      (prefixes ["show"; "event-logging"] @@ stop)
      (fun () (cctxt : #Client_context.full) ->
        let pp_event_definitions fmt schs =
          let open Format in
          pp_open_box fmt 0 ;
          pp_print_list
            ~pp_sep:(fun fmt () -> fprintf fmt "@;")
            (fun fmt obj_schema ->
              pp_open_box fmt 2 ;
              fprintf fmt "* `%s`:@ " obj_schema#name ;
              pp_print_text fmt obj_schema#doc ;
              pp_close_box fmt ())
            fmt
            schs ;
          pp_close_box fmt ()
        in
        cctxt#message
          "Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
          Internal_event.All_sinks.pp_state
          ()
          pp_event_definitions
          Internal_event.(
            All_definitions.get () |> List.map Generic.json_schema)
        >>= fun () -> return_unit);
    command
      ~desc:"Output the JSON schema of an internal-event."
      no_options
      ( prefixes ["output"; "schema"; "of"]
      @@ param
           ~name:"Event-Name"
           ~desc:"Name of the event"
           (parameter (fun _ s -> return s))
      @@ prefix "to"
      @@ param
           ~name:"File-path"
           ~desc:"Path to a JSON file"
           (parameter (fun _ s -> return s))
      @@ stop )
      (fun () event path (cctxt : #Client_context.full) ->
        let open Internal_event in
        match All_definitions.find (( = ) event) with
        | None ->
            failwith "Event %S not found" event
        | Some ev ->
            let o = Generic.json_schema ev in
            Lwt_io.with_file ~mode:Lwt_io.output path (fun chan ->
                let v = Format.asprintf "%a" Json_schema.pp o#schema in
                Lwt_io.write chan v)
            >>= fun () ->
            cctxt#message "Wrote schema of %s to %s" event path
            >>= fun () -> return_unit) ]
src/lib_client_commands/client_event_logging_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| name := "event-logging-framework" % string;
    title := "Commands to inspect the event-logging framework" % string |}.

Definition date_parameter {A B : Type} (option_name : string) (build : Z -> A)
  : Tezos_base__TzPervasives.Clic.parameter A B :=
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        let problem {C D : Type} (fmt : Stdlib.format4 C unit string D) : C :=
          Printf.ksprintf OCaml.Stdlib.invalid_arg fmt in
        (* ❌ Try-with are not handled *)
        try
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          (let _ :=
            if nequiv_decb (String.length s) 8 then
              problem
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "date should be `YYYYMMDD`" % string
                    CamlinternalFormatBasics.End_of_format)
                  "date should be `YYYYMMDD`" % string)
            else
              tt in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            String.iteri
              (fun idx =>
                fun function_parameter =>
                  match function_parameter with
                  |
                    "0" % char |
                      "1" % char |
                        "2" % char |
                          "3" % char |
                            "4" % char |
                              "5" % char |
                                "6" % char |
                                  "7" % char | "8" % char | "9" % char => tt
                  | other =>
                    problem
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "character " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.String_literal
                              " is not a digit: '" % string
                              (CamlinternalFormatBasics.Char
                                (CamlinternalFormatBasics.String_literal
                                  "'." % string
                                  CamlinternalFormatBasics.End_of_format)))))
                        "character %d is not a digit: '%c'." % string) idx other
                  end) s in
          let month := Z.sub (OCaml.Stdlib.int_of_string (String.sub s 4 2)) 1
            in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if OCaml.Stdlib.lt month 0 then
              problem
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The month cannot be '00'" % string
                    CamlinternalFormatBasics.End_of_format)
                  "The month cannot be '00'" % string)
            else
              tt in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if OCaml.Stdlib.gt month 11 then
              problem
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The month cannot be more than '12'" % string
                    CamlinternalFormatBasics.End_of_format)
                  "The month cannot be more than '12'" % string)
            else
              tt in
          let day := OCaml.Stdlib.int_of_string (String.sub s 6 2) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if OCaml.Stdlib.gt day 31 then
              problem
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The month cannot be more than '31'" % string
                    CamlinternalFormatBasics.End_of_format)
                  "The month cannot be more than '31'" % string)
            else
              tt in
          let t :=
            let tm :=
              {| tm_sec := 0; tm_min := 0; tm_hour := 0; tm_mday := day;
                tm_mon := month;
                tm_year :=
                  Z.sub (OCaml.Stdlib.int_of_string (String.sub s 0 4)) 1900;
                tm_wday := 0; tm_yday := 0; tm_isdst := false |} in
            OCaml.Stdlib.reverse_apply (Unix.mktime tm) fst in
          _return (build t))).

Definition flat_pp {A : Type}
  (pp : Stdlib.Format.formatter -> A -> unit) (o : A) : string :=
  asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string)
    (fun fmt =>
      fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := pp_set_margin fmt 2000000 in
        pp fmt o) tt.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let 'tt := function_parameter in
  let command {J K L : Type} (desc : string)
    : (Tezos_base__TzPervasives.Clic.options J K) ->
      (Tezos_base__TzPervasives.Clic.params L K) ->
        (J -> L) -> Tezos_base__TzPervasives.Clic.command K :=
    command (Some group) desc in
  cons
    (command "Query the events from an event sink." % string
      (args7
        (arg "Filter on event names" % string None "names" % string
          "LIST" % string
          (parameter None
            (fun function_parameter =>
              let '_ := function_parameter in
              fun s =>
                (* ❌ Try-with are not handled *)
                try (_return (String.split_on_char "," % char s)))))
        (arg "Filter on event sections (use '_' for no-section)" % string None
          "sections" % string "LIST" % string
          (parameter None
            (fun function_parameter =>
              let '_ := function_parameter in
              fun s =>
                (* ❌ Try-with are not handled *)
                try
                  (_return
                    (OCaml.Stdlib.reverse_apply
                      (String.split_on_char "," % char s)
                      (List.map
                        (fun function_parameter =>
                          match function_parameter with
                          | "_" % string => None
                          | other => Some other
                          end)))))))
        (arg "Filter out events before DATE" % string None "since" % string
          "DATE" % string
          (date_parameter "--since" % string
            (fun s =>
              (* ❌ Variants not supported *)
              variant)))
        (arg "Filter out events after DATE" % string None "until" % string
          "DATE" % string
          (date_parameter "--until" % string
            (fun s =>
              (* ❌ Variants not supported *)
              variant)))
        (switch
          "Display events as JSON instead of pretty-printing them" % string None
          "as-json" % string tt)
        (switch "Try to display unknown events" % string None
          "dump-unknown" % string tt) (Scriptable.clic_arg tt))
      (apply
        (prefixes
          (cons "query" % string
            (cons "events" % string (cons "from" % string []))))
        (apply
          (param "Sink-Name" % string "The URI of the SINK to query" % string
            (parameter None
              (fun function_parameter =>
                let '_ := function_parameter in
                fun s =>
                  (* ❌ Try-with are not handled *)
                  try (_return (Uri.of_string s))))) stop))
      (fun function_parameter =>
        let
          '(only_names, only_sections, since, until, as_json, dump_unknown,
            scriptable) := function_parameter in
        fun uri =>
          fun cctxt =>
            match Uri.scheme uri with
            | None | Some "unix-files" % string =>
              let script_row {J : Type}
                (kind : J) (date : J) (evname : J) (data : J)
                (function_parameter : unit) : list J :=
                let 'tt := function_parameter in
                cons kind (cons date (cons evname (cons data []))) in
              op_gtgteqquestion
                (Scriptable.output_for_human scriptable
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "### Events" % string
                            CamlinternalFormatBasics.End_of_format)
                          "### Events" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let on_unknown :=
                    if negb dump_unknown then
                      None
                    else
                      Some
                        (fun path =>
                          Scriptable.output_row None scriptable
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Unknown: " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "Unknown: %s" % string) path)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (Lwt_stream.iter_s
                                      (fun line =>
                                        (* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "    |" % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.End_of_format))
                                            "    |%s" % string) line)
                                      (Lwt_io.lines_of_file path))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      return_unit)))
                            (script_row "unknown-event" % string "-" % string
                              "-" % string path)) in
                  let time_query :=
                    match (since, until) with
                    | (None, None) => None
                    | (Some a, None) | (None, Some a) => Some a
                    | (Some a, Some b) =>
                      Some
                        (* ❌ Variants not supported *)
                        variant
                    end in
                  op_gtgteqquestion
                    (File_event_sink.Query.fold on_unknown only_sections
                      only_names time_query uri tt
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        fun time_stamp =>
                          fun ev =>
                            let o := Internal_event.Generic.explode_event ev in
                            let time_string (time_value : Z) : string :=
                              let tm := gmtime time_value in
                              Printf.sprintf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    (CamlinternalFormatBasics.Lit_padding
                                      CamlinternalFormatBasics.Zeros 4)
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.Int
                                      CamlinternalFormatBasics.Int_d
                                      (CamlinternalFormatBasics.Lit_padding
                                        CamlinternalFormatBasics.Zeros 2)
                                      CamlinternalFormatBasics.No_precision
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        (CamlinternalFormatBasics.Lit_padding
                                          CamlinternalFormatBasics.Zeros 2)
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.Char_literal
                                          "-" % char
                                          (CamlinternalFormatBasics.Int
                                            CamlinternalFormatBasics.Int_d
                                            (CamlinternalFormatBasics.Lit_padding
                                              CamlinternalFormatBasics.Zeros 2)
                                            CamlinternalFormatBasics.No_precision
                                            (CamlinternalFormatBasics.Int
                                              CamlinternalFormatBasics.Int_d
                                              (CamlinternalFormatBasics.Lit_padding
                                                CamlinternalFormatBasics.Zeros 2)
                                              CamlinternalFormatBasics.No_precision
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_d
                                                (CamlinternalFormatBasics.Lit_padding
                                                  CamlinternalFormatBasics.Zeros
                                                  2)
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.Char_literal
                                                  "-" % char
                                                  (CamlinternalFormatBasics.Int
                                                    CamlinternalFormatBasics.Int_d
                                                    (CamlinternalFormatBasics.Lit_padding
                                                      CamlinternalFormatBasics.Zeros
                                                      4)
                                                    CamlinternalFormatBasics.No_precision
                                                    CamlinternalFormatBasics.End_of_format)))))))))
                                  "%04d%02d%02d-%02d%02d%02d-%04d" % string)
                                (Z.add 1900 (tm_year tm)) (Z.add (tm_mon tm) 1)
                                (tm_mday tm) (tm_hour tm) (tm_min tm)
                                (tm_sec tm)
                                (OCaml.Stdlib.reverse_apply
                                  (Stdlib.op_starpoint
                                    (Stdlib.op_minuspoint time_value
                                      (Stdlib.floor time_value))
                                    (* ❌ Float constant 10_000. is approximated by the integer 10000 *)
                                    10000) Stdlib.int_of_float) in
                            let pp {J : Type}
                              (fmt : Stdlib.Format.formatter) (o :
                              (Tezos_data_encoding.Data_encoding.Json.json *
                                ((Stdlib.Format.formatter -> unit -> unit) * J)))
                              : unit :=
                              if as_json then
                                Data_encoding.Json.pp fmt
                                  (* ❌ Sending method message is not handled *)
                                  send
                              else
                                (* ❌ Sending method message is not handled *)
                                send fmt tt in
                            Scriptable.output_row None scriptable
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<2>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "* [" % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.Char_literal
                                              " " % char
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.Char_literal
                                                  "]" % char
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        CamlinternalFormatBasics.End_of_format)))))))))
                                      "@[<2>* [%s %s]@ %a@]" % string)
                                    (time_string time_stamp)
                                    (* ❌ Sending method message is not handled *)
                                    send pp o)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                let text := flat_pp pp o in
                                script_row "event" % string
                                  (time_string time_stamp)
                                  (* ❌ Sending method message is not handled *)
                                  send text tt)))
                    (fun function_parameter =>
                      match function_parameter with
                      | ([], tt) => return_unit
                      | (errors_and_warnings, tt) =>
                        Scriptable.output None scriptable
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "### Some things were not perfect:" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<2>" % string))
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "### Some things were not perfect:@.@[<2>%a@]"
                                    % string)
                                (pp_print_list
                                  (Some
                                    (fun fmt =>
                                      fun function_parameter =>
                                        let 'tt := function_parameter in
                                        fprintf fmt
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format)
                                            "@." % string)))
                                  (fun fmt =>
                                    fun item =>
                                      fprintf fmt
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "* " % string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "* %a" % string)
                                        File_event_sink.Query.Report.pp item))
                                errors_and_warnings)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            let make_row
                              (e :
                              Tezos_stdlib_unix.File_event_sink.Query.Report.item)
                              : list string :=
                              let text :=
                                flat_pp File_event_sink.Query.Report.pp e in
                              let tag :=
                                match e with
                                | Error _ => "error" % string
                                | Warning _ => "warning" % string
                                end in
                              script_row tag "-" % string "-" % string text tt
                              in
                            List.map make_row errors_and_warnings)
                      end))
            | Some other =>
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "URI scheme " % string
                      (CamlinternalFormatBasics.Caml_string
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          " not handled as of now." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "URI scheme %S not handled as of now." % string) other)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)
            end))
    (cons
      (command
        "Display configuration/state information about the internal-event logging framework."
          % string no_options
        (apply
          (prefixes (cons "show" % string (cons "event-logging" % string [])))
          stop)
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun cctxt =>
            let pp_event_definitions {J : Type}
              (fmt : Stdlib.Format.formatter) (schs :
              list ((string * (string * J)))) : unit :=
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := pp_open_box fmt 0 in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                pp_print_list
                  (Some
                    (fun fmt =>
                      fun function_parameter =>
                        let 'tt := function_parameter in
                        fprintf fmt
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@;" % string 1 0)
                              CamlinternalFormatBasics.End_of_format)
                            "@;" % string)))
                  (fun fmt =>
                    fun obj_schema =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ := pp_open_box fmt 2 in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        fprintf fmt
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "* `" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  "`:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    CamlinternalFormatBasics.End_of_format))))
                            "* `%s`:@ " % string)
                          (* ❌ Sending method message is not handled *)
                          send in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        pp_print_text fmt
                          (* ❌ Sending method message is not handled *)
                          send in
                      pp_close_box fmt tt) fmt schs in
              pp_close_box fmt tt in
            op_gtgteq
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Event logging framework:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Flush_newline
                      (CamlinternalFormatBasics.String_literal
                        "Sinks state:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              (CamlinternalFormatBasics.String_literal
                                "Events registered:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format)))))))))
                  "Event logging framework:@.Sinks state:@ %a@.Events registered:@ %a"
                    % string) Internal_event.All_sinks.pp_state tt
                pp_event_definitions
                (OCaml.Stdlib.reverse_apply (All_definitions.get tt)
                  (List.map Generic.json_schema)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)))
      (cons
        (command "Output the JSON schema of an internal-event." % string
          no_options
          (apply
            (prefixes
              (cons "output" % string
                (cons "schema" % string (cons "of" % string []))))
            (apply
              (param "Event-Name" % string "Name of the event" % string
                (parameter None
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    fun s => _return s)))
              (apply (prefix "to" % string)
                (apply
                  (param "File-path" % string "Path to a JSON file" % string
                    (parameter None
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        fun s => _return s))) stop))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun event =>
              fun path =>
                fun cctxt =>
                  match All_definitions.find (equiv_decb event) with
                  | None =>
                    failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Event " % string
                          (CamlinternalFormatBasics.Caml_string
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " not found" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Event %S not found" % string) event
                  | Some ev =>
                    let o := Generic.json_schema ev in
                    op_gtgteq
                      (Lwt_io.with_file None None None Lwt_io.output path
                        (fun chan =>
                          let v :=
                            Format.asprintf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string) Json_schema.pp
                              (* ❌ Sending method message is not handled *)
                              send in
                          Lwt_io.write chan v))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Wrote schema of " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " to " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.End_of_format))))
                              "Wrote schema of %s to %s" % string) event path)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit))
                  end)) [])).

src/lib_client_commands/client_helpers_commands.ml 82 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let unique_switch =
  Clic.switch
    ~long:"unique"
    ~short:'u'
    ~doc:"Fail when there is more than one possible completion."
    ()

let commands () =
  Clic.
    [ command
        ~desc:
          "Autocomplete a prefix of Base58Check-encoded hash.\n\
           This actually works only for blocks, operations, public key and \
           contract identifiers."
        (args1 unique_switch)
        ( prefixes ["complete"]
        @@ string ~name:"prefix" ~desc:"the prefix of the hash to complete"
        @@ stop )
        (fun unique prefix (cctxt : #Client_context.full) ->
          Shell_services.Blocks.Helpers.complete
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            prefix
          >>=? fun completions ->
          match completions with
          | [] ->
              Pervasives.exit 3
          | _ :: _ :: _ when unique ->
              Pervasives.exit 3
          | completions ->
              List.iter print_endline completions ;
              return_unit);
      command
        ~desc:"Wait for the node to be bootstrapped."
        no_options
        (prefixes ["bootstrapped"] @@ stop)
        (fun () (cctxt : #Client_context.full) ->
          Monitor_services.bootstrapped cctxt
          >>=? fun (stream, _) ->
          Lwt_stream.iter_s
            (fun (hash, time) ->
              cctxt#message
                "Current head: %a (timestamp: %a, validation: %a)"
                Block_hash.pp_short
                hash
                Time.System.pp_hum
                (Time.System.of_protocol_exn time)
                Time.System.pp_hum
                (Tezos_stdlib_unix.Systime_os.now ()))
            stream
          >>= fun () -> cctxt#answer "Bootstrapped." >>= fun () -> return_unit)
    ]
src/lib_client_commands/client_helpers_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition unique_switch {F G I a b i o p q : Type}
  : Tezos_base__TzPervasives.Clic.arg bool
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) :=
  Clic.switch "Fail when there is more than one possible completion." % string
    (Some "u" % char) "unique" % string tt.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let 'tt := function_parameter in
  cons
    (command None
      "Autocomplete a prefix of Base58Check-encoded hash.
This actually works only for blocks, operations, public key and contract identifiers."
        % string (args1 unique_switch)
      (apply (prefixes (cons "complete" % string []))
        (apply
          (string "prefix" % string
            "the prefix of the hash to complete" % string) stop))
      (fun unique =>
        fun prefix =>
          fun cctxt =>
            op_gtgteqquestion
              (Shell_services.Blocks.Helpers.complete cctxt
                (Some
                  (* ❌ Sending method message is not handled *)
                  send)
                (Some
                  (* ❌ Sending method message is not handled *)
                  send) prefix)
              (fun completions =>
                match completions with
                | [] => Pervasives.exit 3
                | cons _ (cons _ _) => Pervasives.exit 3
                | completions =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := List.iter OCaml.Stdlib.print_endline completions in
                  return_unit
                end)))
    (cons
      (command None "Wait for the node to be bootstrapped." % string no_options
        (apply (prefixes (cons "bootstrapped" % string [])) stop)
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun cctxt =>
            op_gtgteqquestion (Monitor_services.bootstrapped cctxt)
              (fun function_parameter =>
                let '(stream, _) := function_parameter in
                op_gtgteq
                  (Lwt_stream.iter_s
                    (fun function_parameter =>
                      let '(hash, time) := function_parameter in
                      (* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Current head: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " (timestamp: " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    ", validation: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        ")" % char
                                        CamlinternalFormatBasics.End_of_format)))))))
                          "Current head: %a (timestamp: %a, validation: %a)" %
                            string) Block_hash.pp_short hash Time.System.pp_hum
                        (Time.System.of_protocol_exn time) Time.System.pp_hum
                        (Tezos_stdlib_unix.Systime_os.now tt)) stream)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Bootstrapped." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Bootstrapped." % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit))))) []).

src/lib_client_commands/client_keys_commands.ml 168 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

let group =
  {
    Clic.name = "keys";
    title = "Commands for managing the wallet of cryptographic keys";
  }

let algo_param () =
  Clic.parameter
    ~autocomplete:(fun _ -> return ["ed25519"; "secp256k1"; "p256"])
    (fun _ name ->
      match name with
      | "ed25519" ->
          return Signature.Ed25519
      | "secp256k1" ->
          return Signature.Secp256k1
      | "p256" ->
          return Signature.P256
      | name ->
          failwith
            "Unknown signature algorithm (%s). Available: 'ed25519', \
             'secp256k1' or 'p256'"
            name)

let sig_algo_arg =
  Clic.default_arg
    ~doc:"use custom signature algorithm"
    ~long:"sig"
    ~short:'s'
    ~placeholder:"ed25519|secp256k1|p256"
    ~default:"ed25519"
    (algo_param ())

let gen_keys_containing ?(encrypted = false) ?(prefix = false) ?(force = false)
    ~containing ~name (cctxt : #Client_context.io_wallet) =
  let unrepresentable =
    List.filter
      (fun s ->
        not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s)
      containing
  in
  let good_initial_char = "KLMNPQRSTUVWXYZabcdefghi" in
  let bad_initial_char = "123456789ABCDEFGHJjkmnopqrstuvwxyz" in
  match unrepresentable with
  | _ :: _ ->
      cctxt#error
        "@[<v 0>The following words can't be written in the key alphabet: %a.@,\
         Valid characters: %a@,\
         Extra restriction for the first character: %s@]"
        (Format.pp_print_list
           ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
           (fun ppf s -> Format.fprintf ppf "'%s'" s))
        unrepresentable
        Base58.Alphabet.pp
        Base58.Alphabet.bitcoin
        good_initial_char
  | [] -> (
      let unrepresentable =
        List.filter
          (fun s -> prefix && String.contains bad_initial_char s.[0])
          containing
      in
      match unrepresentable with
      | _ :: _ ->
          cctxt#error
            "@[<v 0>The following words don't respect the first character \
             restriction: %a.@,\
             Valid characters: %a@,\
             Extra restriction for the first character: %s@]"
            (Format.pp_print_list
               ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ")
               (fun ppf s -> Format.fprintf ppf "'%s'" s))
            unrepresentable
            Base58.Alphabet.pp
            Base58.Alphabet.bitcoin
            good_initial_char
      | [] ->
          Public_key_hash.mem cctxt name
          >>=? fun name_exists ->
          if name_exists && not force then
            cctxt#warning
              "Key for name '%s' already exists. Use --force to update."
              name
            >>= return
          else
            cctxt#warning
              "This process uses a brute force search and may take a long \
               time to find a key."
            >>= fun () ->
            let matches =
              if prefix then
                let containing_tz1 = List.map (( ^ ) "tz1") containing in
                fun key ->
                  List.exists
                    (fun containing ->
                      String.sub key 0 (String.length containing) = containing)
                    containing_tz1
              else
                let re = Re.Str.regexp (String.concat "\\|" containing) in
                fun key ->
                  try
                    ignore (Re.Str.search_forward re key 0) ;
                    true
                  with Not_found -> false
            in
            let rec loop attempts =
              let (public_key_hash, public_key, secret_key) =
                Signature.generate_key ()
              in
              let hash =
                Signature.Public_key_hash.to_b58check
                @@ Signature.Public_key.hash public_key
              in
              if matches hash then
                let pk_uri =
                  Tezos_signer_backends.Unencrypted.make_pk public_key
                in
                ( if encrypted then
                  Tezos_signer_backends.Encrypted.encrypt cctxt secret_key
                else
                  return (Tezos_signer_backends.Unencrypted.make_sk secret_key)
                )
                >>=? fun sk_uri ->
                register_key
                  cctxt
                  ~force
                  (public_key_hash, pk_uri, sk_uri)
                  name
                >>=? fun () -> return hash
              else
                ( if attempts mod 25_000 = 0 then
                  cctxt#message
                    "Tried %d keys without finding a match"
                    attempts
                else Lwt.return_unit )
                >>= fun () ->
                Lwt_unix.yield () >>= fun () -> loop (attempts + 1)
            in
            loop 1
            >>=? fun key_hash ->
            cctxt#message "Generated '%s' under the name '%s'." key_hash name
            >>= fun () -> return_unit )

let rec input_fundraiser_params (cctxt : #Client_context.io_wallet) =
  let rec get_boolean_answer (cctxt : #Client_context.io_wallet) ~default ~msg
      =
    let prompt = if default then "(Y/n/q)" else "(y/N/q)" in
    cctxt#prompt "%s %s: " msg prompt
    >>=? fun gen ->
    match (default, String.lowercase_ascii gen) with
    | (default, "") ->
        return default
    | (_, "y") ->
        return_true
    | (_, "n") ->
        return_false
    | (_, "q") ->
        failwith "Exit by user request."
    | _ ->
        get_boolean_answer cctxt ~msg ~default
  in
  cctxt#prompt "Enter the e-mail used for the paper wallet: "
  >>=? fun email ->
  let rec loop_words acc i =
    if i > 14 then return (List.rev acc)
    else
      cctxt#prompt_password "Enter word %d: " i
      >>=? fun word ->
      match Bip39.index_of_word (Bigstring.to_string word) with
      | None ->
          loop_words acc i
      | Some wordidx ->
          loop_words (wordidx :: acc) (succ i)
  in
  loop_words [] 0
  >>=? fun words ->
  match Bip39.of_indices words with
  | None ->
      assert false
  | Some t -> (
      cctxt#prompt_password "Enter the password used for the paper wallet: "
      >>=? fun password ->
      (* TODO: unicode normalization (NFKD)... *)
      let passphrase = Bigstring.(concat "" [of_string email; password]) in
      let sk = Bip39.to_seed ~passphrase t in
      let sk = Bigstring.sub_bytes sk 0 32 in
      let sk : Signature.Secret_key.t =
        Ed25519
          (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
      in
      let pk = Signature.Secret_key.to_public_key sk in
      let pkh = Signature.Public_key.hash pk in
      let msg =
        Format.asprintf
          "Your public Tezos address is %a is that correct?"
          Signature.Public_key_hash.pp
          pkh
      in
      get_boolean_answer cctxt ~msg ~default:true
      >>=? function
      | true -> return sk | false -> input_fundraiser_params cctxt )

let commands version : Client_context.full Clic.command list =
  let open Clic in
  let encrypted_switch () =
    if
      List.exists
        (fun (scheme, _) -> scheme = Tezos_signer_backends.Unencrypted.scheme)
        (Client_keys.registered_signers ())
    then Clic.switch ~long:"encrypted" ~doc:"Encrypt the key on-disk" ()
    else Clic.constant true
  in
  let show_private_switch =
    switch ~long:"show-secret" ~short:'S' ~doc:"show the private key" ()
  in
  [ command
      ~group
      ~desc:
        "List supported signing schemes.\n\
         Signing schemes are identifiers for signer modules: the built-in \
         signing routines, a hardware wallet, an external agent, etc.\n\
         Each signer has its own format for describing secret keys, such a \
         raw secret key for the default `unencrypted` scheme, the path on a \
         hardware security module, an alias for an external agent, etc.\n\
         This command gives the list of signer modules that this version of \
         the tezos client supports."
      no_options
      (fixed ["list"; "signing"; "schemes"])
      (fun () (cctxt : Client_context.full) ->
        let signers =
          List.sort
            (fun (ka, _) (kb, _) -> String.compare ka kb)
            (registered_signers ())
        in
        Lwt_list.iter_s
          (fun (n, (module S : SIGNER)) ->
            cctxt#message
              "@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]"
              n
              S.title
              Format.pp_print_text
              S.description)
          signers
        >>= return);
    ( match version with
    | Some `Mainnet ->
        command
          ~group
          ~desc:"Generate a pair of keys."
          (args2 (Secret_key.force_switch ()) sig_algo_arg)
          (prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
          (fun (force, algo) name (cctxt : Client_context.full) ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            let (pkh, pk, sk) = Signature.generate_key ~algo () in
            let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
            Tezos_signer_backends.Encrypted.encrypt cctxt sk
            >>=? fun sk_uri ->
            register_key cctxt ~force (pkh, pk_uri, sk_uri) name)
    | _ ->
        command
          ~group
          ~desc:"Generate a pair of keys."
          (args3
             (Secret_key.force_switch ())
             sig_algo_arg
             (encrypted_switch ()))
          (prefixes ["gen"; "keys"] @@ Secret_key.fresh_alias_param @@ stop)
          (fun (force, algo, encrypted) name (cctxt : Client_context.full) ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            let (pkh, pk, sk) = Signature.generate_key ~algo () in
            let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
            ( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
            else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
            >>=? fun sk_uri ->
            register_key cctxt ~force (pkh, pk_uri, sk_uri) name) );
    ( match version with
    | Some `Mainnet ->
        command
          ~group
          ~desc:"Generate keys including the given string."
          (args2
             (switch
                ~long:"prefix"
                ~short:'P'
                ~doc:"the key must begin with tz1[word]"
                ())
             (force_switch ()))
          ( prefixes ["gen"; "vanity"; "keys"]
          @@ Public_key_hash.fresh_alias_param @@ prefix "matching"
          @@ seq_of_param
          @@ string
               ~name:"words"
               ~desc:"string key must contain one of these words" )
          (fun (prefix, force) name containing (cctxt : Client_context.full) ->
            Public_key_hash.of_fresh cctxt force name
            >>=? fun name ->
            gen_keys_containing
              ~encrypted:true
              ~force
              ~prefix
              ~containing
              ~name
              cctxt)
    | _ ->
        command
          ~group
          ~desc:"Generate keys including the given string."
          (args3
             (switch
                ~long:"prefix"
                ~short:'P'
                ~doc:"the key must begin with tz1[word]"
                ())
             (force_switch ())
             (encrypted_switch ()))
          ( prefixes ["gen"; "vanity"; "keys"]
          @@ Public_key_hash.fresh_alias_param @@ prefix "matching"
          @@ seq_of_param
          @@ string
               ~name:"words"
               ~desc:"string key must contain one of these words" )
          (fun (prefix, force, encrypted)
               name
               containing
               (cctxt : Client_context.full) ->
            Public_key_hash.of_fresh cctxt force name
            >>=? fun name ->
            gen_keys_containing
              ~encrypted
              ~force
              ~prefix
              ~containing
              ~name
              cctxt) );
    command
      ~group
      ~desc:"Encrypt an unencrypted secret key."
      no_options
      (prefixes ["encrypt"; "secret"; "key"] @@ stop)
      (fun () (cctxt : Client_context.full) ->
        cctxt#prompt_password "Enter unencrypted secret key: "
        >>=? fun sk_uri ->
        let sk_uri = Uri.of_string (Bigstring.to_string sk_uri) in
        ( match Uri.scheme sk_uri with
        | None | Some "unencrypted" ->
            return_unit
        | _ ->
            failwith
              "This command can only be used with the \"unencrypted\" scheme"
        )
        >>=? fun () ->
        Lwt.return (Signature.Secret_key.of_b58check (Uri.path sk_uri))
        >>=? fun sk ->
        Tezos_signer_backends.Encrypted.encrypt cctxt sk
        >>=? fun sk_uri ->
        cctxt#message "Encrypted secret key %a" Uri.pp_hum (sk_uri :> Uri.t)
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Add a secret key to the wallet."
      (args1 (Secret_key.force_switch ()))
      ( prefix "import"
      @@ prefixes ["secret"; "key"]
      @@ Secret_key.fresh_alias_param @@ Client_keys.sk_uri_param @@ stop )
      (fun force name sk_uri (cctxt : Client_context.full) ->
        Secret_key.of_fresh cctxt force name
        >>=? fun name ->
        Client_keys.neuterize sk_uri
        >>=? fun pk_uri ->
        Public_key.find_opt cctxt name
        >>=? (function
               | None ->
                   return_unit
               | Some (pk_uri_found, _) ->
                   fail_unless
                     (pk_uri = pk_uri_found || force)
                     (failure
                        "public and secret keys '%s' don't correspond, please \
                         don't use --force"
                        name))
        >>=? fun () ->
        Client_keys.import_secret_key
          ~io:(cctxt :> Client_context.io_wallet)
          pk_uri
        >>=? fun (pkh, public_key) ->
        cctxt#message
          "Tezos address added: %a"
          Signature.Public_key_hash.pp
          pkh
        >>= fun () ->
        register_key cctxt ~force (pkh, pk_uri, sk_uri) ?public_key name) ]
  @ ( if version <> Some `Mainnet then []
    else
      [ command
          ~group
          ~desc:"Add a fundraiser secret key to the wallet."
          (args1 (Secret_key.force_switch ()))
          ( prefix "import"
          @@ prefixes ["fundraiser"; "secret"; "key"]
          @@ Secret_key.fresh_alias_param @@ stop )
          (fun force name (cctxt : Client_context.full) ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            input_fundraiser_params cctxt
            >>=? fun sk ->
            Tezos_signer_backends.Encrypted.encrypt cctxt sk
            >>=? fun sk_uri ->
            Client_keys.neuterize sk_uri
            >>=? fun pk_uri ->
            Public_key.find_opt cctxt name
            >>=? (function
                   | None ->
                       return_unit
                   | Some (pk_uri_found, _) ->
                       fail_unless
                         (pk_uri = pk_uri_found || force)
                         (failure
                            "public and secret keys '%s' don't correspond, \
                             please don't use --force"
                            name))
            >>=? fun () ->
            Client_keys.public_key_hash pk_uri
            >>=? fun (pkh, _public_key) ->
            register_key cctxt ~force (pkh, pk_uri, sk_uri) name) ] )
  @ [ command
        ~group
        ~desc:"Add a public key to the wallet."
        (args1 (Public_key.force_switch ()))
        ( prefix "import"
        @@ prefixes ["public"; "key"]
        @@ Public_key.fresh_alias_param @@ Client_keys.pk_uri_param @@ stop )
        (fun force name pk_uri (cctxt : Client_context.full) ->
          Public_key.of_fresh cctxt force name
          >>=? fun name ->
          Client_keys.public_key_hash pk_uri
          >>=? fun (pkh, public_key) ->
          Public_key_hash.add ~force cctxt name pkh
          >>=? fun () ->
          cctxt#message
            "Tezos address added: %a"
            Signature.Public_key_hash.pp
            pkh
          >>= fun () -> Public_key.add ~force cctxt name (pk_uri, public_key));
      command
        ~group
        ~desc:"Add an address to the wallet."
        (args1 (Public_key.force_switch ()))
        ( prefixes ["add"; "address"]
        @@ Public_key_hash.fresh_alias_param @@ Public_key_hash.source_param
        @@ stop )
        (fun force name hash cctxt ->
          Public_key_hash.of_fresh cctxt force name
          >>=? fun name -> Public_key_hash.add ~force cctxt name hash);
      command
        ~group
        ~desc:"List all addresses and associated keys."
        no_options
        (fixed ["list"; "known"; "addresses"])
        (fun () (cctxt : #Client_context.full) ->
          list_keys cctxt
          >>=? fun l ->
          iter_s
            (fun (name, pkh, pk, sk) ->
              Public_key_hash.to_source pkh
              >>=? fun v ->
              ( match (pk, sk) with
              | (None, None) ->
                  cctxt#message "%s: %s" name v
              | (_, Some uri) ->
                  let scheme =
                    Option.unopt ~default:"unencrypted"
                    @@ Uri.scheme (uri : sk_uri :> Uri.t)
                  in
                  cctxt#message "%s: %s (%s sk known)" name v scheme
              | (Some _, _) ->
                  cctxt#message "%s: %s (pk known)" name v )
              >>= fun () -> return_unit)
            l);
      command
        ~group
        ~desc:"Show the keys associated with an implicit account."
        (args1 show_private_switch)
        (prefixes ["show"; "address"] @@ Public_key_hash.alias_param @@ stop)
        (fun show_private (name, _) (cctxt : #Client_context.full) ->
          alias_keys cctxt name
          >>=? fun key_info ->
          match key_info with
          | None ->
              cctxt#message "No keys found for address"
              >>= fun () -> return_unit
          | Some (pkh, pk, skloc) -> (
              cctxt#message "Hash: %a" Signature.Public_key_hash.pp pkh
              >>= fun () ->
              match pk with
              | None ->
                  return_unit
              | Some pk ->
                  cctxt#message "Public Key: %a" Signature.Public_key.pp pk
                  >>= fun () ->
                  if show_private then
                    match skloc with
                    | None ->
                        return_unit
                    | Some skloc ->
                        Secret_key.to_source skloc
                        >>=? fun skloc ->
                        cctxt#message "Secret Key: %s" skloc
                        >>= fun () -> return_unit
                  else return_unit ));
      command
        ~group
        ~desc:"Forget one address."
        (args1
           (Clic.switch
              ~long:"force"
              ~short:'f'
              ~doc:"delete associated keys when present"
              ()))
        (prefixes ["forget"; "address"] @@ Public_key_hash.alias_param @@ stop)
        (fun force (name, _pkh) (cctxt : Client_context.full) ->
          Secret_key.mem cctxt name
          >>=? fun has_secret_key ->
          Public_key.mem cctxt name
          >>=? fun has_public_key ->
          fail_when
            ((not force) && (has_secret_key || has_public_key))
            (failure
               "secret or public key present for %s, use --force to delete"
               name)
          >>=? fun () ->
          Secret_key.del cctxt name
          >>=? fun () ->
          Public_key.del cctxt name
          >>=? fun () -> Public_key_hash.del cctxt name);
      command
        ~group
        ~desc:"Forget the entire wallet of keys."
        (args1
           (Clic.switch
              ~long:"force"
              ~short:'f'
              ~doc:"you got to use the force for that"
              ()))
        (fixed ["forget"; "all"; "keys"])
        (fun force (cctxt : Client_context.full) ->
          fail_unless
            force
            (failure "this can only be used with option --force")
          >>=? fun () ->
          Public_key.set cctxt []
          >>=? fun () ->
          Secret_key.set cctxt [] >>=? fun () -> Public_key_hash.set cctxt []);
      command
        ~group
        ~desc:"Compute deterministic nonce."
        no_options
        ( prefixes ["generate"; "nonce"; "for"]
        @@ Public_key_hash.alias_param
        @@ prefixes ["from"]
        @@ string
             ~name:"data"
             ~desc:"string from which to deterministically generate the nonce"
        @@ stop )
        (fun () (name, _pkh) data (cctxt : Client_context.full) ->
          let data = Bytes.of_string data in
          Secret_key.mem cctxt name
          >>=? fun sk_present ->
          fail_unless sk_present (failure "secret key not present for %s" name)
          >>=? fun () ->
          Secret_key.find cctxt name
          >>=? fun sk_uri ->
          Client_keys.deterministic_nonce sk_uri data
          >>=? fun nonce ->
          cctxt#message "%a" Hex.pp (Hex.of_bytes (Bigstring.to_bytes nonce))
          >>= fun () -> return_unit);
      command
        ~group
        ~desc:"Compute deterministic nonce hash."
        no_options
        ( prefixes ["generate"; "nonce"; "hash"; "for"]
        @@ Public_key_hash.alias_param
        @@ prefixes ["from"]
        @@ string
             ~name:"data"
             ~desc:
               "string from which to deterministically generate the nonce hash"
        @@ stop )
        (fun () (name, _pkh) data (cctxt : Client_context.full) ->
          let data = Bytes.of_string data in
          Secret_key.mem cctxt name
          >>=? fun sk_present ->
          fail_unless sk_present (failure "secret key not present for %s" name)
          >>=? fun () ->
          Secret_key.find cctxt name
          >>=? fun sk_uri ->
          Client_keys.deterministic_nonce_hash sk_uri data
          >>=? fun nonce_hash ->
          cctxt#message "%a" Hex.pp (Hex.of_bytes nonce_hash)
          >>= fun () -> return_unit) ]
src/lib_client_commands/client_keys_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_keys.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "keys" % string;
    Clic.title :=
      "Commands for managing the wallet of cryptographic keys" % string |}.

Definition algo_param {A : Type} (function_parameter : unit)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_base__TzPervasives.Signature.algo A :=
  let 'tt := function_parameter in
  Clic.parameter
    (Some
      (fun function_parameter =>
        let '_ := function_parameter in
        _return
          (cons "ed25519" % string
            (cons "secp256k1" % string (cons "p256" % string [])))))
    (fun function_parameter =>
      let '_ := function_parameter in
      fun name =>
        match name with
        | "ed25519" % string =>
          _return Tezos_base__TzPervasives.Signature.Ed25519
        | "secp256k1" % string =>
          _return Tezos_base__TzPervasives.Signature.Secp256k1
        | "p256" % string => _return Tezos_base__TzPervasives.Signature.P256
        | name =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Unknown signature algorithm (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    "). Available: 'ed25519', 'secp256k1' or 'p256'" % string
                    CamlinternalFormatBasics.End_of_format)))
              "Unknown signature algorithm (%s). Available: 'ed25519', 'secp256k1' or 'p256'"
                % string) name
        end).

Definition sig_algo_arg
  : Tezos_base__TzPervasives.Clic.arg Tezos_base__TzPervasives.Signature.algo
    Tezos_client_base.Client_context.full :=
  Clic.default_arg "use custom signature algorithm" % string (Some "s" % char)
    "sig" % string "ed25519|secp256k1|p256" % string "ed25519" % string
    (algo_param tt).

Definition gen_keys_containing {C a b : Type} (op_staroptstar : option bool)
  : (option bool) ->
    (option bool) ->
      (list string) ->
        string ->
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        (((string ->
                          (Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) *
                            ((((Tezos_client_base.Client_context.lwt_format a
                              (Tezos_base__TzPervasives.tzresult string)) -> a)
                              * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                (Tezos_base__TzPervasives.tzresult Bigstring.t))
                                -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) * C)))))))))))) * C) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let encrypted :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun op_staroptstar =>
    let prefix :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun op_staroptstar =>
      let force :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => false
        end in
      fun containing =>
        fun name =>
          fun cctxt =>
            let unrepresentable :=
              List.filter
                (fun s =>
                  apply negb
                    (Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s))
                containing in
            let good_initial_char := "KLMNPQRSTUVWXYZabcdefghi" % string in
            let bad_initial_char :=
              "123456789ABCDEFGHJjkmnopqrstuvwxyz" % string in
            match unrepresentable with
            | cons _ _ =>
              (* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 0>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 0>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "The following words can't be written in the key alphabet: "
                        % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "." % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "Valid characters: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "Extra restriction for the first character: "
                                      % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))))))))
                  "@[<v 0>The following words can't be written in the key alphabet: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
                    % string)
                (Format.pp_print_list
                  (Some
                    (fun ppf =>
                      fun function_parameter =>
                        let 'tt := function_parameter in
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              ", " % string
                              CamlinternalFormatBasics.End_of_format)
                            ", " % string)))
                  (fun ppf =>
                    fun s =>
                      Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Char_literal "'" % char
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Char_literal "'" % char
                                CamlinternalFormatBasics.End_of_format)))
                          "'%s'" % string) s)) unrepresentable
                Base58.Alphabet.pp Base58.Alphabet.bitcoin good_initial_char
            | [] =>
              let unrepresentable :=
                List.filter
                  (fun s =>
                    andb prefix
                      (String.contains bad_initial_char (String.get s 0)))
                  containing in
              match unrepresentable with
              | cons _ _ =>
                (* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "The following words don't respect the first character restriction: "
                          % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "." % char
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "Valid characters: " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "Extra restriction for the first character: "
                                        % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))))))
                    "@[<v 0>The following words don't respect the first character restriction: %a.@,Valid characters: %a@,Extra restriction for the first character: %s@]"
                      % string)
                  (Format.pp_print_list
                    (Some
                      (fun ppf =>
                        fun function_parameter =>
                          let 'tt := function_parameter in
                          Format.fprintf ppf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                ", " % string
                                CamlinternalFormatBasics.End_of_format)
                              ", " % string)))
                    (fun ppf =>
                      fun s =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Char_literal "'" % char
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Char_literal
                                  "'" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "'%s'" % string) s)) unrepresentable
                  Base58.Alphabet.pp Base58.Alphabet.bitcoin good_initial_char
              | [] =>
                op_gtgteqquestion (Public_key_hash.mem cctxt name)
                  (fun name_exists =>
                    if andb name_exists (negb force) then
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Key for name '" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  "' already exists. Use --force to update." %
                                    string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Key for name '%s' already exists. Use --force to update."
                              % string) name) _return
                    else
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "This process uses a brute force search and may take a long time to find a key."
                                % string CamlinternalFormatBasics.End_of_format)
                            "This process uses a brute force search and may take a long time to find a key."
                              % string))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          let matches :=
                            if prefix then
                              let containing_tz1 :=
                                List.map (String.append "tz1" % string)
                                  containing in
                              fun key =>
                                List._exists
                                  (fun containing =>
                                    equiv_decb
                                      (String.sub key 0
                                        (String.length containing)) containing)
                                  containing_tz1
                            else
                              let re :=
                                Re.Str.regexp
                                  (String.concat "\|" % string containing) in
                              fun key =>
                                (* ❌ Try-with are not handled *)
                                try
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  (let _ :=
                                    OCaml.Stdlib.ignore
                                      (Re.Str.search_forward re key 0) in
                                  true) in
                          let fix loop (attempts : Z)
                            : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
                            let '(public_key_hash, public_key, secret_key) :=
                              Signature.generate_key None None tt in
                            let hash :=
                              apply Signature.Public_key_hash.to_b58check
                                (Signature.Public_key.hash public_key) in
                            if matches hash then
                              let pk_uri :=
                                Tezos_signer_backends.Unencrypted.make_pk
                                  public_key in
                              op_gtgteqquestion
                                (if encrypted then
                                  Tezos_signer_backends.Encrypted.encrypt cctxt
                                    secret_key
                                else
                                  _return
                                    (Tezos_signer_backends.Unencrypted.make_sk
                                      secret_key))
                                (fun sk_uri =>
                                  op_gtgteqquestion
                                    (register_key cctxt (Some force)
                                      (public_key_hash, pk_uri, sk_uri) None
                                      name)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      _return hash))
                            else
                              op_gtgteq
                                (if equiv_decb (Z.modulo attempts 25000) 0 then
                                  (* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Tried " % string
                                        (CamlinternalFormatBasics.Int
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          (CamlinternalFormatBasics.String_literal
                                            " keys without finding a match" %
                                              string
                                            CamlinternalFormatBasics.End_of_format)))
                                      "Tried %d keys without finding a match" %
                                        string) attempts
                                else
                                  Lwt.return_unit)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq (Lwt_unix.yield tt)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      loop (Z.add attempts 1))) in
                          op_gtgteqquestion (loop 1)
                            (fun key_hash =>
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Generated '" % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          "' under the name '" % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              "'." % string
                                              CamlinternalFormatBasics.End_of_format)))))
                                    "Generated '%s' under the name '%s'." %
                                      string) key_hash name)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit))))
              end
            end.

Fixpoint input_fundraiser_params {C a b : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * C)))))))))))) * C)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  let fix get_boolean_answer {D : Type}
    (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * D)))))))))))) * D) (default : bool)
    (msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    let prompt :=
      if default then
        "(Y/n/q)" % string
      else
        "(y/N/q)" % string in
    op_gtgteqquestion
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal " " % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal ": " % string
                  CamlinternalFormatBasics.End_of_format)))) "%s %s: " % string)
        msg prompt)
      (fun gen =>
        match (default, (String.lowercase_ascii gen)) with
        | (default, "" % string) => _return default
        | (_, "y" % string) => return_true
        | (_, "n" % string) => return_false
        | (_, "q" % string) =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Exit by user request." % string
                CamlinternalFormatBasics.End_of_format)
              "Exit by user request." % string)
        | _ => get_boolean_answer cctxt default msg
        end) in
  op_gtgteqquestion
    ((* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Enter the e-mail used for the paper wallet: " % string
          CamlinternalFormatBasics.End_of_format)
        "Enter the e-mail used for the paper wallet: " % string))
    (fun email =>
      let fix loop_words (acc : list Z) (i : Z)
        : Lwt.t (Tezos_base__TzPervasives.tzresult (list Z)) :=
        if OCaml.Stdlib.gt i 14 then
          _return (List.rev acc)
        else
          op_gtgteqquestion
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Enter word " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ": " % string
                      CamlinternalFormatBasics.End_of_format)))
                "Enter word %d: " % string) i)
            (fun word =>
              match Bip39.index_of_word (Bigstring.to_string word) with
              | None => loop_words acc i
              | Some wordidx => loop_words (cons wordidx acc) (Z.succ i)
              end) in
      op_gtgteqquestion (loop_words [] 0)
        (fun words =>
          match Bip39.of_indices words with
          | None =>
            (* ❌ Assert instruction is not handled. *)
            assert false
          | Some t =>
            op_gtgteqquestion
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Enter the password used for the paper wallet: " % string
                    CamlinternalFormatBasics.End_of_format)
                  "Enter the password used for the paper wallet: " % string))
              (fun password =>
                let passphrase :=
                  concat "" % string (cons (of_string email) (cons password []))
                  in
                let sk := Bip39.to_seed (Some passphrase) t in
                let sk := Bigstring.sub_bytes sk 0 32 in
                let sk :=
                  Tezos_crypto__Signature.Ed25519
                    (Data_encoding.Binary.of_bytes_exn
                      Ed25519.Secret_key.encoding sk) in
                let pk := Signature.Secret_key.to_public_key sk in
                let pkh := Signature.Public_key.hash pk in
                let msg :=
                  Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Your public Tezos address is " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " is that correct?" % string
                            CamlinternalFormatBasics.End_of_format)))
                      "Your public Tezos address is %a is that correct?" %
                        string) Signature.Public_key_hash.pp pkh in
                op_gtgteqquestion (get_boolean_answer cctxt true msg)
                  (fun function_parameter =>
                    match function_parameter with
                    | true => _return sk
                    | false => input_fundraiser_params cctxt
                    end))
          end)).

Definition commands (version : option variant)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  let encrypted_switch {A : Type} (function_parameter : unit)
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    let 'tt := function_parameter in
    if
      List._exists
        (fun function_parameter =>
          let '(scheme, _) := function_parameter in
          equiv_decb scheme Tezos_signer_backends.Unencrypted.scheme)
        (Client_keys.registered_signers tt) then
      Clic.switch "Encrypt the key on-disk" % string None "encrypted" % string
        tt
    else
      Clic.constant true in
  let show_private_switch :=
    switch "show the private key" % string (Some "S" % char)
      "show-secret" % string tt in
  OCaml.Stdlib.app
    (cons
      (command (Some group)
        "List supported signing schemes.
Signing schemes are identifiers for signer modules: the built-in signing routines, a hardware wallet, an external agent, etc.
Each signer has its own format for describing secret keys, such a raw secret key for the default `unencrypted` scheme, the path on a hardware security module, an alias for an external agent, etc.
This command gives the list of signer modules that this version of the tezos client supports."
          % string no_options
        (fixed
          (cons "list" % string
            (cons "signing" % string (cons "schemes" % string []))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun cctxt =>
            let signers :=
              List.sort
                (fun function_parameter =>
                  let '(ka, _) := function_parameter in
                  fun function_parameter =>
                    let '(kb, _) := function_parameter in
                    String.compare ka kb) (registered_signers tt) in
            op_gtgteq
              (Lwt_list.iter_s
                (fun function_parameter =>
                  let '(n, _ as S) := function_parameter in
                  let S := projT2 S in
                  (* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Scheme `" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              "`: " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<hov 0>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<hov 0>" % string))
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))
                      "@[<v 2>Scheme `%s`: %s@,@[<hov 0>%a@]@]" % string) n
                    S.(Tezos_client_base.Client_keys.SIGNER.title)
                    Format.pp_print_text
                    S.(Tezos_client_base.Client_keys.SIGNER.description))
                signers) _return))
      (cons
        match version with
        | Some Mainnet =>
          command (Some group) "Generate a pair of keys." % string
            (args2 (Secret_key.force_switch tt) sig_algo_arg)
            (apply (prefixes (cons "gen" % string (cons "keys" % string [])))
              (apply
                (let arg := Secret_key.fresh_alias_param in
                fun eta => arg None None eta) stop))
            (fun function_parameter =>
              let '(force, algo) := function_parameter in
              fun name =>
                fun cctxt =>
                  op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
                    (fun name =>
                      let '(pkh, pk, sk) :=
                        Signature.generate_key (Some algo) None tt in
                      let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
                        in
                      op_gtgteqquestion
                        (Tezos_signer_backends.Encrypted.encrypt cctxt sk)
                        (fun sk_uri =>
                          register_key cctxt (Some force) (pkh, pk_uri, sk_uri)
                            None name)))
        | _ =>
          command (Some group) "Generate a pair of keys." % string
            (args3 (Secret_key.force_switch tt) sig_algo_arg
              (encrypted_switch tt))
            (apply (prefixes (cons "gen" % string (cons "keys" % string [])))
              (apply
                (let arg := Secret_key.fresh_alias_param in
                fun eta => arg None None eta) stop))
            (fun function_parameter =>
              let '(force, algo, encrypted) := function_parameter in
              fun name =>
                fun cctxt =>
                  op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
                    (fun name =>
                      let '(pkh, pk, sk) :=
                        Signature.generate_key (Some algo) None tt in
                      let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk
                        in
                      op_gtgteqquestion
                        (if encrypted then
                          Tezos_signer_backends.Encrypted.encrypt cctxt sk
                        else
                          _return (Tezos_signer_backends.Unencrypted.make_sk sk))
                        (fun sk_uri =>
                          register_key cctxt (Some force) (pkh, pk_uri, sk_uri)
                            None name)))
        end
        (cons
          match version with
          | Some Mainnet =>
            command (Some group)
              "Generate keys including the given string." % string
              (args2
                (switch "the key must begin with tz1[word]" % string
                  (Some "P" % char) "prefix" % string tt) (force_switch tt))
              (apply
                (prefixes
                  (cons "gen" % string
                    (cons "vanity" % string (cons "keys" % string []))))
                (apply
                  (let arg := Public_key_hash.fresh_alias_param in
                  fun eta => arg None None eta)
                  (apply (prefix "matching" % string)
                    (apply seq_of_param
                      (string "words" % string
                        "string key must contain one of these words" % string)))))
              (fun function_parameter =>
                let '(prefix, force) := function_parameter in
                fun name =>
                  fun containing =>
                    fun cctxt =>
                      op_gtgteqquestion
                        (Public_key_hash.of_fresh cctxt force name)
                        (fun name =>
                          gen_keys_containing (Some true) (Some prefix)
                            (Some force) containing name cctxt))
          | _ =>
            command (Some group)
              "Generate keys including the given string." % string
              (args3
                (switch "the key must begin with tz1[word]" % string
                  (Some "P" % char) "prefix" % string tt) (force_switch tt)
                (encrypted_switch tt))
              (apply
                (prefixes
                  (cons "gen" % string
                    (cons "vanity" % string (cons "keys" % string []))))
                (apply
                  (let arg := Public_key_hash.fresh_alias_param in
                  fun eta => arg None None eta)
                  (apply (prefix "matching" % string)
                    (apply seq_of_param
                      (string "words" % string
                        "string key must contain one of these words" % string)))))
              (fun function_parameter =>
                let '(prefix, force, encrypted) := function_parameter in
                fun name =>
                  fun containing =>
                    fun cctxt =>
                      op_gtgteqquestion
                        (Public_key_hash.of_fresh cctxt force name)
                        (fun name =>
                          gen_keys_containing (Some encrypted) (Some prefix)
                            (Some force) containing name cctxt))
          end
          (cons
            (command (Some group) "Encrypt an unencrypted secret key." % string
              no_options
              (apply
                (prefixes
                  (cons "encrypt" % string
                    (cons "secret" % string (cons "key" % string [])))) stop)
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion
                    ((* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Enter unencrypted secret key: " % string
                          CamlinternalFormatBasics.End_of_format)
                        "Enter unencrypted secret key: " % string))
                    (fun sk_uri =>
                      let sk_uri := Uri.of_string (Bigstring.to_string sk_uri)
                        in
                      op_gtgteqquestion
                        match Uri.scheme sk_uri with
                        | None | Some "unencrypted" % string => return_unit
                        | _ =>
                          failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "This command can only be used with the ""unencrypted"" scheme"
                                  % string
                                CamlinternalFormatBasics.End_of_format)
                              "This command can only be used with the ""unencrypted"" scheme"
                                % string)
                        end
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (Lwt._return
                              (Signature.Secret_key.of_b58check
                                (Uri.path sk_uri)))
                            (fun sk =>
                              op_gtgteqquestion
                                (Tezos_signer_backends.Encrypted.encrypt cctxt
                                  sk)
                                (fun sk_uri =>
                                  op_gtgteq
                                    ((* ❌ Sending method message is not handled *)
                                    send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Encrypted secret key " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))
                                        "Encrypted secret key %a" % string)
                                      Uri.pp_hum sk_uri)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      return_unit)))))))
            (cons
              (command (Some group) "Add a secret key to the wallet." % string
                (args1 (Secret_key.force_switch tt))
                (apply (prefix "import" % string)
                  (apply
                    (prefixes (cons "secret" % string (cons "key" % string [])))
                    (apply
                      (let arg := Secret_key.fresh_alias_param in
                      fun eta => arg None None eta)
                      (apply
                        (let arg := Client_keys.sk_uri_param in
                        fun eta => arg None None eta) stop))))
                (fun force =>
                  fun name =>
                    fun sk_uri =>
                      fun cctxt =>
                        op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
                          (fun name =>
                            op_gtgteqquestion (Client_keys.neuterize sk_uri)
                              (fun pk_uri =>
                                op_gtgteqquestion
                                  (op_gtgteqquestion
                                    (Public_key.find_opt cctxt name)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | None => return_unit
                                      | Some (pk_uri_found, _) =>
                                        fail_unless
                                          (orb (equiv_decb pk_uri pk_uri_found)
                                            force)
                                          (failure
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "public and secret keys '" %
                                                  string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.String_literal
                                                    "' don't correspond, please don't use --force"
                                                      % string
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "public and secret keys '%s' don't correspond, please don't use --force"
                                                % string) name)
                                      end))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (Client_keys.import_secret_key cctxt
                                        pk_uri)
                                      (fun function_parameter =>
                                        let '(pkh, public_key) :=
                                          function_parameter in
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Tezos address added: " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format))
                                              "Tezos address added: %a" % string)
                                            Signature.Public_key_hash.pp pkh)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            register_key cctxt (Some force)
                                              (pkh, pk_uri, sk_uri) public_key
                                              name))))))) [])))))
    (OCaml.Stdlib.app
      (if
        nequiv_decb version
          (Some
            (* ❌ Variants not supported *)
            variant) then
        []
      else
        cons
          (command (Some group)
            "Add a fundraiser secret key to the wallet." % string
            (args1 (Secret_key.force_switch tt))
            (apply (prefix "import" % string)
              (apply
                (prefixes
                  (cons "fundraiser" % string
                    (cons "secret" % string (cons "key" % string []))))
                (apply
                  (let arg := Secret_key.fresh_alias_param in
                  fun eta => arg None None eta) stop)))
            (fun force =>
              fun name =>
                fun cctxt =>
                  op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
                    (fun name =>
                      op_gtgteqquestion (input_fundraiser_params cctxt)
                        (fun sk =>
                          op_gtgteqquestion
                            (Tezos_signer_backends.Encrypted.encrypt cctxt sk)
                            (fun sk_uri =>
                              op_gtgteqquestion (Client_keys.neuterize sk_uri)
                                (fun pk_uri =>
                                  op_gtgteqquestion
                                    (op_gtgteqquestion
                                      (Public_key.find_opt cctxt name)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | None => return_unit
                                        | Some (pk_uri_found, _) =>
                                          fail_unless
                                            (orb
                                              (equiv_decb pk_uri pk_uri_found)
                                              force)
                                            (failure
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "public and secret keys '" %
                                                    string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    (CamlinternalFormatBasics.String_literal
                                                      "' don't correspond, please don't use --force"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)))
                                                "public and secret keys '%s' don't correspond, please don't use --force"
                                                  % string) name)
                                        end))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteqquestion
                                        (Client_keys.public_key_hash pk_uri)
                                        (fun function_parameter =>
                                          let '(pkh, _public_key) :=
                                            function_parameter in
                                          register_key cctxt (Some force)
                                            (pkh, pk_uri, sk_uri) None name))))))))
          [])
      (cons
        (command (Some group) "Add a public key to the wallet." % string
          (args1 (Public_key.force_switch tt))
          (apply (prefix "import" % string)
            (apply (prefixes (cons "public" % string (cons "key" % string [])))
              (apply
                (let arg := Public_key.fresh_alias_param in
                fun eta => arg None None eta)
                (apply
                  (let arg := Client_keys.pk_uri_param in
                  fun eta => arg None None eta) stop))))
          (fun force =>
            fun name =>
              fun pk_uri =>
                fun cctxt =>
                  op_gtgteqquestion (Public_key.of_fresh cctxt force name)
                    (fun name =>
                      op_gtgteqquestion (Client_keys.public_key_hash pk_uri)
                        (fun function_parameter =>
                          let '(pkh, public_key) := function_parameter in
                          op_gtgteqquestion
                            (Public_key_hash.add force cctxt name pkh)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Tezos address added: " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Tezos address added: %a" % string)
                                  Signature.Public_key_hash.pp pkh)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  Public_key.add force cctxt name
                                    (pk_uri, public_key)))))))
        (cons
          (command (Some group) "Add an address to the wallet." % string
            (args1 (Public_key.force_switch tt))
            (apply (prefixes (cons "add" % string (cons "address" % string [])))
              (apply
                (let arg := Public_key_hash.fresh_alias_param in
                fun eta => arg None None eta)
                (apply
                  (let arg := Public_key_hash.source_param in
                  fun eta => arg None None eta) stop)))
            (fun force =>
              fun name =>
                fun hash =>
                  fun cctxt =>
                    op_gtgteqquestion
                      (Public_key_hash.of_fresh cctxt force name)
                      (fun name => Public_key_hash.add force cctxt name hash)))
          (cons
            (command (Some group)
              "List all addresses and associated keys." % string no_options
              (fixed
                (cons "list" % string
                  (cons "known" % string (cons "addresses" % string []))))
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion (list_keys cctxt)
                    (fun l =>
                      iter_s
                        (fun function_parameter =>
                          let '(name, pkh, pk, sk) := function_parameter in
                          op_gtgteqquestion (Public_key_hash.to_source pkh)
                            (fun v =>
                              op_gtgteq
                                match (pk, sk) with
                                | (None, None) =>
                                  (* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          ": " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            CamlinternalFormatBasics.End_of_format)))
                                      "%s: %s" % string) name v
                                | (_, Some uri) =>
                                  let scheme :=
                                    apply (Option.unopt "unencrypted" % string)
                                      (Uri.scheme uri) in
                                  (* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          ": " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " (" % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.String_literal
                                                  " sk known)" % string
                                                  CamlinternalFormatBasics.End_of_format))))))
                                      "%s: %s (%s sk known)" % string) name v
                                    scheme
                                | (Some _, _) =>
                                  (* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.String_literal
                                          ": " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " (pk known)" % string
                                              CamlinternalFormatBasics.End_of_format))))
                                      "%s: %s (pk known)" % string) name v
                                end
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit))) l)))
            (cons
              (command (Some group)
                "Show the keys associated with an implicit account." % string
                (args1 show_private_switch)
                (apply
                  (prefixes (cons "show" % string (cons "address" % string [])))
                  (apply
                    (let arg := Public_key_hash.alias_param in
                    fun eta => arg None None eta) stop))
                (fun show_private =>
                  fun function_parameter =>
                    let '(name, _) := function_parameter in
                    fun cctxt =>
                      op_gtgteqquestion (alias_keys cctxt name)
                        (fun key_info =>
                          match key_info with
                          | None =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "No keys found for address" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "No keys found for address" % string))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit)
                          | Some (pkh, pk, skloc) =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Hash: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format))
                                  "Hash: %a" % string)
                                Signature.Public_key_hash.pp pkh)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                match pk with
                                | None => return_unit
                                | Some pk =>
                                  op_gtgteq
                                    ((* ❌ Sending method message is not handled *)
                                    send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Public Key: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))
                                        "Public Key: %a" % string)
                                      Signature.Public_key.pp pk)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      if show_private then
                                        match skloc with
                                        | None => return_unit
                                        | Some skloc =>
                                          op_gtgteqquestion
                                            (Secret_key.to_source skloc)
                                            (fun skloc =>
                                              op_gtgteq
                                                ((* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Secret Key: " % string
                                                      (CamlinternalFormatBasics.String
                                                        CamlinternalFormatBasics.No_padding
                                                        CamlinternalFormatBasics.End_of_format))
                                                    "Secret Key: %s" % string)
                                                  skloc)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  return_unit))
                                        end
                                      else
                                        return_unit)
                                end)
                          end)))
              (cons
                (command (Some group) "Forget one address." % string
                  (args1
                    (Clic.switch "delete associated keys when present" % string
                      (Some "f" % char) "force" % string tt))
                  (apply
                    (prefixes
                      (cons "forget" % string (cons "address" % string [])))
                    (apply
                      (let arg := Public_key_hash.alias_param in
                      fun eta => arg None None eta) stop))
                  (fun force =>
                    fun function_parameter =>
                      let '(name, _pkh) := function_parameter in
                      fun cctxt =>
                        op_gtgteqquestion (Secret_key.mem cctxt name)
                          (fun has_secret_key =>
                            op_gtgteqquestion (Public_key.mem cctxt name)
                              (fun has_public_key =>
                                op_gtgteqquestion
                                  (fail_when
                                    (andb (negb force)
                                      (orb has_secret_key has_public_key))
                                    (failure
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "secret or public key present for " %
                                            string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              ", use --force to delete" % string
                                              CamlinternalFormatBasics.End_of_format)))
                                        "secret or public key present for %s, use --force to delete"
                                          % string) name))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (Secret_key.del cctxt name)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteqquestion
                                          (Public_key.del cctxt name)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            Public_key_hash.del cctxt name)))))))
                (cons
                  (command (Some group)
                    "Forget the entire wallet of keys." % string
                    (args1
                      (Clic.switch "you got to use the force for that" % string
                        (Some "f" % char) "force" % string tt))
                    (fixed
                      (cons "forget" % string
                        (cons "all" % string (cons "keys" % string []))))
                    (fun force =>
                      fun cctxt =>
                        op_gtgteqquestion
                          (fail_unless force
                            (failure
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "this can only be used with option --force" %
                                    string
                                  CamlinternalFormatBasics.End_of_format)
                                "this can only be used with option --force" %
                                  string)))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion (Public_key.set cctxt [])
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion (Secret_key.set cctxt [])
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    Public_key_hash.set cctxt [])))))
                  (cons
                    (command (Some group)
                      "Compute deterministic nonce." % string no_options
                      (apply
                        (prefixes
                          (cons "generate" % string
                            (cons "nonce" % string (cons "for" % string []))))
                        (apply
                          (let arg := Public_key_hash.alias_param in
                          fun eta => arg None None eta)
                          (apply (prefixes (cons "from" % string []))
                            (apply
                              (string "data" % string
                                "string from which to deterministically generate the nonce"
                                  % string) stop))))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        fun function_parameter =>
                          let '(name, _pkh) := function_parameter in
                          fun data =>
                            fun cctxt =>
                              let data := Stdlib.Bytes.of_string data in
                              op_gtgteqquestion (Secret_key.mem cctxt name)
                                (fun sk_present =>
                                  op_gtgteqquestion
                                    (fail_unless sk_present
                                      (failure
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "secret key not present for " %
                                              string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.End_of_format))
                                          "secret key not present for %s" %
                                            string) name))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteqquestion
                                        (Secret_key.find cctxt name)
                                        (fun sk_uri =>
                                          op_gtgteqquestion
                                            (Client_keys.deterministic_nonce
                                              sk_uri data)
                                            (fun nonce =>
                                              op_gtgteq
                                                ((* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.Alpha
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "%a" % string) Hex.pp
                                                  (Hex.of_bytes None
                                                    (Bigstring.to_bytes nonce)))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  return_unit)))))))
                    (cons
                      (command (Some group)
                        "Compute deterministic nonce hash." % string no_options
                        (apply
                          (prefixes
                            (cons "generate" % string
                              (cons "nonce" % string
                                (cons "hash" % string (cons "for" % string [])))))
                          (apply
                            (let arg := Public_key_hash.alias_param in
                            fun eta => arg None None eta)
                            (apply (prefixes (cons "from" % string []))
                              (apply
                                (string "data" % string
                                  "string from which to deterministically generate the nonce hash"
                                    % string) stop))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          fun function_parameter =>
                            let '(name, _pkh) := function_parameter in
                            fun data =>
                              fun cctxt =>
                                let data := Stdlib.Bytes.of_string data in
                                op_gtgteqquestion (Secret_key.mem cctxt name)
                                  (fun sk_present =>
                                    op_gtgteqquestion
                                      (fail_unless sk_present
                                        (failure
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "secret key not present for " %
                                                string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.End_of_format))
                                            "secret key not present for %s" %
                                              string) name))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteqquestion
                                          (Secret_key.find cctxt name)
                                          (fun sk_uri =>
                                            op_gtgteqquestion
                                              (Client_keys.deterministic_nonce_hash
                                                sk_uri data)
                                              (fun nonce_hash =>
                                                op_gtgteq
                                                  ((* ❌ Sending method message is not handled *)
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.Alpha
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "%a" % string) Hex.pp
                                                    (Hex.of_bytes None
                                                      nonce_hash))
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    return_unit))))))) []))))))))).

src/lib_client_commands/client_p2p_commands.ml 235 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let group =
  {
    Clic.name = "p2p";
    title = "Commands for monitoring and controlling p2p-layer state";
  }

let pp_connection_info ppf conn =
  P2p_connection.Info.pp (fun _ _ -> ()) ppf conn

let addr_parameter =
  let open Clic in
  param
    ~name:"address"
    ~desc:"<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)."
    (parameter (fun _ x ->
         return (P2p_point.Id.of_string_exn ~default_port:9732 x)))

let p2p_peer_id_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (P2p_peer.Id.of_b58check str)))
    t

let commands () =
  let open Clic in
  [ command
      ~group
      ~desc:"show global network status"
      no_options
      (prefixes ["p2p"; "stat"] stop)
      (fun () (cctxt : #Client_context.full) ->
        Shell_services.P2p.stat cctxt
        >>=? fun stat ->
        Shell_services.P2p.Connections.list cctxt
        >>=? fun conns ->
        Shell_services.P2p.Peers.list cctxt
        >>=? fun peers ->
        Shell_services.P2p.Points.list cctxt
        >>=? fun points ->
        cctxt#message "GLOBAL STATS"
        >>= fun () ->
        cctxt#message "  %a" P2p_stat.pp stat
        >>= fun () ->
        cctxt#message "CONNECTIONS"
        >>= fun () ->
        let (incoming, outgoing) =
          List.partition (fun c -> c.P2p_connection.Info.incoming) conns
        in
        Lwt_list.iter_s
          (fun conn -> cctxt#message "  %a" pp_connection_info conn)
          incoming
        >>= fun () ->
        Lwt_list.iter_s
          (fun conn -> cctxt#message "  %a" pp_connection_info conn)
          outgoing
        >>= fun () ->
        cctxt#message "KNOWN PEERS"
        >>= fun () ->
        Lwt_list.iter_s
          (fun (p, pi) ->
            cctxt#message
              "  %a  %.0f %a %a %s"
              P2p_peer.State.pp_digram
              pi.P2p_peer.Info.state
              pi.score
              P2p_peer.Id.pp
              p
              P2p_stat.pp
              pi.stat
              (if pi.trusted then "★" else " "))
          peers
        >>= fun () ->
        cctxt#message "KNOWN POINTS"
        >>= fun () ->
        Lwt_list.iter_s
          (fun (p, pi) ->
            match pi.P2p_point.Info.state with
            | Running peer_id ->
                cctxt#message
                  "  %a  %a %a %s"
                  P2p_point.State.pp_digram
                  pi.state
                  P2p_point.Id.pp
                  p
                  P2p_peer.Id.pp
                  peer_id
                  (if pi.trusted then "★" else " ")
            | _ -> (
              match pi.last_seen with
              | Some (peer_id, ts) ->
                  cctxt#message
                    "  %a  %a (last seen: %a %a) %s"
                    P2p_point.State.pp_digram
                    pi.state
                    P2p_point.Id.pp
                    p
                    P2p_peer.Id.pp
                    peer_id
                    Time.System.pp_hum
                    ts
                    (if pi.trusted then "★" else " ")
              | None ->
                  cctxt#message
                    "  %a  %a %s"
                    P2p_point.State.pp_digram
                    pi.state
                    P2p_point.Id.pp
                    p
                    (if pi.trusted then "★" else " ") ))
          points
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Connect to a new point."
      no_options
      (prefixes ["connect"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        let timeout = Time.System.Span.of_seconds_exn 10. in
        P2p_services.connect cctxt ~timeout (address, port)
        >>= function
        | Ok () ->
            cctxt#message
              "Connection to %a:%d established."
              P2p_addr.pp
              address
              port
            >>= fun () -> return_unit
        | Error (Tezos_p2p.P2p_errors.Pending_connection :: _) ->
            cctxt#warning "Already connecting to peer %a" P2p_addr.pp address
            >>= fun () -> return_unit
        | Error (Tezos_p2p.P2p_errors.Connected :: _) ->
            cctxt#warning "Already connected to peer %a" P2p_addr.pp address
            >>= fun () -> return_unit
        | Error _ as e ->
            Lwt.return e);
    command
      ~group
      ~desc:"Kick a peer."
      no_options
      ( prefixes ["kick"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Connections.kick cctxt peer
        >>=? fun () ->
        cctxt#message "Connection to %a interrupted." P2p_peer.Id.pp peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add an IP address and all its ports to the blacklist and kicks it. \
         Remove the address from the whitelist if it was previously in it."
      no_options
      (prefixes ["ban"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, _port) (cctxt : #Client_context.full) ->
        P2p_services.Points.ban cctxt (address, 0)
        >>=? fun () ->
        cctxt#message "Address %a:* is now banned." P2p_addr.pp address
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Remove an IP address and all its ports from the blacklist."
      no_options
      (prefixes ["unban"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, _port) (cctxt : #Client_context.full) ->
        P2p_services.Points.unban cctxt (address, 0)
        >>=? fun () ->
        cctxt#message "Address %a:* is now unbanned." P2p_addr.pp address
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add an IP address to the whitelist. Remove the address from the \
         blacklist if it was previously in it."
      no_options
      (prefixes ["trust"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        P2p_services.Points.trust cctxt (address, port)
        >>=? fun () ->
        cctxt#message "Address %a:%d is now trusted." P2p_addr.pp address port
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Removes an IP address from the whitelist."
      no_options
      (prefixes ["untrust"; "address"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        P2p_services.Points.untrust cctxt (address, port)
        >>=? fun () ->
        cctxt#message
          "Address %a:%d is now untrusted."
          P2p_addr.pp
          address
          port
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Check if an IP address is banned."
      no_options
      (prefixes ["is"; "address"; "banned"] @@ addr_parameter @@ stop)
      (fun () (address, port) (cctxt : #Client_context.full) ->
        P2p_services.Points.banned cctxt (address, port)
        >>=? fun banned ->
        cctxt#message
          "The given ip address is %s"
          (if banned then "banned" else "not banned")
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Check if a peer ID is banned."
      no_options
      ( prefixes ["is"; "peer"; "banned"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.banned cctxt peer
        >>=? fun banned ->
        cctxt#message
          "The given peer ID is %s"
          (if banned then "banned" else "not banned")
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add a peer ID to the blacklist and kicks it. Remove the peer ID from \
         the blacklist if was previously in it."
      no_options
      ( prefixes ["ban"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.ban cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now banned." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Removes a peer ID from the blacklist."
      no_options
      ( prefixes ["unban"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.unban cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now unbanned." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Add a peer ID to the whitelist. Remove the peer ID from the \
         blacklist if it was previously in it."
      no_options
      ( prefixes ["trust"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.trust cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now trusted." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Remove a peer ID from the whitelist."
      no_options
      ( prefixes ["untrust"; "peer"]
      @@ p2p_peer_id_param ~name:"peer" ~desc:"peer network identity"
      @@ stop )
      (fun () peer (cctxt : #Client_context.full) ->
        P2p_services.Peers.untrust cctxt peer
        >>=? fun () ->
        cctxt#message "The peer %a is now untrusted." P2p_peer.Id.pp_short peer
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Clear all access control rules."
      no_options
      (prefixes ["clear"; "acls"] @@ stop)
      (fun () (cctxt : #Client_context.full) ->
        P2p_services.ACL.clear cctxt ()
        >>=? fun () ->
        cctxt#message "The access control rules are now cleared."
        >>= fun () -> return_unit) ]
src/lib_client_commands/client_p2p_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "p2p" % string;
    Clic.title :=
      "Commands for monitoring and controlling p2p-layer state" % string |}.

Definition pp_connection_info {A : Type}
  (ppf : Stdlib.Format.formatter)
  (conn : Tezos_base__TzPervasives.P2p_connection.Info.t A) : unit :=
  P2p_connection.Info.pp
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        tt) ppf conn.

Definition addr_parameter {F G I a b i o p q : Type}
  : (Tezos_base__TzPervasives.Clic.params
    ((((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
    (((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I)) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_base__TzPervasives.P2p_point.Id.t ->
        (((Z -> Lwt.t unit) *
          ((unit -> Ptime.t) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (F * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (G * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) *
                                              ((((unit -> Lwt.t a) -> Lwt.t a) *
                                                (a)) *
                                                (((string ->
                                                  a ->
                                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                                      a) ->
                                                      Lwt.t
                                                        (Tezos_base__TzPervasives.tzresult
                                                          unit)) * (a)) * I)))))))))))))))))))))
          * I) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit))
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I) :=
  param "address" % string
    "<IPv4>:PORT or <IPV6>:PORT address (PORT defaults to 9732)." % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun x => _return (P2p_point.Id.of_string_exn (Some 9732) x))).

Definition p2p_peer_id_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.P2p_peer.Id.t -> A) B :=
  Clic.param name desc
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun str => Lwt._return (P2p_peer.Id.of_b58check str))) t.

Definition commands {F G I a b i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((Z -> Lwt.t unit) *
        ((unit -> Ptime.t) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (F * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (G * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult string))
                                      -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          Bigstring.t)) -> a) * (a)) *
                                        ((string ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * I)))))))))))))))))))))
        * I)) :=
  let 'tt := function_parameter in
  cons
    (command (Some group) "show global network status" % string no_options
      (prefixes (cons "p2p" % string (cons "stat" % string [])) stop)
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          op_gtgteqquestion (Shell_services.P2p.stat cctxt)
            (fun stat =>
              op_gtgteqquestion (Shell_services.P2p.Connections.list cctxt)
                (fun conns =>
                  op_gtgteqquestion (Shell_services.P2p.Peers.list None cctxt)
                    (fun peers =>
                      op_gtgteqquestion
                        (Shell_services.P2p.Points.list None cctxt)
                        (fun points =>
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "GLOBAL STATS" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "GLOBAL STATS" % string))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "  " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "  %a" % string) P2p_stat.pp stat)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    ((* ❌ Sending method message is not handled *)
                                    send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "CONNECTIONS" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "CONNECTIONS" % string))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      let '(incoming, outgoing) :=
                                        List.partition
                                          (fun c =>
                                            P2p_connection.Info.incoming c)
                                          conns in
                                      op_gtgteq
                                        (Lwt_list.iter_s
                                          (fun conn =>
                                            (* ❌ Sending method message is not handled *)
                                            send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "  " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    CamlinternalFormatBasics.End_of_format))
                                                "  %a" % string)
                                              pp_connection_info conn) incoming)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (Lwt_list.iter_s
                                              (fun conn =>
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "  " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        CamlinternalFormatBasics.End_of_format))
                                                    "  %a" % string)
                                                  pp_connection_info conn)
                                              outgoing)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                ((* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "KNOWN PEERS" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "KNOWN PEERS" % string))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteq
                                                    (Lwt_list.iter_s
                                                      (fun function_parameter =>
                                                        let '(p, pi) :=
                                                          function_parameter in
                                                        (* ❌ Sending method message is not handled *)
                                                        send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "  " % string
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "  " % string
                                                                  (CamlinternalFormatBasics.Float
                                                                    CamlinternalFormatBasics.Float_f
                                                                    CamlinternalFormatBasics.No_padding
                                                                    (CamlinternalFormatBasics.Lit_precision
                                                                      0)
                                                                    (CamlinternalFormatBasics.Char_literal
                                                                      " " % char
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          " " %
                                                                            char
                                                                          (CamlinternalFormatBasics.Alpha
                                                                            (CamlinternalFormatBasics.Char_literal
                                                                              " "
                                                                                %
                                                                                char
                                                                              (CamlinternalFormatBasics.String
                                                                                CamlinternalFormatBasics.No_padding
                                                                                CamlinternalFormatBasics.End_of_format))))))))))
                                                            "  %a  %.0f %a %a %s"
                                                              % string)
                                                          P2p_peer.State.pp_digram
                                                          (P2p_peer.Info.state
                                                            pi) (score pi)
                                                          P2p_peer.Id.pp p
                                                          P2p_stat.pp (stat pi)
                                                          (if trusted pi then
                                                            "★" % string
                                                          else
                                                            " " % string)) peers)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        ((* ❌ Sending method message is not handled *)
                                                        send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "KNOWN POINTS" %
                                                                string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "KNOWN POINTS" %
                                                              string))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_gtgteq
                                                            (Lwt_list.iter_s
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let '(p, pi) :=
                                                                  function_parameter
                                                                  in
                                                                match
                                                                  P2p_point.Info.state
                                                                    pi with
                                                                |
                                                                  Tezos_base__P2p_point.State.Running
                                                                    peer_id =>
                                                                  (* ❌ Sending method message is not handled *)
                                                                  send
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "  " %
                                                                          string
                                                                        (CamlinternalFormatBasics.Alpha
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "  "
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Alpha
                                                                              (CamlinternalFormatBasics.Char_literal
                                                                                " "
                                                                                  %
                                                                                  char
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  (CamlinternalFormatBasics.Char_literal
                                                                                    " "
                                                                                      %
                                                                                      char
                                                                                    (CamlinternalFormatBasics.String
                                                                                      CamlinternalFormatBasics.No_padding
                                                                                      CamlinternalFormatBasics.End_of_format))))))))
                                                                      "  %a  %a %a %s"
                                                                        % string)
                                                                    P2p_point.State.pp_digram
                                                                    (state pi)
                                                                    P2p_point.Id.pp
                                                                    p
                                                                    P2p_peer.Id.pp
                                                                    peer_id
                                                                    (if
                                                                      trusted pi
                                                                      then
                                                                      "★" %
                                                                        string
                                                                    else
                                                                      " " %
                                                                        string)
                                                                | _ =>
                                                                  match
                                                                    last_seen pi
                                                                    with
                                                                  |
                                                                    Some
                                                                      (peer_id,
                                                                        ts) =>
                                                                    (* ❌ Sending method message is not handled *)
                                                                    send
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "  " %
                                                                            string
                                                                          (CamlinternalFormatBasics.Alpha
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "  "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  " (last seen: "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    (CamlinternalFormatBasics.Char_literal
                                                                                      " "
                                                                                        %
                                                                                        char
                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          ") "
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.String
                                                                                            CamlinternalFormatBasics.No_padding
                                                                                            CamlinternalFormatBasics.End_of_format))))))))))
                                                                        "  %a  %a (last seen: %a %a) %s"
                                                                          %
                                                                          string)
                                                                      P2p_point.State.pp_digram
                                                                      (state pi)
                                                                      P2p_point.Id.pp
                                                                      p
                                                                      P2p_peer.Id.pp
                                                                      peer_id
                                                                      Time.System.pp_hum
                                                                      ts
                                                                      (if
                                                                        trusted
                                                                          pi
                                                                        then
                                                                        "★" %
                                                                          string
                                                                      else
                                                                        " " %
                                                                          string)
                                                                  | None =>
                                                                    (* ❌ Sending method message is not handled *)
                                                                    send
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "  " %
                                                                            string
                                                                          (CamlinternalFormatBasics.Alpha
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "  "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.Char_literal
                                                                                  " "
                                                                                    %
                                                                                    char
                                                                                  (CamlinternalFormatBasics.String
                                                                                    CamlinternalFormatBasics.No_padding
                                                                                    CamlinternalFormatBasics.End_of_format))))))
                                                                        "  %a  %a %s"
                                                                          %
                                                                          string)
                                                                      P2p_point.State.pp_digram
                                                                      (state pi)
                                                                      P2p_point.Id.pp
                                                                      p
                                                                      (if
                                                                        trusted
                                                                          pi
                                                                        then
                                                                        "★" %
                                                                          string
                                                                      else
                                                                        " " %
                                                                          string)
                                                                  end
                                                                end) points)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              return_unit)))))))))))))))
    (cons
      (command (Some group) "Connect to a new point." % string no_options
        (apply (prefixes (cons "connect" % string (cons "address" % string [])))
          (apply addr_parameter stop))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let '(address, port) := function_parameter in
            fun cctxt =>
              let timeout :=
                Time.System.Span.of_seconds_exn
                  (* ❌ Float constant 10. is approximated by the integer 10 *)
                  10 in
              op_gtgteq (P2p_services.connect cctxt timeout (address, port))
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok tt =>
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Connection to " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal ":" % char
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " established." % string
                                    CamlinternalFormatBasics.End_of_format)))))
                          "Connection to %a:%d established." % string)
                        P2p_addr.pp address port)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)
                  |
                    Stdlib.Error
                      (cons Tezos_base__TzPervasives.Pending_connection _) =>
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Already connecting to peer " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "Already connecting to peer %a" % string) P2p_addr.pp
                        address)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)
                  | Stdlib.Error (cons Tezos_base__TzPervasives.Connected _) =>
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Already connected to peer " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "Already connected to peer %a" % string) P2p_addr.pp
                        address)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)
                  | (Stdlib.Error _) as e => Lwt._return e
                  end)))
      (cons
        (command (Some group) "Kick a peer." % string no_options
          (apply (prefixes (cons "kick" % string (cons "peer" % string [])))
            (apply
              (p2p_peer_id_param "peer" % string
                "peer network identity" % string) stop))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun peer =>
              fun cctxt =>
                op_gtgteqquestion
                  (P2p_services.Connections.kick cctxt None peer)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Connection to " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " interrupted." % string
                                CamlinternalFormatBasics.End_of_format)))
                          "Connection to %a interrupted." % string)
                        P2p_peer.Id.pp peer)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit))))
        (cons
          (command (Some group)
            "Add an IP address and all its ports to the blacklist and kicks it. Remove the address from the whitelist if it was previously in it."
              % string no_options
            (apply (prefixes (cons "ban" % string (cons "address" % string [])))
              (apply addr_parameter stop))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let '(address, _port) := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion (P2p_services.Points.ban cctxt (address, 0))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Address " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  ":* is now banned." % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Address %a:* is now banned." % string) P2p_addr.pp
                          address)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit))))
          (cons
            (command (Some group)
              "Remove an IP address and all its ports from the blacklist." %
                string no_options
              (apply
                (prefixes (cons "unban" % string (cons "address" % string [])))
                (apply addr_parameter stop))
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun function_parameter =>
                  let '(address, _port) := function_parameter in
                  fun cctxt =>
                    op_gtgteqquestion
                      (P2p_services.Points.unban cctxt (address, 0))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Address " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    ":* is now unbanned." % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Address %a:* is now unbanned." % string)
                            P2p_addr.pp address)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit))))
            (cons
              (command (Some group)
                "Add an IP address to the whitelist. Remove the address from the blacklist if it was previously in it."
                  % string no_options
                (apply
                  (prefixes (cons "trust" % string (cons "address" % string [])))
                  (apply addr_parameter stop))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  fun function_parameter =>
                    let '(address, port) := function_parameter in
                    fun cctxt =>
                      op_gtgteqquestion
                        (P2p_services.Points.trust cctxt (address, port))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Address " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      ":" % char
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.String_literal
                                          " is now trusted." % string
                                          CamlinternalFormatBasics.End_of_format)))))
                                "Address %a:%d is now trusted." % string)
                              P2p_addr.pp address port)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit))))
              (cons
                (command (Some group)
                  "Removes an IP address from the whitelist." % string
                  no_options
                  (apply
                    (prefixes
                      (cons "untrust" % string (cons "address" % string [])))
                    (apply addr_parameter stop))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    fun function_parameter =>
                      let '(address, port) := function_parameter in
                      fun cctxt =>
                        op_gtgteqquestion
                          (P2p_services.Points.untrust cctxt (address, port))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Address " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        ":" % char
                                        (CamlinternalFormatBasics.Int
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          (CamlinternalFormatBasics.String_literal
                                            " is now untrusted." % string
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "Address %a:%d is now untrusted." % string)
                                P2p_addr.pp address port)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit))))
                (cons
                  (command (Some group)
                    "Check if an IP address is banned." % string no_options
                    (apply
                      (prefixes
                        (cons "is" % string
                          (cons "address" % string (cons "banned" % string []))))
                      (apply addr_parameter stop))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      fun function_parameter =>
                        let '(address, port) := function_parameter in
                        fun cctxt =>
                          op_gtgteqquestion
                            (P2p_services.Points.banned cctxt (address, port))
                            (fun banned =>
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "The given ip address is " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "The given ip address is %s" % string)
                                  (if banned then
                                    "banned" % string
                                  else
                                    "not banned" % string))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit))))
                  (cons
                    (command (Some group)
                      "Check if a peer ID is banned." % string no_options
                      (apply
                        (prefixes
                          (cons "is" % string
                            (cons "peer" % string (cons "banned" % string []))))
                        (apply
                          (p2p_peer_id_param "peer" % string
                            "peer network identity" % string) stop))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        fun peer =>
                          fun cctxt =>
                            op_gtgteqquestion
                              (P2p_services.Peers.banned cctxt peer)
                              (fun banned =>
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "The given peer ID is " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "The given peer ID is %s" % string)
                                    (if banned then
                                      "banned" % string
                                    else
                                      "not banned" % string))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit))))
                    (cons
                      (command (Some group)
                        "Add a peer ID to the blacklist and kicks it. Remove the peer ID from the blacklist if was previously in it."
                          % string no_options
                        (apply
                          (prefixes
                            (cons "ban" % string (cons "peer" % string [])))
                          (apply
                            (p2p_peer_id_param "peer" % string
                              "peer network identity" % string) stop))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          fun peer =>
                            fun cctxt =>
                              op_gtgteqquestion
                                (P2p_services.Peers.ban cctxt peer)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    ((* ❌ Sending method message is not handled *)
                                    send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "The peer " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " is now banned." % string
                                              CamlinternalFormatBasics.End_of_format)))
                                        "The peer %a is now banned." % string)
                                      P2p_peer.Id.pp_short peer)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      return_unit))))
                      (cons
                        (command (Some group)
                          "Removes a peer ID from the blacklist." % string
                          no_options
                          (apply
                            (prefixes
                              (cons "unban" % string (cons "peer" % string [])))
                            (apply
                              (p2p_peer_id_param "peer" % string
                                "peer network identity" % string) stop))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            fun peer =>
                              fun cctxt =>
                                op_gtgteqquestion
                                  (P2p_services.Peers.unban cctxt peer)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "The peer " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " is now unbanned." % string
                                                CamlinternalFormatBasics.End_of_format)))
                                          "The peer %a is now unbanned." %
                                            string) P2p_peer.Id.pp_short peer)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        return_unit))))
                        (cons
                          (command (Some group)
                            "Add a peer ID to the whitelist. Remove the peer ID from the blacklist if it was previously in it."
                              % string no_options
                            (apply
                              (prefixes
                                (cons "trust" % string (cons "peer" % string [])))
                              (apply
                                (p2p_peer_id_param "peer" % string
                                  "peer network identity" % string) stop))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              fun peer =>
                                fun cctxt =>
                                  op_gtgteqquestion
                                    (P2p_services.Peers.trust cctxt peer)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "The peer " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " is now trusted." % string
                                                  CamlinternalFormatBasics.End_of_format)))
                                            "The peer %a is now trusted." %
                                              string) P2p_peer.Id.pp_short peer)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          return_unit))))
                          (cons
                            (command (Some group)
                              "Remove a peer ID from the whitelist." % string
                              no_options
                              (apply
                                (prefixes
                                  (cons "untrust" % string
                                    (cons "peer" % string [])))
                                (apply
                                  (p2p_peer_id_param "peer" % string
                                    "peer network identity" % string) stop))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                fun peer =>
                                  fun cctxt =>
                                    op_gtgteqquestion
                                      (P2p_services.Peers.untrust cctxt peer)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "The peer " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.String_literal
                                                    " is now untrusted." %
                                                      string
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "The peer %a is now untrusted." %
                                                string) P2p_peer.Id.pp_short
                                            peer)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            return_unit))))
                            (cons
                              (command (Some group)
                                "Clear all access control rules." % string
                                no_options
                                (apply
                                  (prefixes
                                    (cons "clear" % string
                                      (cons "acls" % string []))) stop)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  fun cctxt =>
                                    op_gtgteqquestion
                                      (P2p_services.ACL.clear cctxt tt)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "The access control rules are now cleared."
                                                  % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "The access control rules are now cleared."
                                                % string))
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            return_unit)))) []))))))))))))).

src/lib_client_commands/client_report_commands.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Commands used to introspect the node's state *)

let print_invalid_blocks ppf (b : Shell_services.Chain.invalid_block) =
  Format.fprintf
    ppf
    "@[<v 2>Hash: %a@ Level: %ld@ %a@]"
    Block_hash.pp
    b.hash
    b.level
    pp_print_error
    b.errors

let commands () =
  let open Clic in
  let group =
    {name = "report"; title = "Commands to report the node's status"}
  in
  let output_arg =
    default_arg
      ~doc:"write to a file"
      ~long:"output"
      ~short:'o'
      ~placeholder:"path"
      ~default:"-"
      (parameter (fun _ ->
         function
         | "-" ->
             return Format.std_formatter
         | file ->
             let ppf = Format.formatter_of_out_channel (open_out file) in
             ignore Clic.(setup_formatter ppf Plain Full) ;
             return ppf))
  in
  [ command
      ~group
      ~desc:"The last heads that have been considered by the node."
      (args1 output_arg)
      (fixed ["list"; "heads"])
      (fun ppf cctxt ->
        Shell_services.Blocks.list cctxt ()
        >>=? fun heads ->
        Format.fprintf
          ppf
          "@[<v>%a@]@."
          (Format.pp_print_list Block_hash.pp)
          (List.concat heads) ;
        return_unit);
    command
      ~group
      ~desc:"The blocks that have been marked invalid by the node."
      (args1 output_arg)
      (fixed ["list"; "rejected"; "blocks"])
      (fun ppf cctxt ->
        Shell_services.Invalid_blocks.list cctxt ()
        >>=? function
        | [] ->
            Format.fprintf ppf "No invalid blocks.@." ;
            return_unit
        | _ :: _ as invalid ->
            Format.fprintf
              ppf
              "@[<v>%a@]@."
              (Format.pp_print_list print_invalid_blocks)
              invalid ;
            return_unit) ]
src/lib_client_commands/client_report_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition print_invalid_blocks
  (ppf : Stdlib.Format.formatter)
  (b : Tezos_shell_services.Shell_services.Chain.invalid_block) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 2>" % string
              CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
        (CamlinternalFormatBasics.String_literal "Hash: " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal "Level: " % string
                (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[<v 2>Hash: %a@ Level: %ld@ %a@]" % string) Block_hash.pp (hash b)
    (level b) pp_print_error (errors b).

Definition commands {E F i o p q : Type} (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)) :=
  let 'tt := function_parameter in
  let group :=
    {| name := "report" % string;
      title := "Commands to report the node's status" % string |} in
  let output_arg :=
    default_arg "write to a file" % string (Some "o" % char) "output" % string
      "path" % string "-" % string
      (parameter None
        (fun function_parameter =>
          let '_ := function_parameter in
          fun function_parameter =>
            match function_parameter with
            | "-" % string => _return Format.std_formatter
            | file =>
              let ppf := Format.formatter_of_out_channel (Stdlib.open_out file)
                in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                OCaml.Stdlib.ignore
                  (setup_formatter ppf Tezos_base__TzPervasives.Clic.Plain
                    Tezos_base__TzPervasives.Clic.Full) in
              _return ppf
            end)) in
  cons
    (command (Some group)
      "The last heads that have been considered by the node." % string
      (args1 output_arg)
      (fixed (cons "list" % string (cons "heads" % string [])))
      (fun ppf =>
        fun cctxt =>
          op_gtgteqquestion
            (Shell_services.Blocks.list cctxt None None None None tt)
            (fun heads =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))
                    "@[<v>%a@]@." % string)
                  (Format.pp_print_list None Block_hash.pp) (List.concat heads)
                in
              return_unit)))
    (cons
      (command (Some group)
        "The blocks that have been marked invalid by the node." % string
        (args1 output_arg)
        (fixed
          (cons "list" % string
            (cons "rejected" % string (cons "blocks" % string []))))
        (fun ppf =>
          fun cctxt =>
            op_gtgteqquestion (Shell_services.Invalid_blocks.list cctxt None tt)
              (fun function_parameter =>
                match function_parameter with
                | [] =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "No invalid blocks." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))
                        "No invalid blocks.@." % string) in
                  return_unit
                | (cons _ _) as invalid =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v>" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))
                        "@[<v>%a@]@." % string)
                      (Format.pp_print_list None print_invalid_blocks) invalid
                    in
                  return_unit
                end))) []).

src/lib_crypto/blake2B.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

(*-- Type specific Hash builder ---------------------------------------------*)

module type Name = sig
  val name : string

  val title : string

  val size : int option
end

module type PrefixedName = sig
  include Name

  val b58check_prefix : string
end

module Make_minimal (K : Name) = struct
  open Blake2

  type t = Blake2b.hash

  include K

  let size = match K.size with None -> 32 | Some x -> x

  let of_string_opt s =
    if String.length s <> size then None
    else Some (Blake2b.Hash (Bytes.of_string s))

  let of_string s =
    match of_string_opt s with
    | None ->
        generic_error
          "%s.of_string: wrong string size (%d)"
          K.name
          (String.length s)
    | Some h ->
        Ok h

  let of_string_exn s =
    match of_string_opt s with
    | None ->
        Format.kasprintf
          invalid_arg
          "%s.of_string: wrong string size (%d)"
          K.name
          (String.length s)
    | Some h ->
        h

  let to_string (Blake2b.Hash h) = Bytes.to_string h

  let of_hex s = of_string (Hex.to_string s)

  let of_hex_opt s = of_string_opt (Hex.to_string s)

  let of_hex_exn s = of_string_exn (Hex.to_string s)

  let to_hex s = Hex.of_string (to_string s)

  let pp ppf h =
    let (`Hex h) = to_hex h in
    Format.pp_print_string ppf h

  let pp_short ppf h =
    let (`Hex h) = to_hex h in
    Format.pp_print_string ppf (String.sub h 0 8)

  let of_bytes_opt b =
    if Bytes.length b <> size then None else Some (Blake2b.Hash b)

  let of_bytes_exn b =
    match of_bytes_opt b with
    | None ->
        let msg =
          Printf.sprintf
            "%s.of_bytes: wrong string size (%d)"
            K.name
            (Bytes.length b)
        in
        raise (Invalid_argument msg)
    | Some h ->
        h

  let of_bytes s =
    match of_bytes_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to deserialize a hash (%s)" K.name

  let to_bytes (Blake2b.Hash h) = h

  let hash_bytes ?key l =
    let state = Blake2b.init ?key size in
    List.iter (fun b -> Blake2b.update state b) l ;
    Blake2b.final state

  let hash_string ?key l =
    let key = Option.map ~f:Bytes.of_string key in
    let state = Blake2b.init ?key size in
    List.iter (fun s -> Blake2b.update state (Bytes.of_string s)) l ;
    Blake2b.final state

  let path_length = 6

  (** Converts [key] to hex thus doubling its size then splits it into a list of
      length [path_length] where each element is one byte, or two characters,
      except the last one which contains the rest. *)
  let to_path key l =
    let (`Hex key) = to_hex key in
    String.sub key 0 2 :: String.sub key 2 2 :: String.sub key 4 2
    :: String.sub key 6 2 :: String.sub key 8 2
    :: String.sub key 10 ((size * 2) - 10)
    :: l

  let of_path path =
    let path = String.concat "" path in
    of_hex_opt (`Hex path)

  let of_path_exn path =
    let path = String.concat "" path in
    of_hex_exn (`Hex path)

  let prefix_path p =
    let (`Hex p) = Hex.of_string p in
    let len = String.length p in
    let p1 = if len >= 2 then String.sub p 0 2 else ""
    and p2 = if len >= 4 then String.sub p 2 2 else ""
    and p3 = if len >= 6 then String.sub p 4 2 else ""
    and p4 = if len >= 8 then String.sub p 6 2 else ""
    and p5 = if len >= 10 then String.sub p 8 2 else ""
    and p6 =
      if len > 10 then String.sub p 10 (min (len - 10) ((size * 2) - 10))
      else ""
    in
    [p1; p2; p3; p4; p5; p6]

  let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))

  include Compare.Make (struct
    type nonrec t = t

    let compare (Blake2b.Hash h1) (Blake2b.Hash h2) = Bytes.compare h1 h2
  end)
end

module Make (R : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(K : PrefixedName) =
struct
  include Make_minimal (K)

  (* Serializers *)

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let hash =
    if Compare.Int.(size >= 8) then fun h ->
      Int64.to_int (TzEndian.get_int64 (to_bytes h) 0)
    else if Compare.Int.(size >= 4) then fun h ->
      Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)
    else fun h ->
      let r = ref 0 in
      let h = to_bytes h in
      for i = 0 to size - 1 do
        r := TzEndian.get_uint8 h i + (8 * !r)
      done ;
      !r

  type Base58.data += Data of t

  let b58check_encoding =
    R.register_encoding
      ~prefix:K.b58check_prefix
      ~length:size
      ~wrap:(fun s -> Data s)
      ~of_raw:of_string_opt
      ~to_raw:to_string

  include Helpers.Make (struct
    type nonrec t = t

    let title = title

    let name = name

    let b58check_encoding = b58check_encoding

    let raw_encoding = raw_encoding

    let compare = compare

    let equal = equal

    let hash = hash
  end)
end

module Generic_Merkle_tree (H : sig
  type t

  type elt

  val empty : t

  val leaf : elt -> t

  val node : t -> t -> t
end) =
struct
  let rec step a n =
    let m = (n + 1) / 2 in
    for i = 0 to m - 1 do
      a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
    done ;
    a.(m) <- H.node a.(n) a.(n) ;
    if m = 1 then a.(0)
    else if m mod 2 = 0 then step a m
    else (
      a.(m + 1) <- a.(m) ;
      step a (m + 1) )

  let empty = H.empty

  let compute xs =
    match xs with
    | [] ->
        H.empty
    | [x] ->
        H.leaf x
    | _ :: _ :: _ ->
        let last = TzList.last_exn xs in
        let n = List.length xs in
        let a = Array.make (n + 1) (H.leaf last) in
        List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
        step a n

  type path = Left of path * H.t | Right of H.t * path | Op

  let rec step_path a n p j =
    let m = (n + 1) / 2 in
    let p =
      if j mod 2 = 0 then Left (p, a.(j + 1)) else Right (a.(j - 1), p)
    in
    for i = 0 to m - 1 do
      a.(i) <- H.node a.(2 * i) a.((2 * i) + 1)
    done ;
    a.(m) <- H.node a.(n) a.(n) ;
    if m = 1 then p
    else if m mod 2 = 0 then step_path a m p (j / 2)
    else (
      a.(m + 1) <- a.(m) ;
      step_path a (m + 1) p (j / 2) )

  let compute_path xs i =
    match xs with
    | [] ->
        invalid_arg "compute_path"
    | [_] ->
        Op
    | _ :: _ :: _ ->
        let last = TzList.last_exn xs in
        let n = List.length xs in
        if i < 0 || n <= i then invalid_arg "compute_path" ;
        let a = Array.make (n + 1) (H.leaf last) in
        List.iteri (fun i x -> a.(i) <- H.leaf x) xs ;
        step_path a n Op i

  let rec check_path p h =
    match p with
    | Op ->
        (H.leaf h, 1, 0)
    | Left (p, r) ->
        let (l, s, pos) = check_path p h in
        (H.node l r, s * 2, pos)
    | Right (l, p) ->
        let (r, s, pos) = check_path p h in
        (H.node l r, s * 2, pos + s)

  let check_path p h =
    let (h, _, pos) = check_path p h in
    (h, pos)
end

let rec log2 x = if x <= 1 then 0 else 1 + log2 ((x + 1) / 2)

module Make_merkle_tree (R : sig
  val register_encoding :
    prefix:string ->
    length:int ->
    to_raw:('a -> string) ->
    of_raw:(string -> 'a option) ->
    wrap:('a -> Base58.data) ->
    'a Base58.encoding
end)
(K : PrefixedName) (Contents : sig
  type t

  val to_bytes : t -> Bytes.t
end) =
struct
  include Make (R) (K)

  type elt = Contents.t

  let elt_bytes = Contents.to_bytes

  let empty = hash_bytes []

  include Generic_Merkle_tree (struct
    type nonrec t = t

    type nonrec elt = elt

    let empty = empty

    let leaf x = hash_bytes [Contents.to_bytes x]

    let node x y = hash_bytes [to_bytes x; to_bytes y]
  end)

  let path_encoding =
    let open Data_encoding in
    mu "path" (fun path_encoding ->
        union
          [ case
              (Tag 240)
              ~title:"Left"
              (obj2 (req "path" path_encoding) (req "right" encoding))
              (function Left (p, r) -> Some (p, r) | _ -> None)
              (fun (p, r) -> Left (p, r));
            case
              (Tag 15)
              ~title:"Right"
              (obj2 (req "left" encoding) (req "path" path_encoding))
              (function Right (r, p) -> Some (r, p) | _ -> None)
              (fun (r, p) -> Right (r, p));
            case
              (Tag 0)
              ~title:"Op"
              unit
              (function Op -> Some () | _ -> None)
              (fun () -> Op) ])

  let bounded_path_encoding ?max_length () =
    match max_length with
    | None ->
        path_encoding
    | Some max_length ->
        let max_depth = log2 max_length in
        Data_encoding.check_size ((max_depth * (size + 1)) + 1) path_encoding
end

include Make_minimal (struct
  let name = "Generic_hash"

  let title = ""

  let size = None
end)

let pp ppf h =
  let (`Hex h) = to_hex h in
  Format.pp_print_string ppf h

let pp_short ppf h =
  let (`Hex h) = to_hex h in
  Format.pp_print_string ppf (String.sub h 0 8)
src/lib_crypto/blake2B.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module Name.
  Record signature := {
    name : string;
    title : string;
    size : option Z;
  }.
End Name.

Module PrefixedName.
  Record signature := {
    include;
    b58check_prefix : string;
  }.
End PrefixedName.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

Fixpoint log2 (x : Z) : Z :=
  if OCaml.Stdlib.le x 1 then
    0
  else
    Z.add 1 (log2 (Z.div (Z.add x 1) 2)).

(* ❌ Functors are not handled. *)
functor

(* ❌ Structure item `include` not handled. *)
include

Definition pp (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
  : unit :=
  let 'Hex h := to_hex h in
  Format.pp_print_string ppf h.

Definition pp_short (ppf : Stdlib.Format.formatter) (h : Blake2.Blake2b.hash)
  : unit :=
  let 'Hex h := to_hex h in
  Format.pp_print_string ppf (Stdlib.String.sub h 0 8).

src/lib_crypto/block_hash.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "block_hash"

            let title = "A block identifier"

            let b58check_prefix = Base58.Prefix.block_hash

            let size = None
          end)

module Logging = struct
  let tag = Tag.def ~doc:"Block Hash" "block_hash" pp_short

  let predecessor_tag =
    Tag.def ~doc:"Block Predecessor Hash" "predecessor_hash" pp_short
end

let () = Base58.check_encoded_prefix b58check_encoding "B" 51
src/lib_crypto/block_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Module Logging.
  Definition tag : Tezos_stdlib.Tag.def t :=
    Tag.def (Some "Block Hash" % string) "block_hash" % string pp_short.
  
  Definition predecessor_tag : Tezos_stdlib.Tag.def t :=
    Tag.def (Some "Block Predecessor Hash" % string) "predecessor_hash" % string
      pp_short.
End Logging.



src/lib_crypto/chain_id.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type t = string

let name = "Chain_id"

let title = "Network identifier"

let extract bh = Bytes.sub_string (Block_hash.to_bytes bh) 0 4

let hash_bytes ?key l = extract (Block_hash.hash_bytes ?key l)

let hash_string ?key l = extract (Block_hash.hash_string ?key l)

let size = 4

let of_string_opt s = if String.length s <> size then None else Some s

let of_string s =
  match of_string_opt s with
  | None ->
      generic_error
        "%s.of_string: wrong string size (%d)"
        name
        (String.length s)
  | Some h ->
      Ok h

let of_string_exn s =
  match of_string_opt s with
  | None ->
      Format.kasprintf
        invalid_arg
        "%s.of_string_exn: wrong string size (%d)"
        name
        (String.length s)
  | Some h ->
      h

let to_string s = s

let of_hex s = of_string (Hex.to_string s)

let of_hex_opt s = of_string_opt (Hex.to_string s)

let of_hex_exn s = of_string_exn (Hex.to_string s)

let to_hex s = Hex.of_string (to_string s)

let of_bytes_opt b =
  if Bytes.length b <> size then None else Some (Bytes.to_string b)

let of_bytes_exn b =
  match of_bytes_opt b with
  | None ->
      let msg =
        Printf.sprintf
          "%s.of_bytes: wrong string size (%d)"
          name
          (Bytes.length b)
      in
      raise (Invalid_argument msg)
  | Some h ->
      h

let of_bytes s =
  match of_bytes_opt s with
  | Some x ->
      Ok x
  | None ->
      generic_error "Failed to deserialize a hash (%s)" name

let to_bytes = Bytes.of_string

let path_length = 1

let to_path key l =
  let (`Hex h) = to_hex key in
  h :: l

let of_path path =
  let path = String.concat "" path in
  of_hex_opt (`Hex path)

let of_path_exn path =
  let path = String.concat "" path in
  of_hex_exn (`Hex path)

let prefix_path p =
  let (`Hex p) = Hex.of_string p in
  [p]

let zero = of_hex_exn (`Hex (String.make (size * 2) '0'))

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.chain_id
    ~length:size
    ~wrap:(fun s -> Data s)
    ~of_raw:of_string_opt
    ~to_raw:to_string

let raw_encoding =
  let open Data_encoding in
  conv to_bytes of_bytes_exn (Fixed.bytes size)

let hash h = Int32.to_int (TzEndian.get_int32 (to_bytes h) 0)

let of_block_hash bh = hash_bytes [Block_hash.to_bytes bh]

include Compare.Make (struct
  type nonrec t = t

  let compare = String.compare
end)

include Helpers.Make (struct
  type nonrec t = t

  let title = title

  let name = name

  let b58check_encoding = b58check_encoding

  let raw_encoding = raw_encoding

  let compare = compare

  let equal = equal

  let hash = hash
end)
src/lib_crypto/chain_id.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Definition t := string.

Definition name : string := "Chain_id" % string.

Definition title : string := "Network identifier" % string.

Definition extract (bh : Tezos_crypto.Block_hash.t) : string :=
  Stdlib.Bytes.sub_string (Block_hash.to_bytes bh) 0 4.

Definition hash_bytes (key : option Stdlib.Bytes.t) (l : list Stdlib.Bytes.t)
  : string := extract (Block_hash.hash_bytes key l).

Definition hash_string (key : option string) (l : list string) : string :=
  extract (Block_hash.hash_string key l).

Definition size : Z := 4.

Definition of_string_opt (s : string) : option string :=
  if nequiv_decb (OCaml.String.length s) size then
    None
  else
    Some s.

Definition of_string (s : string)
  : Tezos_error_monad.Error_monad.tzresult string :=
  match of_string_opt s with
  | None =>
    generic_error
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal
            ".of_string: wrong string size (" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))))
        "%s.of_string: wrong string size (%d)" % string) name
      (OCaml.String.length s)
  | Some h => Stdlib.Ok h
  end.

Definition of_string_exn (s : string) : string :=
  match of_string_opt s with
  | None =>
    Format.kasprintf OCaml.Stdlib.invalid_arg
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal
            ".of_string_exn: wrong string size (" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))))
        "%s.of_string_exn: wrong string size (%d)" % string) name
      (OCaml.String.length s)
  | Some h => h
  end.

Definition to_string {A : Type} (s : A) : A := s.

Definition of_hex (s : Hex.t) : Tezos_error_monad.Error_monad.tzresult string :=
  of_string (Hex.to_string s).

Definition of_hex_opt (s : Hex.t) : option string :=
  of_string_opt (Hex.to_string s).

Definition of_hex_exn (s : Hex.t) : string := of_string_exn (Hex.to_string s).

Definition to_hex (s : string) : Hex.t := Hex.of_string None (to_string s).

Definition of_bytes_opt (b : string) : option string :=
  if nequiv_decb (String.length b) size then
    None
  else
    Some (Stdlib.Bytes.to_string b).

Definition of_bytes_exn (b : string) : string :=
  match of_bytes_opt b with
  | None =>
    let msg :=
      Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              ".of_bytes: wrong string size (" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "%s.of_bytes: wrong string size (%d)" % string) name (String.length b)
      in
    Stdlib.raise (OCaml.Invalid_argument msg)
  | Some h => h
  end.

Definition of_bytes (s : string)
  : sum string Tezos_error_monad.Error_monad.trace :=
  match of_bytes_opt s with
  | Some x => Stdlib.Ok x
  | None =>
    generic_error
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to deserialize a hash (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Failed to deserialize a hash (%s)" % string) name
  end.

Definition to_bytes : string -> string := Stdlib.Bytes.of_string.

Definition path_length : Z := 1.

Definition to_path (key : string) (l : list string) : list string :=
  let 'Hex h := to_hex key in
  cons h l.

Definition of_path (path : list string) : option string :=
  let path := Stdlib.String.concat "" % string path in
  of_hex_opt
    (* ❌ Variants not supported *)
    variant.

Definition of_path_exn (path : list string) : string :=
  let path := Stdlib.String.concat "" % string path in
  of_hex_exn
    (* ❌ Variants not supported *)
    variant.

Definition prefix_path (p : string) : list string :=
  let 'Hex p := Hex.of_string None p in
  cons p [].

Definition zero : string :=
  of_hex_exn
    (* ❌ Variants not supported *)
    variant.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
  Base58.register_encoding Base58.Prefix.chain_id size to_string of_string_opt
    (fun s => Tezos_crypto.Base58.Data s).

Definition raw_encoding : Tezos_data_encoding.Data_encoding.encoding string :=
  conv to_bytes of_bytes_exn None (Fixed.bytes size).

Definition hash (h : string) : Z :=
  Int32.to_int (TzEndian.get_int32 (to_bytes h) 0).

Definition of_block_hash (bh : Tezos_crypto.Block_hash.t) : string :=
  hash_bytes None (cons (Block_hash.to_bytes bh) []).

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

src/lib_crypto/context_hash.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Context_hash"

            let title = "A hash of context"

            let b58check_prefix = Base58.Prefix.context_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "Co" 52
src/lib_crypto/context_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include



src/lib_crypto/crypto_box.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos - X25519/XSalsa20-Poly1305 cryptography *)

open Hacl

type secret_key = secret Box.key

type public_key = public Box.key

type channel_key = Box.combined Box.key

type nonce = Bigstring.t

type target = Z.t

module Secretbox = struct
  include Secretbox

  let box_noalloc key nonce msg = box ~key ~nonce ~msg ~cmsg:msg

  let box_open_noalloc key nonce cmsg = box_open ~key ~nonce ~cmsg ~msg:cmsg

  let box key msg nonce =
    let msglen = Bytes.length msg in
    let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
    Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen ;
    box ~key ~nonce ~msg:cmsg ~cmsg ;
    Bigstring.sub cmsg boxzerobytes (msglen + zerobytes - boxzerobytes)

  let box_open key cmsg nonce =
    let cmsglen = Bigstring.length cmsg in
    let msg = Bigstring.make (cmsglen + boxzerobytes) '\x00' in
    Bigstring.blit cmsg 0 msg boxzerobytes cmsglen ;
    match box_open ~key ~nonce ~cmsg:msg ~msg with
    | false ->
        None
    | true ->
        Some (Bigstring.sub_bytes msg zerobytes (cmsglen - boxzerobytes))
end

module Public_key_hash =
  Blake2B.Make
    (Base58)
    (struct
      let name = "Crypto_box.Public_key_hash"

      let title = "A Cryptobox public key ID"

      let b58check_prefix = Base58.Prefix.cryptobox_public_key_hash

      let size = Some 16
    end)

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "id" 30

let hash pk =
  Public_key_hash.hash_bytes [Bigstring.to_bytes (Box.unsafe_to_bytes pk)]

let zerobytes = Box.zerobytes

let boxzerobytes = Box.boxzerobytes

let random_keypair () =
  let (pk, sk) = Box.keypair () in
  (sk, pk, hash pk)

let zero_nonce = Bigstring.make Nonce.bytes '\x00'

let random_nonce = Nonce.gen

let increment_nonce = Nonce.increment

let generate_nonce bytes_list =
  let hash = Blake2B.hash_bytes bytes_list in
  let s = Bigstring.of_bytes (Blake2B.to_bytes hash) in
  Nonce.of_bytes_exn @@ Bigstring.sub s 0 Nonce.bytes

let init_to_resp_seed = Bytes.of_string "Init -> Resp"

let resp_to_init_seed = Bytes.of_string "Resp -> Init"

let generate_nonces ~incoming ~sent_msg ~recv_msg =
  let ((init_msg, resp_msg, false) | (resp_msg, init_msg, true)) =
    (sent_msg, recv_msg, incoming)
  in
  let nonce_init_to_resp =
    generate_nonce [init_msg; resp_msg; init_to_resp_seed]
  in
  let nonce_resp_to_init =
    generate_nonce [init_msg; resp_msg; resp_to_init_seed]
  in
  if incoming then (nonce_init_to_resp, nonce_resp_to_init)
  else (nonce_resp_to_init, nonce_init_to_resp)

let precompute sk pk = Box.dh pk sk

let fast_box_noalloc k nonce bmsg =
  let msg = Bigstring.of_bytes bmsg in
  Box.box ~k ~nonce ~msg ~cmsg:msg ;
  Bigstring.blit_to_bytes msg 0 bmsg 0 (Bytes.length bmsg)

let fast_box_open_noalloc k nonce bcmsg =
  let cmsg = Bigstring.of_bytes bcmsg in
  if Box.box_open ~k ~nonce ~cmsg ~msg:cmsg then (
    Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (Bytes.length bcmsg) ;
    true )
  else false

let fast_box k msg nonce =
  let msglen = Bigstring.length msg in
  let cmsg = Bigstring.make (msglen + zerobytes) '\x00' in
  Bigstring.blit msg 0 cmsg zerobytes msglen ;
  Box.box ~k ~nonce ~msg:cmsg ~cmsg ;
  cmsg

let fast_box_open k cmsg nonce =
  let cmsglen = Bigstring.length cmsg in
  let msg = Bigstring.make cmsglen '\x00' in
  match Box.box_open ~k ~nonce ~cmsg ~msg with
  | false ->
      None
  | true ->
      Some (Bigstring.sub msg zerobytes (cmsglen - zerobytes))

let compare_target hash target =
  let hash = Z.of_bits (Blake2B.to_string hash) in
  Z.compare hash target <= 0

let make_target f =
  if f < 0. || 256. < f then invalid_arg "Cryptobox.target_of_float" ;
  let (frac, shift) = modf f in
  let shift = int_of_float shift in
  let m =
    Z.of_int64
    @@
    if frac = 0. then Int64.(pred (shift_left 1L 54))
    else Int64.of_float (2. ** (54. -. frac))
  in
  if shift < 202 then
    Z.logor
      (Z.shift_left m (202 - shift))
      (Z.pred @@ Z.shift_left Z.one (202 - shift))
  else Z.shift_right m (shift - 202)

let default_target = make_target 24.

let check_proof_of_work pk nonce target =
  let hash =
    Blake2B.hash_bytes
      [Bigstring.to_bytes (Box.unsafe_to_bytes pk); Bigstring.to_bytes nonce]
  in
  compare_target hash target

let generate_proof_of_work ?max pk target =
  let may_interupt =
    match max with
    | None ->
        fun _ -> ()
    | Some max ->
        fun cpt -> if max < cpt then raise Not_found
  in
  let rec loop nonce cpt =
    may_interupt cpt ;
    if check_proof_of_work pk nonce target then nonce
    else loop (Nonce.increment nonce) (cpt + 1)
  in
  loop (random_nonce ()) 0

let public_key_to_bytes pk = Bigstring.to_bytes (Box.unsafe_to_bytes pk)

let public_key_of_bytes buf = Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf)

let public_key_size = Box.pkbytes

let secret_key_to_bytes sk = Bigstring.to_bytes (Box.unsafe_to_bytes sk)

let secret_key_of_bytes buf = Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf)

let secret_key_size = Box.skbytes

let nonce_size = Nonce.bytes

let public_key_encoding =
  let open Data_encoding in
  conv public_key_to_bytes public_key_of_bytes (Fixed.bytes public_key_size)

let secret_key_encoding =
  let open Data_encoding in
  conv secret_key_to_bytes secret_key_of_bytes (Fixed.bytes secret_key_size)

let nonce_encoding =
  let open Data_encoding in
  conv Bigstring.to_bytes Bigstring.of_bytes (Fixed.bytes nonce_size)

let neuterize : secret_key -> public_key = Box.neuterize

let equal : public_key -> public_key -> bool = Box.equal

let pp_pk ppf pk = Hex.pp ppf (Hex.of_bytes (public_key_to_bytes pk))
src/lib_crypto/crypto_box.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Hacl.

Definition secret_key := Hacl.Box.key Hacl.secret.

Definition public_key := Hacl.Box.key Hacl.public.

Definition channel_key := Hacl.Box.key Hacl.Box.combined.

Definition nonce := Bigstring.t.

Definition target := Z.t.

Module Secretbox.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition box_noalloc (key : key) (nonce : Bigstring.t) (msg : Bigstring.t)
    : unit := box key nonce msg msg.
  
  Definition box_open_noalloc
    (key : key) (nonce : Bigstring.t) (cmsg : Bigstring.t) : bool :=
    box_open key nonce cmsg cmsg.
  
  Definition box (key : key) (msg : Stdlib.Bytes.t) (nonce : Bigstring.t)
    : Bigstring.t :=
    let msglen := String.length msg in
    let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Bigstring.blit_of_bytes msg 0 cmsg zerobytes msglen in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := box key nonce cmsg cmsg in
    Bigstring.sub cmsg boxzerobytes
      (Z.sub (Z.add msglen zerobytes) boxzerobytes).
  
  Definition box_open (key : key) (cmsg : Bigstring.t) (nonce : Bigstring.t)
    : option Stdlib.Bytes.t :=
    let cmsglen := Bigstring.length cmsg in
    let msg := Bigstring.make (Z.add cmsglen boxzerobytes) "000" % char in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Bigstring.blit cmsg 0 msg boxzerobytes cmsglen in
    match box_open key nonce msg msg with
    | false => None
    | true =>
      Some (Bigstring.sub_bytes msg zerobytes (Z.sub cmsglen boxzerobytes))
    end.
End Secretbox.

(* ❌ Applications of functors are not handled. *)
functor_application



Definition hash {A : Type} (pk : Hacl.Box.key A)
  : Public_key_hash.(Tezos_crypto__S.HASH.t) :=
  Public_key_hash.(Tezos_crypto__S.HASH.hash_bytes) None
    (cons (Bigstring.to_bytes (Box.unsafe_to_bytes pk)) []).

Definition zerobytes : Z := Box.zerobytes.

Definition boxzerobytes : Z := Box.boxzerobytes.

Definition random_keypair (function_parameter : unit)
  : (Hacl.Box.key Hacl.secret) * (Hacl.Box.key Hacl.public) *
    Public_key_hash.(Tezos_crypto__S.HASH.t) :=
  let 'tt := function_parameter in
  let '(pk, sk) := Box.keypair tt in
  (sk, pk, (hash pk)).

Definition zero_nonce : Bigstring.t := Bigstring.make Nonce.bytes "000" % char.

Definition random_nonce : unit -> Hacl.Nonce.t := Nonce.gen.

Definition increment_nonce : (option Z) -> Hacl.Nonce.t -> Hacl.Nonce.t :=
  Nonce.increment.

Definition generate_nonce (bytes_list : list Stdlib.Bytes.t) : Hacl.Nonce.t :=
  let hash := Blake2B.hash_bytes None bytes_list in
  let s := Bigstring.of_bytes (Blake2B.to_bytes hash) in
  apply Nonce.of_bytes_exn (Bigstring.sub s 0 Nonce.bytes).

Definition init_to_resp_seed : string :=
  Stdlib.Bytes.of_string "Init -> Resp" % string.

Definition resp_to_init_seed : string :=
  Stdlib.Bytes.of_string "Resp -> Init" % string.

Definition generate_nonces
  (incoming : bool) (sent_msg : Stdlib.Bytes.t) (recv_msg : Stdlib.Bytes.t)
  : Hacl.Nonce.t * Hacl.Nonce.t :=
  let '(init_msg, resp_msg, false) | (resp_msg, init_msg, true) :=
    (sent_msg, recv_msg, incoming) in
  let nonce_init_to_resp :=
    generate_nonce (cons init_msg (cons resp_msg (cons init_to_resp_seed [])))
    in
  let nonce_resp_to_init :=
    generate_nonce (cons init_msg (cons resp_msg (cons resp_to_init_seed [])))
    in
  if incoming then
    (nonce_init_to_resp, nonce_resp_to_init)
  else
    (nonce_resp_to_init, nonce_init_to_resp).

Definition precompute
  (sk : Hacl.Box.key Hacl.secret) (pk : Hacl.Box.key Hacl.public)
  : Hacl.Box.key Hacl.Box.combined := Box.dh pk sk.

Definition fast_box_noalloc
  (k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
  (bmsg : Stdlib.Bytes.t) : unit :=
  let msg := Bigstring.of_bytes bmsg in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Box.box k nonce msg msg in
  Bigstring.blit_to_bytes msg 0 bmsg 0 (String.length bmsg).

Definition fast_box_open_noalloc
  (k : Hacl.Box.key Hacl.Box.combined) (nonce : Bigstring.t)
  (bcmsg : Stdlib.Bytes.t) : bool :=
  let cmsg := Bigstring.of_bytes bcmsg in
  if Box.box_open k nonce cmsg cmsg then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Bigstring.blit_to_bytes cmsg 0 bcmsg 0 (String.length bcmsg) in
    true
  else
    false.

Definition fast_box
  (k : Hacl.Box.key Hacl.Box.combined) (msg : Bigstring.t) (nonce : Bigstring.t)
  : Bigstring.t :=
  let msglen := Bigstring.length msg in
  let cmsg := Bigstring.make (Z.add msglen zerobytes) "000" % char in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Bigstring.blit msg 0 cmsg zerobytes msglen in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Box.box k nonce cmsg cmsg in
  cmsg.

Definition fast_box_open
  (k : Hacl.Box.key Hacl.Box.combined) (cmsg : Bigstring.t)
  (nonce : Bigstring.t) : option Bigstring.t :=
  let cmsglen := Bigstring.length cmsg in
  let msg := Bigstring.make cmsglen "000" % char in
  match Box.box_open k nonce cmsg msg with
  | false => None
  | true => Some (Bigstring.sub msg zerobytes (Z.sub cmsglen zerobytes))
  end.

Definition compare_target (hash : Tezos_crypto.Blake2B.t) (target : Z.t)
  : bool :=
  let hash := Z.of_bits (Blake2B.to_string hash) in
  OCaml.Stdlib.le (Z.compare hash target) 0.

Definition make_target (f : Z) : Z.t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      orb
        (OCaml.Stdlib.lt f
          (* ❌ Float constant 0. is approximated by the integer 0 *)
          0)
        (OCaml.Stdlib.lt
          (* ❌ Float constant 256. is approximated by the integer 256 *)
          256 f) then
      OCaml.Stdlib.invalid_arg "Cryptobox.target_of_float" % string
    else
      tt in
  let '(frac, shift) := Stdlib.modf f in
  let shift := Stdlib.int_of_float shift in
  let m :=
    apply Z.of_int64
      (if
        equiv_decb frac
          (* ❌ Float constant 0. is approximated by the integer 0 *)
          0 then
        pred
          (shift_left
            (* ❌ Constant of type int64 is converted to int *)
            1 54)
      else
        Int64.of_float
          (Stdlib.op_starstar
            (* ❌ Float constant 2. is approximated by the integer 2 *)
            2
            (Stdlib.op_minuspoint
              (* ❌ Float constant 54. is approximated by the integer 54 *)
              54 frac))) in
  if OCaml.Stdlib.lt shift 202 then
    Z.logor (Z.shift_left m (Z.sub 202 shift))
      (apply Z.pred (Z.shift_left Z.one (Z.sub 202 shift)))
  else
    Z.shift_right m (Z.sub shift 202).

Definition default_target : Z.t :=
  make_target
    (* ❌ Float constant 24. is approximated by the integer 24 *)
    24.

Definition check_proof_of_work {A : Type}
  (pk : Hacl.Box.key A) (nonce : Bigstring.t) (target : Z.t) : bool :=
  let hash :=
    Blake2B.hash_bytes None
      (cons (Bigstring.to_bytes (Box.unsafe_to_bytes pk))
        (cons (Bigstring.to_bytes nonce) [])) in
  compare_target hash target.

Definition generate_proof_of_work {A : Type}
  (max : option Z) (pk : Hacl.Box.key A) (target : Z.t) : Bigstring.t :=
  let may_interupt :=
    match max with
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        tt
    | Some max =>
      fun cpt =>
        if OCaml.Stdlib.lt max cpt then
          Stdlib.raise OCaml.Not_found
        else
          tt
    end in
  let fix loop (nonce : Bigstring.t) (cpt : Z) : Bigstring.t :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_interupt cpt in
    if check_proof_of_work pk nonce target then
      nonce
    else
      loop (Nonce.increment None nonce) (Z.add cpt 1) in
  loop (random_nonce tt) 0.

Definition public_key_to_bytes {A : Type} (pk : Hacl.Box.key A)
  : Stdlib.Bytes.t := Bigstring.to_bytes (Box.unsafe_to_bytes pk).

Definition public_key_of_bytes (buf : Stdlib.Bytes.t)
  : Hacl.Box.key Hacl.public := Box.unsafe_pk_of_bytes (Bigstring.of_bytes buf).

Definition public_key_size : Z := Box.pkbytes.

Definition secret_key_to_bytes {A : Type} (sk : Hacl.Box.key A)
  : Stdlib.Bytes.t := Bigstring.to_bytes (Box.unsafe_to_bytes sk).

Definition secret_key_of_bytes (buf : Stdlib.Bytes.t)
  : Hacl.Box.key Hacl.secret := Box.unsafe_sk_of_bytes (Bigstring.of_bytes buf).

Definition secret_key_size : Z := Box.skbytes.

Definition nonce_size : Z := Nonce.bytes.

Definition public_key_encoding
  : Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.public) :=
  conv public_key_to_bytes public_key_of_bytes None
    (Fixed.bytes public_key_size).

Definition secret_key_encoding
  : Tezos_data_encoding.Data_encoding.encoding (Hacl.Box.key Hacl.secret) :=
  conv secret_key_to_bytes secret_key_of_bytes None
    (Fixed.bytes secret_key_size).

Definition nonce_encoding
  : Tezos_data_encoding.Data_encoding.encoding Bigstring.t :=
  conv Bigstring.to_bytes Bigstring.of_bytes None (Fixed.bytes nonce_size).

Definition neuterize : secret_key -> public_key := Box.neuterize.

Definition equal : public_key -> public_key -> bool := Box.equal.

Definition pp_pk {A : Type}
  (ppf : Stdlib.Format.formatter) (pk : Hacl.Box.key A) : unit :=
  Hex.pp ppf (Hex.of_bytes None (public_key_to_bytes pk)).

src/lib_crypto/ed25519.ml 33 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module Public_key_hash = struct
  include Blake2B.Make
            (Base58)
            (struct
              let name = "Ed25519.Public_key_hash"

              let title = "An Ed25519 public key hash"

              let b58check_prefix = Base58.Prefix.ed25519_public_key_hash

              let size = Some 20
            end)

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz1" 36

open Hacl

module Public_key = struct
  type t = public Sign.key

  let name = "Ed25519.Public_key"

  let title = "Ed25519 public key"

  let to_string s = Bigstring.to_string (Sign.unsafe_to_bytes s)

  let of_string_opt s =
    if String.length s < Sign.pkbytes then None
    else
      let pk = Bigstring.create Sign.pkbytes in
      Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes ;
      Some (Sign.unsafe_pk_of_bytes pk)

  let to_bytes pk = Bigstring.to_bytes (Sign.unsafe_to_bytes pk)

  let of_bytes_opt buf =
    let buflen = Bytes.length buf in
    if buflen < Sign.pkbytes then None
    else
      let pk = Bigstring.create Sign.pkbytes in
      Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes ;
      Some (Sign.unsafe_pk_of_bytes pk)

  let size = Sign.pkbytes

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_public_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "edpk" 54

  let hash v =
    Public_key_hash.hash_bytes [Bigstring.to_bytes (Sign.unsafe_to_bytes v)]

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = secret Sign.key

  let name = "Ed25519.Secret_key"

  let title = "An Ed25519 secret key"

  let size = Sign.skbytes

  let to_bigstring sk = Sign.unsafe_to_bytes sk

  let to_bytes sk = Bigstring.to_bytes (to_bigstring sk)

  let of_bytes_opt s =
    if Bytes.length s > 64 then None
    else
      let sk = Bigstring.create Sign.skbytes in
      Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes ;
      Some (Sign.unsafe_sk_of_bytes sk)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let to_public_key = Sign.neuterize

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_seed
      ~length:size
      ~to_raw:(fun sk -> Bigstring.to_string (Sign.unsafe_to_bytes sk))
      ~of_raw:(fun buf ->
        if String.length buf <> Sign.skbytes then None
        else Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
      ~wrap:(fun sk -> Data sk)

  (* Legacy NaCl secret key encoding. Used to store both sk and pk. *)
  let secret_key_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_secret_key
      ~length:Sign.(skbytes + pkbytes)
      ~to_raw:(fun sk ->
        let pk = Sign.neuterize sk in
        let buf = Bigstring.create Sign.(skbytes + pkbytes) in
        Sign.blit_to_bytes sk buf ;
        Sign.blit_to_bytes pk ~pos:Sign.skbytes buf ;
        Bigstring.to_string buf)
      ~of_raw:(fun buf ->
        if String.length buf <> Sign.(skbytes + pkbytes) then None
        else
          let sk = Bigstring.create Sign.skbytes in
          Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes ;
          Some (Sign.unsafe_sk_of_bytes sk))
      ~wrap:(fun x -> Data x)

  let of_b58check_opt s =
    match Base58.simple_decode b58check_encoding s with
    | Some x ->
        Some x
    | None ->
        Base58.simple_decode secret_key_encoding s

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error "Failed to read a b58check_encoding data (%s): %S" name s

  let to_b58check s = Base58.simple_encode b58check_encoding s

  let to_short_b58check s =
    String.sub
      (to_b58check s)
      0
      (10 + String.length (Base58.prefix b58check_encoding))

  let () =
    Base58.check_encoded_prefix b58check_encoding "edsk" 54 ;
    Base58.check_encoded_prefix secret_key_encoding "edsk" 98

  include Compare.Make (struct
    type nonrec t = t

    let compare a b =
      Bigstring.compare (Sign.unsafe_to_bytes a) (Sign.unsafe_to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t = Bigstring.t

type watermark = Bytes.t

let name = "Ed25519"

let title = "An Ed25519 signature"

let size = Sign.bytes

let of_bytes_opt s =
  if Bytes.length s = size then Some (Bigstring.of_bytes s) else None

let to_bytes x = Bigstring.to_bytes x

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.ed25519_signature
    ~length:size
    ~to_raw:Bigstring.to_string
    ~of_raw:(fun s -> Some (Bigstring.of_string s))
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "edsig" 99

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Helpers.MakeB58 (struct
  type nonrec t = t

  let name = name

  let b58check_encoding = b58check_encoding
end)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let zero = Bigstring.make size '\000'

let sign ?watermark sk msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  let signature = Bigstring.create Sign.bytes in
  Sign.sign ~sk ~msg:(Bigstring.of_bytes msg) ~signature ;
  signature

let check ?watermark pk signature msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  Sign.verify ~pk ~signature ~msg:(Bigstring.of_bytes msg)

let generate_key ?seed () =
  match seed with
  | None ->
      let (pk, sk) = Sign.keypair () in
      (Public_key.hash pk, pk, sk)
  | Some seed ->
      let seedlen = Bigstring.length seed in
      if seedlen < Sign.skbytes then
        invalid_arg
          (Printf.sprintf
             "Ed25519.generate_key: seed must be at least %d bytes long (got \
              %d)"
             Sign.skbytes
             seedlen) ;
      let sk = Bigstring.create Sign.skbytes in
      Bigstring.blit seed 0 sk 0 Sign.skbytes ;
      let sk = Sign.unsafe_sk_of_bytes sk in
      let pk = Sign.neuterize sk in
      (Public_key.hash pk, pk, sk)

let deterministic_nonce sk msg =
  let msg = Bigstring.of_bytes msg in
  let key = Secret_key.to_bigstring sk in
  Hash.SHA256.HMAC.digest ~key ~msg

let deterministic_nonce_hash sk msg =
  Blake2B.to_bytes
    (Blake2B.hash_bytes [Bigstring.to_bytes (deterministic_nonce sk msg)])

include Compare.Make (struct
  type nonrec t = t

  let compare = Bigstring.compare
end)
src/lib_crypto/ed25519.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module Public_key_hash.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.



Import Hacl.

Module Public_key.
  Definition t := Hacl.Sign.key Hacl.public.
  
  Definition name : string := "Ed25519.Public_key" % string.
  
  Definition title : string := "Ed25519 public key" % string.
  
  Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
    Bigstring.to_string (Sign.unsafe_to_bytes s).
  
  Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.public) :=
    if OCaml.Stdlib.lt (OCaml.String.length s) Sign.pkbytes then
      None
    else
      let pk := Bigstring.create Sign.pkbytes in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Bigstring.blit_of_string s 0 pk 0 Sign.pkbytes in
      Some (Sign.unsafe_pk_of_bytes pk).
  
  Definition to_bytes {A : Type} (pk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
    Bigstring.to_bytes (Sign.unsafe_to_bytes pk).
  
  Definition of_bytes_opt (buf : Stdlib.Bytes.t)
    : option (Hacl.Sign.key Hacl.public) :=
    let buflen := String.length buf in
    if OCaml.Stdlib.lt buflen Sign.pkbytes then
      None
    else
      let pk := Bigstring.create Sign.pkbytes in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Bigstring.blit_of_bytes buf 0 pk 0 Sign.pkbytes in
      Some (Sign.unsafe_pk_of_bytes pk).
  
  Definition size : Z := Sign.pkbytes.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Base58.register_encoding Base58.Prefix.ed25519_public_key size to_string
      of_string_opt (fun x => Tezos_crypto.Base58.Data x).
  
  
  
  Definition hash {A : Type} (v : Hacl.Sign.key A) : Public_key_hash.t :=
    Public_key_hash.hash_bytes None
      (cons (Bigstring.to_bytes (Sign.unsafe_to_bytes v)) []).
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Definition t := Hacl.Sign.key Hacl.secret.
  
  Definition name : string := "Ed25519.Secret_key" % string.
  
  Definition title : string := "An Ed25519 secret key" % string.
  
  Definition size : Z := Sign.skbytes.
  
  Definition to_bigstring {A : Type} (sk : Hacl.Sign.key A) : Bigstring.t :=
    Sign.unsafe_to_bytes sk.
  
  Definition to_bytes {A : Type} (sk : Hacl.Sign.key A) : Stdlib.Bytes.t :=
    Bigstring.to_bytes (to_bigstring sk).
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t)
    : option (Hacl.Sign.key Hacl.secret) :=
    if OCaml.Stdlib.gt (String.length s) 64 then
      None
    else
      let sk := Bigstring.create Sign.skbytes in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Bigstring.blit_of_bytes s 0 sk 0 Sign.skbytes in
      Some (Sign.unsafe_sk_of_bytes sk).
  
  Definition to_string {A : Type} (s : Hacl.Sign.key A) : string :=
    Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string) : option (Hacl.Sign.key Hacl.secret) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition to_public_key {A : Type}
    : (Hacl.Sign.key A) -> Hacl.Sign.key Hacl.public := Sign.neuterize.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Base58.register_encoding Base58.Prefix.ed25519_seed size
      (fun sk => Bigstring.to_string (Sign.unsafe_to_bytes sk))
      (fun buf =>
        if nequiv_decb (OCaml.String.length buf) Sign.skbytes then
          None
        else
          Some (Sign.unsafe_sk_of_bytes (Bigstring.of_string buf)))
      (fun sk => Tezos_crypto.Base58.Data sk).
  
  Definition secret_key_encoding : Tezos_crypto.Base58.encoding t :=
    Base58.register_encoding Base58.Prefix.ed25519_secret_key
      (Z.add skbytes pkbytes)
      (fun sk =>
        let pk := Sign.neuterize sk in
        let buf := Bigstring.create (Z.add skbytes pkbytes) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Sign.blit_to_bytes sk None buf in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Sign.blit_to_bytes pk (Some Sign.skbytes) buf in
        Bigstring.to_string buf)
      (fun buf =>
        if nequiv_decb (OCaml.String.length buf) (Z.add skbytes pkbytes) then
          None
        else
          let sk := Bigstring.create Sign.skbytes in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Bigstring.blit_of_string buf 0 sk 0 Sign.skbytes in
          Some (Sign.unsafe_sk_of_bytes sk))
      (fun x => Tezos_crypto.Base58.Data x).
  
  Definition of_b58check_opt (s : string) : option t :=
    match Base58.simple_decode None b58check_encoding s with
    | Some x => Some x
    | None => Base58.simple_decode None secret_key_encoding s
    end.
  
  Definition of_b58check_exn (s : string) : t :=
    match of_b58check_opt s with
    | Some x => x
    | None =>
      Format.kasprintf Pervasives.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Unexpected data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Unexpected data (%s)" % string) name
    end.
  
  Definition of_b58check (s : string)
    : sum t Tezos_error_monad.Error_monad.trace :=
    match of_b58check_opt s with
    | Some x => Stdlib.Ok x
    | None =>
      generic_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Failed to read a b58check_encoding data (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Failed to read a b58check_encoding data (%s): %S" % string) name s
    end.
  
  Definition to_b58check (s : t) : string :=
    Base58.simple_encode None b58check_encoding s.
  
  Definition to_short_b58check (s : t) : string :=
    Stdlib.String.sub (to_b58check s) 0
      (Z.add 10 (OCaml.String.length (Base58.prefix b58check_encoding))).
  
  
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Definition t := Bigstring.t.

Definition watermark := Stdlib.Bytes.t.

Definition name : string := "Ed25519" % string.

Definition title : string := "An Ed25519 signature" % string.

Definition size : Z := Sign.bytes.

Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
  if equiv_decb (String.length s) size then
    Some (Bigstring.of_bytes s)
  else
    None.

Definition to_bytes (x : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes x.

Definition to_string (s : Bigstring.t) : string :=
  Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string) : option Bigstring.t :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
  Base58.register_encoding Base58.Prefix.ed25519_signature size
    Bigstring.to_string (fun s => Some (Bigstring.of_string s))
    (fun x => Tezos_crypto.Base58.Data x).



(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition zero : Bigstring.t := Bigstring.make size "000" % char.

Definition sign
  (watermark : option Stdlib.Bytes.t) (sk : Hacl.Sign.key Hacl.secret)
  (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg :=
    apply Blake2B.to_bytes
      (apply
        (let arg := Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  let signature := Bigstring.create Sign.bytes in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Sign.sign sk (Bigstring.of_bytes msg) signature in
  signature.

Definition check
  (watermark : option Stdlib.Bytes.t) (pk : Hacl.Sign.key Hacl.public)
  (signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
  let msg :=
    apply Blake2B.to_bytes
      (apply
        (let arg := Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Sign.verify pk (Bigstring.of_bytes msg) signature.

Definition generate_key (seed : option Bigstring.t) (function_parameter : unit)
  : Public_key_hash.t * (Hacl.Sign.key Hacl.public) *
    (Hacl.Sign.key Hacl.secret) :=
  let 'tt := function_parameter in
  match seed with
  | None =>
    let '(pk, sk) := Sign.keypair tt in
    ((Public_key.hash pk), pk, sk)
  | Some seed =>
    let seedlen := Bigstring.length seed in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.lt seedlen Sign.skbytes then
        OCaml.Stdlib.invalid_arg
          (Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Ed25519.generate_key: seed must be at least " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal
                    " bytes long (got " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Ed25519.generate_key: seed must be at least %d bytes long (got %d)"
                % string) Sign.skbytes seedlen)
      else
        tt in
    let sk := Bigstring.create Sign.skbytes in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Bigstring.blit seed 0 sk 0 Sign.skbytes in
    let sk := Sign.unsafe_sk_of_bytes sk in
    let pk := Sign.neuterize sk in
    ((Public_key.hash pk), pk, sk)
  end.

Definition deterministic_nonce {A : Type}
  (sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg := Bigstring.of_bytes msg in
  let key := Secret_key.to_bigstring sk in
  Hash.SHA256.HMAC.digest key msg.

Definition deterministic_nonce_hash {A : Type}
  (sk : Hacl.Sign.key A) (msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
  Blake2B.to_bytes
    (Blake2B.hash_bytes None
      (cons (Bigstring.to_bytes (deterministic_nonce sk msg)) [])).

(* ❌ Structure item `include` not handled. *)
include

src/lib_crypto/helpers.ml 5 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module MakeRaw (H : sig
  type t

  val name : string

  val of_bytes_opt : Bytes.t -> t option

  val to_string : t -> string

  val of_string_opt : string -> t option
end) =
struct
  let of_bytes_exn s =
    match H.of_bytes_opt s with
    | None ->
        Format.kasprintf invalid_arg "of_bytes_exn (%s)" H.name
    | Some pk ->
        pk

  let of_bytes s =
    match H.of_bytes_opt s with
    | None ->
        generic_error "of_bytes (%s)" H.name
    | Some pk ->
        Ok pk

  let of_string_exn s =
    match H.of_string_opt s with
    | None ->
        Format.kasprintf invalid_arg "of_string_exn (%s)" H.name
    | Some pk ->
        pk

  let of_string s =
    match H.of_string_opt s with
    | None ->
        generic_error "of_string (%s)" H.name
    | Some pk ->
        Ok pk

  let to_hex s = Hex.of_string (H.to_string s)

  let of_hex_opt s = H.of_string_opt (Hex.to_string s)

  let of_hex_exn s =
    match H.of_string_opt (Hex.to_string s) with
    | Some x ->
        x
    | None ->
        Format.kasprintf invalid_arg "of_hex_exn (%s)" H.name

  let of_hex s =
    match of_hex_opt s with
    | None ->
        generic_error "of_hex (%s)" H.name
    | Some pk ->
        ok pk
end

module MakeB58 (H : sig
  type t

  val name : string

  val b58check_encoding : t Base58.encoding
end) =
struct
  let of_b58check_opt s = Base58.simple_decode H.b58check_encoding s

  let of_b58check_exn s =
    match of_b58check_opt s with
    | Some x ->
        x
    | None ->
        Format.kasprintf Pervasives.failwith "Unexpected data (%s)" H.name

  let of_b58check s =
    match of_b58check_opt s with
    | Some x ->
        Ok x
    | None ->
        generic_error
          "Failed to read a b58check_encoding data (%s): %S"
          H.name
          s

  let to_b58check s = Base58.simple_encode H.b58check_encoding s

  let to_short_b58check s =
    String.sub
      (to_b58check s)
      0
      (10 + String.length (Base58.prefix H.b58check_encoding))
end

module MakeEncoder (H : sig
  type t

  val title : string

  val name : string

  val to_b58check : t -> string

  val to_short_b58check : t -> string

  val of_b58check : string -> t tzresult

  val of_b58check_exn : string -> t

  val of_b58check_opt : string -> t option

  val raw_encoding : t Data_encoding.t
end) =
struct
  let pp ppf t = Format.pp_print_string ppf (H.to_b58check t)

  let pp_short ppf t = Format.pp_print_string ppf (H.to_short_b58check t)

  let encoding =
    let open Data_encoding in
    splitted
      ~binary:(obj1 (req H.name H.raw_encoding))
      ~json:
        ( def H.name ~title:(H.title ^ " (Base58Check-encoded)")
        @@ conv
             H.to_b58check
             (Data_encoding.Json.wrap_error H.of_b58check_exn)
             string )

  let of_b58check = H.of_b58check

  let rpc_arg =
    RPC_arg.make
      ~name:H.name
      ~descr:(Format.asprintf "%s (Base58Check-encoded)" H.name)
      ~destruct:(fun s ->
        match H.of_b58check_opt s with
        | None ->
            Error
              (Format.asprintf
                 "failed to decode Base58Check-encoded data (%s): %S"
                 H.name
                 s)
        | Some v ->
            Ok v)
      ~construct:H.to_b58check
      ()
end

module MakeIterator (H : sig
  type t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val hash : t -> int
end) =
struct
  module Set = struct
    include Set.Make (struct
      type t = H.t

      let compare = H.compare
    end)

    exception Found of elt

    let random_elt s =
      let n = Random.int (cardinal s) in
      try
        ignore
          ( fold
              (fun x i ->
                if i = n then raise (Found x) ;
                i + 1)
              s
              0
            : int ) ;
        assert false
      with Found x -> x

    let encoding =
      Data_encoding.conv
        elements
        (fun l -> List.fold_left (fun m x -> add x m) empty l)
        Data_encoding.(list H.encoding)
  end

  module Table = struct
    include Hashtbl.Make (struct
      type t = H.t

      let hash = H.hash

      let equal = H.equal
    end)

    let encoding arg_encoding =
      Data_encoding.conv
        (fun h -> fold (fun k v l -> (k, v) :: l) h [])
        (fun l ->
          let h = create (List.length l) in
          List.iter (fun (k, v) -> add h k v) l ;
          h)
        Data_encoding.(list (tup2 H.encoding arg_encoding))
  end

  module Map = struct
    include Map.Make (struct
      type t = H.t

      let compare = H.compare
    end)

    let encoding arg_encoding =
      Data_encoding.conv
        bindings
        (fun l -> List.fold_left (fun m (k, v) -> add k v m) empty l)
        Data_encoding.(list (tup2 H.encoding arg_encoding))
  end

  module Error_table = struct
    include Error_table.Make (Table)
  end

  module WeakRingTable = struct
    include WeakRingTable.Make (struct
      type t = H.t

      let hash = H.hash

      let equal = H.equal
    end)

    let encoding arg_encoding =
      Data_encoding.conv
        (fun h -> fold (fun k v l -> (k, v) :: l) h [])
        (fun l ->
          let h = create (List.length l) in
          List.iter (fun (k, v) -> add h k v) l ;
          h)
        Data_encoding.(list (tup2 H.encoding arg_encoding))
  end
end

module Make (H : sig
  type t

  val title : string

  val name : string

  val b58check_encoding : t Base58.encoding

  val raw_encoding : t Data_encoding.t

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val hash : t -> int
end) =
struct
  include MakeB58 (H)

  include MakeEncoder (struct
    include H

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn
  end)

  include MakeIterator (struct
    include H

    let encoding = encoding
  end)
end
src/lib_crypto/helpers.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

src/lib_crypto/operation_hash.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Operation_hash"

            let title = "A Tezos operation ID"

            let b58check_prefix = Base58.Prefix.operation_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "o" 51

module Logging = struct
  let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/operation_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include



Module Logging.
  Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.

src/lib_crypto/operation_list_hash.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make_merkle_tree
          (Base58)
          (struct
            let name = "Operation_list_hash"

            let title = "A list of operations"

            let b58check_prefix = Base58.Prefix.operation_list_hash

            let size = None
          end)
          (Operation_hash)

let () = Base58.check_encoded_prefix b58check_encoding "Lo" 52
src/lib_crypto/operation_list_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include



src/lib_crypto/operation_list_list_hash.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make_merkle_tree
          (Base58)
          (struct
            let name = "Operation_list_list_hash"

            let title = "A list of list of operations"

            let b58check_prefix = Base58.Prefix.operation_list_list_hash

            let size = None
          end)
          (Operation_list_hash)

let () = Base58.check_encoded_prefix b58check_encoding "LLo" 53
src/lib_crypto/operation_list_list_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include



src/lib_crypto/p256.ml 24 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Public_key_hash = struct
  include Blake2B.Make
            (Base58)
            (struct
              let name = "P256.Public_key_hash"

              let title = "A P256 public key hash"

              let b58check_prefix = Base58.Prefix.p256_public_key_hash

              let size = Some 20
            end)

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz3" 36

open Uecc

module Public_key = struct
  type t = (secp256r1, public) key

  let name = "P256.Public_key"

  let title = "A P256 public key"

  let to_bigstring = to_bytes ~compress:true

  let to_bytes b = Bigstring.to_bytes (to_bigstring b)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_bytes_opt b = pk_of_bytes secp256r1 (Bigstring.of_bytes b)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let size = compressed_size secp256r1

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.p256_public_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "p2pk" 55

  let hash v = Public_key_hash.hash_bytes [to_bytes v]

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = (secp256r1, secret) key

  let name = "P256.Secret_key"

  let title = "A P256 secret key"

  let size = sk_size secp256r1

  let of_bytes_opt buf =
    Option.map ~f:fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf))

  let to_bigstring = to_bytes ~compress:true

  let to_bytes t = Bigstring.to_bytes (to_bigstring t)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let to_public_key = neuterize

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.p256_secret_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "p2sk" 54

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t = Bigstring.t

type watermark = Bytes.t

let name = "P256"

let title = "A P256 signature"

let size = pk_size secp256r1

let of_bytes_opt s =
  if Bytes.length s = size then Some (Bigstring.of_bytes s) else None

let to_bytes s = Bigstring.to_bytes s

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.p256_signature
    ~length:size
    ~to_raw:to_string
    ~of_raw:of_string_opt
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "p2sig" 98

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Helpers.MakeB58 (struct
  type nonrec t = t

  let name = name

  let b58check_encoding = b58check_encoding
end)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let zero = of_bytes_exn (Bytes.make size '\000')

let sign ?watermark sk msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  match sign sk (Bigstring.of_bytes msg) with
  | None ->
      (* Will never happen in practice. This can only happen in case
         of RNG error. *)
      invalid_arg "P256.sign: internal error"
  | Some signature ->
      signature

let check ?watermark public_key signature msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  verify public_key ~msg:(Bigstring.of_bytes msg) ~signature

let generate_key ?(seed = Hacl.Rand.gen 32) () =
  let seedlen = Bigstring.length seed in
  if seedlen < 32 then
    invalid_arg
      (Printf.sprintf
         "P256.generate_key: seed must be at least 32 bytes long (was %d)"
         seedlen) ;
  match sk_of_bytes secp256r1 seed with
  | None ->
      invalid_arg "P256.generate_key: invalid seed (very rare!)"
  | Some (sk, pk) ->
      let pkh = Public_key.hash pk in
      (pkh, pk, sk)

let deterministic_nonce sk msg =
  let msg = Bigstring.of_bytes msg in
  let key = Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest ~key ~msg

let deterministic_nonce_hash sk msg =
  let nonce = deterministic_nonce sk msg in
  Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])

include Compare.Make (struct
  type nonrec t = t

  let compare = Bigstring.compare
end)
src/lib_crypto/p256.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Public_key_hash.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.



Import Uecc.

Module Public_key.
  Definition t := Uecc.key Uecc.secp256r1 Uecc.public.
  
  Definition name : string := "P256.Public_key" % string.
  
  Definition title : string := "A P256 public key" % string.
  
  Definition to_bigstring
    : (Uecc.key Uecc.secp256r1 Uecc.public) -> Bigstring.t :=
    to_bytes (Some true).
  
  Definition to_bytes (b : Uecc.key Uecc.secp256r1 Uecc.public)
    : Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring b).
  
  Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.public) : string :=
    Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_bytes_opt (b : Stdlib.Bytes.t)
    : option (Uecc.key Uecc.secp256r1 Uecc.public) :=
    pk_of_bytes secp256r1 (Bigstring.of_bytes b).
  
  Definition of_string_opt (s : string)
    : option (Uecc.key Uecc.secp256r1 Uecc.public) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition size : Z := compressed_size secp256r1.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Base58.register_encoding Base58.Prefix.p256_public_key size to_string
      of_string_opt (fun x => Tezos_crypto.Base58.Data x).
  
  
  
  Definition hash (v : Uecc.key Uecc.secp256r1 Uecc.public)
    : Public_key_hash.t :=
    Public_key_hash.hash_bytes None (cons (to_bytes v) []).
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Definition t := Uecc.key Uecc.secp256r1 Uecc.secret.
  
  Definition name : string := "P256.Secret_key" % string.
  
  Definition title : string := "A P256 secret key" % string.
  
  Definition size : Z := sk_size secp256r1.
  
  Definition of_bytes_opt (buf : Stdlib.Bytes.t)
    : option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
    Option.map fst (sk_of_bytes secp256r1 (Bigstring.of_bytes buf)).
  
  Definition to_bigstring
    : (Uecc.key Uecc.secp256r1 Uecc.secret) -> Bigstring.t :=
    to_bytes (Some true).
  
  Definition to_bytes (t : Uecc.key Uecc.secp256r1 Uecc.secret)
    : Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring t).
  
  Definition to_string (s : Uecc.key Uecc.secp256r1 Uecc.secret) : string :=
    Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string)
    : option (Uecc.key Uecc.secp256r1 Uecc.secret) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition to_public_key {A B : Type}
    : (Uecc.key A B) -> Uecc.key A Uecc.public := neuterize.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition b58check_encoding : Tezos_crypto.Base58.encoding t :=
    Base58.register_encoding Base58.Prefix.p256_secret_key size to_string
      of_string_opt (fun x => Tezos_crypto.Base58.Data x).
  
  
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Definition t := Bigstring.t.

Definition watermark := Stdlib.Bytes.t.

Definition name : string := "P256" % string.

Definition title : string := "A P256 signature" % string.

Definition size : Z := pk_size secp256r1.

Definition of_bytes_opt (s : Stdlib.Bytes.t) : option Bigstring.t :=
  if equiv_decb (String.length s) size then
    Some (Bigstring.of_bytes s)
  else
    None.

Definition to_bytes (s : Bigstring.t) : Stdlib.Bytes.t := Bigstring.to_bytes s.

Definition to_string (s : Bigstring.t) : string :=
  Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string) : option Bigstring.t :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition b58check_encoding : Tezos_crypto.Base58.encoding Bigstring.t :=
  Base58.register_encoding Base58.Prefix.p256_signature size to_string
    of_string_opt (fun x => Tezos_crypto.Base58.Data x).



(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).

Definition sign {A : Type}
  (watermark : option Stdlib.Bytes.t) (sk : Uecc.key A Uecc.secret)
  (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg :=
    apply Blake2B.to_bytes
      (apply
        (let arg := Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  match sign sk (Bigstring.of_bytes msg) with
  | None => OCaml.Stdlib.invalid_arg "P256.sign: internal error" % string
  | Some signature => signature
  end.

Definition check {A : Type}
  (watermark : option Stdlib.Bytes.t) (public_key : Uecc.key A Uecc.public)
  (signature : Bigstring.t) (msg : Stdlib.Bytes.t) : bool :=
  let msg :=
    apply Blake2B.to_bytes
      (apply
        (let arg := Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  verify public_key (Bigstring.of_bytes msg) signature.

Definition generate_key (op_staroptstar : option Bigstring.t)
  : unit ->
    Public_key_hash.t * (Uecc.key Uecc.secp256r1 Uecc.public) *
      (Uecc.key Uecc.secp256r1 Uecc.secret) :=
  let seed :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Hacl.Rand.gen 32
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    let seedlen := Bigstring.length seed in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.lt seedlen 32 then
        OCaml.Stdlib.invalid_arg
          (Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "P256.generate_key: seed must be at least 32 bytes long (was " %
                  string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "P256.generate_key: seed must be at least 32 bytes long (was %d)"
                % string) seedlen)
      else
        tt in
    match sk_of_bytes secp256r1 seed with
    | None =>
      OCaml.Stdlib.invalid_arg
        "P256.generate_key: invalid seed (very rare!)" % string
    | Some (sk, pk) =>
      let pkh := Public_key.hash pk in
      (pkh, pk, sk)
    end.

Definition deterministic_nonce
  (sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
  : Bigstring.t :=
  let msg := Bigstring.of_bytes msg in
  let key := Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest key msg.

Definition deterministic_nonce_hash
  (sk : Uecc.key Uecc.secp256r1 Uecc.secret) (msg : Stdlib.Bytes.t)
  : Stdlib.Bytes.t :=
  let nonce := deterministic_nonce sk msg in
  Blake2B.to_bytes
    (Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).

(* ❌ Structure item `include` not handled. *)
include

src/lib_crypto/protocol_hash.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Protocol_hash"

            let title = "A Tezos protocol ID"

            let b58check_prefix = Base58.Prefix.protocol_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "P" 51

module Logging = struct
  let tag = Tag.def ~doc:title name pp
end
src/lib_crypto/protocol_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include



Module Logging.
  Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
End Logging.

src/lib_crypto/pvss_secp256k1.ml 56 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Secp256k1_group

module G : Pvss.CYCLIC_GROUP = struct
  module Z_m = struct
    include Group.Scalar

    let n = Group.order

    let ( + ) = Group.Scalar.add

    let ( * ) = Group.Scalar.mul

    let ( - ) = Group.Scalar.sub

    let ( = ) = Group.Scalar.equal

    let inv = Group.Scalar.inverse
  end

  include Group

  let name = "secp256k1"

  (* This pvss algorithm assumes the public keys of the participants receiving
     shares are based on g2, so we set g2 to Group.g to match regular Secp256k1
     public keys.
  *)
  let g1 = Group.h

  let g2 = Group.g

  (* We use a multiplicative notation in the pvss module, but
     secp256k1 usually uses an additive notation. *)
  let ( * ) = Group.(( + ))

  let pow x n = Group.mul n x

  let of_bits b = try Some (Group.of_bits_exn b) with _ -> None
end

include Pvss.MakePvss (G)
src/lib_crypto/pvss_secp256k1.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Secp256k1_group.

Module G.
  Module Z_m.
    (* ❌ Structure item `include` not handled. *)
    include
    
    Definition n : Z.t := Group.order.
    
    Definition op_plus
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
          Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.add.
    
    Definition op_star
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
          Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.mul.
    
    Definition op_minus
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
          Tezos_crypto.Secp256k1_group.Group.Scalar.t := Group.Scalar.sub.
    
    Definition op_eq
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        Tezos_crypto.Secp256k1_group.Group.Scalar.t -> bool :=
      Group.Scalar.equal.
    
    Definition inv
      : Tezos_crypto.Secp256k1_group.Group.Scalar.t ->
        option Tezos_crypto.Secp256k1_group.Group.Scalar.t :=
      Group.Scalar.inverse.
  End Z_m.
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition name : string := "secp256k1" % string.
  
  Definition g1 : Tezos_crypto.Secp256k1_group.Group.t := Group.h.
  
  Definition g2 : Tezos_crypto.Secp256k1_group.Group.t := Group.g.
  
  Definition op_star
    : Tezos_crypto.Secp256k1_group.Group.t ->
      Tezos_crypto.Secp256k1_group.Group.t ->
        Tezos_crypto.Secp256k1_group.Group.t := op_plus.
  
  Definition pow
    (x : Tezos_crypto.Secp256k1_group.Group.t)
    (n : Tezos_crypto.Secp256k1_group.Group.Scalar.t)
    : Tezos_crypto.Secp256k1_group.Group.t := Group.mul n x.
  
  Definition of_bits (b : string)
    : option Tezos_crypto.Secp256k1_group.Group.t :=
    (* ❌ Try-with are not handled *)
    try (Some (Group.of_bits_exn b)).
End G.

(* ❌ Structure item `include` not handled. *)
include

src/lib_crypto/rand.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let generate len = Bigstring.to_bytes (Hacl.Rand.gen len)

let generate_into ?(pos = 0) ?len buf =
  let buflen = Bytes.length buf in
  let len = match len with Some len -> len | None -> buflen - pos in
  if pos < 0 || len < 0 || pos + len > buflen then
    invalid_arg
      (Printf.sprintf
         "Rand.generate_into: invalid slice (pos=%d len=%d)"
         pos
         len) ;
  let rand = Hacl.Rand.gen len in
  Bigstring.blit_to_bytes rand 0 buf pos len
src/lib_crypto/rand.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition generate (len : Z) : Stdlib.Bytes.t :=
  Bigstring.to_bytes (Hacl.Rand.gen len).

Definition generate_into (op_staroptstar : option Z)
  : (option Z) -> Stdlib.Bytes.t -> unit :=
  let pos :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun len =>
    fun buf =>
      let buflen := String.length buf in
      let len :=
        match len with
        | Some len => len
        | None => Z.sub buflen pos
        end in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if
          orb (OCaml.Stdlib.lt pos 0)
            (orb (OCaml.Stdlib.lt len 0)
              (OCaml.Stdlib.gt (Z.add pos len) buflen)) then
          OCaml.Stdlib.invalid_arg
            (Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Rand.generate_into: invalid slice (pos=" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal " len=" % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))))
                "Rand.generate_into: invalid slice (pos=%d len=%d)" % string)
              pos len)
        else
          tt in
      let rand := Hacl.Rand.gen len in
      Bigstring.blit_to_bytes rand 0 buf pos len.

src/lib_crypto/s.ml 31 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

(** {2 Hash Types} *)

(** The signature of an abstract hash type, as produced by functor
    {!Make_Blake2B}. The {!t} type is abstracted for separating the
    various kinds of hashes in the system at typing time. Each type is
    equipped with functions to use it as is of as keys in the database
    or in memory sets and maps. *)

module type MINIMAL_HASH = sig
  type t

  val name : string

  val title : string

  val pp : Format.formatter -> t -> unit

  val pp_short : Format.formatter -> t -> unit

  include Compare.S with type t := t

  val hash_bytes : ?key:Bytes.t -> Bytes.t list -> t

  val hash_string : ?key:string -> string list -> t

  val zero : t
end

module type RAW_DATA = sig
  type t

  val size : int (* in bytes *)

  val to_hex : t -> Hex.t

  val of_hex : Hex.t -> t tzresult

  val of_hex_opt : Hex.t -> t option

  val of_hex_exn : Hex.t -> t

  val to_string : t -> string

  val of_string : string -> t tzresult

  val of_string_opt : string -> t option

  val of_string_exn : string -> t

  val to_bytes : t -> Bytes.t

  val of_bytes : Bytes.t -> t tzresult

  val of_bytes_opt : Bytes.t -> t option

  val of_bytes_exn : Bytes.t -> t
end

module type B58_DATA = sig
  type t

  val to_b58check : t -> string

  val to_short_b58check : t -> string

  val of_b58check : string -> t tzresult

  val of_b58check_exn : string -> t

  val of_b58check_opt : string -> t option

  type Base58.data += Data of t

  val b58check_encoding : t Base58.encoding
end

module type ENCODER = sig
  type t

  val encoding : t Data_encoding.t

  val rpc_arg : t RPC_arg.t
end

module type PVSS = sig
  type proof

  module Clear_share : sig
    type t
  end

  module Commitment : sig
    type t
  end

  module Encrypted_share : sig
    type t
  end

  module Public_key : sig
    type t

    include B58_DATA with type t := t

    include ENCODER with type t := t
  end
end

module type INDEXES = sig
  type t

  val hash : t -> int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val of_path_exn : string list -> t

  val prefix_path : string -> string list

  val path_length : int

  module Set : sig
    include Set.S with type elt = t

    val random_elt : t -> elt

    val encoding : t Data_encoding.t
  end

  module Map : sig
    include Map.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end

  module Table : sig
    include Hashtbl.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end

  module Error_table : sig
    include Error_table.S with type key = t
  end

  module WeakRingTable : sig
    include WeakRingTable.S with type key = t

    val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
  end
end

module type HASH = sig
  include MINIMAL_HASH

  include RAW_DATA with type t := t

  include B58_DATA with type t := t

  include ENCODER with type t := t

  include INDEXES with type t := t
end

module type MERKLE_TREE = sig
  type elt

  val elt_bytes : elt -> Bytes.t

  include HASH

  val compute : elt list -> t

  val empty : t

  type path = Left of path * t | Right of t * path | Op

  val path_encoding : path Data_encoding.t

  val bounded_path_encoding : ?max_length:int -> unit -> path Data_encoding.t

  val compute_path : elt list -> int -> path

  val check_path : path -> elt -> t * int
end

module type SIGNATURE = sig
  module Public_key_hash : sig
    type t

    val pp : Format.formatter -> t -> unit

    val pp_short : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include RAW_DATA with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    include INDEXES with type t := t

    val zero : t

    module Logging : sig
      val tag : t Tag.def
    end
  end

  module Public_key : sig
    type t

    val pp : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    val hash : t -> Public_key_hash.t
  end

  module Secret_key : sig
    type t

    val pp : Format.formatter -> t -> unit

    include Compare.S with type t := t

    include B58_DATA with type t := t

    include ENCODER with type t := t

    val to_public_key : t -> Public_key.t
  end

  type t

  val pp : Format.formatter -> t -> unit

  include Compare.S with type t := t

  include B58_DATA with type t := t

  include ENCODER with type t := t

  val zero : t

  type watermark

  val sign : ?watermark:watermark -> Secret_key.t -> Bytes.t -> t

  val check : ?watermark:watermark -> Public_key.t -> t -> Bytes.t -> bool

  val generate_key :
    ?seed:Bigstring.t ->
    unit ->
    Public_key_hash.t * Public_key.t * Secret_key.t

  val deterministic_nonce : Secret_key.t -> Bytes.t -> Bigstring.t

  val deterministic_nonce_hash : Secret_key.t -> Bytes.t -> Bytes.t
end
src/lib_crypto/s.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module MINIMAL_HASH.
  Record signature {t : Type} := {
    t := t;
    name : string;
    title : string;
    pp : Stdlib.Format.formatter -> t -> unit;
    pp_short : Stdlib.Format.formatter -> t -> unit;
    include;
    hash_bytes : (option Stdlib.Bytes.t) -> (list Stdlib.Bytes.t) -> t;
    hash_string : (option string) -> (list string) -> t;
    zero : t;
  }.
  Arguments signature : clear implicits.
End MINIMAL_HASH.

Module RAW_DATA.
  Record signature {t : Type} := {
    t := t;
    size : Z;
    to_hex : t -> Hex.t;
    of_hex : Hex.t -> Tezos_error_monad.Error_monad.tzresult t;
    of_hex_opt : Hex.t -> option t;
    of_hex_exn : Hex.t -> t;
    to_string : t -> string;
    of_string : string -> Tezos_error_monad.Error_monad.tzresult t;
    of_string_opt : string -> option t;
    of_string_exn : string -> t;
    to_bytes : t -> Stdlib.Bytes.t;
    of_bytes : Stdlib.Bytes.t -> Tezos_error_monad.Error_monad.tzresult t;
    of_bytes_opt : Stdlib.Bytes.t -> option t;
    of_bytes_exn : Stdlib.Bytes.t -> t;
  }.
  Arguments signature : clear implicits.
End RAW_DATA.

Module B58_DATA.
  Record signature {t : Type} := {
    t := t;
    to_b58check : t -> string;
    to_short_b58check : t -> string;
    of_b58check : string -> Tezos_error_monad.Error_monad.tzresult t;
    of_b58check_exn : string -> t;
    of_b58check_opt : string -> option t;
    extensible_type;
    b58check_encoding : Tezos_crypto.Base58.encoding t;
  }.
  Arguments signature : clear implicits.
End B58_DATA.

Module ENCODER.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_data_encoding.Data_encoding.t t;
    rpc_arg : Tezos_rpc.RPC_arg.t t;
  }.
  Arguments signature : clear implicits.
End ENCODER.

Module PVSS.
  Record signature {proof Clear_share_t Commitment_t Encrypted_share_t
    Public_key_t : Type} := {
    proof := proof;
    Clear_share : signature;
    Commitment : signature;
    Encrypted_share : signature;
    Public_key : signature;
  }.
  Arguments signature : clear implicits.
End PVSS.

Module INDEXES.
  Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
    := {
    t := t;
    hash : t -> Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
    of_path_exn : (list string) -> t;
    prefix_path : string -> list string;
    path_length : Z;
    Set : signature;
    Map : signature;
    Table : signature;
    Error_table : signature;
    WeakRingTable : signature;
  }.
  Arguments signature : clear implicits.
End INDEXES.

Module HASH.
  Record signature {t Set_t Map_t Table_t Error_table_t WeakRingTable_t : Type}
    := {
    include;
    include;
    include;
    include;
    include;
  }.
  Arguments signature : clear implicits.
End HASH.

Module MERKLE_TREE.
  Record signature {elt t Set_t Map_t Table_t Error_table_t WeakRingTable_t path
    : Type} := {
    elt := elt;
    elt_bytes : elt -> Stdlib.Bytes.t;
    include;
    compute : (list elt) -> t;
    empty : t;
    path := path;
    path_encoding : Tezos_data_encoding.Data_encoding.t path;
    bounded_path_encoding : (option Z) ->
      unit -> Tezos_data_encoding.Data_encoding.t path;
    compute_path : (list elt) -> Z -> path;
    check_path : path -> elt -> t * Z;
  }.
  Arguments signature : clear implicits.
End MERKLE_TREE.

Module SIGNATURE.
  Record signature {Public_key_hash_t Public_key_hash_Set_t
    Public_key_hash_Map_t Public_key_hash_Table_t Public_key_hash_Error_table_t
    Public_key_hash_WeakRingTable_t Public_key_t Secret_key_t t watermark :
    Type} := {
    Public_key_hash : signature;
    Public_key : signature;
    Secret_key : signature;
    t := t;
    pp : Stdlib.Format.formatter -> t -> unit;
    include;
    include;
    include;
    zero : t;
    watermark := watermark;
    sign : (option watermark) -> Secret_key.t -> Stdlib.Bytes.t -> t;
    check : (option watermark) -> Public_key.t -> t -> Stdlib.Bytes.t -> bool;
    generate_key : (option Bigstring.t) ->
      unit -> Public_key_hash.t * Public_key.t * Secret_key.t;
    deterministic_nonce : Secret_key.t -> Stdlib.Bytes.t -> Bigstring.t;
    deterministic_nonce_hash : Secret_key.t -> Stdlib.Bytes.t -> Stdlib.Bytes.t;
  }.
  Arguments signature : clear implicits.
End SIGNATURE.

src/lib_crypto/secp256k1.ml 90 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Public_key_hash = struct
  include Blake2B.Make
            (Base58)
            (struct
              let name = "Secp256k1.Public_key_hash"

              let title = "A Secp256k1 public key hash"

              let b58check_prefix = Base58.Prefix.secp256k1_public_key_hash

              let size = Some 20
            end)

  module Logging = struct
    let tag = Tag.def ~doc:title name pp
  end
end

let () = Base58.check_encoded_prefix Public_key_hash.b58check_encoding "tz2" 36

open Libsecp256k1.External

let context =
  let ctx = Context.create () in
  match Context.randomize ctx (Hacl.Rand.gen 32) with
  | false ->
      failwith "Secp256k1 context randomization failed. Aborting."
  | true ->
      ctx

module Public_key = struct
  type t = Key.public Key.t

  let name = "Secp256k1.Public_key"

  let title = "A Secp256k1 public key"

  let to_bytes pk = Bigstring.to_bytes (Key.to_bytes context pk)

  let of_bytes_opt s =
    try Some (Key.read_pk_exn context (Bigstring.of_bytes s)) with _ -> None

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let size = Key.compressed_pk_bytes

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.secp256k1_public_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "sppk" 55

  let hash v = Public_key_hash.hash_bytes [to_bytes v]

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bytes.compare (to_bytes a) (to_bytes b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

module Secret_key = struct
  type t = Key.secret Key.t

  let name = "Secp256k1.Secret_key"

  let title = "A Secp256k1 secret key"

  let size = Key.secret_bytes

  let of_bytes_opt s =
    match Key.read_sk context (Bigstring.of_bytes s) with
    | Ok x ->
        Some x
    | _ ->
        None

  let to_bigstring = Key.to_bytes context

  let to_bytes x = Bigstring.to_bytes (to_bigstring x)

  let to_string s = Bytes.to_string (to_bytes s)

  let of_string_opt s = of_bytes_opt (Bytes.of_string s)

  let to_public_key key = Key.neuterize_exn context key

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:Base58.Prefix.secp256k1_secret_key
      ~length:size
      ~to_raw:to_string
      ~of_raw:of_string_opt
      ~wrap:(fun x -> Data x)

  let () = Base58.check_encoded_prefix b58check_encoding "spsk" 54

  include Compare.Make (struct
    type nonrec t = t

    let compare a b = Bigstring.compare (Key.buffer a) (Key.buffer b)
  end)

  include Helpers.MakeRaw (struct
    type nonrec t = t

    let name = name

    let of_bytes_opt = of_bytes_opt

    let of_string_opt = of_string_opt

    let to_string = to_string
  end)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding =
      let open Data_encoding in
      conv to_bytes of_bytes_exn (Fixed.bytes size)

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check
  end)

  let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)
end

type t = Sign.plain Sign.t

type watermark = Bytes.t

let name = "Secp256k1"

let title = "A Secp256k1 signature"

let size = Sign.plain_bytes

let of_bytes_opt s =
  match Sign.read context (Bigstring.of_bytes s) with
  | Ok s ->
      Some s
  | Error _ ->
      None

let to_bytes t = Bigstring.to_bytes (Sign.to_bytes ~der:false context t)

let to_string s = Bytes.to_string (to_bytes s)

let of_string_opt s = of_bytes_opt (Bytes.of_string s)

type Base58.data += Data of t

let b58check_encoding =
  Base58.register_encoding
    ~prefix:Base58.Prefix.secp256k1_signature
    ~length:size
    ~to_raw:to_string
    ~of_raw:of_string_opt
    ~wrap:(fun x -> Data x)

let () = Base58.check_encoded_prefix b58check_encoding "spsig1" 99

include Compare.Make (struct
  type nonrec t = t

  let compare a b = Bigstring.compare (Sign.buffer a) (Sign.buffer b)
end)

include Helpers.MakeRaw (struct
  type nonrec t = t

  let name = name

  let of_bytes_opt = of_bytes_opt

  let of_string_opt = of_string_opt

  let to_string = to_string
end)

include Helpers.MakeB58 (struct
  type nonrec t = t

  let name = name

  let b58check_encoding = b58check_encoding
end)

include Helpers.MakeEncoder (struct
  type nonrec t = t

  let name = name

  let title = title

  let raw_encoding =
    let open Data_encoding in
    conv to_bytes of_bytes_exn (Fixed.bytes size)

  let of_b58check = of_b58check

  let of_b58check_opt = of_b58check_opt

  let of_b58check_exn = of_b58check_exn

  let to_b58check = to_b58check

  let to_short_b58check = to_short_b58check
end)

let pp ppf t = Format.fprintf ppf "%s" (to_b58check t)

let zero = of_bytes_exn (Bytes.make size '\000')

let sign ?watermark sk msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  Sign.sign_exn context ~sk (Bigstring.of_bytes msg)

let check ?watermark public_key signature msg =
  let msg =
    Blake2B.to_bytes @@ Blake2B.hash_bytes
    @@ match watermark with None -> [msg] | Some prefix -> [prefix; msg]
  in
  Sign.verify_exn
    context
    ~pk:public_key
    ~msg:(Bigstring.of_bytes msg)
    ~signature

let generate_key ?(seed = Hacl.Rand.gen 32) () =
  let sk = Key.read_sk_exn context seed in
  let pk = Key.neuterize_exn context sk in
  let pkh = Public_key.hash pk in
  (pkh, pk, sk)

let deterministic_nonce sk msg =
  let msg = Bigstring.of_bytes msg in
  let key = Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest ~key ~msg

let deterministic_nonce_hash sk msg =
  let nonce = deterministic_nonce sk msg in
  Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce])
src/lib_crypto/secp256k1.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Public_key_hash.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Module Logging.
    Definition tag : Tezos_stdlib.Tag.def t := Tag.def (Some title) name pp.
  End Logging.
End Public_key_hash.



Import Libsecp256k1.External.

Definition context : Libsecp256k1.External.Context.t :=
  let ctx := Context.create None None tt in
  match Context.randomize ctx (Hacl.Rand.gen 32) with
  | false =>
    OCaml.Stdlib.failwith
      "Secp256k1 context randomization failed. Aborting." % string
  | true => ctx
  end.

Module Public_key.
  Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public.
  
  Definition name : string := "Secp256k1.Public_key" % string.
  
  Definition title : string := "A Secp256k1 public key" % string.
  
  Definition to_bytes {A : Type} (pk : Libsecp256k1.External.Key.t A)
    : Stdlib.Bytes.t := Bigstring.to_bytes (Key.to_bytes None context pk).
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
    (* ❌ Try-with are not handled *)
    try (Some (Key.read_pk_exn context (Bigstring.of_bytes s))).
  
  Definition to_string {A : Type} (s : Libsecp256k1.External.Key.t A)
    : string := Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition size : Z := Key.compressed_pk_bytes.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition b58check_encoding
    : Tezos_crypto.Base58.encoding
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) :=
    Base58.register_encoding Base58.Prefix.secp256k1_public_key size to_string
      of_string_opt (fun x => Tezos_crypto.Base58.Data x).
  
  
  
  Definition hash {A : Type} (v : Libsecp256k1.External.Key.t A)
    : Public_key_hash.t :=
    Public_key_hash.hash_bytes None (cons (to_bytes v) []).
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Public_key.

Module Secret_key.
  Definition t := Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret.
  
  Definition name : string := "Secp256k1.Secret_key" % string.
  
  Definition title : string := "A Secp256k1 secret key" % string.
  
  Definition size : Z := Key.secret_bytes.
  
  Definition of_bytes_opt (s : Stdlib.Bytes.t)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
    match Key.read_sk context (Bigstring.of_bytes s) with
    | Stdlib.Ok x => Some x
    | _ => None
    end.
  
  Definition to_bigstring
    : (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) ->
      Bigstring.t := Key.to_bytes None context.
  
  Definition to_bytes
    (x : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
    : Stdlib.Bytes.t := Bigstring.to_bytes (to_bigstring x).
  
  Definition to_string
    (s : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
    : string := Stdlib.Bytes.to_string (to_bytes s).
  
  Definition of_string_opt (s : string)
    : option (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
    of_bytes_opt (Stdlib.Bytes.of_string s).
  
  Definition to_public_key {A : Type} (key : Libsecp256k1.External.Key.t A)
    : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public :=
    Key.neuterize_exn context key.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition b58check_encoding
    : Tezos_crypto.Base58.encoding
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
    Base58.register_encoding Base58.Prefix.secp256k1_secret_key size to_string
      of_string_opt (fun x => Tezos_crypto.Base58.Data x).
  
  
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).
End Secret_key.

Definition t := Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain.

Definition watermark := Stdlib.Bytes.t.

Definition name : string := "Secp256k1" % string.

Definition title : string := "A Secp256k1 signature" % string.

Definition size : Z := Sign.plain_bytes.

Definition of_bytes_opt (s : Stdlib.Bytes.t)
  : option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
  match Sign.read context (Bigstring.of_bytes s) with
  | Stdlib.Ok s => Some s
  | Stdlib.Error _ => None
  end.

Definition to_bytes {A : Type} (t : Libsecp256k1.External.Sign.t A)
  : Stdlib.Bytes.t := Bigstring.to_bytes (Sign.to_bytes (Some false) context t).

Definition to_string {A : Type} (s : Libsecp256k1.External.Sign.t A) : string :=
  Stdlib.Bytes.to_string (to_bytes s).

Definition of_string_opt (s : string)
  : option (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
  of_bytes_opt (Stdlib.Bytes.of_string s).

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition b58check_encoding
  : Tezos_crypto.Base58.encoding
    (Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain) :=
  Base58.register_encoding Base58.Prefix.secp256k1_signature size to_string
    of_string_opt (fun x => Tezos_crypto.Base58.Data x).



(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

Definition pp (ppf : Stdlib.Format.formatter) (t : t) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        CamlinternalFormatBasics.End_of_format) "%s" % string) (to_b58check t).

Definition zero : t := of_bytes_exn (Stdlib.Bytes.make size "000" % char).

Definition sign
  (watermark : option Stdlib.Bytes.t)
  (sk : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.secret)
  (msg : Stdlib.Bytes.t)
  : Libsecp256k1.External.Sign.t Libsecp256k1.External.Sign.plain :=
  let msg :=
    apply Blake2B.to_bytes
      (apply
        (let arg := Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Sign.sign_exn context sk (Bigstring.of_bytes msg).

Definition check {A : Type}
  (watermark : option Stdlib.Bytes.t)
  (public_key : Libsecp256k1__External.Key.t Libsecp256k1__External.Key.public)
  (signature : Libsecp256k1.External.Sign.t A) (msg : Stdlib.Bytes.t) : bool :=
  let msg :=
    apply Blake2B.to_bytes
      (apply
        (let arg := Blake2B.hash_bytes in
        fun eta => arg None eta)
        match watermark with
        | None => cons msg []
        | Some prefix => cons prefix (cons msg [])
        end) in
  Sign.verify_exn context public_key (Bigstring.of_bytes msg) signature.

Definition generate_key (op_staroptstar : option Bigstring.t)
  : unit ->
    Public_key_hash.t *
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.public) *
      (Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret) :=
  let seed :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Hacl.Rand.gen 32
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    let sk := Key.read_sk_exn context seed in
    let pk := Key.neuterize_exn context sk in
    let pkh := Public_key.hash pk in
    (pkh, pk, sk).

Definition deterministic_nonce
  (sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
  (msg : Stdlib.Bytes.t) : Bigstring.t :=
  let msg := Bigstring.of_bytes msg in
  let key := Secret_key.to_bigstring sk in
  Hacl.Hash.SHA256.HMAC.digest key msg.

Definition deterministic_nonce_hash
  (sk : Libsecp256k1.External.Key.t Libsecp256k1.External.Key.secret)
  (msg : Stdlib.Bytes.t) : Stdlib.Bytes.t :=
  let nonce := deterministic_nonce sk msg in
  Blake2B.to_bytes
    (Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])).

src/lib_crypto/secp256k1_group.ml 91 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Sp = Libsecp256k1.Internal

module type SCALAR_SIG = sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val zero : t

  val one : t

  val of_Z : Z.t -> t

  val to_Z : t -> Z.t

  val of_int : int -> t

  val add : t -> t -> t

  val mul : t -> t -> t

  val negate : t -> t

  val sub : t -> t -> t

  val of_bits_exn : string -> t

  val to_bits : t -> string

  val inverse : t -> t option

  val pow : t -> Z.t -> t

  val equal : t -> t -> bool
end

module Group : sig
  val order : Z.t

  module Scalar : SCALAR_SIG

  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val e : t

  val g : t

  val h : t

  val of_coordinates : x:Z.t -> y:Z.t -> t

  val of_bits_exn : string -> t

  val to_bits : t -> string

  val mul : Scalar.t -> t -> t

  val ( + ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( = ) : t -> t -> bool
end = struct
  let order =
    Z.of_string_base
      16
      "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141"

  let string_rev s =
    let len = String.length s in
    String.init len (fun i -> s.[len - 1 - i])

  let b32_of_Z z =
    let cs = Cstruct.create 32 in
    let bits = Z.to_bits z in
    let length = min 32 (String.length bits) in
    let bits = String.sub bits 0 length in
    let bits = string_rev bits in
    Cstruct.blit_from_string bits 0 cs (32 - length) length ;
    cs

  let z_of_b32 b = b |> Cstruct.to_string |> string_rev |> Z.of_bits

  module Scalar : SCALAR_SIG with type t = Sp.Scalar.t = struct
    type t = Sp.Scalar.t

    let zero = Sp.Scalar.zero ()

    let one = Sp.Scalar.one ()

    let equal x y = Sp.Scalar.equal x y

    let of_Z z =
      let z = Z.erem z order in
      let r = Sp.Scalar.const () in
      let cs = b32_of_Z z in
      let _ = Sp.Scalar.set_b32 r cs in
      r

    let to_Z s =
      let cs = Cstruct.create 32 in
      Sp.Scalar.get_b32 cs s ; cs |> z_of_b32

    let of_int i = i |> Z.of_int |> of_Z

    let pow t n = Z.powm (to_Z t) n order |> of_Z

    let add x y =
      let r = Sp.Scalar.const () in
      let _ = Sp.Scalar.add r x y in
      r

    let mul x y =
      let r = Sp.Scalar.const () in
      Sp.Scalar.mul r x y ; r

    let negate x =
      let r = Sp.Scalar.const () in
      Sp.Scalar.negate r x ; r

    let sub x y = add x (negate y)

    let of_bits_exn bits =
      let r = Sp.Scalar.const () in
      (* trim to 32 bytes *)
      let cs = Cstruct.create 32 in
      Cstruct.blit_from_string bits 0 cs 0 (min (String.length bits) 32) ;
      (* ignore overflow condition, it's always 0 based on the c-code *)
      let _ = Sp.Scalar.set_b32 r cs in
      r

    (* TODO, check that we are less than the order *)

    let to_bits x =
      let c = Cstruct.create 32 in
      Sp.Scalar.get_b32 c x ; Cstruct.to_string c

    let inverse x =
      if x = zero then None
      else
        let r = Sp.Scalar.const () in
        Sp.Scalar.inverse r x ; Some r

    type Base58.data += Data of t

    let b58check_encoding =
      Base58.register_encoding
        ~prefix:Base58.Prefix.secp256k1_scalar
        ~length:32
        ~to_raw:to_bits
        ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
        ~wrap:(fun x -> Data x)

    let title = "Secp256k1_group.Scalar"

    let name = "Anscalar for the secp256k1 group"

    include Helpers.MakeB58 (struct
      type nonrec t = t

      let name = name

      let b58check_encoding = b58check_encoding
    end)

    include Helpers.MakeEncoder (struct
      type nonrec t = t

      let name = name

      let title = title

      let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)

      let to_b58check = to_b58check

      let to_short_b58check = to_short_b58check

      let of_b58check = of_b58check

      let of_b58check_opt = of_b58check_opt

      let of_b58check_exn = of_b58check_exn
    end)
  end

  type t = Sp.Group.Jacobian.t

  (* type ge = Sp.Group.ge *)

  let field_of_Z z =
    let fe = Sp.Field.const () in
    let cs = b32_of_Z z in
    let _ = Sp.Field.set_b32 fe cs in
    fe

  let group_of_jacobian j =
    let r = Sp.Group.of_fields () in
    Sp.Group.Jacobian.get_ge r j ;
    r

  let jacobian_of_group g =
    let j = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.set_ge j g ;
    j

  let of_coordinates ~x ~y =
    Sp.Group.of_fields ~x:(field_of_Z x) ~y:(field_of_Z y) ()
    |> jacobian_of_group

  let e = Sp.Group.Jacobian.of_fields ~infinity:true ()

  let g =
    let gx =
      Z.of_string
        "55066263022277343669578718895168534326250603453777594175500187360389116729240"
    and gy =
      Z.of_string
        "32670510020758816978083085130507043184471273380659243275938904335757337482424"
    in
    of_coordinates ~x:gx ~y:gy

  (* To obtain the second generator, take the sha256 hash of the decimal representation of g1_y
       python -c "import hashlib;print int(hashlib.sha256('32670510020758816978083085130507043184471273380659243275938904335757337482424').hexdigest(),16)"
  *)
  let h =
    let hx =
      Z.of_string
        "54850469061264194188802857211425616972714231399857248865148107587305936171824"
    and hy =
      Z.of_string
        "6558914719042992724977242403721980463337660510165027616783569279181206179101"
    in
    of_coordinates ~x:hx ~y:hy

  let ( + ) x y =
    let r = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.add_var r x y ;
    r

  let ( - ) x y =
    let neg_y = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.neg neg_y y ;
    x + neg_y

  let ( = ) x y = Sp.Group.Jacobian.is_infinity (x - y)

  let mul s g =
    let r = Sp.Group.Jacobian.of_fields () in
    Sp.Group.Jacobian.mul r (group_of_jacobian g) s ;
    r

  let to_bits j =
    let x = group_of_jacobian j and buf = Cstruct.create 33 in
    let cs = Sp.Group.to_pubkey ~compress:true buf x in
    Cstruct.to_string cs

  let of_bits_exn bits =
    let buf = Cstruct.of_string bits and x = Sp.Group.of_fields () in
    Sp.Group.from_pubkey x buf ; x |> jacobian_of_group

  module Encoding = struct
    type Base58.data += Data of t

    let title = "Secp256k1_group.Group"

    let name = "An element of secp256k1"

    let b58check_encoding =
      Base58.register_encoding
        ~prefix:Base58.Prefix.secp256k1_element
        ~length:33
        ~to_raw:to_bits
        ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
        ~wrap:(fun x -> Data x)

    include Helpers.MakeB58 (struct
      type nonrec t = t

      let name = name

      let b58check_encoding = b58check_encoding
    end)

    include Helpers.MakeEncoder (struct
      type nonrec t = t

      let name = name

      let title = title

      let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)

      let to_b58check = to_b58check

      let to_short_b58check = to_short_b58check

      let of_b58check = of_b58check

      let of_b58check_opt = of_b58check_opt

      let of_b58check_exn = of_b58check_exn
    end)
  end

  include Encoding
end
src/lib_crypto/secp256k1_group.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module SCALAR_SIG.
  Record signature {t : Type} := {
    t := t;
    include;
    include;
    zero : t;
    one : t;
    of_Z : Z.t -> t;
    to_Z : t -> Z.t;
    of_int : Z -> t;
    add : t -> t -> t;
    mul : t -> t -> t;
    negate : t -> t;
    sub : t -> t -> t;
    of_bits_exn : string -> t;
    to_bits : t -> string;
    inverse : t -> option t;
    pow : t -> Z.t -> t;
    equal : t -> t -> bool;
  }.
  Arguments signature : clear implicits.
End SCALAR_SIG.

Module Group.
  Definition order : Z.t :=
    Z.of_string_base 16
      "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEBAAEDCE6AF48A03BBFD25E8CD0364141" %
        string.
  
  Definition string_rev (s : string) : string :=
    let len := OCaml.String.length s in
    Stdlib.String.init len
      (fun i => Stdlib.String.get s (Z.sub (Z.sub len 1) i)).
  
  Definition b32_of_Z (z : Z.t) : Cstruct.t :=
    let cs := Cstruct.create 32 in
    let bits := Z.to_bits z in
    let length := OCaml.Stdlib.min 32 (OCaml.String.length bits) in
    let bits := Stdlib.String.sub bits 0 length in
    let bits := string_rev bits in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Cstruct.blit_from_string bits 0 cs (Z.sub 32 length) length in
    cs.
  
  Definition z_of_b32 (b : Cstruct.t) : Z.t :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply b Cstruct.to_string) string_rev) Z.of_bits.
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
  
  Definition t := Sp.Group.Jacobian.t.
  
  Definition field_of_Z (z : Z.t) : Sp.Field.t :=
    let fe := Sp.Field.const None None None None None None None None tt in
    let cs := b32_of_Z z in
    let '_ := Sp.Field.set_b32 fe cs in
    fe.
  
  Definition group_of_jacobian (j : Sp.Group.Jacobian.t) : Sp.Group.t :=
    let r := Sp.Group.of_fields None None None tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Sp.Group.Jacobian.get_ge r j in
    r.
  
  Definition jacobian_of_group (g : Libsecp256k1__Internal.Group.ge)
    : Sp.Group.Jacobian.t :=
    let j := Sp.Group.Jacobian.of_fields None None None None tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Sp.Group.Jacobian.set_ge j g in
    j.
  
  Definition of_coordinates (x : Z.t) (y : Z.t) : Sp.Group.Jacobian.t :=
    OCaml.Stdlib.reverse_apply
      (Sp.Group.of_fields (Some (field_of_Z x)) (Some (field_of_Z y)) None tt)
      jacobian_of_group.
  
  Definition e : Sp.Group.Jacobian.t :=
    Sp.Group.Jacobian.of_fields None None None (Some true) tt.
  
  Definition g : Sp.Group.Jacobian.t :=
    let gx : Z.t :=
      Z.of_string
        "55066263022277343669578718895168534326250603453777594175500187360389116729240"
          % string
    with gy : Z.t :=
      Z.of_string
        "32670510020758816978083085130507043184471273380659243275938904335757337482424"
          % string in
    of_coordinates gx gy.
  
  Definition h : Sp.Group.Jacobian.t :=
    let hx : Z.t :=
      Z.of_string
        "54850469061264194188802857211425616972714231399857248865148107587305936171824"
          % string
    with hy : Z.t :=
      Z.of_string
        "6558914719042992724977242403721980463337660510165027616783569279181206179101"
          % string in
    of_coordinates hx hy.
  
  Definition op_plus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
    : Sp.Group.Jacobian.t :=
    let r := Sp.Group.Jacobian.of_fields None None None None tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Sp.Group.Jacobian.add_var None r x y in
    r.
  
  Definition op_minus (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t)
    : Sp.Group.Jacobian.t :=
    let neg_y := Sp.Group.Jacobian.of_fields None None None None tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Sp.Group.Jacobian.neg neg_y y in
    op_plus x neg_y.
  
  Definition op_eq (x : Sp.Group.Jacobian.t) (y : Sp.Group.Jacobian.t) : bool :=
    Sp.Group.Jacobian.is_infinity (op_minus x y).
  
  Definition mul (s : Libsecp256k1__Internal.Scalar.t) (g : Sp.Group.Jacobian.t)
    : Sp.Group.Jacobian.t :=
    let r := Sp.Group.Jacobian.of_fields None None None None tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Sp.Group.Jacobian.mul r (group_of_jacobian g) s in
    r.
  
  Definition to_bits (j : Sp.Group.Jacobian.t) : string :=
    let x : Sp.Group.t :=
      group_of_jacobian j
    with buf : Cstruct.t :=
      Cstruct.create 33 in
    let cs := Sp.Group.to_pubkey (Some true) buf x in
    Cstruct.to_string cs.
  
  Definition of_bits_exn (bits : string) : Sp.Group.Jacobian.t :=
    let buf : Cstruct.t :=
      Cstruct.of_string None None None bits
    with x : Sp.Group.t :=
      Sp.Group.of_fields None None None tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Sp.Group.from_pubkey x buf in
    OCaml.Stdlib.reverse_apply x jacobian_of_group.
  
  Module Encoding.
    (* ❌ Structure item `typext` not handled. *)
    type_extension
    
    Definition title : string := "Secp256k1_group.Group" % string.
    
    Definition name : string := "An element of secp256k1" % string.
    
    Definition b58check_encoding
      : Tezos_crypto.Base58.encoding Sp.Group.Jacobian.t :=
      Base58.register_encoding Base58.Prefix.secp256k1_element 33 to_bits
        (fun s =>
          (* ❌ Try-with are not handled *)
          try (Some (of_bits_exn s))) (fun x => Tezos_crypto.Base58.Data x).
    
    (* ❌ Structure item `include` not handled. *)
    include
    
    (* ❌ Structure item `include` not handled. *)
    include
  End Encoding.
  
  (* ❌ Structure item `include` not handled. *)
  include
End Group.

src/lib_crypto/test/roundtrips.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_rt_opt name testable enc dec input =
  try
    let roundtripped = dec (enc input) in
    Alcotest.check (Alcotest.option testable) name (Some input) roundtripped
  with exc ->
    Alcotest.failf
      "%s failed for %a: exception whilst decoding: %s"
      name
      (Alcotest.pp testable)
      input
      (Printexc.to_string exc)

let test_decode_opt_safe name testable dec encoded =
  match dec encoded with
  | Some _ | None ->
      ()
  | exception exc ->
      Alcotest.failf
        "%s failed for %a: exception whilst decoding: %s"
        name
        (Alcotest.pp testable)
        encoded
        (Printexc.to_string exc)

let test_decode_opt_fail name testable dec encoded =
  try
    let decoded = dec encoded in
    Alcotest.check (Alcotest.option testable) name None decoded
  with exc ->
    Alcotest.failf
      "%s failed: exception whilst decoding: %s"
      name
      (Printexc.to_string exc)
src/lib_crypto/test/roundtrips.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_rt_opt {A B C D E F : Type}
  (name : A) (testable : B) (enc : C -> D) (dec : D -> E) (input : C) : F :=
  (* ❌ Try-with are not handled *)
  try
    (let roundtripped := dec (enc input) in
    op_startypeminuserrorstar (op_startypeminuserrorstar testable) name
      (Some input) roundtripped).

Definition test_decode_opt_safe {A B C D : Type}
  (name : A) (testable : B) (dec : C -> option D) (encoded : C) : unit :=
  let 'Some _ | None := dec encoded in
  tt.

Definition test_decode_opt_fail {A B C D E : Type}
  (name : A) (testable : B) (dec : C -> D) (encoded : C) : E :=
  (* ❌ Try-with are not handled *)
  try
    (let decoded := dec encoded in
    op_startypeminuserrorstar (op_startypeminuserrorstar testable) name None
      decoded).

src/lib_crypto/test/test_base58.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_roundtrip_safe input =
  Roundtrips.test_rt_opt
    "safe base58"
    Alcotest.string
    Base58.safe_encode
    Base58.safe_decode
    input

let test_roundtrip_raw input =
  Roundtrips.test_rt_opt
    "raw base58"
    Alcotest.string
    Base58.raw_encode
    Base58.raw_decode
    input

let inputs =
  [ "abc";
    string_of_int max_int;
    "0";
    "00";
    "000";
    "0000";
    "0000000000000000";
    String.make 64 '0';
    "1";
    "11";
    "111";
    "1111";
    String.make 2048 '0';
    "2";
    "22";
    "5";
    "Z";
    String.make 2048 'Z';
    "z";
    "zz";
    "zzzzzzzz";
    String.make 2048 'z';
    (*loads of ascii characters: codes between 32 and 126 *)
    String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
    "" ]

let test_roundtrip_safes () = List.iter test_roundtrip_safe inputs

let test_roundtrip_raws () = List.iter test_roundtrip_raw inputs

let test_safety input =
  Roundtrips.test_decode_opt_safe
    "safe base58"
    Alcotest.string
    Base58.safe_decode
    input

let test_safetys () = List.iter test_safety inputs

let tests =
  [ ("safe decoding", `Quick, test_safetys);
    ("safe encoding/decoding", `Quick, test_roundtrip_safes);
    ("raw encoding/decoding", `Quick, test_roundtrip_raws) ]

let () = Alcotest.run "tezos-crypto" [("base58", tests)]
src/lib_crypto/test/test_base58.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_roundtrip_safe {A B : Type} (input : A) : B :=
  op_startypeminuserrorstar "safe base58" % string op_startypeminuserrorstar
    Base58.safe_encode Base58.safe_decode input.

Definition test_roundtrip_raw {A B : Type} (input : A) : B :=
  op_startypeminuserrorstar "raw base58" % string op_startypeminuserrorstar
    Base58.raw_encode Base58.raw_decode input.

Definition inputs : list string :=
  cons "abc" % string
    (cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
      (cons "0" % string
        (cons "00" % string
          (cons "000" % string
            (cons "0000" % string
              (cons "0000000000000000" % string
                (cons (Stdlib.String.make 64 "0" % char)
                  (cons "1" % string
                    (cons "11" % string
                      (cons "111" % string
                        (cons "1111" % string
                          (cons (Stdlib.String.make 2048 "0" % char)
                            (cons "2" % string
                              (cons "22" % string
                                (cons "5" % string
                                  (cons "Z" % string
                                    (cons (Stdlib.String.make 2048 "Z" % char)
                                      (cons "z" % string
                                        (cons "zz" % string
                                          (cons "zzzzzzzz" % string
                                            (cons
                                              (Stdlib.String.make 2048
                                                "z" % char)
                                              (cons
                                                (Stdlib.String.init 1000
                                                  (fun i =>
                                                    Char.chr
                                                      (Z.add 32
                                                        (Z.modulo i
                                                          (Z.sub 126 32)))))
                                                (cons "" % string []))))))))))))))))))))))).

Definition test_roundtrip_safes (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Stdlib.List.iter test_roundtrip_safe inputs.

Definition test_roundtrip_raws (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Stdlib.List.iter test_roundtrip_raw inputs.

Definition test_safety {A B : Type} (input : A) : B :=
  op_startypeminuserrorstar "safe base58" % string op_startypeminuserrorstar
    Base58.safe_decode input.

Definition test_safetys (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Stdlib.List.iter test_safety inputs.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("safe decoding" % string,
      (* ❌ Variants not supported *)
      variant, test_safetys)
    (cons
      ("safe encoding/decoding" % string,
        (* ❌ Variants not supported *)
        variant, test_roundtrip_safes)
      (cons
        ("raw encoding/decoding" % string,
          (* ❌ Variants not supported *)
          variant, test_roundtrip_raws) [])).



src/lib_crypto/test/test_blake2b.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_hashed_roundtrip name enc dec input =
  (* this wrapper to start with hashing *)
  Roundtrips.test_rt_opt
    name
    (Alcotest.testable
       (fun fmt (input, _) -> Format.fprintf fmt "%s" input)
       (fun (_, hashed) (_, decoded) -> hashed = decoded))
    (fun (_, hashed) -> enc hashed)
    (fun encoded ->
      match dec encoded with
      | None ->
          None
      | Some decoded ->
          Some (input, decoded))
    (input, Blake2B.hash_string [input])

let test_roundtrip_hex input =
  test_hashed_roundtrip "Hex" Blake2B.to_hex Blake2B.of_hex_opt input

let test_roundtrip_string input =
  test_hashed_roundtrip "String" Blake2B.to_string Blake2B.of_string_opt input

let inputs =
  [ "abc";
    string_of_int max_int;
    "0";
    "00";
    String.make 64 '0';
    (*loads of ascii characters: codes between 32 and 126 *)
    String.init 1000 (fun i -> Char.chr (32 + (i mod (126 - 32))));
    "" ]

let test_roundtrip_hexs () = List.iter test_roundtrip_hex inputs

let test_roundtrip_strings () = List.iter test_roundtrip_string inputs

let tests =
  [ ("hash hex/dehex", `Quick, test_roundtrip_hexs);
    ("hash print/parse", `Quick, test_roundtrip_strings) ]

let () = Alcotest.run "tezos-crypto" [("blake2b", tests)]
src/lib_crypto/test/test_blake2b.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_hashed_roundtrip {A B C D E F : Type}
  (name : A) (enc : B -> C) (dec : D -> option E) (input : string) : F :=
  op_startypeminuserrorstar name
    (op_startypeminuserrorstar
      (fun fmt =>
        fun function_parameter =>
          let '(input, _) := function_parameter in
          Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) input)
      (fun function_parameter =>
        let '(_, hashed) := function_parameter in
        fun function_parameter =>
          let '(_, decoded) := function_parameter in
          equiv_decb hashed decoded))
    (fun function_parameter =>
      let '(_, hashed) := function_parameter in
      enc hashed)
    (fun encoded =>
      match dec encoded with
      | None => None
      | Some decoded => Some (input, decoded)
      end) (input, (Blake2B.hash_string None (cons input []))).

Definition test_roundtrip_hex {A : Type} (input : string) : A :=
  test_hashed_roundtrip "Hex" % string Blake2B.to_hex Blake2B.of_hex_opt input.

Definition test_roundtrip_string {A : Type} (input : string) : A :=
  test_hashed_roundtrip "String" % string Blake2B.to_string
    Blake2B.of_string_opt input.

Definition inputs : list string :=
  cons "abc" % string
    (cons (OCaml.Stdlib.string_of_int Stdlib.max_int)
      (cons "0" % string
        (cons "00" % string
          (cons (Stdlib.String.make 64 "0" % char)
            (cons
              (Stdlib.String.init 1000
                (fun i => Char.chr (Z.add 32 (Z.modulo i (Z.sub 126 32)))))
              (cons "" % string [])))))).

Definition test_roundtrip_hexs (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Stdlib.List.iter test_roundtrip_hex inputs.

Definition test_roundtrip_strings (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Stdlib.List.iter test_roundtrip_string inputs.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("hash hex/dehex" % string,
      (* ❌ Variants not supported *)
      variant, test_roundtrip_hexs)
    (cons
      ("hash print/parse" % string,
        (* ❌ Variants not supported *)
        variant, test_roundtrip_strings) []).



src/lib_crypto/test/test_crypto_box.ml 21 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let (sk, pk, pkh) = Crypto_box.random_keypair ()

let zero_nonce = Crypto_box.zero_nonce

let chkey = Crypto_box.precompute sk pk

let test_check_pow () =
  let target = Crypto_box.make_target 2. in
  let pow = Crypto_box.generate_proof_of_work pk target in
  Alcotest.(check bool)
    "check_pow"
    (Crypto_box.check_proof_of_work pk pow target)
    true

let test_neutrize sk pk () =
  Alcotest.check
    (Alcotest.testable Crypto_box.pp_pk Crypto_box.equal)
    "neuterize"
    (Crypto_box.neuterize sk)
    pk

let test_hash pk pkh () =
  Alcotest.check
    (Alcotest.testable
       Crypto_box.Public_key_hash.pp
       Crypto_box.Public_key_hash.equal)
    "test_hash"
    (Crypto_box.hash pk)
    pkh

let test_fast_box msg () =
  let msglen = Bytes.length msg in
  let buf_length = msglen + Crypto_box.zerobytes in
  let buf = Bytes.make buf_length '\x00' in
  Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
  (* encryption / decryption *)
  Crypto_box.fast_box_noalloc chkey zero_nonce buf ;
  ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf) ;
  let res =
    Bytes.sub buf Crypto_box.zerobytes (buf_length - Crypto_box.zerobytes)
  in
  Alcotest.check
    Alcotest.(testable (fun fmt x -> Hex.pp fmt (Hex.of_bytes x)) Bytes.equal)
    "test_fastbox enc/dec"
    res
    msg

let tests =
  [ ("Neutrize Secret roundtrip", `Quick, test_neutrize sk pk);
    ("Public Key Hash roundtrip", `Quick, test_hash pk pkh);
    ("Check PoW", `Slow, test_check_pow);
    ("Test hacl fastbox", `Quick, test_fast_box (Bytes.of_string "test")) ]

let () = Alcotest.run "tezos-crypto" [("crypto_box", tests)]
src/lib_crypto/test/test_crypto_box.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



Definition zero_nonce : Tezos_crypto.Crypto_box.nonce := Crypto_box.zero_nonce.

Definition chkey : Tezos_crypto.Crypto_box.channel_key :=
  Crypto_box.precompute sk pk.

Definition test_check_pow {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  let target :=
    Crypto_box.make_target
      (* ❌ Float constant 2. is approximated by the integer 2 *)
      2 in
  let pow := Crypto_box.generate_proof_of_work None pk target in
  op_startypeminuserrorstar "check_pow" % string
    (Crypto_box.check_proof_of_work pk pow target) true.

Definition test_neutrize {A B : Type}
  (sk : Tezos_crypto.Crypto_box.secret_key) (pk : A) (function_parameter : unit)
  : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar Crypto_box.pp_pk Crypto_box.equal)
    "neuterize" % string (Crypto_box.neuterize sk) pk.

Definition test_hash {A B : Type}
  (pk : Tezos_crypto.Crypto_box.public_key) (pkh : A)
  (function_parameter : unit) : B :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (op_startypeminuserrorstar Crypto_box.Public_key_hash.pp
      Crypto_box.Public_key_hash.equal) "test_hash" % string
    (Crypto_box.hash pk) pkh.

Definition test_fast_box {A : Type} (msg : string) (function_parameter : unit)
  : A :=
  let 'tt := function_parameter in
  let msglen := String.length msg in
  let buf_length := Z.add msglen Crypto_box.zerobytes in
  let buf := Stdlib.Bytes.make buf_length "000" % char in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Crypto_box.fast_box_noalloc chkey zero_nonce buf in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    OCaml.Stdlib.ignore (Crypto_box.fast_box_open_noalloc chkey zero_nonce buf)
    in
  let res :=
    String.sub buf Crypto_box.zerobytes (Z.sub buf_length Crypto_box.zerobytes)
    in
  op_startypeminuserrorstar op_startypeminuserrorstar
    "test_fastbox enc/dec" % string res msg.

Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
  cons
    ("Neutrize Secret roundtrip" % string,
      (* ❌ Variants not supported *)
      variant, (test_neutrize sk pk))
    (cons
      ("Public Key Hash roundtrip" % string,
        (* ❌ Variants not supported *)
        variant, (test_hash pk pkh))
      (cons
        ("Check PoW" % string,
          (* ❌ Variants not supported *)
          variant, test_check_pow)
        (cons
          ("Test hacl fastbox" % string,
            (* ❌ Variants not supported *)
            variant, (test_fast_box (Stdlib.Bytes.of_string "test" % string)))
          []))).



src/lib_crypto/test/test_deterministic_nonce.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let test_hash_matches (module X : S.SIGNATURE) () =
  let (_, _, sk) = X.generate_key () in
  let data = Bytes.of_string "ce input sa pun eu aici oare?" in
  let nonce = X.deterministic_nonce sk data in
  let nonce_hash = X.deterministic_nonce_hash sk data in
  let hashed_nonce = Blake2B.hash_bytes [Bigstring.to_bytes nonce] in
  if nonce_hash <> Blake2B.to_bytes hashed_nonce then
    Alcotest.failf
      "the hash of deterministic_nonce is NOT deterministic_nonce_hash"

let ed25519 = (module Ed25519 : S.SIGNATURE)

let p256 = (module P256 : S.SIGNATURE)

let secp256k1 = (module Secp256k1 : S.SIGNATURE)

let tests =
  [ ("hash_matches_ed25519", `Quick, test_hash_matches ed25519);
    ("hash_matches_p256", `Quick, test_hash_matches p256);
    ("hash_matches_secp256k1", `Quick, test_hash_matches secp256k1) ]

let () = Alcotest.run "tezos-crypto" [("deterministic_nonce", tests)]
src/lib_crypto/test/test_deterministic_nonce.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_hash_matches
  (X :
    {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
      Public_key_hash_Table_t, Public_key_hash_Error_table_t,
      Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark)
      : _ &
      Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
        Public_key_hash_Map_t Public_key_hash_Table_t
        Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t
        Public_key_t Secret_key_t t watermark}) : unit -> unit :=
  let X := projT2 X in
  fun function_parameter =>
    let 'tt := function_parameter in
    let '(_, _, sk) := X.(Tezos_crypto__S.SIGNATURE.generate_key) None tt in
    let data := Stdlib.Bytes.of_string "ce input sa pun eu aici oare?" % string
      in
    let nonce := X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce) sk data in
    let nonce_hash :=
      X.(Tezos_crypto__S.SIGNATURE.deterministic_nonce_hash) sk data in
    let hashed_nonce :=
      Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) []) in
    if nequiv_decb nonce_hash (Blake2B.to_bytes hashed_nonce) then
      op_startypeminuserrorstar
        "the hash of deterministic_nonce is NOT deterministic_nonce_hash" %
          string
    else
      tt.

Definition ed25519
  : {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
    Public_key_hash_Table_t, Public_key_hash_Error_table_t,
    Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
    _ &
    Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
      Public_key_hash_Map_t Public_key_hash_Table_t
      Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
      Secret_key_t t watermark} := Ed25519.

Definition p256
  : {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
    Public_key_hash_Table_t, Public_key_hash_Error_table_t,
    Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
    _ &
    Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
      Public_key_hash_Map_t Public_key_hash_Table_t
      Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
      Secret_key_t t watermark} := P256.

Definition secp256k1
  : {'(Public_key_hash_t, Public_key_hash_Set_t, Public_key_hash_Map_t,
    Public_key_hash_Table_t, Public_key_hash_Error_table_t,
    Public_key_hash_WeakRingTable_t, Public_key_t, Secret_key_t, t, watermark) :
    _ &
    Tezos_crypto.S.SIGNATURE.signature Public_key_hash_t Public_key_hash_Set_t
      Public_key_hash_Map_t Public_key_hash_Table_t
      Public_key_hash_Error_table_t Public_key_hash_WeakRingTable_t Public_key_t
      Secret_key_t t watermark} := Secp256k1.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("hash_matches_ed25519" % string,
      (* ❌ Variants not supported *)
      variant, (test_hash_matches ed25519))
    (cons
      ("hash_matches_p256" % string,
        (* ❌ Variants not supported *)
        variant, (test_hash_matches p256))
      (cons
        ("hash_matches_secp256k1" % string,
          (* ❌ Variants not supported *)
          variant, (test_hash_matches secp256k1)) [])).



src/lib_crypto/test/test_ed25519.ml 17 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type B58CHECK = sig
  type t

  val pp : Format.formatter -> t -> unit

  include S.B58_DATA with type t := t
end

let test_b58check_roundtrip :
    type t. (module B58CHECK with type t = t) -> t -> unit =
 fun m input ->
  let module M = (val m) in
  let testable = Alcotest.testable M.pp ( = ) in
  Roundtrips.test_rt_opt
    "b58check"
    testable
    M.to_b58check
    M.of_b58check_opt
    input

let test_b58check_roundtrips () =
  let (pubkey_hash, pubkey, seckey) = Ed25519.generate_key () in
  test_b58check_roundtrip (module Ed25519.Public_key_hash) pubkey_hash ;
  test_b58check_roundtrip (module Ed25519.Public_key) pubkey ;
  test_b58check_roundtrip (module Ed25519.Secret_key) seckey

let test_b58check_invalid input =
  Roundtrips.test_decode_opt_fail
    "b58check"
    (Alcotest.testable Ed25519.Public_key_hash.pp Ed25519.Public_key_hash.( = ))
    Ed25519.Public_key_hash.of_b58check_opt
    input

let test_b58check_invalids () =
  List.iter
    test_b58check_invalid
    [ "ThisIsGarbageNotACheck";
      "\x00";
      String.make 1000 '\x00';
      String.make 2048 'a';
      String.init 2048 (fun _ -> Char.chr (Random.int 256));
      "" ]

let tests =
  [ ("b58check.roundtrip", `Quick, test_b58check_roundtrips);
    ("b58check.invalid", `Slow, test_b58check_invalids) ]

let () = Alcotest.run "tezos-crypto" [("ed25519", tests)]
src/lib_crypto/test/test_ed25519.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module B58CHECK.
  Record signature {t : Type} := {
    t := t;
    pp : Stdlib.Format.formatter -> t -> unit;
    include;
  }.
  Arguments signature : clear implicits.
End B58CHECK.

Definition test_b58check_roundtrip {t : Type}
  (m : {_ : unit & B58CHECK.signature t}) (input : t) : unit :=
  let M := projT2 m in
  let testable := op_startypeminuserrorstar M.(B58CHECK.pp) equiv_decb in
  op_startypeminuserrorstar "b58check" % string testable
    M.(B58CHECK.to_b58check) M.(B58CHECK.of_b58check_opt) input.

Definition test_b58check_roundtrips (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let '(pubkey_hash, pubkey, seckey) := Ed25519.generate_key None tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := test_b58check_roundtrip Ed25519.Public_key_hash pubkey_hash in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := test_b58check_roundtrip Ed25519.Public_key pubkey in
  test_b58check_roundtrip Ed25519.Secret_key seckey.

Definition test_b58check_invalid {A B : Type} (input : A) : B :=
  op_startypeminuserrorstar "b58check" % string
    (op_startypeminuserrorstar Ed25519.Public_key_hash.pp
      Ed25519.Public_key_hash.op_eq) Ed25519.Public_key_hash.of_b58check_opt
    input.

Definition test_b58check_invalids (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Stdlib.List.iter test_b58check_invalid
    (cons "ThisIsGarbageNotACheck" % string
      (cons "" % string
        (cons (Stdlib.String.make 1000 "000" % char)
          (cons (Stdlib.String.make 2048 "a" % char)
            (cons
              (Stdlib.String.init 2048
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Char.chr (Random.int 256))) (cons "" % string [])))))).

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("b58check.roundtrip" % string,
      (* ❌ Variants not supported *)
      variant, test_b58check_roundtrips)
    (cons
      ("b58check.invalid" % string,
        (* ❌ Variants not supported *)
        variant, test_b58check_invalids) []).



src/lib_crypto/test/test_merkle.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Utils.Infix

type tree = Empty | Leaf of int | Node of tree * tree

let rec list_of_tree = function
  | Empty ->
      ([], 0)
  | Leaf x ->
      ([x], 1)
  | Node (x, y) ->
      let (x, sx) = list_of_tree x and (y, sy) = list_of_tree y in
      assert (sx = sy) ;
      (x @ y, sx + sy)

module Merkle = Blake2B.Generic_Merkle_tree (struct
  type t = tree

  type elt = int

  let empty = Empty

  let leaf i = Leaf i

  let node x y = Node (x, y)
end)

let rec compare_list xs ys =
  match (xs, ys) with
  | ([], []) ->
      true
  | ([x], y :: ys) when x = y ->
      ys = [] || compare_list xs ys
  | (x :: xs, y :: ys) when x = y ->
      compare_list xs ys
  | (_, _) ->
      false

let check_size i =
  let l = 0 -- i in
  let (l2, _) = list_of_tree (Merkle.compute l) in
  if compare_list l l2 then ()
  else
    Format.kasprintf
      failwith
      "Failed for %d: %a"
      i
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.pp_print_string ppf ";")
         Format.pp_print_int)
      l2

let test_compute _ = List.iter check_size (0 -- 99)

let check_path i =
  let l = 0 -- i in
  let orig = Merkle.compute l in
  List.iter
    (fun j ->
      let path = Merkle.compute_path l j in
      let (found, pos) = Merkle.check_path path j in
      if found = orig && j = pos then ()
      else Format.kasprintf failwith "Failed for %d in %d." j i)
    l

let test_path _ = List.iter check_path (0 -- 128)

let tests = [("compute", `Quick, test_compute); ("path", `Quick, test_path)]

let () = Alcotest.run "tezos-crypto" [("merkel", tests)]
src/lib_crypto/test/test_merkle.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Utils.Infix.

Inductive tree : Type :=
| Empty : tree
| Leaf : Z -> tree
| Node : tree -> tree -> tree.

Fixpoint list_of_tree (function_parameter : tree) : (list Z) * Z :=
  match function_parameter with
  | Empty => ([], 0)
  | Leaf x => ((cons x []), 1)
  | Node x y =>
    in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Assert instruction is not handled. *)
      assert (equiv_decb sx sy) in
    ((OCaml.Stdlib.app x y), (Z.add sx sy))
  end.

(* ❌ Applications of functors are not handled. *)
functor_application

Fixpoint compare_list {A : Type} (xs : list A) (ys : list A) : bool :=
  match (xs, ys) with
  | ([], []) => true
  | (cons x [], cons y ys) => orb (equiv_decb ys []) (compare_list xs ys)
  | (cons x xs, cons y ys) => compare_list xs ys
  | (_, _) => false
  end.

Definition check_size (i : Z) : unit :=
  let l := op_minusminus 0 i in
  let '(l2, _) := list_of_tree (Merkle.compute l) in
  if compare_list l l2 then
    tt
  else
    Format.kasprintf OCaml.Stdlib.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Failed for " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal ": " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))))
        "Failed for %d: %a" % string) i
      (Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              Format.pp_print_string ppf ";" % string)) Format.pp_print_int) l2.

Definition test_compute {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  Stdlib.List.iter check_size (op_minusminus 0 99).

Definition check_path (i : Z) : unit :=
  let l := op_minusminus 0 i in
  let orig := Merkle.compute l in
  Stdlib.List.iter
    (fun j =>
      let path := Merkle.compute_path l j in
      let '(found, pos) := Merkle.check_path path j in
      if andb (equiv_decb found orig) (equiv_decb j pos) then
        tt
      else
        Format.kasprintf OCaml.Stdlib.failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Failed for " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " in " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal "." % char
                      CamlinternalFormatBasics.End_of_format)))))
            "Failed for %d in %d." % string) j i) l.

Definition test_path {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  Stdlib.List.iter check_path (op_minusminus 0 128).

Definition tests {A : Type} : list (string * variant * (A -> unit)) :=
  cons
    ("compute" % string,
      (* ❌ Variants not supported *)
      variant, test_compute)
    (cons
      ("path" % string,
        (* ❌ Variants not supported *)
        variant, test_path) []).



src/lib_crypto/test/test_pvss.ml 57 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* pvss tests here *)

module Pvss = Pvss_secp256k1
module Sp = Secp256k1_group

module Setup : sig
  val shares : Pvss.Encrypted_share.t list

  val commitments : Pvss.Commitment.t list

  val proof : Pvss.proof

  val secret_scalar : Sp.Group.Scalar.t

  val secret : Pvss.Secret_key.t

  val public_secret : Pvss.Public_key.t

  val other_shares : Pvss.Encrypted_share.t list

  val other_commitments : Pvss.Commitment.t list

  val other_proof : Pvss.proof

  val other_secret : Pvss.Secret_key.t

  type keypair = {
    secret_key : Pvss.Secret_key.t;
    public_key : Pvss.Public_key.t;
  }

  val public_keys : Pvss.Public_key.t list

  val keypairs : keypair list

  val reveals :
    (Pvss.Encrypted_share.t * (Pvss.Clear_share.t * Pvss.proof)) list

  val convert_encoding : 'a Data_encoding.t -> 'b Data_encoding.t -> 'a -> 'b

  val group_encoding : Sp.Group.t Data_encoding.t
end = struct
  type keypair = {
    secret_key : Pvss.Secret_key.t;
    public_key : Pvss.Public_key.t;
  }

  let group_encoding =
    Data_encoding.(conv Sp.Group.to_bits Sp.Group.of_bits_exn string)

  let scalar_encoding =
    Data_encoding.(
      conv Sp.Group.Scalar.to_bits Sp.Group.Scalar.of_bits_exn string)

  let convert_encoding de1 de2 x =
    Data_encoding.Binary.of_bytes_exn
      de2
      (Data_encoding.Binary.to_bytes_exn de1 x)

  (** Random value of Z in the range [0,2^256] *)
  let rand_Z () =
    [Random.int64 Int64.max_int |> Z.of_int64 |> Z.to_bits]
    |> Blake2B.hash_string |> Blake2B.to_string |> Z.of_bits

  (** Generates n random keypairs *)
  let random_keypairs n =
    List.init n (fun _ ->
        let s = Sp.Group.Scalar.of_Z (rand_Z ()) in
        let secret_key =
          convert_encoding scalar_encoding Pvss.Secret_key.encoding s
        in
        {secret_key; public_key = Pvss.Secret_key.to_public_key secret_key})

  let t = 5

  let n = 8

  let random_scalar () = Sp.Group.Scalar.of_Z (rand_Z ())

  let secret_of_scalar s =
    convert_encoding scalar_encoding Pvss.Secret_key.encoding s

  let secret_scalar = random_scalar ()

  let secret = secret_of_scalar secret_scalar

  let public_secret = Pvss.Secret_key.to_public_key secret

  let other_secret = secret_of_scalar (random_scalar ())

  let keypairs = random_keypairs n

  let public_keys = List.map (fun {public_key; _} -> public_key) keypairs

  let ( (shares, commitments, proof),
        (other_shares, other_commitments, other_proof) ) =
    ( Pvss.dealer_shares_and_proof ~secret ~t ~public_keys,
      Pvss.dealer_shares_and_proof ~secret:other_secret ~t ~public_keys )

  let reveals =
    List.map2
      (fun share keypair ->
        ( share,
          Pvss.reveal_share
            share
            ~secret_key:keypair.secret_key
            ~public_key:keypair.public_key ))
      shares
      keypairs
end

let test_dealer_proof () =
  let shr = (Setup.shares, Setup.other_shares)
  and cmt = (Setup.commitments, Setup.other_commitments)
  and prf = (Setup.proof, Setup.other_proof) in
  for i = 0 to 1 do
    for j = 0 to 1 do
      for k = 0 to 1 do
        let pick = function 0 -> fst | _ -> snd in
        assert (
          Pvss.check_dealer_proof
            (pick i shr)
            (pick j cmt)
            ~proof:(pick k prf)
            ~public_keys:Setup.public_keys
          = (i = j && j = k) )
      done
    done
  done

let test_share_reveal () =
  (* check reveal shares *)
  let shares_valid =
    List.map2
      (fun (share, (reveal, proof)) public_key ->
        Pvss.check_revealed_share share reveal ~public_key proof)
      Setup.reveals
      Setup.public_keys
  in
  List.iteri
    (fun i b ->
      print_endline (string_of_int i) ;
      assert b)
    shares_valid

let test_reconstruct () =
  let indices = [0; 1; 2; 3; 4] in
  let reconstructed =
    Pvss.reconstruct
      (List.map
         (fun n ->
           let (_, (r, _)) = List.nth Setup.reveals n in
           r)
         indices)
      indices
  in
  assert (
    Sp.Group.(( = ))
      (Setup.convert_encoding
         Pvss.Public_key.encoding
         Setup.group_encoding
         reconstructed)
      (Setup.convert_encoding
         Pvss.Public_key.encoding
         Setup.group_encoding
         Setup.public_secret) )

let tests =
  [ ("dealer_proof", `Quick, test_dealer_proof);
    ("reveal", `Quick, test_share_reveal);
    ("recontruct", `Quick, test_reconstruct) ]

let () = Alcotest.run "test-pvss" [("pvss", tests)]
src/lib_crypto/test/test_pvss.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Setup.
  Record keypair := {
    secret_key : Pvss.Secret_key.t;
    public_key : Pvss.Public_key.t }.
  
  Definition group_encoding
    : Tezos_data_encoding.Data_encoding.encoding Sp.Group.t :=
    conv Sp.Group.to_bits Sp.Group.of_bits_exn None string.
  
  Definition scalar_encoding
    : Tezos_data_encoding.Data_encoding.encoding Sp.Group.Scalar.t :=
    conv Sp.Group.Scalar.to_bits Sp.Group.Scalar.of_bits_exn None string.
  
  Definition convert_encoding {A B : Type}
    (de1 : Tezos_data_encoding__Data_encoding.Encoding.t A)
    (de2 : Tezos_data_encoding__Data_encoding.Encoding.t B) (x : A) : B :=
    Data_encoding.Binary.of_bytes_exn de2
      (Data_encoding.Binary.to_bytes_exn de1 x).
  
  Definition rand_Z (function_parameter : unit) : Z.t :=
    let 'tt := function_parameter in
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (cons
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply (Random.int64 Int64.max_int)
                Z.of_int64) Z.to_bits) [])
          (let arg := Blake2B.hash_string in
          fun eta => arg None eta)) Blake2B.to_string) Z.of_bits.
  
  Definition random_keypairs (n : Z) : list keypair :=
    Stdlib.List.init n
      (fun function_parameter =>
        let '_ := function_parameter in
        let s := Sp.Group.Scalar.of_Z (rand_Z tt) in
        let secret_key :=
          convert_encoding scalar_encoding Pvss.Secret_key.encoding s in
        {| secret_key := secret_key;
          public_key := Pvss.Secret_key.to_public_key secret_key |}).
  
  Definition t : Z := 5.
  
  Definition n : Z := 8.
  
  Definition random_scalar (function_parameter : unit) : Sp.Group.Scalar.t :=
    let 'tt := function_parameter in
    Sp.Group.Scalar.of_Z (rand_Z tt).
  
  Definition secret_of_scalar (s : Sp.Group.Scalar.t) : Pvss.Secret_key.t :=
    convert_encoding scalar_encoding Pvss.Secret_key.encoding s.
  
  Definition secret_scalar : Sp.Group.Scalar.t := random_scalar tt.
  
  Definition secret : Pvss.Secret_key.t := secret_of_scalar secret_scalar.
  
  Definition public_secret
    : Tezos_crypto__Pvss_secp256k1.Public_key.(Tezos_crypto__Pvss_secp256k1.ENCODED.t) :=
    Pvss.Secret_key.to_public_key secret.
  
  Definition other_secret : Pvss.Secret_key.t :=
    secret_of_scalar (random_scalar tt).
  
  Definition keypairs : list keypair := random_keypairs n.
  
  Definition public_keys : list Pvss.Public_key.t :=
    List.map
      (fun function_parameter =>
        let '{| public_key := public_key |} := function_parameter in
        public_key) keypairs.
  
  
  
  Definition reveals
    : list (Pvss.Encrypted_share.t * (Pvss.Clear_share.t * Pvss.proof)) :=
    Stdlib.List.map2
      (fun share =>
        fun keypair =>
          (share,
            (Pvss.reveal_share share (secret_key keypair) (public_key keypair))))
      shares keypairs.
End Setup.

Definition test_dealer_proof (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let shr : (list Pvss.Encrypted_share.t) * (list Pvss.Encrypted_share.t) :=
    (Setup.shares, Setup.other_shares)
  with cmt : (list Pvss.Commitment.t) * (list Pvss.Commitment.t) :=
    (Setup.commitments, Setup.other_commitments)
  with prf : Pvss.proof * Pvss.proof :=
    (Setup.proof, Setup.other_proof) in
  (* ❌ For loops not handled. *)
  for.

Definition test_share_reveal (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let shares_valid :=
    Stdlib.List.map2
      (fun function_parameter =>
        let '(share, (reveal, proof)) := function_parameter in
        fun public_key =>
          Pvss.check_revealed_share share reveal public_key proof) Setup.reveals
      Setup.public_keys in
  Stdlib.List.iteri
    (fun i =>
      fun b =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := OCaml.Stdlib.print_endline (OCaml.Stdlib.string_of_int i) in
        (* ❌ Assert instruction is not handled. *)
        assert b) shares_valid.

Definition test_reconstruct (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let indices := cons 0 (cons 1 (cons 2 (cons 3 (cons 4 [])))) in
  let reconstructed :=
    Pvss.reconstruct
      (List.map
        (fun n =>
          let '(_, (r, _)) := Stdlib.List.nth Setup.reveals n in
          r) indices) indices in
  (* ❌ Assert instruction is not handled. *)
  assert
    (op_eq
      (Setup.convert_encoding Pvss.Public_key.encoding Setup.group_encoding
        reconstructed)
      (Setup.convert_encoding Pvss.Public_key.encoding Setup.group_encoding
        Setup.public_secret)).

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("dealer_proof" % string,
      (* ❌ Variants not supported *)
      variant, test_dealer_proof)
    (cons
      ("reveal" % string,
        (* ❌ Variants not supported *)
        variant, test_share_reveal)
      (cons
        ("recontruct" % string,
          (* ❌ Variants not supported *)
          variant, test_reconstruct) [])).



src/lib_crypto/znz.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type ZN = sig
  type t

  include S.B58_DATA with type t := t

  include S.ENCODER with type t := t

  val zero : t

  val one : t

  val n : Z.t

  val ( + ) : t -> t -> t

  val ( * ) : t -> t -> t

  val ( - ) : t -> t -> t

  val ( = ) : t -> t -> bool

  val of_int : int -> t

  val of_Z : Z.t -> t

  val to_Z : t -> Z.t

  val of_bits_exn : String.t -> t

  val to_bits : t -> String.t

  val pow : t -> Z.t -> t

  val inv : t -> t option
end

module type INT = sig
  val n : Z.t
end

module MakeZn
    (N : INT) (B : sig
      val b58_prefix : string
    end) : ZN = struct
  type t = Z.t

  let n = N.n

  let max_char_length = 2 * Z.numbits n

  let zero = Z.zero

  let one = Z.one

  let of_Z r = Z.(erem r n)

  let to_Z a = a

  let of_int u = u |> Z.of_int |> of_Z

  let to_bits h =
    h |> Zplus.serialize |> fun s -> String.sub s 0 (String.length s - 1)

  let of_bits_exn bits =
    (* Do not process oversized inputs. *)
    if Compare.Int.(String.length bits > max_char_length) then
      failwith "input too long"
    else
      (* Make sure the input is in the range [0, N.n-1]. Do not reduce modulo
         N.n for free! *)
      let x = Zplus.deserialize bits in
      if Zplus.(x < zero || x >= N.n) then failwith "out of range" else of_Z x

  let pow a x = Z.powm a Z.(erem x (sub n one)) n

  let ( + ) x y = Z.(erem (add x y) n)

  let ( * ) x y = Z.(erem (mul x y) n)

  let ( - ) x y = Z.(erem (sub x y) n)

  let ( = ) x y = Z.equal x y

  let inv a = Zplus.invert a n

  let title = Format.sprintf "Znz.Make(%s)" (Z.to_string N.n)

  let name = Format.sprintf "An element of Z/nZ for n = %s" (Z.to_string N.n)

  type Base58.data += Data of t

  let b58check_encoding =
    Base58.register_encoding
      ~prefix:B.b58_prefix
      ~length:32
      ~to_raw:to_bits
      ~of_raw:(fun s -> try Some (of_bits_exn s) with _ -> None)
      ~wrap:(fun x -> Data x)

  include Helpers.MakeB58 (struct
    type nonrec t = t

    let name = name

    let b58check_encoding = b58check_encoding
  end)

  include Helpers.MakeEncoder (struct
    type nonrec t = t

    let name = name

    let title = title

    let raw_encoding = Data_encoding.(conv to_bits of_bits_exn string)

    let to_b58check = to_b58check

    let to_short_b58check = to_short_b58check

    let of_b58check = of_b58check

    let of_b58check_opt = of_b58check_opt

    let of_b58check_exn = of_b58check_exn
  end)
end
src/lib_crypto/znz.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module ZN.
  Record signature {t : Type} := {
    t := t;
    include;
    include;
    zero : t;
    one : t;
    n : Z.t;
    op_plus : t -> t -> t;
    op_star : t -> t -> t;
    op_minus : t -> t -> t;
    op_eq : t -> t -> bool;
    of_int : Z -> t;
    of_Z : Z.t -> t;
    to_Z : t -> Z.t;
    of_bits_exn : Stdlib.String.t -> t;
    to_bits : t -> Stdlib.String.t;
    pow : t -> Z.t -> t;
    inv : t -> option t;
  }.
  Arguments signature : clear implicits.
End ZN.

Module INT.
  Record signature := {
    n : Z.t;
  }.
End INT.

(* ❌ Functors are not handled. *)
functor

src/lib_crypto/zplus.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* let re_trailing_null =
   Re_pcre.regexp "^(.*?)\000*$"

   let remove_trailing_null s =
   Re.get (Re.exec re_trailing_null s) 1 *)

let remove_trailing_null s =
  let n = String.length s in
  let i = ref (n - 1) in
  while !i >= 0 && s.[!i] = '\000' do
    i := !i - 1
  done ;
  String.sub s 0 (!i + 1)

let serialize z =
  let n = if Z.(lt z zero) then Z.(neg (add (add z z) one)) else Z.(add z z) in
  n |> Z.to_bits |> remove_trailing_null

let deserialize z =
  let n = Z.of_bits z in
  let z = Z.shift_right_trunc n 1 in
  if Z.(n land one = zero) then z else Z.neg z

let leq a b = Z.compare a b <= 0

let geq a b = Z.compare a b >= 0

let lt a b = Z.compare a b < 0

let gt a b = Z.compare a b > 0

let ( < ) = lt

let ( > ) = gt

let ( <= ) = leq

let ( >= ) = geq

let zero = Z.zero

let one = Z.one

let invert a n = try Some (Z.invert a n) with Division_by_zero -> None
src/lib_crypto/zplus.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition remove_trailing_null (s : string) : string :=
  let n := OCaml.String.length s in
  let i := Stdlib.ref (Z.sub n 1) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ While loops not handled. *)
    while in
  Stdlib.String.sub s 0 (Z.add (Stdlib.op_exclamation i) 1).

Definition serialize (z : Z.t) : string :=
  let n :=
    if lt z zero then
      neg (add (add z z) one)
    else
      add z z in
  OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply n Z.to_bits)
    remove_trailing_null.

Definition deserialize (z : string) : Z.t :=
  let n := Z.of_bits z in
  let z := Z.shift_right_trunc n 1 in
  if equiv_decb (land n one) zero then
    z
  else
    Z.neg z.

Definition leq (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.le (Z.compare a b) 0.

Definition geq (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.ge (Z.compare a b) 0.

Definition lt (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.lt (Z.compare a b) 0.

Definition gt (a : Z.t) (b : Z.t) : bool := OCaml.Stdlib.gt (Z.compare a b) 0.

Definition op_lt : Z.t -> Z.t -> bool := lt.

Definition op_gt : Z.t -> Z.t -> bool := gt.

Definition op_lteq : Z.t -> Z.t -> bool := leq.

Definition op_gteq : Z.t -> Z.t -> bool := geq.

Definition zero : Z.t := Z.zero.

Definition one : Z.t := Z.one.

Definition invert (a : Z.t) (n : Z.t) : option Z.t :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.invert a n)).

src/lib_data_encoding/binary_description.ml 36 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type recursives = string list

type references = {
  descriptions : (string * Binary_schema.toplevel_encoding) list;
}
[@@unwrapped]

(* Simple Union find implementation, there are several optimizations
   that give UF it's usual time complexity that could be added.
   If this is a bottleneck, they're easy to add. *)
module UF : sig
  type t

  val add : t -> Binary_schema.description -> unit

  val find : t -> string -> Binary_schema.description

  val union :
    t -> new_cannonical:Binary_schema.description -> existing:string -> unit

  val empty : unit -> t
end = struct
  open Binary_schema

  type ele = Ref of string | Root of description

  type t = (string, ele) Hashtbl.t

  let add t x = Hashtbl.replace t x.title (Root x)

  let rec find tbl key =
    match Hashtbl.find tbl key with Ref s -> find tbl s | Root desc -> desc

  let union tbl ~new_cannonical ~existing =
    add tbl new_cannonical ;
    let root = find tbl existing in
    if root.title = new_cannonical.title then ()
    else Hashtbl.replace tbl root.title (Ref new_cannonical.title)

  let empty () = Hashtbl.create 128
end

let fixup_references uf =
  let open Binary_schema in
  let rec fixup_layout = function
    | Ref s ->
        Ref (UF.find uf s).title
    | Enum (i, name) ->
        Enum (i, (UF.find uf name).title)
    | Seq (layout, len) ->
        Seq (fixup_layout layout, len)
    | ( Zero_width
      | Int _
      | Bool
      | RangedInt (_, _)
      | RangedFloat (_, _)
      | Float
      | Bytes
      | String
      | Padding ) as enc ->
        enc
  in
  let field = function
    | Named_field (name, kind, layout) ->
        Named_field (name, kind, fixup_layout layout)
    | Anonymous_field (kind, layout) ->
        Anonymous_field (kind, fixup_layout layout)
    | (Dynamic_size_field _ | Optional_field _) as field ->
        field
  in
  function
  | Obj {fields} ->
      Obj {fields = List.map field fields}
  | Cases ({cases; _} as x) ->
      Cases
        {
          x with
          cases =
            List.map
              (fun (i, name, fields) -> (i, name, List.map field fields))
              cases;
        }
  | Int_enum _ as ie ->
      ie

let z_reference_name = "Z.t"

let z_reference_description =
  "A variable length sequence of bytes, encoding a Zarith number. Each byte \
   has a running unary size bit: the most significant bit of each byte tells \
   is this is the last byte in the sequence (0) or if there is more to read \
   (1). The second most significant bit of the first byte is reserved for the \
   sign (positive if zero). Size and sign bits ignored, data is then the \
   binary representation of the absolute value of the number in little endian \
   order."

let z_encoding =
  Binary_schema.Obj {fields = [Named_field ("Z.t", `Dynamic, Bytes)]}

let add_z_reference uf {descriptions} =
  UF.add
    uf
    {title = z_reference_name; description = Some z_reference_description} ;
  {descriptions = (z_reference_name, z_encoding) :: descriptions}

let n_reference_name = "N.t"

let n_reference_description =
  "A variable length sequence of bytes, encoding a Zarith number. Each byte \
   has a running unary size bit: the most significant bit of each byte tells \
   is this is the last byte in the sequence (0) or if there is more to read \
   (1). Size bits ignored, data is then the binary representation of the \
   absolute value of the number in little endian order."

let n_encoding =
  Binary_schema.Obj {fields = [Named_field ("N.t", `Dynamic, Bytes)]}

let add_n_reference uf {descriptions} =
  UF.add
    uf
    {title = n_reference_name; description = Some n_reference_description} ;
  {descriptions = (n_reference_name, n_encoding) :: descriptions}

let dedup_canonicalize uf =
  let tbl :
      (Binary_schema.toplevel_encoding, Binary_schema.description) Hashtbl.t =
    Hashtbl.create 100
  in
  let rec help prev_len acc = function
    | [] ->
        let fixedup =
          List.map
            (fun (desc, layout) -> (desc, fixup_references uf layout))
            acc
        in
        if List.length fixedup = prev_len then
          List.map (fun (name, layout) -> (UF.find uf name, layout)) fixedup
        else (
          Hashtbl.clear tbl ;
          help (List.length fixedup) [] fixedup )
    | (name, layout) :: tl -> (
      match Hashtbl.find_opt tbl layout with
      | None ->
          let desc = UF.find uf name in
          Hashtbl.add tbl layout desc ;
          help prev_len ((desc.title, layout) :: acc) tl
      | Some original_desc ->
          UF.union uf ~new_cannonical:original_desc ~existing:name ;
          help prev_len acc tl )
  in
  help 0 []

type pdesc = P : 'x Encoding.desc -> pdesc

let describe (type x) (encoding : x Encoding.t) =
  let open Encoding in
  let uf = UF.empty () in
  let uf_add_name title = UF.add uf {title; description = None} in
  let add_reference name description {descriptions} =
    {descriptions = (name, description) :: descriptions}
  in
  let new_reference =
    let x = ref ~-1 in
    fun () ->
      x := !x + 1 ;
      let name = "X_" ^ string_of_int !x in
      uf_add_name name ; name
  in
  let may_new_reference = function
    | None ->
        new_reference ()
    | Some name ->
        uf_add_name name ; name
  in
  let rec extract_dynamic :
      type x.
      string option ->
      x Encoding.desc ->
      Binary_size.unsigned_integer option * string option * pdesc =
   fun ref_name -> function
    | Conv {encoding; _} ->
        extract_dynamic ref_name encoding.encoding
    | Describe {id = ref_name; encoding; _} ->
        extract_dynamic (Some ref_name) encoding.encoding
    | Splitted {encoding; _} ->
        extract_dynamic ref_name encoding.encoding
    | Delayed f ->
        extract_dynamic ref_name (f ()).encoding
    | Dynamic_size {kind; encoding} ->
        (Some kind, ref_name, P encoding.encoding)
    | enc ->
        (None, ref_name, P enc)
  in
  let rec field_descr :
      type a.
      recursives ->
      references ->
      a Encoding.field ->
      Binary_schema.field_descr list * references =
   fun recursives references -> function
    | Req {name; encoding = {encoding; _}; _}
    | Dft {name; encoding = {encoding; _}; _} -> (
        let (dynamics, ref_name, P field) = extract_dynamic None encoding in
        let (layout, references) =
          layout ref_name recursives references field
        in
        if layout = Zero_width then ([], references)
        else
          let field_descr =
            Binary_schema.Named_field (name, classify_desc field, layout)
          in
          match dynamics with
          | Some kind ->
              ( [Dynamic_size_field (ref_name, 1, kind); field_descr],
                references )
          | None ->
              ([field_descr], references) )
    | Opt {kind = `Variable; name; encoding = {encoding; _}; _} ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Named_field (name, `Variable, layout)], references)
    | Opt {kind = `Dynamic; name; encoding = {encoding; _}; _} ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ( [ Binary_schema.Optional_field name;
            Named_field (name, classify_desc encoding, layout) ],
          references )
  and obj fields = Binary_schema.Obj {fields}
  and union :
      type a.
      string option ->
      recursives ->
      references ->
      Kind.t ->
      Binary_size.tag_size ->
      a case list ->
      string * references =
   fun ref_name recursives references kind size cases ->
    let cases =
      List.sort (fun (t1, _) (t2, _) -> (compare : int -> int -> int) t1 t2)
      @@ List.fold_left
           (fun acc case ->
             match case with
             | Case {tag = Json_only; _} ->
                 acc
             | Case {tag = Tag tag; _} ->
                 (tag, case) :: acc)
           []
           cases
    in
    let tag_field =
      Binary_schema.Named_field
        ( "Tag",
          `Fixed (Binary_size.tag_size size),
          Int (size :> Binary_schema.integer_extended) )
    in
    let (cases, references) =
      List.fold_right
        (fun (tag, Case case) (cases, references) ->
          let (fields, references) =
            fields None recursives references case.encoding.encoding
          in
          ((tag, Some case.title, tag_field :: fields) :: cases, references))
        cases
        ([], references)
    in
    let name = may_new_reference ref_name in
    let references =
      add_reference name (Cases {kind; tag_size = size; cases}) references
    in
    (name, references)
  and describe :
      type b.
      ?description:string ->
      title:string ->
      string ->
      recursives ->
      references ->
      b desc ->
      string * references =
   fun ?description ~title name recursives references encoding ->
    let new_cannonical = {Binary_schema.title; description} in
    UF.add uf new_cannonical ;
    let (layout, references) = layout None recursives references encoding in
    match layout with
    | Ref ref_name ->
        UF.union uf ~existing:ref_name ~new_cannonical ;
        (ref_name, references)
    | layout ->
        UF.add uf new_cannonical ;
        ( name,
          add_reference
            name
            (obj [Anonymous_field (classify_desc encoding, layout)])
            references )
  and enum : type a. (a, _) Hashtbl.t -> a array -> _ =
   fun tbl encoding_array ->
    ( Binary_size.range_to_size
        ~minimum:0
        ~maximum:(Array.length encoding_array),
      List.map
        (fun i -> (i, fst @@ Hashtbl.find tbl encoding_array.(i)))
        (List.init (Array.length encoding_array) (fun i -> i)) )
  and fields :
      type b.
      string option ->
      recursives ->
      references ->
      b Encoding.desc ->
      Binary_schema.fields * references =
   fun ref_name recursives references -> function
    | Obj field ->
        field_descr recursives references field
    | Objs {left; right; _} ->
        let (left_fields, references) =
          fields None recursives references left.encoding
        in
        let (right_fields, references) =
          fields None recursives references right.encoding
        in
        (left_fields @ right_fields, references)
    | Null ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Empty ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Ignore ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Constant _ ->
        ([Anonymous_field (`Fixed 0, Zero_width)], references)
    | Dynamic_size {kind; encoding} ->
        let (fields, refs) =
          fields None recursives references encoding.encoding
        in
        (Dynamic_size_field (None, List.length fields, kind) :: fields, refs)
    | Check_size {encoding; _} ->
        fields ref_name recursives references encoding.encoding
    | Conv {encoding; _} ->
        fields ref_name recursives references encoding.encoding
    | Describe {id = name; encoding; _} ->
        fields (Some name) recursives references encoding.encoding
    | Splitted {encoding; _} ->
        fields ref_name recursives references encoding.encoding
    | Delayed func ->
        fields ref_name recursives references (func ()).encoding
    | List (len, {encoding; _}) ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (`Variable, Seq (layout, len))], references)
    | Array (len, {encoding; _}) ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (`Variable, Seq (layout, len))], references)
    | Bytes kind ->
        ([Anonymous_field ((kind :> Kind.t), Bytes)], references)
    | String kind ->
        ([Anonymous_field ((kind :> Kind.t), String)], references)
    | Padded ({encoding = e; _}, n) ->
        let (fields, references) = fields ref_name recursives references e in
        (fields @ [Named_field ("padding", `Fixed n, Padding)], references)
    | String_enum (tbl, encoding_array) as encoding ->
        let (size, cases) = enum tbl encoding_array in
        let name = may_new_reference ref_name in
        ( [Anonymous_field (classify_desc encoding, Ref name)],
          add_reference name (Int_enum {size; cases}) references )
    | Tup {encoding; _} ->
        let (layout, references) =
          layout ref_name recursives references encoding
        in
        if layout = Zero_width then ([], references)
        else ([Anonymous_field (classify_desc encoding, layout)], references)
    | Tups {left; right; _} ->
        let (fields1, references) =
          fields None recursives references left.encoding
        in
        let (fields2, references) =
          fields None recursives references right.encoding
        in
        (fields1 @ fields2, references)
    | Union {kind; tag_size; cases} ->
        let (name, references) =
          union None recursives references kind tag_size cases
        in
        ([Anonymous_field (kind, Ref name)], references)
    | Mu {kind; name; title; description; fix} as encoding ->
        let kind = (kind :> Kind.t) in
        let title = match title with Some title -> title | None -> name in
        if List.mem name recursives then
          ([Anonymous_field (kind, Ref name)], references)
        else
          let {encoding; _} = fix {encoding; json_encoding = None} in
          let (name, references) =
            describe
              ~title
              ?description
              name
              (name :: recursives)
              references
              encoding
          in
          ([Anonymous_field (kind, Ref name)], references)
    | Bool as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int8 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Uint8 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int16 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Uint16 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int31 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int32 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Int64 as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | N as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Z as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | RangedInt _ as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | RangedFloat _ as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
    | Float as encoding ->
        let (layout, references) =
          layout None recursives references encoding
        in
        ([Anonymous_field (classify_desc encoding, layout)], references)
  and layout :
      type c.
      string option ->
      recursives ->
      references ->
      c Encoding.desc ->
      Binary_schema.layout * references =
   fun ref_name recursives references -> function
    | Null ->
        (Zero_width, references)
    | Empty ->
        (Zero_width, references)
    | Ignore ->
        (Zero_width, references)
    | Constant _ ->
        (Zero_width, references)
    | Bool ->
        (Bool, references)
    | Int8 ->
        (Int `Int8, references)
    | Uint8 ->
        (Int `Uint8, references)
    | Int16 ->
        (Int `Int16, references)
    | Uint16 ->
        (Int `Uint16, references)
    | Int31 ->
        (RangedInt (~-1073741824, 1073741823), references)
    | Int32 ->
        (Int `Int32, references)
    | Int64 ->
        (Int `Int64, references)
    | N ->
        (Ref n_reference_name, add_n_reference uf references)
    | Z ->
        (Ref z_reference_name, add_z_reference uf references)
    | RangedInt {minimum; maximum} ->
        (RangedInt (minimum, maximum), references)
    | RangedFloat {minimum; maximum} ->
        (RangedFloat (minimum, maximum), references)
    | Float ->
        (Float, references)
    | Bytes _kind ->
        (Bytes, references)
    | String _kind ->
        (String, references)
    | Padded _ as enc ->
        let name = may_new_reference ref_name in
        let (fields, references) = fields None recursives references enc in
        let references = add_reference name (obj fields) references in
        (Ref name, references)
    | String_enum (tbl, encoding_array) ->
        let name = may_new_reference ref_name in
        let (size, cases) = enum tbl encoding_array in
        let references =
          add_reference name (Int_enum {size; cases}) references
        in
        (Enum (size, name), references)
    | Array (len, data) ->
        let (descr, references) =
          layout None recursives references data.encoding
        in
        (Seq (descr, len), references)
    | List (len, data) ->
        let (layout, references) =
          layout None recursives references data.encoding
        in
        (Seq (layout, len), references)
    | Obj (Req {encoding = {encoding; _}; _})
    | Obj (Dft {encoding = {encoding; _}; _}) ->
        layout ref_name recursives references encoding
    | Obj (Opt _) as enc ->
        let name = may_new_reference ref_name in
        let (fields, references) = fields None recursives references enc in
        let references = add_reference name (obj fields) references in
        (Ref name, references)
    | Objs {left; right; _} ->
        let name = may_new_reference ref_name in
        let (fields1, references) =
          fields None recursives references left.encoding
        in
        let (fields2, references) =
          fields None recursives references right.encoding
        in
        let references =
          add_reference name (obj (fields1 @ fields2)) references
        in
        (Ref name, references)
    | Tup {encoding; _} ->
        layout ref_name recursives references encoding
    | Tups _ as descr ->
        let name = may_new_reference ref_name in
        let (fields, references) = fields None recursives references descr in
        let references = add_reference name (obj fields) references in
        (Ref name, references)
    | Union {kind; tag_size; cases} ->
        let (name, references) =
          union ref_name recursives references kind tag_size cases
        in
        (Ref name, references)
    | Mu {name; title; description; fix; _} as encoding ->
        let title = match title with Some title -> title | None -> name in
        if List.mem name recursives then (Ref name, references)
        else
          let {encoding; _} = fix {encoding; json_encoding = None} in
          let (name, references) =
            describe
              name
              ~title
              ?description
              (name :: recursives)
              references
              encoding
          in
          (Ref name, references)
    | Conv {encoding; _} ->
        layout ref_name recursives references encoding.encoding
    | Describe {id = name; encoding; _} ->
        layout (Some name) recursives references encoding.encoding
    | Splitted {encoding; _} ->
        layout ref_name recursives references encoding.encoding
    | Dynamic_size _ as encoding ->
        let name = may_new_reference ref_name in
        let (fields, references) =
          fields None recursives references encoding
        in
        UF.add uf {title = name; description = None} ;
        (Ref name, add_reference name (obj fields) references)
    | Check_size {encoding; _} ->
        layout ref_name recursives references encoding.encoding
    | Delayed func ->
        layout ref_name recursives references (func ()).encoding
  in
  let (fields, references) =
    fields None [] {descriptions = []} encoding.encoding
  in
  uf_add_name "" ;
  let (_, toplevel) = List.hd (dedup_canonicalize uf [("", obj fields)]) in
  let filtered =
    List.filter
      (fun (name, encoding) ->
        match encoding with
        | Binary_schema.Obj {fields = [Anonymous_field (_, Ref reference)]} ->
            UF.union uf ~new_cannonical:(UF.find uf name) ~existing:reference ;
            false
        | _ ->
            true)
      references.descriptions
  in
  let fields = List.rev (dedup_canonicalize uf filtered) in
  {Binary_schema.toplevel; fields}
src/lib_data_encoding/binary_description.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition recursives := list string.

Record references := {
  descriptions :
    list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding) }.

Module UF.
  Import Binary_schema.
  
  Inductive ele : Type :=
  | Ref : string -> ele
  | Root : Tezos_data_encoding.Binary_schema.description -> ele.
  
  Definition t := Stdlib.Hashtbl.t string ele.
  
  Definition add
    (t : Stdlib.Hashtbl.t string ele)
    (x : Tezos_data_encoding.Binary_schema.description) : unit :=
    Hashtbl.replace t (title x) (Root x).
  
  Fixpoint find (tbl : Stdlib.Hashtbl.t string ele) (key : string)
    : Tezos_data_encoding.Binary_schema.description :=
    match Hashtbl.find tbl key with
    | Ref s => find tbl s
    | Root desc => desc
    end.
  
  Definition union
    (tbl : Stdlib.Hashtbl.t string ele)
    (new_cannonical : Tezos_data_encoding.Binary_schema.description)
    (existing : string) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := add tbl new_cannonical in
    let root := find tbl existing in
    if equiv_decb (title root) (title new_cannonical) then
      tt
    else
      Hashtbl.replace tbl (title root) (Ref (title new_cannonical)).
  
  Definition empty {A B : Type} (function_parameter : unit)
    : Stdlib.Hashtbl.t A B :=
    let 'tt := function_parameter in
    Hashtbl.create None 128.
End UF.

Definition fixup_references (uf : UF.t)
  : Tezos_data_encoding.Binary_schema.toplevel_encoding ->
    Tezos_data_encoding.Binary_schema.toplevel_encoding :=
  let fix fixup_layout
    (function_parameter : Tezos_data_encoding.Binary_schema.layout)
    : Tezos_data_encoding.Binary_schema.layout :=
    match function_parameter with
    | Tezos_data_encoding.Binary_schema.Ref s =>
      Tezos_data_encoding.Binary_schema.Ref (title (UF.find uf s))
    | Tezos_data_encoding.Binary_schema.Enum i name =>
      Tezos_data_encoding.Binary_schema.Enum i (title (UF.find uf name))
    | Tezos_data_encoding.Binary_schema.Seq layout len =>
      Tezos_data_encoding.Binary_schema.Seq (fixup_layout layout) len
    |
      (Tezos_data_encoding.Binary_schema.Zero_width |
        Tezos_data_encoding.Binary_schema.Int _ |
        Tezos_data_encoding.Binary_schema.Bool |
        Tezos_data_encoding.Binary_schema.RangedInt _ _ |
        Tezos_data_encoding.Binary_schema.RangedFloat _ _ |
        Tezos_data_encoding.Binary_schema.Float |
        Tezos_data_encoding.Binary_schema.Bytes |
        Tezos_data_encoding.Binary_schema.String |
        Tezos_data_encoding.Binary_schema.Padding) as enc => enc
    end in
  let field (function_parameter : Tezos_data_encoding.Binary_schema.field_descr)
    : Tezos_data_encoding.Binary_schema.field_descr :=
    match function_parameter with
    | Tezos_data_encoding.Binary_schema.Named_field name kind layout =>
      Tezos_data_encoding.Binary_schema.Named_field name kind
        (fixup_layout layout)
    | Tezos_data_encoding.Binary_schema.Anonymous_field kind layout =>
      Tezos_data_encoding.Binary_schema.Anonymous_field kind
        (fixup_layout layout)
    |
      (Tezos_data_encoding.Binary_schema.Dynamic_size_field _ _ _ |
        Tezos_data_encoding.Binary_schema.Optional_field _) as field => field
    end in
  fun function_parameter =>
    match function_parameter with
    | Tezos_data_encoding.Binary_schema.Obj {| fields := fields |} =>
      Tezos_data_encoding.Binary_schema.Obj
        {| fields := List.map field fields |}
    | Tezos_data_encoding.Binary_schema.Cases ({| cases := cases |} as x) =>
      Tezos_data_encoding.Binary_schema.Cases
        (* ❌ Record substitution not handled *)
        record_substitution
    | (Tezos_data_encoding.Binary_schema.Int_enum _) as ie => ie
    end.

Definition z_reference_name : string := "Z.t" % string.

Definition z_reference_description : string :=
  "A variable length sequence of bytes, encoding a Zarith number. Each byte has a running unary size bit: the most significant bit of each byte tells is this is the last byte in the sequence (0) or if there is more to read (1). The second most significant bit of the first byte is reserved for the sign (positive if zero). Size and sign bits ignored, data is then the binary representation of the absolute value of the number in little endian order."
    % string.

Definition z_encoding : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
  Tezos_data_encoding.Binary_schema.Obj
    {|
      fields :=
        cons
          (Tezos_data_encoding.Binary_schema.Named_field "Z.t" % string
            (* ❌ Variants not supported *)
            variant Tezos_data_encoding.Binary_schema.Bytes) [] |}.

Definition add_z_reference (uf : UF.t) (function_parameter : references)
  : references :=
  let '{| descriptions := descriptions |} := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    UF.add uf
      {| title := z_reference_name; description := Some z_reference_description
        |} in
  {| descriptions := cons (z_reference_name, z_encoding) descriptions |}.

Definition n_reference_name : string := "N.t" % string.

Definition n_reference_description : string :=
  "A variable length sequence of bytes, encoding a Zarith number. Each byte has a running unary size bit: the most significant bit of each byte tells is this is the last byte in the sequence (0) or if there is more to read (1). Size bits ignored, data is then the binary representation of the absolute value of the number in little endian order."
    % string.

Definition n_encoding : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
  Tezos_data_encoding.Binary_schema.Obj
    {|
      fields :=
        cons
          (Tezos_data_encoding.Binary_schema.Named_field "N.t" % string
            (* ❌ Variants not supported *)
            variant Tezos_data_encoding.Binary_schema.Bytes) [] |}.

Definition add_n_reference (uf : UF.t) (function_parameter : references)
  : references :=
  let '{| descriptions := descriptions |} := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    UF.add uf
      {| title := n_reference_name; description := Some n_reference_description
        |} in
  {| descriptions := cons (n_reference_name, n_encoding) descriptions |}.

Definition dedup_canonicalize (uf : UF.t)
  : (list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding)) ->
    list
      (Tezos_data_encoding.Binary_schema.description *
        Tezos_data_encoding.Binary_schema.toplevel_encoding) :=
  let tbl := Hashtbl.create None 100 in
  let fix help
    (prev_len : Z) (acc :
    list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding))
    (function_parameter :
    list (string * Tezos_data_encoding.Binary_schema.toplevel_encoding))
    : list
      (Tezos_data_encoding.Binary_schema.description *
        Tezos_data_encoding.Binary_schema.toplevel_encoding) :=
    match function_parameter with
    | [] =>
      let fixedup :=
        List.map
          (fun function_parameter =>
            let '(desc, layout) := function_parameter in
            (desc, (fixup_references uf layout))) acc in
      if equiv_decb (OCaml.List.length fixedup) prev_len then
        List.map
          (fun function_parameter =>
            let '(name, layout) := function_parameter in
            ((UF.find uf name), layout)) fixedup
      else
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Hashtbl.clear tbl in
        help (OCaml.List.length fixedup) [] fixedup
    | cons (name, layout) tl =>
      match Hashtbl.find_opt tbl layout with
      | None =>
        let desc := UF.find uf name in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Hashtbl.add tbl layout desc in
        help prev_len (cons ((title desc), layout) acc) tl
      | Some original_desc =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := UF.union uf original_desc name in
        help prev_len acc tl
      end
    end in
  help 0 [].

Inductive pdesc : Type :=
| P : forall {x : Type}, (Tezos_data_encoding.Encoding.desc x) -> pdesc.

Definition describe {A : Type} (encoding : Tezos_data_encoding.Encoding.t A)
  : Tezos_data_encoding.Binary_schema.t :=
  let uf := UF.empty tt in
  let uf_add_name (title : string) : unit :=
    UF.add uf {| title := title; description := None |} in
  let add_reference
    (name : string) (description :
    Tezos_data_encoding.Binary_schema.toplevel_encoding) (function_parameter :
    references) : references :=
    let '{| descriptions := descriptions |} := function_parameter in
    {| descriptions := cons (name, description) descriptions |} in
  let new_reference :=
    let x := Stdlib.ref (Z.opp 1) in
    fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq x (Z.add (Stdlib.op_exclamation x) 1) in
      let name :=
        String.append "X_" % string
          (OCaml.Stdlib.string_of_int (Stdlib.op_exclamation x)) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := uf_add_name name in
      name in
  let may_new_reference (function_parameter : option string) : string :=
    match function_parameter with
    | None => new_reference tt
    | Some name =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := uf_add_name name in
      name
    end in
  let fix extract_dynamic {x : Type}
    (ref_name : option string) (function_parameter :
    Tezos_data_encoding.Encoding.desc x)
    : (option Tezos_data_encoding.Binary_size.unsigned_integer) *
      (option string) * pdesc :=
    match function_parameter with
    | Tezos_data_encoding.Encoding.Conv {| encoding := encoding |} =>
      extract_dynamic ref_name (encoding encoding)
    |
      Tezos_data_encoding.Encoding.Describe {|
        id := ref_name; encoding := encoding |} =>
      extract_dynamic (Some ref_name) (encoding encoding)
    | Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} =>
      extract_dynamic ref_name (encoding encoding)
    | Tezos_data_encoding.Encoding.Delayed f =>
      extract_dynamic ref_name (encoding (f tt))
    |
      Tezos_data_encoding.Encoding.Dynamic_size {|
        kind := kind; encoding := encoding |} =>
      ((Some kind), ref_name, (P (encoding encoding)))
    | enc => (None, ref_name, (P enc))
    end in
  let fix field_descr {a : Type}
    (recursives : recursives) (references : references) (function_parameter :
    Tezos_data_encoding.Encoding.field a)
    : (list Tezos_data_encoding.Binary_schema.field_descr) * references :=
    match function_parameter with
    |
      Tezos_data_encoding.Encoding.Req {|
        name := name; encoding := {| encoding := encoding |} |} |
        Tezos_data_encoding.Encoding.Dft {|
          name := name; encoding := {| encoding := encoding |} |} =>
      let '(dynamics, ref_name, P field) := extract_dynamic None encoding in
      let '(layout, references) := layout ref_name recursives references field
        in
      if equiv_decb layout Tezos_data_encoding.Binary_schema.Zero_width then
        ([], references)
      else
        let field_descr :=
          Tezos_data_encoding.Binary_schema.Named_field name
            (classify_desc field) layout in
        match dynamics with
        | Some kind =>
          ((cons
            (Tezos_data_encoding.Binary_schema.Dynamic_size_field ref_name 1
              kind) (cons field_descr [])), references)
        | None => ((cons field_descr []), references)
        end
    |
      Tezos_data_encoding.Encoding.Opt {|
        name := name;
          kind := Variable;
          encoding := {| encoding := encoding |}
          |} =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Named_field name
          (* ❌ Variants not supported *)
          variant layout) []), references)
    |
      Tezos_data_encoding.Encoding.Opt {|
        name := name;
          kind := Dynamic;
          encoding := {| encoding := encoding |}
          |} =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons (Tezos_data_encoding.Binary_schema.Optional_field name)
        (cons
          (Tezos_data_encoding.Binary_schema.Named_field name
            (classify_desc encoding) layout) [])), references)
    end
  with obj (fields : Tezos_data_encoding.Binary_schema.fields)
    : Tezos_data_encoding.Binary_schema.toplevel_encoding :=
    Tezos_data_encoding.Binary_schema.Obj {| fields := fields |}
  with union {a : Type}
    (ref_name : option string) (recursives : recursives) (references :
    references) (kind : Tezos_data_encoding.Encoding.Kind.t) (size :
    Tezos_data_encoding.Binary_size.tag_size) (cases :
    list (Tezos_data_encoding.Encoding.case a)) : string * references :=
    let cases :=
      apply
        (Stdlib.List.sort
          (fun function_parameter =>
            let '(t1, _) := function_parameter in
            fun function_parameter =>
              let '(t2, _) := function_parameter in
              OCaml.Stdlib.compare t1 t2))
        (Stdlib.List.fold_left
          (fun acc =>
            fun case =>
              match case with
              |
                Tezos_data_encoding.Encoding.Case {|
                  tag := Tezos_data_encoding.Encoding.Json_only |} => acc
              |
                Tezos_data_encoding.Encoding.Case {|
                  tag := Tezos_data_encoding.Encoding.Tag tag |} =>
                cons (tag, case) acc
              end) [] cases) in
    let tag_field :=
      Tezos_data_encoding.Binary_schema.Named_field "Tag" % string
        (* ❌ Variants not supported *)
        variant (Tezos_data_encoding.Binary_schema.Int size) in
    let '(cases, references) :=
      Stdlib.List.fold_right
        (fun function_parameter =>
          let '(tag, Tezos_data_encoding.Encoding.Case case) :=
            function_parameter in
          fun function_parameter =>
            let '(cases, references) := function_parameter in
            let '(fields, references) :=
              fields None recursives references (encoding (encoding case)) in
            ((cons (tag, (Some (title case)), (cons tag_field fields)) cases),
              references)) cases ([], references) in
    let name := may_new_reference ref_name in
    let references :=
      add_reference name
        (Tezos_data_encoding.Binary_schema.Cases
          {| kind := kind; tag_size := size; cases := cases |}) references in
    (name, references)
  with describe {b : Type}
    (description : option string) (title : string) (name : string) (recursives :
    recursives) (references : references) (encoding :
    Tezos_data_encoding.Encoding.desc b) : string * references :=
    let new_cannonical :=
      {| Binary_schema.title := title; Binary_schema.description := description
        |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := UF.add uf new_cannonical in
    let '(layout, references) := layout None recursives references encoding in
    match layout with
    | Tezos_data_encoding.Binary_schema.Ref ref_name =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := UF.union uf new_cannonical ref_name in
      (ref_name, references)
    | layout =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := UF.add uf new_cannonical in
      (name,
        (add_reference name
          (obj
            (cons
              (Tezos_data_encoding.Binary_schema.Anonymous_field
                (classify_desc encoding) layout) [])) references))
    end
  with enum {a : Type}
    (tbl : Stdlib.Hashtbl.t a (string * Z)) (encoding_array : array a)
    : Tezos_data_encoding.Binary_size.integer * (list (Z * string)) :=
    ((Binary_size.range_to_size 0 (Array.length encoding_array)),
      (List.map
        (fun i =>
          (i, (apply fst (Hashtbl.find tbl (Array.get encoding_array i)))))
        (Stdlib.List.init (Array.length encoding_array) (fun i => i))))
  with fields {b : Type}
    (ref_name : option string) (recursives : recursives) (references :
    references) (function_parameter : Tezos_data_encoding.Encoding.desc b)
    : Tezos_data_encoding.Binary_schema.fields * references :=
    match function_parameter with
    | Tezos_data_encoding.Encoding.Obj field =>
      field_descr recursives references field
    | Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
      let '(left_fields, references) :=
        fields None recursives references (encoding left) in
      let '(right_fields, references) :=
        fields None recursives references (encoding right) in
      ((OCaml.Stdlib.app left_fields right_fields), references)
    | Tezos_data_encoding.Encoding.Null =>
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (* ❌ Variants not supported *)
          variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
    | Tezos_data_encoding.Encoding.Empty =>
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (* ❌ Variants not supported *)
          variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
    | Tezos_data_encoding.Encoding.Ignore =>
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (* ❌ Variants not supported *)
          variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
    | Tezos_data_encoding.Encoding.Constant _ =>
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (* ❌ Variants not supported *)
          variant Tezos_data_encoding.Binary_schema.Zero_width) []), references)
    |
      Tezos_data_encoding.Encoding.Dynamic_size {|
        kind := kind; encoding := encoding |} =>
      let '(fields, refs) :=
        fields None recursives references (encoding encoding) in
      ((cons
        (Tezos_data_encoding.Binary_schema.Dynamic_size_field None
          (OCaml.List.length fields) kind) fields), refs)
    | Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
      fields ref_name recursives references (encoding encoding)
    | Tezos_data_encoding.Encoding.Conv {| encoding := encoding |} =>
      fields ref_name recursives references (encoding encoding)
    |
      Tezos_data_encoding.Encoding.Describe {|
        id := name; encoding := encoding |} =>
      fields (Some name) recursives references (encoding encoding)
    | Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} =>
      fields ref_name recursives references (encoding encoding)
    | Tezos_data_encoding.Encoding.Delayed func =>
      fields ref_name recursives references (encoding (func tt))
    | Tezos_data_encoding.Encoding.List len {| encoding := encoding |} =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (* ❌ Variants not supported *)
          variant (Tezos_data_encoding.Binary_schema.Seq layout len)) []),
        references)
    | Tezos_data_encoding.Encoding.Array len {| encoding := encoding |} =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (* ❌ Variants not supported *)
          variant (Tezos_data_encoding.Binary_schema.Seq layout len)) []),
        references)
    | Tezos_data_encoding.Encoding.Bytes kind =>
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field kind
          Tezos_data_encoding.Binary_schema.Bytes) []), references)
    | Tezos_data_encoding.Encoding.String kind =>
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field kind
          Tezos_data_encoding.Binary_schema.String) []), references)
    | Tezos_data_encoding.Encoding.Padded {| encoding := e |} n =>
      let '(fields, references) := fields ref_name recursives references e in
      ((OCaml.Stdlib.app fields
        (cons
          (Tezos_data_encoding.Binary_schema.Named_field "padding" % string
            (* ❌ Variants not supported *)
            variant Tezos_data_encoding.Binary_schema.Padding) [])), references)
    | (Tezos_data_encoding.Encoding.String_enum tbl encoding_array) as encoding
      =>
      let '(size, cases) := enum tbl encoding_array in
      let name := may_new_reference ref_name in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) (Tezos_data_encoding.Binary_schema.Ref name))
        []),
        (add_reference name
          (Tezos_data_encoding.Binary_schema.Int_enum
            {| size := size; cases := cases |}) references))
    | Tezos_data_encoding.Encoding.Tup {| encoding := encoding |} =>
      let '(layout, references) :=
        layout ref_name recursives references encoding in
      if equiv_decb layout Tezos_data_encoding.Binary_schema.Zero_width then
        ([], references)
      else
        ((cons
          (Tezos_data_encoding.Binary_schema.Anonymous_field
            (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Tups {| left := left; right := right |} =>
      let '(fields1, references) :=
        fields None recursives references (encoding left) in
      let '(fields2, references) :=
        fields None recursives references (encoding right) in
      ((OCaml.Stdlib.app fields1 fields2), references)
    |
      Tezos_data_encoding.Encoding.Union {|
        kind := kind; tag_size := tag_size; cases := cases |} =>
      let '(name, references) :=
        union None recursives references kind tag_size cases in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field kind
          (Tezos_data_encoding.Binary_schema.Ref name)) []), references)
    |
      (Tezos_data_encoding.Encoding.Mu {|
        kind := kind;
          name := name;
          title := title;
          description := description;
          fix := fix
          |}) as encoding =>
      let kind := kind in
      let title :=
        match title with
        | Some title => title
        | None => name
        end in
      if Stdlib.List.mem name recursives then
        ((cons
          (Tezos_data_encoding.Binary_schema.Anonymous_field kind
            (Tezos_data_encoding.Binary_schema.Ref name)) []), references)
      else
        let '{| encoding := encoding |} :=
          fix {| encoding := encoding; json_encoding := None |} in
        let '(name, references) :=
          describe description title name (cons name recursives) references
            encoding in
        ((cons
          (Tezos_data_encoding.Binary_schema.Anonymous_field kind
            (Tezos_data_encoding.Binary_schema.Ref name)) []), references)
    | Tezos_data_encoding.Encoding.Bool as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Int8 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Uint8 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Int16 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Uint16 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Int31 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Int32 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Int64 as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.N as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Z as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | (Tezos_data_encoding.Encoding.RangedInt _) as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | (Tezos_data_encoding.Encoding.RangedFloat _) as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    | Tezos_data_encoding.Encoding.Float as encoding =>
      let '(layout, references) := layout None recursives references encoding in
      ((cons
        (Tezos_data_encoding.Binary_schema.Anonymous_field
          (classify_desc encoding) layout) []), references)
    end
  with layout {c : Type}
    (ref_name : option string) (recursives : recursives) (references :
    references) (function_parameter : Tezos_data_encoding.Encoding.desc c)
    : Tezos_data_encoding.Binary_schema.layout * references :=
    match function_parameter with
    | Tezos_data_encoding.Encoding.Null =>
      (Tezos_data_encoding.Binary_schema.Zero_width, references)
    | Tezos_data_encoding.Encoding.Empty =>
      (Tezos_data_encoding.Binary_schema.Zero_width, references)
    | Tezos_data_encoding.Encoding.Ignore =>
      (Tezos_data_encoding.Binary_schema.Zero_width, references)
    | Tezos_data_encoding.Encoding.Constant _ =>
      (Tezos_data_encoding.Binary_schema.Zero_width, references)
    | Tezos_data_encoding.Encoding.Bool =>
      (Tezos_data_encoding.Binary_schema.Bool, references)
    | Tezos_data_encoding.Encoding.Int8 =>
      ((Tezos_data_encoding.Binary_schema.Int
        (* ❌ Variants not supported *)
        variant), references)
    | Tezos_data_encoding.Encoding.Uint8 =>
      ((Tezos_data_encoding.Binary_schema.Int
        (* ❌ Variants not supported *)
        variant), references)
    | Tezos_data_encoding.Encoding.Int16 =>
      ((Tezos_data_encoding.Binary_schema.Int
        (* ❌ Variants not supported *)
        variant), references)
    | Tezos_data_encoding.Encoding.Uint16 =>
      ((Tezos_data_encoding.Binary_schema.Int
        (* ❌ Variants not supported *)
        variant), references)
    | Tezos_data_encoding.Encoding.Int31 =>
      ((Tezos_data_encoding.Binary_schema.RangedInt (Z.opp 1073741824)
        1073741823), references)
    | Tezos_data_encoding.Encoding.Int32 =>
      ((Tezos_data_encoding.Binary_schema.Int
        (* ❌ Variants not supported *)
        variant), references)
    | Tezos_data_encoding.Encoding.Int64 =>
      ((Tezos_data_encoding.Binary_schema.Int
        (* ❌ Variants not supported *)
        variant), references)
    | Tezos_data_encoding.Encoding.N =>
      ((Tezos_data_encoding.Binary_schema.Ref n_reference_name),
        (add_n_reference uf references))
    | Tezos_data_encoding.Encoding.Z =>
      ((Tezos_data_encoding.Binary_schema.Ref z_reference_name),
        (add_z_reference uf references))
    |
      Tezos_data_encoding.Encoding.RangedInt {|
        minimum := minimum; maximum := maximum |} =>
      ((Tezos_data_encoding.Binary_schema.RangedInt minimum maximum), references)
    |
      Tezos_data_encoding.Encoding.RangedFloat {|
        minimum := minimum; maximum := maximum |} =>
      ((Tezos_data_encoding.Binary_schema.RangedFloat minimum maximum),
        references)
    | Tezos_data_encoding.Encoding.Float =>
      (Tezos_data_encoding.Binary_schema.Float, references)
    | Tezos_data_encoding.Encoding.Bytes _kind =>
      (Tezos_data_encoding.Binary_schema.Bytes, references)
    | Tezos_data_encoding.Encoding.String _kind =>
      (Tezos_data_encoding.Binary_schema.String, references)
    | (Tezos_data_encoding.Encoding.Padded _ _) as enc =>
      let name := may_new_reference ref_name in
      let '(fields, references) := fields None recursives references enc in
      let references := add_reference name (obj fields) references in
      ((Tezos_data_encoding.Binary_schema.Ref name), references)
    | Tezos_data_encoding.Encoding.String_enum tbl encoding_array =>
      let name := may_new_reference ref_name in
      let '(size, cases) := enum tbl encoding_array in
      let references :=
        add_reference name
          (Tezos_data_encoding.Binary_schema.Int_enum
            {| size := size; cases := cases |}) references in
      ((Tezos_data_encoding.Binary_schema.Enum size name), references)
    | Tezos_data_encoding.Encoding.Array len data =>
      let '(descr, references) :=
        layout None recursives references (encoding data) in
      ((Tezos_data_encoding.Binary_schema.Seq descr len), references)
    | Tezos_data_encoding.Encoding.List len data =>
      let '(layout, references) :=
        layout None recursives references (encoding data) in
      ((Tezos_data_encoding.Binary_schema.Seq layout len), references)
    |
      Tezos_data_encoding.Encoding.Obj
        (Tezos_data_encoding.Encoding.Req {|
          encoding := {| encoding := encoding |} |}) |
        Tezos_data_encoding.Encoding.Obj
          (Tezos_data_encoding.Encoding.Dft {|
            encoding := {| encoding := encoding |} |}) =>
      layout ref_name recursives references encoding
    |
      (Tezos_data_encoding.Encoding.Obj (Tezos_data_encoding.Encoding.Opt _)) as
        enc =>
      let name := may_new_reference ref_name in
      let '(fields, references) := fields None recursives references enc in
      let references := add_reference name (obj fields) references in
      ((Tezos_data_encoding.Binary_schema.Ref name), references)
    | Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
      let name := may_new_reference ref_name in
      let '(fields1, references) :=
        fields None recursives references (encoding left) in
      let '(fields2, references) :=
        fields None recursives references (encoding right) in
      let references :=
        add_reference name (obj (OCaml.Stdlib.app fields1 fields2)) references
        in
      ((Tezos_data_encoding.Binary_schema.Ref name), references)
    | Tezos_data_encoding.Encoding.Tup {| encoding := encoding |} =>
      layout ref_name recursives references encoding
    | (Tezos_data_encoding.Encoding.Tups _) as descr =>
      let name := may_new_reference ref_name in
      let '(fields, references) := fields None recursives references descr in
      let references := add_reference name (obj fields) references in
      ((Tezos_data_encoding.Binary_schema.Ref name), references)
    |
      Tezos_data_encoding.Encoding.Union {|
        kind := kind; tag_size := tag_size; cases := cases |} =>
      let '(name, references) :=
        union ref_name recursives references kind tag_size cases in
      ((Tezos_data_encoding.Binary_schema.Ref name), references)
    |
      (Tezos_data_encoding.Encoding.Mu {|
        name := name;
          title := title;
          description := description;
          fix := fix
          |}) as encoding =>
      let title :=
        match title with
        | Some title => title
        | None => name
        end in
      if Stdlib.List.mem name recursives then
        ((Tezos_data_encoding.Binary_schema.Ref name), references)
      else
        let '{| encoding := encoding |} :=
          fix {| encoding := encoding; json_encoding := None |} in
        let '(name, references) :=
          describe description title name (cons name recursives) references
            encoding in
        ((Tezos_data_encoding.Binary_schema.Ref name), references)
    | Tezos_data_encoding.Encoding.Conv {| encoding := encoding |} =>
      layout ref_name recursives references (encoding encoding)
    |
      Tezos_data_encoding.Encoding.Describe {|
        id := name; encoding := encoding |} =>
      layout (Some name) recursives references (encoding encoding)
    | Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} =>
      layout ref_name recursives references (encoding encoding)
    | (Tezos_data_encoding.Encoding.Dynamic_size _) as encoding =>
      let name := may_new_reference ref_name in
      let '(fields, references) := fields None recursives references encoding in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := UF.add uf {| title := name; description := None |} in
      ((Tezos_data_encoding.Binary_schema.Ref name),
        (add_reference name (obj fields) references))
    | Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
      layout ref_name recursives references (encoding encoding)
    | Tezos_data_encoding.Encoding.Delayed func =>
      layout ref_name recursives references (encoding (func tt))
    end in
  let '(fields, references) :=
    fields None [] {| descriptions := [] |} (encoding encoding) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := uf_add_name "" % string in
  let '(_, toplevel) :=
    Stdlib.List.hd (dedup_canonicalize uf (cons ("" % string, (obj fields)) []))
    in
  let filtered :=
    Stdlib.List.filter
      (fun function_parameter =>
        let '(name, encoding) := function_parameter in
        match encoding with
        |
          Tezos_data_encoding.Binary_schema.Obj {|
            fields :=
              cons
                (Tezos_data_encoding.Binary_schema.Anonymous_field _
                  (Tezos_data_encoding.Binary_schema.Ref
                    reference)) []
              |} =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := UF.union uf (UF.find uf name) reference in
          false
        | _ => true
        end) (descriptions references) in
  let fields := List.rev (dedup_canonicalize uf filtered) in
  {| Binary_schema.toplevel := toplevel; Binary_schema.fields := fields |}.

src/lib_data_encoding/binary_error.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type read_error =
  | Not_enough_data
  | Extra_bytes
  | No_case_matched
  | Unexpected_tag of int
  | Invalid_size of int
  | Invalid_int of {min : int; v : int; max : int}
  | Invalid_float of {min : float; v : float; max : float}
  | Trailing_zero
  | Size_limit_exceeded
  | List_too_long
  | Array_too_long

let pp_read_error ppf = function
  | Not_enough_data ->
      Format.fprintf ppf "Not enough data"
  | Extra_bytes ->
      Format.fprintf ppf "Extra bytes"
  | No_case_matched ->
      Format.fprintf ppf "No case matched"
  | Unexpected_tag tag ->
      Format.fprintf ppf "Unexpected tag %d" tag
  | Invalid_size sz ->
      Format.fprintf ppf "Invalid size %d" sz
  | Invalid_int {min; v; max} ->
      Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
  | Invalid_float {min; v; max} ->
      Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
  | Trailing_zero ->
      Format.fprintf ppf "Trailing zero in Z"
  | Size_limit_exceeded ->
      Format.fprintf ppf "Size limit exceeded"
  | List_too_long ->
      Format.fprintf ppf "List length limit exceeded"
  | Array_too_long ->
      Format.fprintf ppf "Array length limit exceeded"

exception Read_error of read_error

type write_error =
  | Size_limit_exceeded
  | No_case_matched
  | Invalid_int of {min : int; v : int; max : int}
  | Invalid_float of {min : float; v : float; max : float}
  | Invalid_bytes_length of {expected : int; found : int}
  | Invalid_string_length of {expected : int; found : int}
  | Invalid_natural
  | List_too_long
  | Array_too_long

let pp_write_error ppf = function
  | Size_limit_exceeded ->
      Format.fprintf ppf "Size limit exceeded"
  | No_case_matched ->
      Format.fprintf ppf "No case matched"
  | Invalid_int {min; v; max} ->
      Format.fprintf ppf "Invalid int (%d <= %d <= %d) " min v max
  | Invalid_float {min; v; max} ->
      Format.fprintf ppf "Invalid float (%f <= %f <= %f) " min v max
  | Invalid_bytes_length {expected; found} ->
      Format.fprintf
        ppf
        "Invalid bytes length (expected: %d ; found %d)"
        expected
        found
  | Invalid_string_length {expected; found} ->
      Format.fprintf
        ppf
        "Invalid string length (expected: %d ; found %d)"
        expected
        found
  | Invalid_natural ->
      Format.fprintf ppf "Negative natural"
  | List_too_long ->
      Format.fprintf ppf "List length limit exceeded"
  | Array_too_long ->
      Format.fprintf ppf "Array length limit exceeded"

exception Write_error of write_error
src/lib_data_encoding/binary_error.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive read_error : Type :=
| Not_enough_data : read_error
| Extra_bytes : read_error
| No_case_matched : read_error
| Unexpected_tag : Z -> read_error
| Invalid_size : Z -> read_error
| Invalid_int : Z -> Z -> Z -> read_error
| Invalid_float : Z -> Z -> Z -> read_error
| Trailing_zero : read_error
| Size_limit_exceeded : read_error
| List_too_long : read_error
| Array_too_long : read_error.

Definition pp_read_error
  (ppf : Stdlib.Format.formatter) (function_parameter : read_error) : unit :=
  match function_parameter with
  | Not_enough_data =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Not enough data" % string
          CamlinternalFormatBasics.End_of_format) "Not enough data" % string)
  | Extra_bytes =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Extra bytes" % string
          CamlinternalFormatBasics.End_of_format) "Extra bytes" % string)
  | No_case_matched =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "No case matched" % string
          CamlinternalFormatBasics.End_of_format) "No case matched" % string)
  | Unexpected_tag tag =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Unexpected tag " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "Unexpected tag %d" % string) tag
  | Invalid_size sz =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid size " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "Invalid size %d" % string)
      sz
  | Invalid_int {| min := min; v := v; max := max |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid int (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid int (%d <= %d <= %d) " % string) min v max
  | Invalid_float {| min := min; v := v; max := max |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid float (" % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Float
                    CamlinternalFormatBasics.Float_f
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid float (%f <= %f <= %f) " % string) min v max
  | Trailing_zero =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Trailing zero in Z" % string
          CamlinternalFormatBasics.End_of_format) "Trailing zero in Z" % string)
  | Size_limit_exceeded =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Size limit exceeded" % string
          CamlinternalFormatBasics.End_of_format) "Size limit exceeded" % string)
  | List_too_long =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "List length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "List length limit exceeded" % string)
  | Array_too_long =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Array length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "Array length limit exceeded" % string)
  end.

(* ❌ The definition of exceptions is not handled. *)
exception

Inductive write_error : Type :=
| Size_limit_exceeded : write_error
| No_case_matched : write_error
| Invalid_int : Z -> Z -> Z -> write_error
| Invalid_float : Z -> Z -> Z -> write_error
| Invalid_bytes_length : Z -> Z -> write_error
| Invalid_string_length : Z -> Z -> write_error
| Invalid_natural : write_error
| List_too_long : write_error
| Array_too_long : write_error.

Definition pp_write_error
  (ppf : Stdlib.Format.formatter) (function_parameter : write_error) : unit :=
  match function_parameter with
  | Size_limit_exceeded =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Size limit exceeded" % string
          CamlinternalFormatBasics.End_of_format) "Size limit exceeded" % string)
  | No_case_matched =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "No case matched" % string
          CamlinternalFormatBasics.End_of_format) "No case matched" % string)
  | Invalid_int {| min := min; v := v; max := max |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid int (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid int (%d <= %d <= %d) " % string) min v max
  | Invalid_float {| min := min; v := v; max := max |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid float (" % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " <= " % string
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " <= " % string
                  (CamlinternalFormatBasics.Float
                    CamlinternalFormatBasics.Float_f
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ") " % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid float (%f <= %f <= %f) " % string) min v max
  | Invalid_bytes_length {| expected := expected; found := found |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid bytes length (expected: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " ; found " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "Invalid bytes length (expected: %d ; found %d)" % string) expected
      found
  | Invalid_string_length {| expected := expected; found := found |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid string length (expected: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " ; found " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "Invalid string length (expected: %d ; found %d)" % string) expected
      found
  | Invalid_natural =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Negative natural" % string
          CamlinternalFormatBasics.End_of_format) "Negative natural" % string)
  | List_too_long =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "List length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "List length limit exceeded" % string)
  | Array_too_long =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Array length limit exceeded" % string
          CamlinternalFormatBasics.End_of_format)
        "Array length limit exceeded" % string)
  end.

(* ❌ The definition of exceptions is not handled. *)
exception

src/lib_data_encoding/binary_length.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let n_length value =
  let bits = Z.numbits value in
  if bits = 0 then 1 else (bits + 6) / 7

let z_length value = (Z.numbits value + 1 + 6) / 7

let rec length : type x. x Encoding.t -> x -> int =
 fun e value ->
  let open Encoding in
  match e.encoding with
  (* Fixed *)
  | Null ->
      0
  | Empty ->
      0
  | Constant _ ->
      0
  | Bool ->
      Binary_size.bool
  | Int8 ->
      Binary_size.int8
  | Uint8 ->
      Binary_size.uint8
  | Int16 ->
      Binary_size.int16
  | Uint16 ->
      Binary_size.uint16
  | Int31 ->
      Binary_size.int31
  | Int32 ->
      Binary_size.int32
  | Int64 ->
      Binary_size.int64
  | N ->
      n_length value
  | Z ->
      z_length value
  | RangedInt {minimum; maximum} ->
      Binary_size.integer_to_size
      @@ Binary_size.range_to_size ~minimum ~maximum
  | Float ->
      Binary_size.float
  | RangedFloat _ ->
      Binary_size.float
  | Bytes (`Fixed n) ->
      n
  | String (`Fixed n) ->
      n
  | Padded (e, n) ->
      length e value + n
  | String_enum (_, arr) ->
      Binary_size.integer_to_size @@ Binary_size.enum_size arr
  | Objs {kind = `Fixed n; _} ->
      n
  | Tups {kind = `Fixed n; _} ->
      n
  | Union {kind = `Fixed n; _} ->
      n
  (* Dynamic *)
  | Objs {kind = `Dynamic; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Tups {kind = `Dynamic; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Union {kind = `Dynamic; tag_size; cases} ->
      let rec length_case = function
        | [] ->
            raise (Write_error No_case_matched)
        | Case {tag = Json_only; _} :: tl ->
            length_case tl
        | Case {encoding = e; proj; _} :: tl -> (
          match proj value with
          | None ->
              length_case tl
          | Some value ->
              Binary_size.tag_size tag_size + length e value )
      in
      length_case cases
  | Mu {kind = `Dynamic; fix; _} ->
      length (fix e) value
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) -> (
    match value with None -> 1 | Some value -> 1 + length e value )
  (* Variable *)
  | Ignore ->
      0
  | Bytes `Variable ->
      Bytes.length value
  | String `Variable ->
      String.length value
  | Array (Some max_length, _e) when Array.length value > max_length ->
      raise (Write_error Array_too_long)
  | Array (_, e) ->
      Array.fold_left (fun acc v -> length e v + acc) 0 value
  | List (Some max_length, _e) when List.length value > max_length ->
      raise (Write_error List_too_long)
  | List (_, e) ->
      List.fold_left (fun acc v -> length e v + acc) 0 value
  | Objs {kind = `Variable; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Tups {kind = `Variable; left; right} ->
      let (v1, v2) = value in
      length left v1 + length right v2
  | Obj (Opt {kind = `Variable; encoding = e; _}) -> (
    match value with None -> 0 | Some value -> length e value )
  | Union {kind = `Variable; tag_size; cases} ->
      let rec length_case = function
        | [] ->
            raise (Write_error No_case_matched)
        | Case {tag = Json_only; _} :: tl ->
            length_case tl
        | Case {encoding = e; proj; _} :: tl -> (
          match proj value with
          | None ->
              length_case tl
          | Some value ->
              Binary_size.tag_size tag_size + length e value )
      in
      length_case cases
  | Mu {kind = `Variable; fix; _} ->
      length (fix e) value
  (* Recursive*)
  | Obj (Req {encoding = e; _}) ->
      length e value
  | Obj (Dft {encoding = e; _}) ->
      length e value
  | Tup e ->
      length e value
  | Conv {encoding = e; proj; _} ->
      length e (proj value)
  | Describe {encoding = e; _} ->
      length e value
  | Splitted {encoding = e; _} ->
      length e value
  | Dynamic_size {kind; encoding = e} ->
      let length = length e value in
      Binary_size.integer_to_size kind + length
  | Check_size {limit; encoding = e} ->
      let length = length e value in
      if length > limit then raise (Write_error Size_limit_exceeded) ;
      length
  | Delayed f ->
      length (f ()) value

let fixed_length e =
  match Encoding.classify e with
  | `Fixed n ->
      Some n
  | `Dynamic | `Variable ->
      None

let fixed_length_exn e =
  match fixed_length e with
  | Some n ->
      n
  | None ->
      invalid_arg "Data_encoding.Binary.fixed_length_exn"
src/lib_data_encoding/binary_length.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Binary_error.

Definition n_length (value : Z.t) : Z :=
  let bits := Z.numbits value in
  if equiv_decb bits 0 then
    1
  else
    Z.div (Z.add bits 6) 7.

Definition z_length (value : Z.t) : Z :=
  Z.div (Z.add (Z.add (Z.numbits value) 1) 6) 7.

Fixpoint length {x : Type} (e : Tezos_data_encoding.Encoding.t x) (value : x)
  : Z :=
  match encoding e with
  | Tezos_data_encoding.Encoding.Null => 0
  | Tezos_data_encoding.Encoding.Empty => 0
  | Tezos_data_encoding.Encoding.Constant _ => 0
  | Tezos_data_encoding.Encoding.Bool => Binary_size.bool
  | Tezos_data_encoding.Encoding.Int8 => Binary_size.int8
  | Tezos_data_encoding.Encoding.Uint8 => Binary_size.uint8
  | Tezos_data_encoding.Encoding.Int16 => Binary_size.int16
  | Tezos_data_encoding.Encoding.Uint16 => Binary_size.uint16
  | Tezos_data_encoding.Encoding.Int31 => Binary_size.int31
  | Tezos_data_encoding.Encoding.Int32 => Binary_size.int32
  | Tezos_data_encoding.Encoding.Int64 => Binary_size.int64
  | Tezos_data_encoding.Encoding.N => n_length value
  | Tezos_data_encoding.Encoding.Z => z_length value
  |
    Tezos_data_encoding.Encoding.RangedInt {|
      minimum := minimum; maximum := maximum |} =>
    apply Binary_size.integer_to_size
      (Binary_size.range_to_size minimum maximum)
  | Tezos_data_encoding.Encoding.Float => Binary_size.float
  | Tezos_data_encoding.Encoding.RangedFloat _ => Binary_size.float
  | Tezos_data_encoding.Encoding.Bytes (Fixed n) => n
  | Tezos_data_encoding.Encoding.String (Fixed n) => n
  | Tezos_data_encoding.Encoding.Padded e n => Z.add (length e value) n
  | Tezos_data_encoding.Encoding.String_enum _ arr =>
    apply Binary_size.integer_to_size (Binary_size.enum_size arr)
  | Tezos_data_encoding.Encoding.Objs {| kind := Fixed n |} => n
  | Tezos_data_encoding.Encoding.Tups {| kind := Fixed n |} => n
  | Tezos_data_encoding.Encoding.Union {| kind := Fixed n |} => n
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Dynamic; left := left; right := right |} =>
    let '(v1, v2) := value in
    Z.add (length left v1) (length right v2)
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Dynamic; left := left; right := right |} =>
    let '(v1, v2) := value in
    Z.add (length left v1) (length right v2)
  |
    Tezos_data_encoding.Encoding.Union {|
      kind := Dynamic; tag_size := tag_size; cases := cases |} =>
    let fix length_case
      (function_parameter : list (Tezos_data_encoding.Encoding.case x)) : Z :=
      match function_parameter with
      | [] =>
        Stdlib.raise
          (Write_error Tezos_data_encoding.Binary_error.No_case_matched)
      |
        cons
          (Tezos_data_encoding.Encoding.Case {|
            tag := Tezos_data_encoding.Encoding.Json_only |}) tl =>
        length_case tl
      |
        cons
          (Tezos_data_encoding.Encoding.Case {| encoding := e; proj := proj |})
          tl =>
        match proj value with
        | None => length_case tl
        | Some value => Z.add (Binary_size.tag_size tag_size) (length e value)
        end
      end in
    length_case cases
  | Tezos_data_encoding.Encoding.Mu {| kind := Dynamic; fix := fix |} =>
    length (fix e) value
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
    match value with
    | None => 1
    | Some value => Z.add 1 (length e value)
    end
  | Tezos_data_encoding.Encoding.Ignore => 0
  | Tezos_data_encoding.Encoding.Bytes Variable => String.length value
  | Tezos_data_encoding.Encoding.String Variable => OCaml.String.length value
  | Tezos_data_encoding.Encoding.Array (Some max_length) _e =>
    Stdlib.raise (Write_error Tezos_data_encoding.Binary_error.Array_too_long)
  | Tezos_data_encoding.Encoding.Array _ e =>
    Array.fold_left (fun acc => fun v => Z.add (length e v) acc) 0 value
  | Tezos_data_encoding.Encoding.List (Some max_length) _e =>
    Stdlib.raise (Write_error Tezos_data_encoding.Binary_error.List_too_long)
  | Tezos_data_encoding.Encoding.List _ e =>
    Stdlib.List.fold_left (fun acc => fun v => Z.add (length e v) acc) 0 value
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Variable; left := left; right := right |} =>
    let '(v1, v2) := value in
    Z.add (length left v1) (length right v2)
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Variable; left := left; right := right |} =>
    let '(v1, v2) := value in
    Z.add (length left v1) (length right v2)
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
    =>
    match value with
    | None => 0
    | Some value => length e value
    end
  |
    Tezos_data_encoding.Encoding.Union {|
      kind := Variable; tag_size := tag_size; cases := cases |} =>
    let fix length_case
      (function_parameter : list (Tezos_data_encoding.Encoding.case x)) : Z :=
      match function_parameter with
      | [] =>
        Stdlib.raise
          (Write_error Tezos_data_encoding.Binary_error.No_case_matched)
      |
        cons
          (Tezos_data_encoding.Encoding.Case {|
            tag := Tezos_data_encoding.Encoding.Json_only |}) tl =>
        length_case tl
      |
        cons
          (Tezos_data_encoding.Encoding.Case {| encoding := e; proj := proj |})
          tl =>
        match proj value with
        | None => length_case tl
        | Some value => Z.add (Binary_size.tag_size tag_size) (length e value)
        end
      end in
    length_case cases
  | Tezos_data_encoding.Encoding.Mu {| kind := Variable; fix := fix |} =>
    length (fix e) value
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Req {| encoding := e |}) => length e value
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Dft {| encoding := e |}) => length e value
  | Tezos_data_encoding.Encoding.Tup e => length e value
  | Tezos_data_encoding.Encoding.Conv {| proj := proj; encoding := e |} =>
    length e (proj value)
  | Tezos_data_encoding.Encoding.Describe {| encoding := e |} => length e value
  | Tezos_data_encoding.Encoding.Splitted {| encoding := e |} => length e value
  | Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
    =>
    let length := length e value in
    Z.add (Binary_size.integer_to_size kind) length
  | Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
    =>
    let length := length e value in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.gt length limit then
        Stdlib.raise
          (Write_error Tezos_data_encoding.Binary_error.Size_limit_exceeded)
      else
        tt in
    length
  | Tezos_data_encoding.Encoding.Delayed f => length (f tt) value
  end.

Definition fixed_length {A : Type} (e : Tezos_data_encoding.Encoding.encoding A)
  : option Z :=
  match Encoding.classify e with
  | Fixed n => Some n
  | Dynamic | Variable => None
  end.

Definition fixed_length_exn {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) : Z :=
  match fixed_length e with
  | Some n => n
  | None =>
    OCaml.Stdlib.invalid_arg "Data_encoding.Binary.fixed_length_exn" % string
  end.

src/lib_data_encoding/binary_reader.ml 81 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let raise e = raise (Read_error e)

type state = {
  buffer : Bytes.t;
  mutable offset : int;
  mutable remaining_bytes : int;
  mutable allowed_bytes : int option;
}

let check_allowed_bytes state size =
  match state.allowed_bytes with
  | Some len when len < size ->
      raise Size_limit_exceeded
  | Some len ->
      Some (len - size)
  | None ->
      None

let check_remaining_bytes state size =
  if state.remaining_bytes < size then raise Not_enough_data ;
  state.remaining_bytes - size

let read_atom size conv state =
  let offset = state.offset in
  state.remaining_bytes <- check_remaining_bytes state size ;
  state.allowed_bytes <- check_allowed_bytes state size ;
  state.offset <- state.offset + size ;
  conv state.buffer offset

(** Reader for all the atomic types. *)
module Atom = struct
  let uint8 = read_atom Binary_size.uint8 TzEndian.get_uint8

  let uint16 = read_atom Binary_size.int16 TzEndian.get_uint16

  let int8 = read_atom Binary_size.int8 TzEndian.get_int8

  let int16 = read_atom Binary_size.int16 TzEndian.get_int16

  let int32 = read_atom Binary_size.int32 TzEndian.get_int32

  let int64 = read_atom Binary_size.int64 TzEndian.get_int64

  let float = read_atom Binary_size.float TzEndian.get_double

  let bool state = int8 state <> 0

  let uint30 =
    read_atom Binary_size.uint30
    @@ fun buffer ofs ->
    let v = Int32.to_int (TzEndian.get_int32 buffer ofs) in
    if v < 0 then raise (Invalid_int {min = 0; v; max = (1 lsl 30) - 1}) ;
    v

  let int31 =
    read_atom Binary_size.int31
    @@ fun buffer ofs -> Int32.to_int (TzEndian.get_int32 buffer ofs)

  let int = function
    | `Int31 ->
        int31
    | `Int16 ->
        int16
    | `Int8 ->
        int8
    | `Uint30 ->
        uint30
    | `Uint16 ->
        uint16
    | `Uint8 ->
        uint8

  let ranged_int ~minimum ~maximum state =
    let read_int =
      match Binary_size.range_to_size ~minimum ~maximum with
      | `Int8 ->
          int8
      | `Int16 ->
          int16
      | `Int31 ->
          int31
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    let ranged = read_int state in
    let ranged = if minimum > 0 then ranged + minimum else ranged in
    if not (minimum <= ranged && ranged <= maximum) then
      raise (Invalid_int {min = minimum; v = ranged; max = maximum}) ;
    ranged

  let ranged_float ~minimum ~maximum state =
    let ranged = float state in
    if not (minimum <= ranged && ranged <= maximum) then
      raise (Invalid_float {min = minimum; v = ranged; max = maximum}) ;
    ranged

  let rec read_z res value bit_in_value state =
    let byte = uint8 state in
    let value = value lor ((byte land 0x7F) lsl bit_in_value) in
    let bit_in_value = bit_in_value + 7 in
    let (bit_in_value, value) =
      if bit_in_value < 8 then (bit_in_value, value)
      else (
        Buffer.add_char res (Char.unsafe_chr (value land 0xFF)) ;
        (bit_in_value - 8, value lsr 8) )
    in
    if byte land 0x80 = 0x80 then read_z res value bit_in_value state
    else (
      if bit_in_value > 0 then Buffer.add_char res (Char.unsafe_chr value) ;
      if byte = 0x00 then raise Trailing_zero ;
      Z.of_bits (Buffer.contents res) )

  let n state =
    let first = uint8 state in
    let first_value = first land 0x7F in
    if first land 0x80 = 0x80 then
      read_z (Buffer.create 100) first_value 7 state
    else Z.of_int first_value

  let z state =
    let first = uint8 state in
    let first_value = first land 0x3F in
    let sign = first land 0x40 <> 0 in
    if first land 0x80 = 0x80 then
      let n = read_z (Buffer.create 100) first_value 6 state in
      if sign then Z.neg n else n
    else
      let n = Z.of_int first_value in
      if sign then Z.neg n else n

  let string_enum arr state =
    let read_index =
      match Binary_size.enum_size arr with
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    let index = read_index state in
    if index >= Array.length arr then raise No_case_matched ;
    arr.(index)

  let fixed_length_bytes length =
    read_atom length @@ fun buf ofs -> Bytes.sub buf ofs length

  let fixed_length_string length =
    read_atom length @@ fun buf ofs -> Bytes.sub_string buf ofs length

  let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end

(** Main recursive reading function, in continuation passing style. *)
let rec read_rec : type ret. ret Encoding.t -> state -> ret =
 fun e state ->
  let open Encoding in
  match e.encoding with
  | Null ->
      ()
  | Empty ->
      ()
  | Constant _ ->
      ()
  | Ignore ->
      ()
  | Bool ->
      Atom.bool state
  | Int8 ->
      Atom.int8 state
  | Uint8 ->
      Atom.uint8 state
  | Int16 ->
      Atom.int16 state
  | Uint16 ->
      Atom.uint16 state
  | Int31 ->
      Atom.int31 state
  | Int32 ->
      Atom.int32 state
  | Int64 ->
      Atom.int64 state
  | N ->
      Atom.n state
  | Z ->
      Atom.z state
  | Float ->
      Atom.float state
  | Bytes (`Fixed n) ->
      Atom.fixed_length_bytes n state
  | Bytes `Variable ->
      Atom.fixed_length_bytes state.remaining_bytes state
  | String (`Fixed n) ->
      Atom.fixed_length_string n state
  | String `Variable ->
      Atom.fixed_length_string state.remaining_bytes state
  | Padded (e, n) ->
      let v = read_rec e state in
      ignore (Atom.fixed_length_string n state : string) ;
      v
  | RangedInt {minimum; maximum} ->
      Atom.ranged_int ~minimum ~maximum state
  | RangedFloat {minimum; maximum} ->
      Atom.ranged_float ~minimum ~maximum state
  | String_enum (_, arr) ->
      Atom.string_enum arr state
  | Array (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      let l = read_list List_too_long max_length e state in
      Array.of_list l
  | List (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      read_list Array_too_long max_length e state
  | Obj (Req {encoding = e; _}) ->
      read_rec e state
  | Obj (Dft {encoding = e; _}) ->
      read_rec e state
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) ->
      let present = Atom.bool state in
      if not present then None else Some (read_rec e state)
  | Obj (Opt {kind = `Variable; encoding = e; _}) ->
      if state.remaining_bytes = 0 then None else Some (read_rec e state)
  | Objs {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int) ;
      ignore (check_allowed_bytes state sz : int option) ;
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Objs {kind = `Dynamic; left; right} ->
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Objs {kind = `Variable; left; right} ->
      read_variable_pair left right state
  | Tup e ->
      read_rec e state
  | Tups {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int) ;
      ignore (check_allowed_bytes state sz : int option) ;
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Tups {kind = `Dynamic; left; right} ->
      let left = read_rec left state in
      let right = read_rec right state in
      (left, right)
  | Tups {kind = `Variable; left; right} ->
      read_variable_pair left right state
  | Conv {inj; encoding; _} ->
      inj (read_rec encoding state)
  | Union {tag_size; cases; _} ->
      let ctag = Atom.tag tag_size state in
      let (Case {encoding; inj; _}) =
        try
          List.find
            (function
              | Case {tag = Tag tag; _} ->
                  tag = ctag
              | Case {tag = Json_only; _} ->
                  false)
            cases
        with Not_found -> raise (Unexpected_tag ctag)
      in
      inj (read_rec encoding state)
  | Dynamic_size {kind; encoding = e} ->
      let sz = Atom.int kind state in
      let remaining = check_remaining_bytes state sz in
      state.remaining_bytes <- sz ;
      ignore (check_allowed_bytes state sz : int option) ;
      let v = read_rec e state in
      if state.remaining_bytes <> 0 then raise Extra_bytes ;
      state.remaining_bytes <- remaining ;
      v
  | Check_size {limit; encoding = e} ->
      let old_allowed_bytes = state.allowed_bytes in
      let limit =
        match state.allowed_bytes with
        | None ->
            limit
        | Some current_limit ->
            min current_limit limit
      in
      state.allowed_bytes <- Some limit ;
      let v = read_rec e state in
      let allowed_bytes =
        match old_allowed_bytes with
        | None ->
            None
        | Some old_limit ->
            let remaining =
              match state.allowed_bytes with
              | None ->
                  assert false
              | Some remaining ->
                  remaining
            in
            let read = limit - remaining in
            Some (old_limit - read)
      in
      state.allowed_bytes <- allowed_bytes ;
      v
  | Describe {encoding = e; _} ->
      read_rec e state
  | Splitted {encoding = e; _} ->
      read_rec e state
  | Mu {fix; _} ->
      read_rec (fix e) state
  | Delayed f ->
      read_rec (f ()) state

and read_variable_pair :
    type left right.
    left Encoding.t -> right Encoding.t -> state -> left * right =
 fun e1 e2 state ->
  match (Encoding.classify e1, Encoding.classify e2) with
  | ((`Dynamic | `Fixed _), `Variable) ->
      let left = read_rec e1 state in
      let right = read_rec e2 state in
      (left, right)
  | (`Variable, `Fixed n) ->
      if n > state.remaining_bytes then raise Not_enough_data ;
      state.remaining_bytes <- state.remaining_bytes - n ;
      let left = read_rec e1 state in
      assert (state.remaining_bytes = 0) ;
      state.remaining_bytes <- n ;
      let right = read_rec e2 state in
      assert (state.remaining_bytes = 0) ;
      (left, right)
  | _ ->
      assert false

(* Should be rejected by [Encoding.Kind.combine] *)
and read_list : type a. read_error -> int -> a Encoding.t -> state -> a list =
 fun error max_length e state ->
  let rec loop max_length acc =
    if state.remaining_bytes = 0 then List.rev acc
    else if max_length = 0 then raise error
    else
      let v = read_rec e state in
      loop (max_length - 1) (v :: acc)
  in
  loop max_length []

(** ******************** *)

(** Various entry points *)

let read encoding buffer ofs len =
  let state =
    {buffer; offset = ofs; remaining_bytes = len; allowed_bytes = None}
  in
  match read_rec encoding state with
  | exception Read_error _ ->
      None
  | v ->
      Some (state.offset, v)

let of_bytes_exn encoding buffer =
  let len = Bytes.length buffer in
  let state =
    {buffer; offset = 0; remaining_bytes = len; allowed_bytes = None}
  in
  let v = read_rec encoding state in
  if state.offset <> len then raise Extra_bytes ;
  v

let of_bytes encoding buffer =
  try Some (of_bytes_exn encoding buffer) with Read_error _ -> None
src/lib_data_encoding/binary_reader.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Binary_error.

Definition raise {A : Type} (e : Tezos_data_encoding.Binary_error.read_error)
  : A := Stdlib.raise (Read_error e).

Record state := {
  buffer : Stdlib.Bytes.t;
  offset : Z;
  remaining_bytes : Z;
  allowed_bytes : option Z }.

Definition check_allowed_bytes (state : state) (size : Z) : option Z :=
  match allowed_bytes state with
  | Some len => raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
  | Some len => Some (Z.sub len size)
  | None => None
  end.

Definition check_remaining_bytes (state : state) (size : Z) : Z :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if OCaml.Stdlib.lt (remaining_bytes state) size then
      raise Tezos_data_encoding.Binary_error.Not_enough_data
    else
      tt in
  Z.sub (remaining_bytes state) size.

Definition read_atom {A : Type}
  (size : Z) (conv : Stdlib.Bytes.t -> Z -> A) (state : state) : A :=
  let offset := offset state in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field state "remaining_bytes" % string
      (check_remaining_bytes state size) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field state "allowed_bytes" % string
      (check_allowed_bytes state size) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field state "offset" % string (Z.add (offset state) size) in
  conv (buffer state) offset.

Module Atom.
  Definition uint8 : state -> Z :=
    read_atom Binary_size.uint8 TzEndian.get_uint8.
  
  Definition uint16 : state -> Z :=
    read_atom Binary_size.int16 TzEndian.get_uint16.
  
  Definition int8 : state -> Z := read_atom Binary_size.int8 TzEndian.get_int8.
  
  Definition int16 : state -> Z :=
    read_atom Binary_size.int16 TzEndian.get_int16.
  
  Definition int32 : state -> int32 :=
    read_atom Binary_size.int32 TzEndian.get_int32.
  
  Definition int64 : state -> int64 :=
    read_atom Binary_size.int64 TzEndian.get_int64.
  
  Definition float : state -> Z :=
    read_atom Binary_size.float TzEndian.get_double.
  
  Definition bool (state : state) : bool := nequiv_decb (int8 state) 0.
  
  Definition uint30 : state -> Z :=
    apply (read_atom Binary_size.uint30)
      (fun buffer =>
        fun ofs =>
          let v := Int32.to_int (TzEndian.get_int32 buffer ofs) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if OCaml.Stdlib.lt v 0 then
              raise
                (Tezos_data_encoding.Binary_error.Invalid_int
                  {| min := 0; v := v; max := Z.sub (Z.shiftl 1 30) 1 |})
            else
              tt in
          v).
  
  Definition int31 : state -> Z :=
    apply (read_atom Binary_size.int31)
      (fun buffer => fun ofs => Int32.to_int (TzEndian.get_int32 buffer ofs)).
  
  Definition int (function_parameter : variant) : state -> Z :=
    match function_parameter with
    | Int31 => int31
    | Int16 => int16
    | Int8 => int8
    | Uint30 => uint30
    | Uint16 => uint16
    | Uint8 => uint8
    end.
  
  Definition ranged_int (minimum : Z) (maximum : Z) (state : state) : Z :=
    let read_int :=
      match Binary_size.range_to_size minimum maximum with
      | Int8 => int8
      | Int16 => int16
      | Int31 => int31
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    let ranged := read_int state in
    let ranged :=
      if OCaml.Stdlib.gt minimum 0 then
        Z.add ranged minimum
      else
        ranged in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if
        negb
          (andb (OCaml.Stdlib.le minimum ranged)
            (OCaml.Stdlib.le ranged maximum)) then
        raise
          (Tezos_data_encoding.Binary_error.Invalid_int
            {| min := minimum; v := ranged; max := maximum |})
      else
        tt in
    ranged.
  
  Definition ranged_float (minimum : Z) (maximum : Z) (state : state) : Z :=
    let ranged := Z state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if
        negb
          (andb (OCaml.Stdlib.le minimum ranged)
            (OCaml.Stdlib.le ranged maximum)) then
        raise
          (Tezos_data_encoding.Binary_error.Invalid_float
            {| min := minimum; v := ranged; max := maximum |})
      else
        tt in
    ranged.
  
  Fixpoint read_z
    (res : Stdlib.Buffer.t) (value : Z) (bit_in_value : Z) (state : state)
    : Z.t :=
    let byte := uint8 state in
    let value := Z.lor value (Z.shiftl (Z.land byte 127) bit_in_value) in
    let bit_in_value := Z.add bit_in_value 7 in
    let '(bit_in_value, value) :=
      if OCaml.Stdlib.lt bit_in_value 8 then
        (bit_in_value, value)
      else
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Buffer.add_char res (Char.unsafe_chr (Z.land value 255)) in
        ((Z.sub bit_in_value 8), (Z.shiftr value 8)) in
    if equiv_decb (Z.land byte 128) 128 then
      read_z res value bit_in_value state
    else
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if OCaml.Stdlib.gt bit_in_value 0 then
          Buffer.add_char res (Char.unsafe_chr value)
        else
          tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if equiv_decb byte 0 then
          raise Tezos_data_encoding.Binary_error.Trailing_zero
        else
          tt in
      Z.of_bits (Buffer.contents res).
  
  Definition n (state : state) : Z.t :=
    let first := uint8 state in
    let first_value := Z.land first 127 in
    if equiv_decb (Z.land first 128) 128 then
      read_z (Buffer.create 100) first_value 7 state
    else
      Z.of_int first_value.
  
  Definition z (state : state) : Z.t :=
    let first := uint8 state in
    let first_value := Z.land first 63 in
    let sign := nequiv_decb (Z.land first 64) 0 in
    if equiv_decb (Z.land first 128) 128 then
      let n := read_z (Buffer.create 100) first_value 6 state in
      if sign then
        Z.neg n
      else
        n
    else
      let n := Z.of_int first_value in
      if sign then
        Z.neg n
      else
        n.
  
  Definition string_enum {A : Type} (arr : array A) (state : state) : A :=
    let read_index :=
      match Binary_size.enum_size arr with
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    let index := read_index state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.ge index (Array.length arr) then
        raise Tezos_data_encoding.Binary_error.No_case_matched
      else
        tt in
    Array.get arr index.
  
  Definition fixed_length_bytes (length : Z) : state -> string :=
    apply (read_atom length) (fun buf => fun ofs => String.sub buf ofs length).
  
  Definition fixed_length_string (length : Z) : state -> string :=
    apply (read_atom length)
      (fun buf => fun ofs => Stdlib.Bytes.sub_string buf ofs length).
  
  Definition tag (function_parameter : variant) : state -> Z :=
    match function_parameter with
    | Uint8 => uint8
    | Uint16 => uint16
    end.
End Atom.

Fixpoint read_rec {ret : Type}
  (e : Tezos_data_encoding.Encoding.t ret) (state : state) : ret :=
  match encoding e with
  | Tezos_data_encoding.Encoding.Null => tt
  | Tezos_data_encoding.Encoding.Empty => tt
  | Tezos_data_encoding.Encoding.Constant _ => tt
  | Tezos_data_encoding.Encoding.Ignore => tt
  | Tezos_data_encoding.Encoding.Bool => Atom.bool state
  | Tezos_data_encoding.Encoding.Int8 => Atom.int8 state
  | Tezos_data_encoding.Encoding.Uint8 => Atom.uint8 state
  | Tezos_data_encoding.Encoding.Int16 => Atom.int16 state
  | Tezos_data_encoding.Encoding.Uint16 => Atom.uint16 state
  | Tezos_data_encoding.Encoding.Int31 => Atom.int31 state
  | Tezos_data_encoding.Encoding.Int32 => Atom.int32 state
  | Tezos_data_encoding.Encoding.Int64 => Atom.int64 state
  | Tezos_data_encoding.Encoding.N => Atom.n state
  | Tezos_data_encoding.Encoding.Z => Atom.z state
  | Tezos_data_encoding.Encoding.Float => Atom.float state
  | Tezos_data_encoding.Encoding.Bytes (Fixed n) =>
    Atom.fixed_length_bytes n state
  | Tezos_data_encoding.Encoding.Bytes Variable =>
    Atom.fixed_length_bytes (remaining_bytes state) state
  | Tezos_data_encoding.Encoding.String (Fixed n) =>
    Atom.fixed_length_string n state
  | Tezos_data_encoding.Encoding.String Variable =>
    Atom.fixed_length_string (remaining_bytes state) state
  | Tezos_data_encoding.Encoding.Padded e n =>
    let v := read_rec e state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (Atom.fixed_length_string n state) in
    v
  |
    Tezos_data_encoding.Encoding.RangedInt {|
      minimum := minimum; maximum := maximum |} =>
    Atom.ranged_int minimum maximum state
  |
    Tezos_data_encoding.Encoding.RangedFloat {|
      minimum := minimum; maximum := maximum |} =>
    Atom.ranged_float minimum maximum state
  | Tezos_data_encoding.Encoding.String_enum _ arr => Atom.string_enum arr state
  | Tezos_data_encoding.Encoding.Array max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    let l :=
      read_list Tezos_data_encoding.Binary_error.List_too_long max_length e
        state in
    Array.of_list l
  | Tezos_data_encoding.Encoding.List max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    read_list Tezos_data_encoding.Binary_error.Array_too_long max_length e state
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Req {| encoding := e |}) => read_rec e state
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Dft {| encoding := e |}) => read_rec e state
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
    let present := Atom.bool state in
    if negb present then
      None
    else
      Some (read_rec e state)
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
    =>
    if equiv_decb (remaining_bytes state) 0 then
      None
    else
      Some (read_rec e state)
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Fixed sz; left := left; right := right |} =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Dynamic; left := left; right := right |} =>
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state
  | Tezos_data_encoding.Encoding.Tup e => read_rec e state
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Fixed sz; left := left; right := right |} =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Dynamic; left := left; right := right |} =>
    let left := read_rec left state in
    let right := read_rec right state in
    (left, right)
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state
  | Tezos_data_encoding.Encoding.Conv {| inj := inj; encoding := encoding |} =>
    inj (read_rec encoding state)
  |
    Tezos_data_encoding.Encoding.Union {|
      tag_size := tag_size; cases := cases |} =>
    let ctag := Atom.tag tag_size state in
    let
      'Tezos_data_encoding.Encoding.Case {| encoding := encoding; inj := inj |} :=
      (* ❌ Try-with are not handled *)
      try
        (Stdlib.List.find
          (fun function_parameter =>
            match function_parameter with
            |
              Tezos_data_encoding.Encoding.Case {|
                tag := Tezos_data_encoding.Encoding.Tag tag |} =>
              equiv_decb tag ctag
            |
              Tezos_data_encoding.Encoding.Case {|
                tag := Tezos_data_encoding.Encoding.Json_only |} => false
            end) cases) in
    inj (read_rec encoding state)
  | Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
    =>
    let sz := Atom.int kind state in
    let remaining := check_remaining_bytes state sz in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "remaining_bytes" % string sz in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
    let v := read_rec e state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb (remaining_bytes state) 0 then
        raise Tezos_data_encoding.Binary_error.Extra_bytes
      else
        tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "remaining_bytes" % string remaining in
    v
  | Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
    =>
    let old_allowed_bytes := allowed_bytes state in
    let limit :=
      match allowed_bytes state with
      | None => limit
      | Some current_limit => OCaml.Stdlib.min current_limit limit
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "allowed_bytes" % string (Some limit) in
    let v := read_rec e state in
    let allowed_bytes :=
      match old_allowed_bytes with
      | None => None
      | Some old_limit =>
        let remaining :=
          match allowed_bytes state with
          | None =>
            (* ❌ Assert instruction is not handled. *)
            assert false
          | Some remaining => remaining
          end in
        let read := Z.sub limit remaining in
        Some (Z.sub old_limit read)
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "allowed_bytes" % string allowed_bytes in
    v
  | Tezos_data_encoding.Encoding.Describe {| encoding := e |} =>
    read_rec e state
  | Tezos_data_encoding.Encoding.Splitted {| encoding := e |} =>
    read_rec e state
  | Tezos_data_encoding.Encoding.Mu {| fix := fix |} => read_rec (fix e) state
  | Tezos_data_encoding.Encoding.Delayed f => read_rec (f tt) state
  end

with read_variable_pair {left right : Type}
  (e1 : Tezos_data_encoding.Encoding.t left)
  (e2 : Tezos_data_encoding.Encoding.t right) (state : state) : left * right :=
  match ((Encoding.classify e1), (Encoding.classify e2)) with
  | (Dynamic | Fixed _, Variable) =>
    let left := read_rec e1 state in
    let right := read_rec e2 state in
    (left, right)
  | (Variable, Fixed n) =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.gt n (remaining_bytes state) then
        raise Tezos_data_encoding.Binary_error.Not_enough_data
      else
        tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "remaining_bytes" % string
        (Z.sub (remaining_bytes state) n) in
    let left := read_rec e1 state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Assert instruction is not handled. *)
      assert (equiv_decb (remaining_bytes state) 0) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "remaining_bytes" % string n in
    let right := read_rec e2 state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Assert instruction is not handled. *)
      assert (equiv_decb (remaining_bytes state) 0) in
    (left, right)
  | _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end

with read_list {a : Type}
  (error : Tezos_data_encoding.Binary_error.read_error) (max_length : Z)
  (e : Tezos_data_encoding.Encoding.t a) (state : state) : list a :=
  let fix loop (max_length : Z) (acc : list a) : list a :=
    if equiv_decb (remaining_bytes state) 0 then
      List.rev acc
    else
      if equiv_decb max_length 0 then
        raise error
      else
        let v := read_rec e state in
        loop (Z.sub max_length 1) (cons v acc) in
  loop max_length [].

Definition read {A : Type}
  (encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t)
  (ofs : Z) (len : Z) : option (Z * A) :=
  let state :=
    {| buffer := buffer; offset := ofs; remaining_bytes := len;
      allowed_bytes := None |} in
  let 'v := read_rec encoding state in
  Some ((offset state), v).

Definition of_bytes_exn {A : Type}
  (encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t) : A :=
  let len := String.length buffer in
  let state :=
    {| buffer := buffer; offset := 0; remaining_bytes := len;
      allowed_bytes := None |} in
  let v := read_rec encoding state in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if nequiv_decb (offset state) len then
      raise Tezos_data_encoding.Binary_error.Extra_bytes
    else
      tt in
  v.

Definition of_bytes {A : Type}
  (encoding : Tezos_data_encoding.Encoding.t A) (buffer : Stdlib.Bytes.t)
  : option A :=
  (* ❌ Try-with are not handled *)
  try (Some (of_bytes_exn encoding buffer)).

src/lib_data_encoding/binary_schema.ml 54 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Encoding

type integer_extended = [Binary_size.integer | `Int32 | `Int64]

type field_descr =
  | Named_field of string * Kind.t * layout
  | Anonymous_field of Kind.t * layout
  | Dynamic_size_field of string option * int * Binary_size.unsigned_integer
  | Optional_field of string

and layout =
  | Zero_width
  | Int of integer_extended
  | Bool
  | RangedInt of int * int
  | RangedFloat of float * float
  | Float
  | Bytes
  | String
  | Enum of Binary_size.integer * string
  | Seq of layout * int option (* For arrays and lists *)
  | Ref of string
  | Padding

and fields = field_descr list

and toplevel_encoding =
  | Obj of {fields : fields}
  | Cases of {
      kind : Kind.t;
      tag_size : Binary_size.tag_size;
      cases : (int * string option * fields) list;
    }
  | Int_enum of {size : Binary_size.integer; cases : (int * string) list}

and description = {title : string; description : string option}

type t = {
  toplevel : toplevel_encoding;
  fields : (description * toplevel_encoding) list;
}

module Printer_ast = struct
  type table = {headers : string list; body : string list list}

  type t =
    | Table of table
    | Union of Binary_size.tag_size * (description * table) list

  let pp_size ppf = function
    | `Fixed size ->
        Format.fprintf ppf "%d byte%s" size (if size = 1 then "" else "s")
    | `Variable ->
        Format.fprintf ppf "Variable"
    | `Dynamic ->
        Format.fprintf ppf "Determined from data"

  let pp_int ppf (int : integer_extended) =
    Format.fprintf
      ppf
      "%s"
      ( match int with
      | `Int16 ->
          "signed 16-bit integer"
      | `Int31 ->
          "signed 31-bit integer"
      | `Uint30 ->
          "unsigned 30-bit integer"
      | `Int32 ->
          "signed 32-bit integer"
      | `Int64 ->
          "signed 64-bit integer"
      | `Int8 ->
          "signed 8-bit integer"
      | `Uint16 ->
          "unsigned 16-bit integer"
      | `Uint8 ->
          "unsigned 8-bit integer" )

  let rec pp_layout ppf = function
    | Zero_width ->
        Format.fprintf ppf "placeholder (not actually present in the encoding)"
    | Int integer ->
        Format.fprintf ppf "%a" pp_int integer
    | Bool ->
        Format.fprintf ppf "boolean (0 for false, 255 for true)"
    | RangedInt (minimum, maximum) when minimum <= 0 ->
        Format.fprintf
          ppf
          "%a in the range %d to %d"
          pp_int
          (Binary_size.range_to_size ~minimum ~maximum :> integer_extended)
          minimum
          maximum
    | RangedInt (minimum, maximum) (* when minimum > 0 *) ->
        Format.fprintf
          ppf
          "%a in the range %d to %d (shifted by %d)"
          pp_int
          (Binary_size.range_to_size ~minimum ~maximum :> integer_extended)
          minimum
          maximum
          minimum
    | RangedFloat (minimum, maximum) ->
        Format.fprintf
          ppf
          "double-precision floating-point number, in the range %f to %f"
          minimum
          maximum
    | Float ->
        Format.fprintf ppf "double-precision floating-point number"
    | Bytes ->
        Format.fprintf ppf "bytes"
    | String ->
        Format.fprintf ppf "bytes"
    | Ref reference ->
        Format.fprintf ppf "$%s" reference
    | Padding ->
        Format.fprintf ppf "padding"
    | Enum (size, reference) ->
        Format.fprintf
          ppf
          "%a encoding an enumeration (see %s)"
          pp_int
          (size :> integer_extended)
          reference
    | Seq (data, len) -> (
        Format.fprintf ppf "sequence of " ;
        ( match len with
        | None ->
            ()
        | Some len ->
            Format.fprintf ppf "at most %d " len ) ;
        match data with
        | Ref reference ->
            Format.fprintf ppf "$%s" reference
        | _ ->
            pp_layout ppf data )

  let pp_tag_size ppf tag =
    Format.fprintf ppf "%s"
    @@ match tag with `Uint8 -> "8-bit" | `Uint16 -> "16-bit"

  let field_descr () =
    let reference = ref 0 in
    let string_of_layout = Format.asprintf "%a" pp_layout in
    let anon_num () =
      let value = !reference in
      reference := value + 1 ;
      string_of_int value
    in
    function
    | Named_field (name, kind, desc) ->
        [name; Format.asprintf "%a" pp_size kind; string_of_layout desc]
    | Dynamic_size_field (Some name, 1, size) ->
        [ Format.asprintf "# bytes in field \"%s\"" name;
          Format.asprintf
            "%a"
            pp_size
            (`Fixed (Binary_size.integer_to_size size));
          string_of_layout (Int (size :> integer_extended)) ]
    | Dynamic_size_field (None, 1, size) ->
        [ Format.asprintf "# bytes in next field";
          Format.asprintf
            "%a"
            pp_size
            (`Fixed (Binary_size.integer_to_size size));
          string_of_layout (Int (size :> integer_extended)) ]
    | Dynamic_size_field (_, i, size) ->
        [ Format.asprintf "# bytes in next %d fields" i;
          Format.asprintf
            "%a"
            pp_size
            (`Fixed (Binary_size.integer_to_size size));
          string_of_layout (Int (size :> integer_extended)) ]
    | Anonymous_field (kind, desc) ->
        [ "Unnamed field " ^ anon_num ();
          Format.asprintf "%a" pp_size kind;
          string_of_layout desc ]
    | Optional_field name ->
        [ Format.asprintf "? presence of field \"%s\"" name;
          Format.asprintf "%a" pp_size (`Fixed 1);
          string_of_layout Bool ]

  let binary_table_headers = ["Name"; "Size"; "Contents"]

  let enum_headers = ["Case number"; "Encoded string"]

  let toplevel (descr, encoding) =
    match encoding with
    | Obj {fields} ->
        ( descr,
          Table
            {
              headers = binary_table_headers;
              body = List.map (field_descr ()) fields;
            } )
    | Cases {kind; tag_size; cases} ->
        ( {
            title =
              Format.asprintf
                "%s (%a, %a tag)"
                descr.title
                pp_size
                kind
                pp_tag_size
                tag_size;
            description = descr.description;
          },
          Union
            ( tag_size,
              List.map
                (fun (tag, name, fields) ->
                  ( {
                      title =
                        ( match name with
                        | Some name ->
                            Format.asprintf "%s (tag %d)" name tag
                        | None ->
                            Format.asprintf "Tag %d" tag );
                      description = None;
                    },
                    {
                      headers = binary_table_headers;
                      body = List.map (field_descr ()) fields;
                    } ))
                cases ) )
    | Int_enum {size; cases} ->
        ( {
            title =
              Format.asprintf
                "%s (Enumeration: %a):"
                descr.title
                pp_int
                (size :> integer_extended);
            description = descr.description;
          },
          Table
            {
              headers = enum_headers;
              body =
                List.map (fun (num, str) -> [string_of_int num; str]) cases;
            } )
end

module Printer = struct
  let rec pad char ppf = function
    | 0 ->
        ()
    | n ->
        Format.pp_print_char ppf char ;
        pad char ppf (n - 1)

  let pp_title level ppf title =
    let char = if level = 1 then '*' else if level = 2 then '=' else '`' in
    let sub = String.map (fun _ -> char) title in
    Format.fprintf ppf "%s@ %s@\n@\n" title sub

  let pp_table ppf {Printer_ast.headers; body} =
    let max_widths =
      List.fold_left
        (List.map2 (fun len str -> max (String.length str) len))
        (List.map String.length headers)
        body
    in
    let pp_row pad_char ppf =
      Format.fprintf ppf "|%a" (fun ppf ->
          List.iter2
            (fun width str ->
              Format.fprintf
                ppf
                " %s%a |"
                str
                (pad pad_char)
                (width - String.length str))
            max_widths)
    in
    let pp_line c ppf =
      Format.fprintf ppf "+%a" (fun ppf ->
          List.iter2
            (fun width _str -> Format.fprintf ppf "%a+" (pad c) (width + 2))
            max_widths)
    in
    Format.fprintf
      ppf
      "%a@\n%a@\n%a@\n%a@\n@\n"
      (pp_line '-')
      headers
      (pp_row ' ')
      headers
      (pp_line '=')
      headers
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
         (fun ppf s ->
           Format.fprintf ppf "%a@\n%a" (pp_row ' ') s (pp_line '-') s))
      body

  let pp_option_nl ppf = function
    | Some s ->
        Format.fprintf ppf "%s@\n@\n" s
    | None ->
        ()

  let pp_toplevel ppf = function
    | Printer_ast.Table table ->
        pp_table ppf table
    | Union (_tag_size, tables) ->
        Format.fprintf
          ppf
          "%a"
          (fun ppf ->
            Format.pp_print_list
              ~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
              (fun ppf (descr, table) ->
                Format.fprintf
                  ppf
                  "%a%a%a"
                  (pp_title 2)
                  descr.title
                  pp_option_nl
                  descr.description
                  pp_table
                  table)
              ppf)
          tables

  let pp ppf {toplevel; fields} =
    let (_, toplevel) =
      Printer_ast.toplevel ({title = ""; description = None}, toplevel)
    in
    Format.fprintf
      ppf
      "%a@\n%a"
      pp_toplevel
      toplevel
      (Format.pp_print_list
         ~pp_sep:(fun ppf () -> Format.fprintf ppf "@\n")
         (fun ppf (descr, toplevel) ->
           Format.fprintf
             ppf
             "%a%a%a"
             (pp_title 1)
             descr.title
             pp_option_nl
             descr.description
             pp_toplevel
             toplevel))
      (List.map Printer_ast.toplevel fields)
end

module Encoding = struct
  let description_encoding =
    conv
      (fun {title; description} -> (title, description))
      (fun (title, description) -> {title; description})
      (obj2 (req "title" string) (opt "description" string))

  let integer_cases =
    [("Int16", `Int16); ("Int8", `Int8); ("Uint16", `Uint16); ("Uint8", `Uint8)]

  let integer_encoding : Binary_size.integer encoding =
    string_enum integer_cases

  let integer_extended_encoding =
    string_enum (("Int64", `Int64) :: ("Int32", `Int32) :: integer_cases)

  let layout_encoding =
    mu "layout" (fun layout ->
        union
          [ case
              ~title:"Zero_width"
              (Tag 0)
              (obj1 (req "kind" (constant "Zero_width")))
              (function Zero_width -> Some () | _ -> None)
              (fun () -> Zero_width);
            case
              ~title:"Int"
              (Tag 1)
              (obj2
                 (req "size" integer_extended_encoding)
                 (req "kind" (constant "Int")))
              (function Int integer -> Some (integer, ()) | _ -> None)
              (fun (integer, _) -> Int integer);
            case
              ~title:"Bool"
              (Tag 2)
              (obj1 (req "kind" (constant "Bool")))
              (function Bool -> Some () | _ -> None)
              (fun () -> Bool);
            case
              ~title:"RangedInt"
              (Tag 3)
              (obj3
                 (req "min" int31)
                 (req "max" int31)
                 (req "kind" (constant "RangedInt")))
              (function
                | RangedInt (min, max) -> Some (min, max, ()) | _ -> None)
              (fun (min, max, _) -> RangedInt (min, max));
            case
              ~title:"RangedFloat"
              (Tag 4)
              (obj3
                 (req "min" float)
                 (req "max" float)
                 (req "kind" (constant "RangedFloat")))
              (function
                | RangedFloat (min, max) -> Some (min, max, ()) | _ -> None)
              (fun (min, max, ()) -> RangedFloat (min, max));
            case
              ~title:"Float"
              (Tag 5)
              (obj1 (req "kind" (constant "Float")))
              (function Float -> Some () | _ -> None)
              (fun () -> Float);
            case
              ~title:"Bytes"
              (Tag 6)
              (obj1 (req "kind" (constant "Bytes")))
              (function Bytes -> Some () | _ -> None)
              (fun () -> Bytes);
            case
              ~title:"String"
              (Tag 7)
              (obj1 (req "kind" (constant "String")))
              (function String -> Some () | _ -> None)
              (fun () -> String);
            case
              ~title:"Enum"
              (Tag 8)
              (obj3
                 (req "size" integer_encoding)
                 (req "reference" string)
                 (req "kind" (constant "Enum")))
              (function
                | Enum (size, cases) -> Some (size, cases, ()) | _ -> None)
              (fun (size, cases, _) -> Enum (size, cases));
            case
              ~title:"Seq"
              (Tag 9)
              (obj3
                 (req "layout" layout)
                 (req "kind" (constant "Seq"))
                 (opt "max_length" int31))
              (function
                | Seq (layout, len) -> Some (layout, (), len) | _ -> None)
              (fun (layout, (), len) -> Seq (layout, len));
            case
              ~title:"Ref"
              (Tag 10)
              (obj2 (req "name" string) (req "kind" (constant "Ref")))
              (function Ref layout -> Some (layout, ()) | _ -> None)
              (fun (name, ()) -> Ref name);
            case
              ~title:"Padding"
              (Tag 11)
              (obj1 (req "kind" (constant "Padding")))
              (function Padding -> Some () | _ -> None)
              (fun () -> Padding) ])

  let kind_enum_cases () =
    [ case
        ~title:"Dynamic"
        (Tag 0)
        (obj1 (req "kind" (constant "Dynamic")))
        (function `Dynamic -> Some () | _ -> None)
        (fun () -> `Dynamic);
      case
        ~title:"Variable"
        (Tag 1)
        (obj1 (req "kind" (constant "Variable")))
        (function `Variable -> Some () | _ -> None)
        (fun () -> `Variable) ]

  let kind_t_encoding =
    def "schema.kind"
    @@ union
         ( case
             ~title:"Fixed"
             (Tag 2)
             (obj2 (req "size" int31) (req "kind" (constant "Float")))
             (function `Fixed n -> Some (n, ()) | _ -> None)
             (fun (n, _) -> `Fixed n)
         :: kind_enum_cases () )

  let unsigned_integer_encoding =
    string_enum [("Uint30", `Uint30); ("Uint16", `Uint16); ("Uint8", `Uint8)]

  let field_descr_encoding =
    let dynamic_layout_encoding = dynamic_size layout_encoding in
    def "schema.field"
    @@ union
         [ case
             ~title:"Named_field"
             (Tag 0)
             (obj4
                (req "name" string)
                (req "layout" dynamic_layout_encoding)
                (req "data_kind" kind_t_encoding)
                (req "kind" (constant "named")))
             (function
               | Named_field (name, kind, layout) ->
                   Some (name, layout, kind, ())
               | _ ->
                   None)
             (fun (name, kind, layout, _) -> Named_field (name, layout, kind));
           case
             ~title:"Anonymous_field"
             (Tag 1)
             (obj3
                (req "layout" dynamic_layout_encoding)
                (req "kind" (constant "anon"))
                (req "data_kind" kind_t_encoding))
             (function
               | Anonymous_field (kind, layout) ->
                   Some (layout, (), kind)
               | _ ->
                   None)
             (fun (kind, _, layout) -> Anonymous_field (layout, kind));
           case
             ~title:"Dynamic_field"
             (Tag 2)
             (obj4
                (req "kind" (constant "dyn"))
                (opt "name" string)
                (req "num_fields" int31)
                (req "size" unsigned_integer_encoding))
             (function
               | Dynamic_size_field (name, i, size) ->
                   Some ((), name, i, size)
               | _ ->
                   None)
             (fun ((), name, i, size) -> Dynamic_size_field (name, i, size));
           case
             ~title:"Optional_field"
             (Tag 3)
             (obj2
                (req "kind" (constant "option_indicator"))
                (req "name" string))
             (function Optional_field s -> Some ((), s) | _ -> None)
             (fun ((), s) -> Optional_field s) ]

  let tag_size_encoding = string_enum [("Uint16", `Uint16); ("Uint8", `Uint8)]

  let binary_description_encoding =
    union
      [ case
          ~title:"Obj"
          (Tag 0)
          (obj1 (req "fields" (list (dynamic_size field_descr_encoding))))
          (function Obj {fields} -> Some fields | _ -> None)
          (fun fields -> Obj {fields});
        case
          ~title:"Cases"
          (Tag 1)
          (obj3
             (req "tag_size" tag_size_encoding)
             (req "kind" (dynamic_size kind_t_encoding))
             (req
                "cases"
                (list
                   ( def "union case"
                   @@ conv
                        (fun (tag, name, fields) -> (tag, fields, name))
                        (fun (tag, fields, name) -> (tag, name, fields))
                   @@ obj3
                        (req "tag" int31)
                        (req
                           "fields"
                           (list (dynamic_size field_descr_encoding)))
                        (opt "name" string) ))))
          (function
            | Cases {kind; tag_size; cases} ->
                Some (tag_size, kind, cases)
            | _ ->
                None)
          (fun (tag_size, kind, cases) -> Cases {kind; tag_size; cases});
        case
          ~title:"Int_enum"
          (Tag 2)
          (obj2
             (req "size" integer_encoding)
             (req "cases" (list (tup2 int31 string))))
          (function Int_enum {size; cases} -> Some (size, cases) | _ -> None)
          (fun (size, cases) -> Int_enum {size; cases}) ]

  let encoding =
    conv
      (fun {toplevel; fields} -> (toplevel, fields))
      (fun (toplevel, fields) -> {toplevel; fields})
    @@ obj2
         (req "toplevel" binary_description_encoding)
         (req
            "fields"
            (list
               (obj2
                  (req "description" description_encoding)
                  (req "encoding" binary_description_encoding))))
end

let encoding = Encoding.encoding

let pp = Printer.pp
src/lib_data_encoding/binary_schema.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Encoding.

Definition integer_extended := variant.

Reserved Notation "'fields".

Inductive field_descr : Type :=
| Named_field : string -> Tezos_data_encoding.Encoding.Kind.t -> layout ->
  field_descr
| Anonymous_field : Tezos_data_encoding.Encoding.Kind.t -> layout -> field_descr
| Dynamic_size_field : (option string) -> Z ->
  Tezos_data_encoding.Binary_size.unsigned_integer -> field_descr
| Optional_field : string -> field_descr

with layout : Type :=
| Zero_width : layout
| Int : integer_extended -> layout
| Bool : layout
| RangedInt : Z -> Z -> layout
| RangedFloat : Z -> Z -> layout
| Float : layout
| Bytes : layout
| String : layout
| Enum : Tezos_data_encoding.Binary_size.integer -> string -> layout
| Seq : layout -> (option Z) -> layout
| Ref : string -> layout
| Padding : layout

with toplevel_encoding : Type :=
| Obj : 'fields -> toplevel_encoding
| Cases : Tezos_data_encoding.Encoding.Kind.t ->
  Tezos_data_encoding.Binary_size.tag_size ->
  (list (Z * (option string) * 'fields)) -> toplevel_encoding
| Int_enum : Tezos_data_encoding.Binary_size.integer -> (list (Z * string)) ->
  toplevel_encoding

where "'fields" := ( list field_descr).

Definition fields := 'fields.

Record t := {
  toplevel : toplevel_encoding;
  fields : list (description * toplevel_encoding) }.

Module Printer_ast.
  Record table := {
    headers : list string;
    body : list (list string) }.
  
  Inductive t : Type :=
  | Table : table -> t
  | Union : Tezos_data_encoding.Binary_size.tag_size ->
    (list (description * table)) -> t.
  
  Definition pp_size
    (ppf : Stdlib.Format.formatter) (function_parameter : variant) : unit :=
    match function_parameter with
    | Fixed size =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " byte" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))) "%d byte%s" % string)
        size
        (if equiv_decb size 1 then
          "" % string
        else
          "s" % string)
    | Variable =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Variable" % string
            CamlinternalFormatBasics.End_of_format) "Variable" % string)
    | Dynamic =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Determined from data" % string
            CamlinternalFormatBasics.End_of_format)
          "Determined from data" % string)
    end.
  
  Definition pp_int (ppf : Stdlib.Format.formatter) (int : integer_extended)
    : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      match Z with
      | Int16 => "signed 16-bit integer" % string
      | Int31 => "signed 31-bit integer" % string
      | Uint30 => "unsigned 30-bit integer" % string
      | Int32 => "signed 32-bit integer" % string
      | Int64 => "signed 64-bit integer" % string
      | Int8 => "signed 8-bit integer" % string
      | Uint16 => "unsigned 16-bit integer" % string
      | Uint8 => "unsigned 8-bit integer" % string
      end.
  
  Fixpoint pp_layout
    (ppf : Stdlib.Format.formatter) (function_parameter : layout) : unit :=
    match function_parameter with
    | Zero_width =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "placeholder (not actually present in the encoding)" % string
            CamlinternalFormatBasics.End_of_format)
          "placeholder (not actually present in the encoding)" % string)
    | Int integer =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) pp_int integer
    | Bool =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "boolean (0 for false, 255 for true)" % string
            CamlinternalFormatBasics.End_of_format)
          "boolean (0 for false, 255 for true)" % string)
    | RangedInt minimum maximum =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " in the range " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " to " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format)))))
          "%a in the range %d to %d" % string) pp_int
        (Binary_size.range_to_size minimum maximum) minimum maximum
    | RangedInt minimum maximum =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " in the range " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " to " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      " (shifted by " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))))))
          "%a in the range %d to %d (shifted by %d)" % string) pp_int
        (Binary_size.range_to_size minimum maximum) minimum maximum minimum
    | RangedFloat minimum maximum =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "double-precision floating-point number, in the range " % string
            (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " to " % string
                (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))
          "double-precision floating-point number, in the range %f to %f" %
            string) minimum maximum
    | Float =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "double-precision floating-point number" % string
            CamlinternalFormatBasics.End_of_format)
          "double-precision floating-point number" % string)
    | Bytes =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "bytes" % string
            CamlinternalFormatBasics.End_of_format) "bytes" % string)
    | String =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "bytes" % string
            CamlinternalFormatBasics.End_of_format) "bytes" % string)
    | Ref reference =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "$" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) "$%s" % string) reference
    | Padding =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "padding" % string
            CamlinternalFormatBasics.End_of_format) "padding" % string)
    | Enum size reference =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " encoding an enumeration (see " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "%a encoding an enumeration (see %s)" % string) pp_int size reference
    | Seq data len =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "sequence of " % string
              CamlinternalFormatBasics.End_of_format) "sequence of " % string)
        in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        match len with
        | None => tt
        | Some len =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "at most " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal " " % char
                    CamlinternalFormatBasics.End_of_format)))
              "at most %d " % string) len
        end in
      match data with
      | Ref reference =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "$" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "$%s" % string)
          reference
      | _ => pp_layout ppf data
      end
    end.
  
  Definition pp_tag_size (ppf : Stdlib.Format.formatter) (tag : variant)
    : unit :=
    apply
      (Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string))
      match tag with
      | Uint8 => "8-bit" % string
      | Uint16 => "16-bit" % string
      end.
  
  Definition field_descr (function_parameter : unit)
    : field_descr -> list string :=
    let 'tt := function_parameter in
    let reference := Stdlib.ref 0 in
    let string_of_layout :=
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) pp_layout in
    let anon_num (function_parameter : unit) : string :=
      let 'tt := function_parameter in
      let value := Stdlib.op_exclamation reference in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq reference (Z.add value 1) in
      OCaml.Stdlib.string_of_int value in
    fun function_parameter =>
      match function_parameter with
      | Named_field name kind desc =>
        cons name
          (cons
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
              kind) (cons (string_of_layout desc) []))
      | Dynamic_size_field (Some name) 1 size =>
        cons
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "# bytes in field """ % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal """" % char
                    CamlinternalFormatBasics.End_of_format)))
              "# bytes in field ""%s""" % string) name)
          (cons
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
              (* ❌ Variants not supported *)
              variant) (cons (string_of_layout (Int size)) []))
      | Dynamic_size_field None 1 size =>
        cons
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "# bytes in next field" % string
                CamlinternalFormatBasics.End_of_format)
              "# bytes in next field" % string))
          (cons
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
              (* ❌ Variants not supported *)
              variant) (cons (string_of_layout (Int size)) []))
      | Dynamic_size_field _ i size =>
        cons
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "# bytes in next " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " fields" % string
                    CamlinternalFormatBasics.End_of_format)))
              "# bytes in next %d fields" % string) i)
          (cons
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
              (* ❌ Variants not supported *)
              variant) (cons (string_of_layout (Int size)) []))
      | Anonymous_field kind desc =>
        cons (String.append "Unnamed field " % string (anon_num tt))
          (cons
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
              kind) (cons (string_of_layout desc) []))
      | Optional_field name =>
        cons
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "? presence of field """ % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal """" % char
                    CamlinternalFormatBasics.End_of_format)))
              "? presence of field ""%s""" % string) name)
          (cons
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string) pp_size
              (* ❌ Variants not supported *)
              variant) (cons (string_of_layout Bool) []))
      end.
  
  Definition binary_table_headers : list string :=
    cons "Name" % string (cons "Size" % string (cons "Contents" % string [])).
  
  Definition enum_headers : list string :=
    cons "Case number" % string (cons "Encoded string" % string []).
  
  Definition toplevel (function_parameter : description * toplevel_encoding)
    : description * t :=
    let '(descr, encoding) := function_parameter in
    match encoding with
    | Obj {| fields := fields |} =>
      (descr,
        (Table
          {| headers := binary_table_headers;
            body := List.map (field_descr tt) fields |}))
    | Cases {| kind := kind; tag_size := tag_size; cases := cases |} =>
      ({|
        title :=
          Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " (" % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ", " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " tag)" % string
                          CamlinternalFormatBasics.End_of_format))))))
              "%s (%a, %a tag)" % string) (title descr) pp_size kind pp_tag_size
            tag_size; description := description descr |},
        (Union tag_size
          (List.map
            (fun function_parameter =>
              let '(tag, name, fields) := function_parameter in
              ({|
                title :=
                  match name with
                  | Some name =>
                    Format.asprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            " (tag " % string
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                CamlinternalFormatBasics.End_of_format))))
                        "%s (tag %d)" % string) name tag
                  | None =>
                    Format.asprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal "Tag " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            CamlinternalFormatBasics.End_of_format))
                        "Tag %d" % string) tag
                  end; description := None |},
                {| headers := binary_table_headers;
                  body := List.map (field_descr tt) fields |})) cases)))
    | Int_enum {| size := size; cases := cases |} =>
      ({|
        title :=
          Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " (Enumeration: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal "):" % string
                      CamlinternalFormatBasics.End_of_format))))
              "%s (Enumeration: %a):" % string) (title descr) pp_int size;
        description := description descr |},
        (Table
          {| headers := enum_headers;
            body :=
              List.map
                (fun function_parameter =>
                  let '(num, str) := function_parameter in
                  cons (OCaml.Stdlib.string_of_int num) (cons str [])) cases |}))
    end.
End Printer_ast.

Module Printer.
  Fixpoint pad
    (char : ascii) (ppf : Stdlib.Format.formatter) (function_parameter : Z)
    : unit :=
    match function_parameter with
    | 0 => tt
    | n =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Format.pp_print_char ppf ascii in
      pad ascii ppf (Z.sub n 1)
    end.
  
  Definition pp_title
    (level : Z) (ppf : Stdlib.Format.formatter) (title : string) : unit :=
    let char :=
      if equiv_decb level 1 then
        "*" % char
      else
        if equiv_decb level 2 then
          "=" % char
        else
          "`" % char in
    let sub :=
      Stdlib.String.map
        (fun function_parameter =>
          let '_ := function_parameter in
          ascii) title in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Force_newline
                  CamlinternalFormatBasics.End_of_format)))))
        "%s@ %s@
@
" % string) title sub.
  
  Definition pp_table
    (ppf : Stdlib.Format.formatter) (function_parameter : Printer_ast.table)
    : unit :=
    let '{| Printer_ast.headers := headers; Printer_ast.body := body |} :=
      function_parameter in
    let max_widths :=
      Stdlib.List.fold_left
        (Stdlib.List.map2
          (fun len => fun str => OCaml.Stdlib.max (OCaml.String.length str) len))
        (List.map OCaml.String.length headers) body in
    let pp_row (pad_char : ascii) (ppf : Stdlib.Format.formatter)
      : (list string) -> unit :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "|" % char
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "|%a" % string)
        (fun ppf =>
          Stdlib.List.iter2
            (fun width =>
              fun str =>
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal " " % char
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal " |" % string
                            CamlinternalFormatBasics.End_of_format))))
                    " %s%a |" % string) str (pad pad_char)
                  (Z.sub width (OCaml.String.length str))) max_widths) in
    let pp_line {A : Type} (c : ascii) (ppf : Stdlib.Format.formatter)
      : (list A) -> unit :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "+" % char
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "+%a" % string)
        (fun ppf =>
          Stdlib.List.iter2
            (fun width =>
              fun _str =>
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "+" % char
                        CamlinternalFormatBasics.End_of_format)) "%a+" % string)
                  (pad c) (Z.add width 2)) max_widths) in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Force_newline
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Force_newline
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          CamlinternalFormatBasics.End_of_format)))))))))
        "%a@
%a@
%a@
%a@
@
" % string) (pp_line "-" % char) headers
      (pp_row " " % char) headers (pp_line "=" % char) headers
      (Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Force_newline
                    CamlinternalFormatBasics.End_of_format) "@
" % string)))
        (fun ppf =>
          fun s =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Force_newline
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))
                "%a@
%a" % string) (pp_row " " % char) s (pp_line "-" % char) s))
      body.
  
  Definition pp_option_nl
    (ppf : Stdlib.Format.formatter) (function_parameter : option string)
    : unit :=
    match function_parameter with
    | Some s =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Force_newline
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                CamlinternalFormatBasics.End_of_format))) "%s@
@
" % string) s
    | None => tt
    end.
  
  Definition pp_toplevel
    (ppf : Stdlib.Format.formatter) (function_parameter : Printer_ast.t)
    : unit :=
    match function_parameter with
    | Printer_ast.Table table => pp_table ppf table
    | Printer_ast.Union _tag_size tables =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string)
        (fun ppf =>
          Format.pp_print_list
            (Some
              (fun ppf =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Force_newline
                        CamlinternalFormatBasics.End_of_format) "@
" % string)))
            (fun ppf =>
              fun function_parameter =>
                let '(descr, table) := function_parameter in
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format)))
                    "%a%a%a" % string) (pp_title 2) (title descr) pp_option_nl
                  (description descr) pp_table table) ppf) tables
    end.
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    let '{| toplevel := toplevel; fields := fields |} := function_parameter in
    let '(_, toplevel) :=
      Printer_ast.toplevel
        ({| title := "" % string; description := None |}, toplevel) in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Force_newline
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a@
%a" % string)
      pp_toplevel toplevel
      (Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Force_newline
                    CamlinternalFormatBasics.End_of_format) "@
" % string)))
        (fun ppf =>
          fun function_parameter =>
            let '(descr, toplevel) := function_parameter in
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))
                "%a%a%a" % string) (pp_title 1) (title descr) pp_option_nl
              (description descr) pp_toplevel toplevel))
      (List.map Printer_ast.toplevel fields).
End Printer.

Module Encoding.
  Definition description_encoding
    : Tezos_data_encoding.Encoding.encoding description :=
    conv
      (fun function_parameter =>
        let '{| title := title; description := description |} :=
          function_parameter in
        (title, description))
      (fun function_parameter =>
        let '(title, description) := function_parameter in
        {| title := title; description := description |}) None
      (obj2 (req None None "title" % string string)
        (opt None None "description" % string string)).
  
  Definition integer_cases : list (string * variant) :=
    cons
      ("Int16" % string,
        (* ❌ Variants not supported *)
        variant)
      (cons
        ("Int8" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("Uint16" % string,
            (* ❌ Variants not supported *)
            variant)
          (cons
            ("Uint8" % string,
              (* ❌ Variants not supported *)
              variant) []))).
  
  Definition integer_encoding
    : Tezos_data_encoding.Encoding.encoding
      Tezos_data_encoding.Binary_size.integer := string_enum integer_cases.
  
  Definition integer_extended_encoding
    : Tezos_data_encoding.Encoding.encoding variant :=
    string_enum
      (cons
        ("Int64" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("Int32" % string,
            (* ❌ Variants not supported *)
            variant) integer_cases)).
  
  Definition layout_encoding : Tezos_data_encoding.Encoding.encoding layout :=
    mu "layout" % string None None
      (fun layout =>
        union None
          (cons
            (case "Zero_width" % string None
              (Tezos_data_encoding.Encoding.Tag 0)
              (obj1
                (req None None "kind" % string (constant "Zero_width" % string)))
              (fun function_parameter =>
                match function_parameter with
                | Zero_width => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Zero_width))
            (cons
              (case "Int" % string None (Tezos_data_encoding.Encoding.Tag 1)
                (obj2 (req None None "size" % string integer_extended_encoding)
                  (req None None "kind" % string (constant "Int" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | Int integer => Some (integer, tt)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(integer, _) := function_parameter in
                  Int integer))
              (cons
                (case "Bool" % string None (Tezos_data_encoding.Encoding.Tag 2)
                  (obj1
                    (req None None "kind" % string (constant "Bool" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Bool => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Bool))
                (cons
                  (case "RangedInt" % string None
                    (Tezos_data_encoding.Encoding.Tag 3)
                    (obj3 (req None None "min" % string int31)
                      (req None None "max" % string int31)
                      (req None None "kind" % string
                        (constant "RangedInt" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | RangedInt min max => Some (min, max, tt)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let '(min, max, _) := function_parameter in
                      RangedInt min max))
                  (cons
                    (case "RangedFloat" % string None
                      (Tezos_data_encoding.Encoding.Tag 4)
                      (obj3 (req None None "min" % string float)
                        (req None None "max" % string float)
                        (req None None "kind" % string
                          (constant "RangedFloat" % string)))
                      (fun function_parameter =>
                        match function_parameter with
                        | RangedFloat min max => Some (min, max, tt)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        let '(min, max, tt) := function_parameter in
                        RangedFloat min max))
                    (cons
                      (case "Float" % string None
                        (Tezos_data_encoding.Encoding.Tag 5)
                        (obj1
                          (req None None "kind" % string
                            (constant "Float" % string)))
                        (fun function_parameter =>
                          match function_parameter with
                          | Float => Some tt
                          | _ => None
                          end)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Float))
                      (cons
                        (case "Bytes" % string None
                          (Tezos_data_encoding.Encoding.Tag 6)
                          (obj1
                            (req None None "kind" % string
                              (constant "Bytes" % string)))
                          (fun function_parameter =>
                            match function_parameter with
                            | Bytes => Some tt
                            | _ => None
                            end)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            Bytes))
                        (cons
                          (case "String" % string None
                            (Tezos_data_encoding.Encoding.Tag 7)
                            (obj1
                              (req None None "kind" % string
                                (constant "String" % string)))
                            (fun function_parameter =>
                              match function_parameter with
                              | String => Some tt
                              | _ => None
                              end)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              String))
                          (cons
                            (case "Enum" % string None
                              (Tezos_data_encoding.Encoding.Tag 8)
                              (obj3
                                (req None None "size" % string integer_encoding)
                                (req None None "reference" % string string)
                                (req None None "kind" % string
                                  (constant "Enum" % string)))
                              (fun function_parameter =>
                                match function_parameter with
                                | Enum size cases => Some (size, cases, tt)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                let '(size, cases, _) := function_parameter in
                                Enum size cases))
                            (cons
                              (case "Seq" % string None
                                (Tezos_data_encoding.Encoding.Tag 9)
                                (obj3 (req None None "layout" % string layout)
                                  (req None None "kind" % string
                                    (constant "Seq" % string))
                                  (opt None None "max_length" % string int31))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Seq layout len => Some (layout, tt, len)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  let '(layout, tt, len) := function_parameter
                                    in
                                  Seq layout len))
                              (cons
                                (case "Ref" % string None
                                  (Tezos_data_encoding.Encoding.Tag 10)
                                  (obj2 (req None None "name" % string string)
                                    (req None None "kind" % string
                                      (constant "Ref" % string)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Ref layout => Some (layout, tt)
                                    | _ => None
                                    end)
                                  (fun function_parameter =>
                                    let '(name, tt) := function_parameter in
                                    Ref name))
                                (cons
                                  (case "Padding" % string None
                                    (Tezos_data_encoding.Encoding.Tag 11)
                                    (obj1
                                      (req None None "kind" % string
                                        (constant "Padding" % string)))
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | Padding => Some tt
                                      | _ => None
                                      end)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      Padding)) []))))))))))))).
  
  Definition kind_enum_cases (function_parameter : unit)
    : list (Tezos_data_encoding.Encoding.case variant) :=
    let 'tt := function_parameter in
    cons
      (case "Dynamic" % string None (Tezos_data_encoding.Encoding.Tag 0)
        (obj1 (req None None "kind" % string (constant "Dynamic" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Dynamic => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Variants not supported *)
          variant))
      (cons
        (case "Variable" % string None (Tezos_data_encoding.Encoding.Tag 1)
          (obj1 (req None None "kind" % string (constant "Variable" % string)))
          (fun function_parameter =>
            match function_parameter with
            | Variable => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Variants not supported *)
            variant)) []).
  
  Definition kind_t_encoding : Tezos_data_encoding.Encoding.encoding variant :=
    apply
      (let arg := def "schema.kind" % string in
      fun eta => arg None None eta)
      (union None
        (cons
          (case "Fixed" % string None (Tezos_data_encoding.Encoding.Tag 2)
            (obj2 (req None None "size" % string int31)
              (req None None "kind" % string (constant "Float" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Fixed n => Some (n, tt)
              | _ => None
              end)
            (fun function_parameter =>
              let '(n, _) := function_parameter in
              (* ❌ Variants not supported *)
              variant)) (kind_enum_cases tt))).
  
  Definition unsigned_integer_encoding
    : Tezos_data_encoding.Encoding.encoding variant :=
    string_enum
      (cons
        ("Uint30" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("Uint16" % string,
            (* ❌ Variants not supported *)
            variant)
          (cons
            ("Uint8" % string,
              (* ❌ Variants not supported *)
              variant) []))).
  
  Definition field_descr_encoding
    : Tezos_data_encoding.Encoding.encoding field_descr :=
    let dynamic_layout_encoding := dynamic_size None layout_encoding in
    apply
      (let arg := def "schema.field" % string in
      fun eta => arg None None eta)
      (union None
        (cons
          (case "Named_field" % string None (Tezos_data_encoding.Encoding.Tag 0)
            (obj4 (req None None "name" % string string)
              (req None None "layout" % string dynamic_layout_encoding)
              (req None None "data_kind" % string kind_t_encoding)
              (req None None "kind" % string (constant "named" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Named_field name kind layout => Some (name, layout, kind, tt)
              | _ => None
              end)
            (fun function_parameter =>
              let '(name, kind, layout, _) := function_parameter in
              Named_field name layout kind))
          (cons
            (case "Anonymous_field" % string None
              (Tezos_data_encoding.Encoding.Tag 1)
              (obj3 (req None None "layout" % string dynamic_layout_encoding)
                (req None None "kind" % string (constant "anon" % string))
                (req None None "data_kind" % string kind_t_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Anonymous_field kind layout => Some (layout, tt, kind)
                | _ => None
                end)
              (fun function_parameter =>
                let '(kind, _, layout) := function_parameter in
                Anonymous_field layout kind))
            (cons
              (case "Dynamic_field" % string None
                (Tezos_data_encoding.Encoding.Tag 2)
                (obj4 (req None None "kind" % string (constant "dyn" % string))
                  (opt None None "name" % string string)
                  (req None None "num_fields" % string int31)
                  (req None None "size" % string unsigned_integer_encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | Dynamic_size_field name i size => Some (tt, name, i, size)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, name, i, size) := function_parameter in
                  Dynamic_size_field name i size))
              (cons
                (case "Optional_field" % string None
                  (Tezos_data_encoding.Encoding.Tag 3)
                  (obj2
                    (req None None "kind" % string
                      (constant "option_indicator" % string))
                    (req None None "name" % string string))
                  (fun function_parameter =>
                    match function_parameter with
                    | Optional_field s => Some (tt, s)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let '(tt, s) := function_parameter in
                    Optional_field s)) []))))).
  
  Definition tag_size_encoding
    : Tezos_data_encoding.Encoding.encoding variant :=
    string_enum
      (cons
        ("Uint16" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("Uint8" % string,
            (* ❌ Variants not supported *)
            variant) [])).
  
  Definition binary_description_encoding
    : Tezos_data_encoding.Encoding.encoding toplevel_encoding :=
    union None
      (cons
        (case "Obj" % string None (Tezos_data_encoding.Encoding.Tag 0)
          (obj1
            (req None None "fields" % string
              (list None (dynamic_size None field_descr_encoding))))
          (fun function_parameter =>
            match function_parameter with
            | Obj {| fields := fields |} => Some fields
            | _ => None
            end) (fun fields => Obj {| fields := fields |}))
        (cons
          (case "Cases" % string None (Tezos_data_encoding.Encoding.Tag 1)
            (obj3 (req None None "tag_size" % string tag_size_encoding)
              (req None None "kind" % string (dynamic_size None kind_t_encoding))
              (req None None "cases" % string
                (list None
                  (apply
                    (let arg := def "union case" % string in
                    fun eta => arg None None eta)
                    (apply
                      (let arg :=
                        conv
                          (fun function_parameter =>
                            let '(tag, name, fields) := function_parameter in
                            (tag, fields, name))
                          (fun function_parameter =>
                            let '(tag, fields, name) := function_parameter in
                            (tag, name, fields)) in
                      fun eta => arg None eta)
                      (obj3 (req None None "tag" % string int31)
                        (req None None "fields" % string
                          (list None (dynamic_size None field_descr_encoding)))
                        (opt None None "name" % string string)))))))
            (fun function_parameter =>
              match function_parameter with
              | Cases {| kind := kind; tag_size := tag_size; cases := cases |}
                => Some (tag_size, kind, cases)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tag_size, kind, cases) := function_parameter in
              Cases {| kind := kind; tag_size := tag_size; cases := cases |}))
          (cons
            (case "Int_enum" % string None (Tezos_data_encoding.Encoding.Tag 2)
              (obj2 (req None None "size" % string integer_encoding)
                (req None None "cases" % string (list None (tup2 int31 string))))
              (fun function_parameter =>
                match function_parameter with
                | Int_enum {| size := size; cases := cases |} =>
                  Some (size, cases)
                | _ => None
                end)
              (fun function_parameter =>
                let '(size, cases) := function_parameter in
                Int_enum {| size := size; cases := cases |})) []))).
  
  Definition encoding : Tezos_data_encoding.Encoding.encoding t :=
    apply
      (let arg :=
        conv
          (fun function_parameter =>
            let '{| toplevel := toplevel; fields := fields |} :=
              function_parameter in
            (toplevel, fields))
          (fun function_parameter =>
            let '(toplevel, fields) := function_parameter in
            {| toplevel := toplevel; fields := fields |}) in
      fun eta => arg None eta)
      (obj2 (req None None "toplevel" % string binary_description_encoding)
        (req None None "fields" % string
          (list None
            (obj2 (req None None "description" % string description_encoding)
              (req None None "encoding" % string binary_description_encoding))))).
End Encoding.

Definition encoding : Tezos_data_encoding.Encoding.encoding t :=
  Encoding.encoding.

Definition pp : Stdlib.Format.formatter -> t -> unit := Printer.pp.

src/lib_data_encoding/binary_size.ml 39 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let bool = 1

let int8 = 1

let uint8 = 1

let char = 1

let int16 = 2

let uint16 = 2

let uint30 = 4

let uint32 = 4

let uint64 = 8

let int31 = 4

let int32 = 4

let int64 = 8

let float = 8

type tag_size = [`Uint8 | `Uint16]

let tag_size = function `Uint8 -> uint8 | `Uint16 -> uint16

type signed_integer = [`Int31 | `Int16 | `Int8]

type unsigned_integer = [`Uint30 | `Uint16 | `Uint8]

type integer = [signed_integer | unsigned_integer]

let signed_range_to_size min max : [> signed_integer] =
  if min >= ~-128 && max <= 127 then `Int8
  else if min >= ~-32_768 && max <= 32_767 then `Int16
  else `Int31

(* max should be centered at zero *)
let unsigned_range_to_size max : [> unsigned_integer] =
  assert (max >= 0) ;
  if max <= 255 then `Uint8 else if max <= 65535 then `Uint16 else `Uint30

let integer_to_size = function
  | `Int31 ->
      int31
  | `Int16 ->
      int16
  | `Int8 ->
      int8
  | `Uint30 ->
      uint30
  | `Uint16 ->
      uint16
  | `Uint8 ->
      uint8

let max_int = function
  | `Uint30 | `Int31 ->
      (1 lsl 30) - 1
  | `Int16 ->
      (1 lsl 15) - 1
  | `Int8 ->
      (1 lsl 7) - 1
  | `Uint16 ->
      (1 lsl 16) - 1
  | `Uint8 ->
      (1 lsl 8) - 1

let min_int = function
  | `Uint8 | `Uint16 | `Uint30 ->
      0
  | `Int31 ->
      -(1 lsl 30)
  | `Int16 ->
      -(1 lsl 15)
  | `Int8 ->
      -(1 lsl 7)

let range_to_size ~minimum ~maximum : integer =
  if minimum < 0 then signed_range_to_size minimum maximum
  else unsigned_range_to_size (maximum - minimum)

let enum_size arr = unsigned_range_to_size (Array.length arr)
src/lib_data_encoding/binary_size.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bool : Z := 1.

Definition int8 : Z := 1.

Definition uint8 : Z := 1.

Definition char : Z := 1.

Definition int16 : Z := 2.

Definition uint16 : Z := 2.

Definition uint30 : Z := 4.

Definition uint32 : Z := 4.

Definition uint64 : Z := 8.

Definition int31 : Z := 4.

Definition int32 : Z := 4.

Definition int64 : Z := 8.

Definition float : Z := 8.

Definition tag_size := variant.

Definition tag_size (function_parameter : variant) : Z :=
  match function_parameter with
  | Uint8 => uint8
  | Uint16 => uint16
  end.

Definition signed_integer := variant.

Definition unsigned_integer := variant.

Definition integer := variant.

Definition signed_range_to_size (min : Z) (max : Z) : variant :=
  if andb (OCaml.Stdlib.ge min (Z.opp 128)) (OCaml.Stdlib.le max 127) then
    (* ❌ Variants not supported *)
    variant
  else
    if andb (OCaml.Stdlib.ge min (Z.opp 32768)) (OCaml.Stdlib.le max 32767) then
      (* ❌ Variants not supported *)
      variant
    else
      (* ❌ Variants not supported *)
      variant.

Definition unsigned_range_to_size (max : Z) : variant :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.ge max 0) in
  if OCaml.Stdlib.le max 255 then
    (* ❌ Variants not supported *)
    variant
  else
    if OCaml.Stdlib.le max 65535 then
      (* ❌ Variants not supported *)
      variant
    else
      (* ❌ Variants not supported *)
      variant.

Definition integer_to_size (function_parameter : variant) : Z :=
  match function_parameter with
  | Int31 => int31
  | Int16 => int16
  | Int8 => int8
  | Uint30 => uint30
  | Uint16 => uint16
  | Uint8 => uint8
  end.

Definition max_int (function_parameter : variant) : Z :=
  match function_parameter with
  | Uint30 | Int31 => Z.sub (Z.shiftl 1 30) 1
  | Int16 => Z.sub (Z.shiftl 1 15) 1
  | Int8 => Z.sub (Z.shiftl 1 7) 1
  | Uint16 => Z.sub (Z.shiftl 1 16) 1
  | Uint8 => Z.sub (Z.shiftl 1 8) 1
  end.

Definition min_int (function_parameter : variant) : Z :=
  match function_parameter with
  | Uint8 | Uint16 | Uint30 => 0
  | Int31 => Z.opp (Z.shiftl 1 30)
  | Int16 => Z.opp (Z.shiftl 1 15)
  | Int8 => Z.opp (Z.shiftl 1 7)
  end.

Definition range_to_size (minimum : Z) (maximum : Z) : integer :=
  if OCaml.Stdlib.lt minimum 0 then
    signed_range_to_size minimum maximum
  else
    unsigned_range_to_size (Z.sub maximum minimum).

Definition enum_size {A : Type} (arr : array A) : variant :=
  unsigned_range_to_size (Array.length arr).

src/lib_data_encoding/binary_stream.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Facilities to decode streams of binary data *)

type buffer = {buffer : Bytes.t; ofs : int; len : int}

type t = {
  current : buffer;
  (* buffer queue (classical double list implementation) *)
  pending : Bytes.t list;
  pending_rev : Bytes.t list;
  (* number unread bytes in 'current + pending + pending_rev' *)
  unread : int;
}

let is_empty {unread; _} = unread = 0

let of_buffer current =
  {current; pending = []; pending_rev = []; unread = current.len}

let of_bytes buffer =
  let len = Bytes.length buffer in
  of_buffer {buffer; ofs = 0; len}

let empty = of_bytes (Bytes.create 0)

let push buffer stream =
  {
    stream with
    pending_rev = buffer :: stream.pending_rev;
    unread = stream.unread + Bytes.length buffer;
  }

exception Need_more_data

let split buffer len =
  assert (len <= buffer.len) ;
  ( {buffer with len},
    {buffer with ofs = buffer.ofs + len; len = buffer.len - len} )

let read stream len =
  if len > stream.unread then raise Need_more_data ;
  if len <= stream.current.len then
    let (res, current) = split stream.current len in
    (res, {stream with current; unread = stream.unread - len})
  else
    let res = {buffer = Bytes.create len; ofs = 0; len} in
    Bytes.blit
      stream.current.buffer
      stream.current.ofs
      res.buffer
      0
      stream.current.len ;
    let rec loop ofs pending_rev = function
      | [] ->
          loop ofs [] (List.rev pending_rev)
      | buffer :: pending ->
          let current = {buffer; ofs = 0; len = Bytes.length buffer} in
          let to_read = len - ofs in
          if to_read <= current.len then (
            Bytes.blit current.buffer 0 res.buffer ofs to_read ;
            ( res,
              {
                current =
                  {current with ofs = to_read; len = current.len - to_read};
                pending;
                pending_rev;
                unread = stream.unread - len;
              } ) )
          else (
            Bytes.blit current.buffer 0 res.buffer ofs current.len ;
            loop (ofs + current.len) pending_rev pending )
    in
    loop stream.current.len stream.pending_rev stream.pending
src/lib_data_encoding/binary_stream.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record buffer := {
  buffer : Stdlib.Bytes.t;
  ofs : Z;
  len : Z }.

Record t := {
  current : buffer;
  pending : list Stdlib.Bytes.t;
  pending_rev : list Stdlib.Bytes.t;
  unread : Z }.

Definition is_empty (function_parameter : t) : bool :=
  let '{| unread := unread |} := function_parameter in
  equiv_decb unread 0.

Definition of_buffer (current : buffer) : t :=
  {| current := current; pending := []; pending_rev := []; unread := len current
    |}.

Definition of_bytes (buffer : Stdlib.Bytes.t) : t :=
  let len := String.length buffer in
  of_buffer {| buffer := buffer; ofs := 0; len := len |}.

Definition empty : t := of_bytes (Stdlib.Bytes.create 0).

Definition push (buffer : Stdlib.Bytes.t) (stream : t) : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition split (buffer : buffer) (len : Z) : buffer * buffer :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.le len (len buffer)) in
  ((* ❌ Record substitution not handled *)
  record_substitution,
    (* ❌ Record substitution not handled *)
    record_substitution).

Definition read (stream : t) (len : Z) : buffer * t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if OCaml.Stdlib.gt len (unread stream) then
      Stdlib.raise Need_more_data
    else
      tt in
  if OCaml.Stdlib.le len (len (current stream)) then
    let '(res, current) := split (current stream) len in
    (res,
      (* ❌ Record substitution not handled *)
      record_substitution)
  else
    let res := {| buffer := Stdlib.Bytes.create len; ofs := 0; len := len |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Stdlib.Bytes.blit (buffer (current stream)) (ofs (current stream))
        (buffer res) 0 (len (current stream)) in
    let fix loop
      (ofs : Z) (pending_rev : list Stdlib.Bytes.t) (function_parameter :
      list Stdlib.Bytes.t) : buffer * t :=
      match function_parameter with
      | [] => loop ofs [] (List.rev pending_rev)
      | cons buffer pending =>
        let current :=
          {| buffer := buffer; ofs := 0; len := String.length buffer |} in
        let to_read := Z.sub len ofs in
        if OCaml.Stdlib.le to_read (len current) then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Stdlib.Bytes.blit (buffer current) 0 (buffer res) ofs to_read
            in
          (res,
            {|
              current :=
                (* ❌ Record substitution not handled *)
                record_substitution; pending := pending;
              pending_rev := pending_rev; unread := Z.sub (unread stream) len |})
        else
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.Bytes.blit (buffer current) 0 (buffer res) ofs (len current)
            in
          loop (Z.add ofs (len current)) pending_rev pending
      end in
    loop (len (current stream)) (pending_rev stream) (pending stream).

src/lib_data_encoding/binary_stream_reader.ml 77 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let raise e = raise (Read_error e)

(** Persistent state of the binary reader. *)
type state = {
  stream : Binary_stream.t;  (** All the remaining data to be read. *)
  remaining_bytes : int option;
      (** Total number of bytes that should be from 'stream' (None =
      illimited). Reading less bytes should raise [Extra_bytes] and
      trying to read more bytes should raise [Not_enough_data]. *)
  allowed_bytes : int option;
      (** Maximum number of bytes that are allowed to be read from 'stream'
      before to fail (None = illimited). *)
  total_read : int;
      (** Total number of bytes that has been read from [stream] since the
      beginning. *)
}

(** Return type for the function [read_rec]. See [Data_encoding] for its
    description. *)
type 'ret status =
  | Success of {result : 'ret; size : int; stream : Binary_stream.t}
  | Await of (Bytes.t -> 'ret status)
  | Error of read_error

let check_remaining_bytes state size =
  match state.remaining_bytes with
  | Some len when len < size ->
      raise Not_enough_data
  | Some len ->
      Some (len - size)
  | None ->
      None

let check_allowed_bytes state size =
  match state.allowed_bytes with
  | Some len when len < size ->
      raise Size_limit_exceeded
  | Some len ->
      Some (len - size)
  | None ->
      None

(** [read_atom resume size conv state k] reads [size] bytes from [state],
    pass it to [conv] to be decoded, and finally call the continuation [k]
    with the decoded value and the updated state.

    The function [conv] is also allowed to raise [Read_error err].
    In that case the exception is catched and [Error err] is returned.

    If there is not enough [remaining_bytes] to be read in [state], the
    function returns [Error Not_enough_data] instead of calling
    the continuation.

    If there is not enough [allowed_bytes] to be read in [state], the
    function returns [Error Size_limit_exceeded] instead of calling
    the continuation.

    If there is not enough bytes to be read in [state], the function
    returns [Await resume] instead of calling the continuation. *)
let read_atom resume size conv state k =
  match
    let remaining_bytes = check_remaining_bytes state size in
    let allowed_bytes = check_allowed_bytes state size in
    let (res, stream) = Binary_stream.read state.stream size in
    ( conv res.buffer res.ofs,
      {
        remaining_bytes;
        allowed_bytes;
        stream;
        total_read = state.total_read + size;
      } )
  with
  | exception Read_error error ->
      Error error
  | exception Binary_stream.Need_more_data ->
      Await resume
  | v ->
      k v

(* tail call *)

(** Reader for all the atomic types. *)
module Atom = struct
  let uint8 r = read_atom r Binary_size.uint8 TzEndian.get_uint8

  let uint16 r = read_atom r Binary_size.int16 TzEndian.get_uint16

  let int8 r = read_atom r Binary_size.int8 TzEndian.get_int8

  let int16 r = read_atom r Binary_size.int16 TzEndian.get_int16

  let int32 r = read_atom r Binary_size.int32 TzEndian.get_int32

  let int64 r = read_atom r Binary_size.int64 TzEndian.get_int64

  let float r = read_atom r Binary_size.float TzEndian.get_double

  let bool resume state k =
    int8 resume state @@ fun (v, state) -> k (v <> 0, state)

  let uint30 r =
    read_atom r Binary_size.uint30
    @@ fun buffer ofs ->
    let v = Int32.to_int (TzEndian.get_int32 buffer ofs) in
    if v < 0 then raise (Invalid_int {min = 0; v; max = (1 lsl 30) - 1}) ;
    v

  let int31 r =
    read_atom r Binary_size.int31
    @@ fun buffer ofs -> Int32.to_int (TzEndian.get_int32 buffer ofs)

  let int = function
    | `Int31 ->
        int31
    | `Int16 ->
        int16
    | `Int8 ->
        int8
    | `Uint30 ->
        uint30
    | `Uint16 ->
        uint16
    | `Uint8 ->
        uint8

  let ranged_int ~minimum ~maximum resume state k =
    let read_int =
      match Binary_size.range_to_size ~minimum ~maximum with
      | `Int8 ->
          int8
      | `Int16 ->
          int16
      | `Int31 ->
          int31
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    read_int resume state
    @@ fun (ranged, state) ->
    let ranged = if minimum > 0 then ranged + minimum else ranged in
    if not (minimum <= ranged && ranged <= maximum) then
      Error (Invalid_int {min = minimum; v = ranged; max = maximum})
    else k (ranged, state)

  let ranged_float ~minimum ~maximum resume state k =
    float resume state
    @@ fun (ranged, state) ->
    if not (minimum <= ranged && ranged <= maximum) then
      Error (Invalid_float {min = minimum; v = ranged; max = maximum})
    else k (ranged, state)

  let rec read_z res value bit_in_value state k =
    let resume buffer =
      let stream = Binary_stream.push buffer state.stream in
      read_z res value bit_in_value {state with stream} k
    in
    uint8 resume state
    @@ fun (byte, state) ->
    let value = value lor ((byte land 0x7F) lsl bit_in_value) in
    let bit_in_value = bit_in_value + 7 in
    let (bit_in_value, value) =
      if bit_in_value < 8 then (bit_in_value, value)
      else (
        Buffer.add_char res (Char.unsafe_chr (value land 0xFF)) ;
        (bit_in_value - 8, value lsr 8) )
    in
    if byte land 0x80 = 0x80 then read_z res value bit_in_value state k
    else (
      if bit_in_value > 0 then Buffer.add_char res (Char.unsafe_chr value) ;
      if byte = 0x00 then raise Trailing_zero ;
      k (Z.of_bits (Buffer.contents res), state) )

  let n resume state k =
    uint8 resume state
    @@ fun (first, state) ->
    let first_value = first land 0x7F in
    if first land 0x80 = 0x80 then
      read_z (Buffer.create 100) first_value 7 state k
    else k (Z.of_int first_value, state)

  let z resume state k =
    uint8 resume state
    @@ fun (first, state) ->
    let first_value = first land 0x3F in
    let sign = first land 0x40 <> 0 in
    if first land 0x80 = 0x80 then
      read_z (Buffer.create 100) first_value 6 state
      @@ fun (n, state) -> k ((if sign then Z.neg n else n), state)
    else
      let n = Z.of_int first_value in
      k ((if sign then Z.neg n else n), state)

  let string_enum arr resume state k =
    let read_index =
      match Binary_size.enum_size arr with
      | `Uint8 ->
          uint8
      | `Uint16 ->
          uint16
      | `Uint30 ->
          uint30
    in
    read_index resume state
    @@ fun (index, state) ->
    if index >= Array.length arr then Error No_case_matched
    else k (arr.(index), state)

  let fixed_length_bytes length r =
    read_atom r length @@ fun buf ofs -> Bytes.sub buf ofs length

  let fixed_length_string length r =
    read_atom r length @@ fun buf ofs -> Bytes.sub_string buf ofs length

  let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end

let rec skip n state k =
  let resume buffer =
    let stream = Binary_stream.push buffer state.stream in
    try skip n {state with stream} k with Read_error err -> Error err
  in
  Atom.fixed_length_string n resume state
  @@ fun ((_, state) : string * _) -> k state

(** Main recursive reading function, in continuation passing style. *)
let rec read_rec :
    type next ret.
    bool ->
    next Encoding.t ->
    state ->
    (next * state -> ret status) ->
    ret status =
 fun whole e state k ->
  let resume buffer =
    let stream = Binary_stream.push buffer state.stream in
    try read_rec whole e {state with stream} k
    with Read_error err -> Error err
  in
  let open Encoding in
  assert (Encoding.classify e <> `Variable || state.remaining_bytes <> None) ;
  match e.encoding with
  | Null ->
      k ((), state)
  | Empty ->
      k ((), state)
  | Constant _ ->
      k ((), state)
  | Ignore ->
      k ((), state)
  | Bool ->
      Atom.bool resume state k
  | Int8 ->
      Atom.int8 resume state k
  | Uint8 ->
      Atom.uint8 resume state k
  | Int16 ->
      Atom.int16 resume state k
  | Uint16 ->
      Atom.uint16 resume state k
  | Int31 ->
      Atom.int31 resume state k
  | Int32 ->
      Atom.int32 resume state k
  | Int64 ->
      Atom.int64 resume state k
  | N ->
      Atom.n resume state k
  | Z ->
      Atom.z resume state k
  | Float ->
      Atom.float resume state k
  | Bytes (`Fixed n) ->
      Atom.fixed_length_bytes n resume state k
  | Bytes `Variable ->
      let size = remaining_bytes state in
      Atom.fixed_length_bytes size resume state k
  | String (`Fixed n) ->
      Atom.fixed_length_string n resume state k
  | String `Variable ->
      let size = remaining_bytes state in
      Atom.fixed_length_string size resume state k
  | Padded (e, n) ->
      read_rec false e state
      @@ fun (v, state) -> skip n state @@ fun state -> k (v, state)
  | RangedInt {minimum; maximum} ->
      Atom.ranged_int ~minimum ~maximum resume state k
  | RangedFloat {minimum; maximum} ->
      Atom.ranged_float ~minimum ~maximum resume state k
  | String_enum (_, arr) ->
      Atom.string_enum arr resume state k
  | Array (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      read_list Array_too_long max_length e state
      @@ fun (l, state) -> k (Array.of_list l, state)
  | List (max_length, e) ->
      let max_length = match max_length with Some l -> l | None -> max_int in
      read_list List_too_long max_length e state k
  | Obj (Req {encoding = e; _}) ->
      read_rec whole e state k
  | Obj (Dft {encoding = e; _}) ->
      read_rec whole e state k
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) ->
      Atom.bool resume state
      @@ fun (present, state) ->
      if not present then k (None, state)
      else read_rec whole e state @@ fun (v, state) -> k (Some v, state)
  | Obj (Opt {kind = `Variable; encoding = e; _}) ->
      let size = remaining_bytes state in
      if size = 0 then k (None, state)
      else read_rec whole e state @@ fun (v, state) -> k (Some v, state)
  | Objs {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int option) ;
      ignore (check_allowed_bytes state sz : int option) ;
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Objs {kind = `Dynamic; left; right} ->
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Objs {kind = `Variable; left; right} ->
      read_variable_pair left right state k
  | Tup e ->
      read_rec whole e state k
  | Tups {kind = `Fixed sz; left; right} ->
      ignore (check_remaining_bytes state sz : int option) ;
      ignore (check_allowed_bytes state sz : int option) ;
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Tups {kind = `Dynamic; left; right} ->
      read_rec false left state
      @@ fun (left, state) ->
      read_rec whole right state
      @@ fun (right, state) -> k ((left, right), state)
  | Tups {kind = `Variable; left; right} ->
      read_variable_pair left right state k
  | Conv {inj; encoding; _} ->
      read_rec whole encoding state @@ fun (v, state) -> k (inj v, state)
  | Union {tag_size; cases; _} -> (
      Atom.tag tag_size resume state
      @@ fun (ctag, state) ->
      match
        List.find_opt
          (function
            | Case {tag = Tag tag; _} ->
                tag = ctag
            | Case {tag = Json_only; _} ->
                false)
          cases
      with
      | None ->
          Error (Unexpected_tag ctag)
      | Some (Case {encoding; inj; _}) ->
          read_rec whole encoding state @@ fun (v, state) -> k (inj v, state) )
  | Dynamic_size {kind; encoding = e} ->
      Atom.int kind resume state
      @@ fun (sz, state) ->
      let remaining = check_remaining_bytes state sz in
      let state = {state with remaining_bytes = Some sz} in
      ignore (check_allowed_bytes state sz : int option) ;
      read_rec true e state
      @@ fun (v, state) ->
      if state.remaining_bytes <> Some 0 then Error Extra_bytes
      else k (v, {state with remaining_bytes = remaining})
  | Check_size {limit; encoding = e} ->
      let old_allowed_bytes = state.allowed_bytes in
      let limit =
        match state.allowed_bytes with
        | None ->
            limit
        | Some current_limit ->
            min current_limit limit
      in
      ( match state.remaining_bytes with
      | Some remaining when whole && limit < remaining ->
          raise Size_limit_exceeded
      | _ ->
          () ) ;
      let state = {state with allowed_bytes = Some limit} in
      read_rec whole e state
      @@ fun (v, state) ->
      let allowed_bytes =
        match old_allowed_bytes with
        | None ->
            None
        | Some old_limit ->
            let remaining =
              match state.allowed_bytes with
              | None ->
                  assert false
              | Some remaining ->
                  remaining
            in
            let read = limit - remaining in
            Some (old_limit - read)
      in
      k (v, {state with allowed_bytes})
  | Describe {encoding = e; _} ->
      read_rec whole e state k
  | Splitted {encoding = e; _} ->
      read_rec whole e state k
  | Mu {fix; _} ->
      read_rec whole (fix e) state k
  | Delayed f ->
      read_rec whole (f ()) state k

and remaining_bytes {remaining_bytes; _} =
  match remaining_bytes with
  | None ->
      (* This function should only be called with a variable encoding,
         for which the `remaining_bytes` should never be `None`. *)
      assert false
  | Some len ->
      len

and read_variable_pair :
    type left right ret.
    left Encoding.t ->
    right Encoding.t ->
    state ->
    ((left * right) * state -> ret status) ->
    ret status =
 fun e1 e2 state k ->
  let size = remaining_bytes state in
  match (Encoding.classify e1, Encoding.classify e2) with
  | ((`Dynamic | `Fixed _), `Variable) ->
      read_rec false e1 state
      @@ fun (left, state) ->
      read_rec true e2 state @@ fun (right, state) -> k ((left, right), state)
  | (`Variable, `Fixed n) ->
      if n > size then Error Not_enough_data
      else
        let state = {state with remaining_bytes = Some (size - n)} in
        read_rec true e1 state
        @@ fun (left, state) ->
        assert (state.remaining_bytes = Some 0) ;
        let state = {state with remaining_bytes = Some n} in
        read_rec true e2 state
        @@ fun (right, state) ->
        assert (state.remaining_bytes = Some 0) ;
        k ((left, right), state)
  | _ ->
      assert false

(* Should be rejected by [Encoding.Kind.combine] *)
and read_list :
    type a ret.
    read_error ->
    int ->
    a Encoding.t ->
    state ->
    (a list * state -> ret status) ->
    ret status =
 fun error max_length e state k ->
  let rec loop state acc max_length =
    let size = remaining_bytes state in
    if size = 0 then k (List.rev acc, state)
    else if max_length = 0 then raise error
    else
      read_rec false e state
      @@ fun (v, state) -> loop state (v :: acc) (max_length - 1)
  in
  loop state [] max_length

let read_rec e state k =
  try read_rec false e state k with Read_error err -> Error err

(** ******************** *)

(** Various entry points *)

let success (v, state) =
  Success {result = v; size = state.total_read; stream = state.stream}

let read_stream ?(init = Binary_stream.empty) encoding =
  match Encoding.classify encoding with
  | `Variable ->
      invalid_arg "Data_encoding.Binary.read_stream: variable encoding"
  | `Dynamic | `Fixed _ ->
      (* No hardcoded read limit in a stream. *)
      let state =
        {
          remaining_bytes = None;
          allowed_bytes = None;
          stream = init;
          total_read = 0;
        }
      in
      read_rec encoding state success
src/lib_data_encoding/binary_stream_reader.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Binary_error.

Definition raise {A : Type} (e : Tezos_data_encoding.Binary_error.read_error)
  : A := Stdlib.raise (Read_error e).

Record state := {
  stream : Tezos_data_encoding.Binary_stream.t;
  remaining_bytes : option Z;
  allowed_bytes : option Z;
  total_read : Z }.

Inductive status (ret : Type) : Type :=
| Success : ret -> Z -> Tezos_data_encoding.Binary_stream.t -> status ret
| Await : (Stdlib.Bytes.t -> status ret) -> status ret
| Error : Tezos_data_encoding.Binary_error.read_error -> status ret.

Arguments Success {_}.
Arguments Await {_}.
Arguments Error {_}.

Definition check_remaining_bytes (state : state) (size : Z) : option Z :=
  match remaining_bytes state with
  | Some len => raise Tezos_data_encoding.Binary_error.Not_enough_data
  | Some len => Some (Z.sub len size)
  | None => None
  end.

Definition check_allowed_bytes (state : state) (size : Z) : option Z :=
  match allowed_bytes state with
  | Some len => raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
  | Some len => Some (Z.sub len size)
  | None => None
  end.

Definition read_atom {A B : Type}
  (resume : Stdlib.Bytes.t -> status A) (size : Z)
  (conv : Stdlib.Bytes.t -> Z -> B) (state : state)
  (k : (B * state) -> status A) : status A :=
  let 'v :=
    let remaining_bytes := check_remaining_bytes state size in
    let allowed_bytes := check_allowed_bytes state size in
    let '(res, stream) := Binary_stream.read (stream state) size in
    ((conv (buffer res) (ofs res)),
      {| stream := stream; remaining_bytes := remaining_bytes;
        allowed_bytes := allowed_bytes;
        total_read := Z.add (total_read state) size |}) in
  k v.

Module Atom.
  Definition uint8 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Binary_size.uint8 TzEndian.get_uint8.
  
  Definition uint16 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Binary_size.int16 TzEndian.get_uint16.
  
  Definition int8 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Binary_size.int8 TzEndian.get_int8.
  
  Definition int16 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Binary_size.int16 TzEndian.get_int16.
  
  Definition int32 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((int32 * state) -> status A) -> status A :=
    read_atom r Binary_size.int32 TzEndian.get_int32.
  
  Definition int64 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((int64 * state) -> status A) -> status A :=
    read_atom r Binary_size.int64 TzEndian.get_int64.
  
  Definition float {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    read_atom r Binary_size.float TzEndian.get_double.
  
  Definition bool {A : Type}
    (resume : Stdlib.Bytes.t -> status A) (state : state)
    (k : (bool * state) -> status A) : status A :=
    apply (int8 resume state)
      (fun function_parameter =>
        let '(v, state) := function_parameter in
        k ((nequiv_decb v 0), state)).
  
  Definition uint30 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    apply (read_atom r Binary_size.uint30)
      (fun buffer =>
        fun ofs =>
          let v := Int32.to_int (TzEndian.get_int32 buffer ofs) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if OCaml.Stdlib.lt v 0 then
              raise
                (Tezos_data_encoding.Binary_error.Invalid_int
                  {| min := 0; v := v; max := Z.sub (Z.shiftl 1 30) 1 |})
            else
              tt in
          v).
  
  Definition int31 {A : Type} (r : Stdlib.Bytes.t -> status A)
    : state -> ((Z * state) -> status A) -> status A :=
    apply (read_atom r Binary_size.int31)
      (fun buffer => fun ofs => Int32.to_int (TzEndian.get_int32 buffer ofs)).
  
  Definition int {A : Type} (function_parameter : variant)
    : (Stdlib.Bytes.t -> status A) ->
      state -> ((Z * state) -> status A) -> status A :=
    match function_parameter with
    | Int31 => int31
    | Int16 => int16
    | Int8 => int8
    | Uint30 => uint30
    | Uint16 => uint16
    | Uint8 => uint8
    end.
  
  Definition ranged_int {A : Type}
    (minimum : Z) (maximum : Z) (resume : Stdlib.Bytes.t -> status A)
    (state : state) (k : (Z * state) -> status A) : status A :=
    let read_int :=
      match Binary_size.range_to_size minimum maximum with
      | Int8 => int8
      | Int16 => int16
      | Int31 => int31
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    apply (read_int resume state)
      (fun function_parameter =>
        let '(ranged, state) := function_parameter in
        let ranged :=
          if OCaml.Stdlib.gt minimum 0 then
            Z.add ranged minimum
          else
            ranged in
        if
          negb
            (andb (OCaml.Stdlib.le minimum ranged)
              (OCaml.Stdlib.le ranged maximum)) then
          inr
            (Tezos_data_encoding.Binary_error.Invalid_int
              {| min := minimum; v := ranged; max := maximum |})
        else
          k (ranged, state)).
  
  Definition ranged_float {A : Type}
    (minimum : Z) (maximum : Z) (resume : Stdlib.Bytes.t -> status A)
    (state : state) (k : (Z * state) -> status A) : status A :=
    apply (Z resume state)
      (fun function_parameter =>
        let '(ranged, state) := function_parameter in
        if
          negb
            (andb (OCaml.Stdlib.le minimum ranged)
              (OCaml.Stdlib.le ranged maximum)) then
          inr
            (Tezos_data_encoding.Binary_error.Invalid_float
              {| min := minimum; v := ranged; max := maximum |})
        else
          k (ranged, state)).
  
  Fixpoint read_z {A : Type}
    (res : Stdlib.Buffer.t) (value : Z) (bit_in_value : Z) (state : state)
    (k : (Z.t * state) -> status A) : status A :=
    let resume (buffer : Stdlib.Bytes.t) : status A :=
      let stream := Binary_stream.push buffer (stream state) in
      read_z res value bit_in_value
        (* ❌ Record substitution not handled *)
        record_substitution k in
    apply (uint8 resume state)
      (fun function_parameter =>
        let '(byte, state) := function_parameter in
        let value := Z.lor value (Z.shiftl (Z.land byte 127) bit_in_value) in
        let bit_in_value := Z.add bit_in_value 7 in
        let '(bit_in_value, value) :=
          if OCaml.Stdlib.lt bit_in_value 8 then
            (bit_in_value, value)
          else
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Buffer.add_char res (Char.unsafe_chr (Z.land value 255)) in
            ((Z.sub bit_in_value 8), (Z.shiftr value 8)) in
        if equiv_decb (Z.land byte 128) 128 then
          read_z res value bit_in_value state k
        else
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if OCaml.Stdlib.gt bit_in_value 0 then
              Buffer.add_char res (Char.unsafe_chr value)
            else
              tt in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if equiv_decb byte 0 then
              raise Tezos_data_encoding.Binary_error.Trailing_zero
            else
              tt in
          k ((Z.of_bits (Buffer.contents res)), state)).
  
  Definition n {A : Type}
    (resume : Stdlib.Bytes.t -> status A) (state : state)
    (k : (Z.t * state) -> status A) : status A :=
    apply (uint8 resume state)
      (fun function_parameter =>
        let '(first, state) := function_parameter in
        let first_value := Z.land first 127 in
        if equiv_decb (Z.land first 128) 128 then
          read_z (Buffer.create 100) first_value 7 state k
        else
          k ((Z.of_int first_value), state)).
  
  Definition z {A : Type}
    (resume : Stdlib.Bytes.t -> status A) (state : state)
    (k : (Z.t * state) -> status A) : status A :=
    apply (uint8 resume state)
      (fun function_parameter =>
        let '(first, state) := function_parameter in
        let first_value := Z.land first 63 in
        let sign := nequiv_decb (Z.land first 64) 0 in
        if equiv_decb (Z.land first 128) 128 then
          apply (read_z (Buffer.create 100) first_value 6 state)
            (fun function_parameter =>
              let '(n, state) := function_parameter in
              k
                ((if sign then
                  Z.neg n
                else
                  n), state))
        else
          let n := Z.of_int first_value in
          k
            ((if sign then
              Z.neg n
            else
              n), state)).
  
  Definition string_enum {A B : Type}
    (arr : array A) (resume : Stdlib.Bytes.t -> status B) (state : state)
    (k : (A * state) -> status B) : status B :=
    let read_index :=
      match Binary_size.enum_size arr with
      | Uint8 => uint8
      | Uint16 => uint16
      | Uint30 => uint30
      end in
    apply (read_index resume state)
      (fun function_parameter =>
        let '(index, state) := function_parameter in
        if OCaml.Stdlib.ge index (Array.length arr) then
          inr Tezos_data_encoding.Binary_error.No_case_matched
        else
          k ((Array.get arr index), state)).
  
  Definition fixed_length_bytes {A : Type}
    (length : Z) (r : Stdlib.Bytes.t -> status A)
    : state -> ((string * state) -> status A) -> status A :=
    apply (read_atom r length) (fun buf => fun ofs => String.sub buf ofs length).
  
  Definition fixed_length_string {A : Type}
    (length : Z) (r : Stdlib.Bytes.t -> status A)
    : state -> ((string * state) -> status A) -> status A :=
    apply (read_atom r length)
      (fun buf => fun ofs => Stdlib.Bytes.sub_string buf ofs length).
  
  Definition tag {A : Type} (function_parameter : variant)
    : (Stdlib.Bytes.t -> status A) ->
      state -> ((Z * state) -> status A) -> status A :=
    match function_parameter with
    | Uint8 => uint8
    | Uint16 => uint16
    end.
End Atom.

Fixpoint skip {A : Type} (n : Z) (state : state) (k : state -> status A)
  : status A :=
  let resume (buffer : Stdlib.Bytes.t) : status A :=
    let stream := Binary_stream.push buffer (stream state) in
    (* ❌ Try-with are not handled *)
    try
      (skip n
        (* ❌ Record substitution not handled *)
        record_substitution k) in
  apply (Atom.fixed_length_string n resume state)
    (fun function_parameter =>
      let '(_, state) := function_parameter in
      k state).

Fixpoint read_rec {next ret : Type}
  (whole : bool) (e : Tezos_data_encoding.Encoding.t next) (state : state)
  (k : (next * state) -> status ret) : status ret :=
  let resume (buffer : Stdlib.Bytes.t) : status ret :=
    let stream := Binary_stream.push buffer (stream state) in
    (* ❌ Try-with are not handled *)
    try
      (read_rec whole e
        (* ❌ Record substitution not handled *)
        record_substitution k) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      (orb
        (nequiv_decb (Encoding.classify e)
          (* ❌ Variants not supported *)
          variant) (nequiv_decb (remaining_bytes state) None)) in
  match encoding e with
  | Tezos_data_encoding.Encoding.Null => k (tt, state)
  | Tezos_data_encoding.Encoding.Empty => k (tt, state)
  | Tezos_data_encoding.Encoding.Constant _ => k (tt, state)
  | Tezos_data_encoding.Encoding.Ignore => k (tt, state)
  | Tezos_data_encoding.Encoding.Bool => Atom.bool resume state k
  | Tezos_data_encoding.Encoding.Int8 => Atom.int8 resume state k
  | Tezos_data_encoding.Encoding.Uint8 => Atom.uint8 resume state k
  | Tezos_data_encoding.Encoding.Int16 => Atom.int16 resume state k
  | Tezos_data_encoding.Encoding.Uint16 => Atom.uint16 resume state k
  | Tezos_data_encoding.Encoding.Int31 => Atom.int31 resume state k
  | Tezos_data_encoding.Encoding.Int32 => Atom.int32 resume state k
  | Tezos_data_encoding.Encoding.Int64 => Atom.int64 resume state k
  | Tezos_data_encoding.Encoding.N => Atom.n resume state k
  | Tezos_data_encoding.Encoding.Z => Atom.z resume state k
  | Tezos_data_encoding.Encoding.Float => Atom.float resume state k
  | Tezos_data_encoding.Encoding.Bytes (Fixed n) =>
    Atom.fixed_length_bytes n resume state k
  | Tezos_data_encoding.Encoding.Bytes Variable =>
    let size := remaining_bytes state in
    Atom.fixed_length_bytes size resume state k
  | Tezos_data_encoding.Encoding.String (Fixed n) =>
    Atom.fixed_length_string n resume state k
  | Tezos_data_encoding.Encoding.String Variable =>
    let size := remaining_bytes state in
    Atom.fixed_length_string size resume state k
  | Tezos_data_encoding.Encoding.Padded e n =>
    apply (read_rec false e state)
      (fun function_parameter =>
        let '(v, state) := function_parameter in
        apply (skip n state) (fun state => k (v, state)))
  |
    Tezos_data_encoding.Encoding.RangedInt {|
      minimum := minimum; maximum := maximum |} =>
    Atom.ranged_int minimum maximum resume state k
  |
    Tezos_data_encoding.Encoding.RangedFloat {|
      minimum := minimum; maximum := maximum |} =>
    Atom.ranged_float minimum maximum resume state k
  | Tezos_data_encoding.Encoding.String_enum _ arr =>
    Atom.string_enum arr resume state k
  | Tezos_data_encoding.Encoding.Array max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    apply
      (read_list Tezos_data_encoding.Binary_error.Array_too_long max_length e
        state)
      (fun function_parameter =>
        let '(l, state) := function_parameter in
        k ((Array.of_list l), state))
  | Tezos_data_encoding.Encoding.List max_length e =>
    let max_length :=
      match max_length with
      | Some l => l
      | None => Stdlib.max_int
      end in
    read_list Tezos_data_encoding.Binary_error.List_too_long max_length e state
      k
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Req {| encoding := e |}) =>
    read_rec whole e state k
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Dft {| encoding := e |}) =>
    read_rec whole e state k
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
    apply (Atom.bool resume state)
      (fun function_parameter =>
        let '(present, state) := function_parameter in
        if negb present then
          k (None, state)
        else
          apply (read_rec whole e state)
            (fun function_parameter =>
              let '(v, state) := function_parameter in
              k ((Some v), state)))
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
    =>
    let size := remaining_bytes state in
    if equiv_decb size 0 then
      k (None, state)
    else
      apply (read_rec whole e state)
        (fun function_parameter =>
          let '(v, state) := function_parameter in
          k ((Some v), state))
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Fixed sz; left := left; right := right |} =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
    apply (read_rec false left state)
      (fun function_parameter =>
        let '(left, state) := function_parameter in
        apply (read_rec whole right state)
          (fun function_parameter =>
            let '(right, state) := function_parameter in
            k ((left, right), state)))
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Dynamic; left := left; right := right |} =>
    apply (read_rec false left state)
      (fun function_parameter =>
        let '(left, state) := function_parameter in
        apply (read_rec whole right state)
          (fun function_parameter =>
            let '(right, state) := function_parameter in
            k ((left, right), state)))
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state k
  | Tezos_data_encoding.Encoding.Tup e => read_rec whole e state k
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Fixed sz; left := left; right := right |} =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_remaining_bytes state sz) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
    apply (read_rec false left state)
      (fun function_parameter =>
        let '(left, state) := function_parameter in
        apply (read_rec whole right state)
          (fun function_parameter =>
            let '(right, state) := function_parameter in
            k ((left, right), state)))
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Dynamic; left := left; right := right |} =>
    apply (read_rec false left state)
      (fun function_parameter =>
        let '(left, state) := function_parameter in
        apply (read_rec whole right state)
          (fun function_parameter =>
            let '(right, state) := function_parameter in
            k ((left, right), state)))
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := Variable; left := left; right := right |} =>
    read_variable_pair left right state k
  | Tezos_data_encoding.Encoding.Conv {| inj := inj; encoding := encoding |} =>
    apply (read_rec whole encoding state)
      (fun function_parameter =>
        let '(v, state) := function_parameter in
        k ((inj v), state))
  |
    Tezos_data_encoding.Encoding.Union {|
      tag_size := tag_size; cases := cases |} =>
    apply (Atom.tag tag_size resume state)
      (fun function_parameter =>
        let '(ctag, state) := function_parameter in
        match
          Stdlib.List.find_opt
            (fun function_parameter =>
              match function_parameter with
              |
                Tezos_data_encoding.Encoding.Case {|
                  tag := Tezos_data_encoding.Encoding.Tag tag |} =>
                equiv_decb tag ctag
              |
                Tezos_data_encoding.Encoding.Case {|
                  tag := Tezos_data_encoding.Encoding.Json_only |} => false
              end) cases with
        | None => inr (Tezos_data_encoding.Binary_error.Unexpected_tag ctag)
        |
          Some
            (Tezos_data_encoding.Encoding.Case {|
              encoding := encoding; inj := inj |}) =>
          apply (read_rec whole encoding state)
            (fun function_parameter =>
              let '(v, state) := function_parameter in
              k ((inj v), state))
        end)
  | Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
    =>
    apply (Atom.int kind resume state)
      (fun function_parameter =>
        let '(sz, state) := function_parameter in
        let remaining := check_remaining_bytes state sz in
        let state :=
          (* ❌ Record substitution not handled *)
          record_substitution in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := OCaml.Stdlib.ignore (check_allowed_bytes state sz) in
        apply (read_rec true e state)
          (fun function_parameter =>
            let '(v, state) := function_parameter in
            if nequiv_decb (remaining_bytes state) (Some 0) then
              inr Tezos_data_encoding.Binary_error.Extra_bytes
            else
              k
                (v,
                  (* ❌ Record substitution not handled *)
                  record_substitution)))
  | Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
    =>
    let old_allowed_bytes := allowed_bytes state in
    let limit :=
      match allowed_bytes state with
      | None => limit
      | Some current_limit => OCaml.Stdlib.min current_limit limit
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match remaining_bytes state with
      | Some remaining =>
        raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
      | _ => tt
      end in
    let state :=
      (* ❌ Record substitution not handled *)
      record_substitution in
    apply (read_rec whole e state)
      (fun function_parameter =>
        let '(v, state) := function_parameter in
        let allowed_bytes :=
          match old_allowed_bytes with
          | None => None
          | Some old_limit =>
            let remaining :=
              match allowed_bytes state with
              | None =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              | Some remaining => remaining
              end in
            let read := Z.sub limit remaining in
            Some (Z.sub old_limit read)
          end in
        k
          (v,
            (* ❌ Record substitution not handled *)
            record_substitution))
  | Tezos_data_encoding.Encoding.Describe {| encoding := e |} =>
    read_rec whole e state k
  | Tezos_data_encoding.Encoding.Splitted {| encoding := e |} =>
    read_rec whole e state k
  | Tezos_data_encoding.Encoding.Mu {| fix := fix |} =>
    read_rec whole (fix e) state k
  | Tezos_data_encoding.Encoding.Delayed f => read_rec whole (f tt) state k
  end

with remaining_bytes (function_parameter : state) : Z :=
  let '{| remaining_bytes := remaining_bytes |} := function_parameter in
  match remaining_bytes with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some len => len
  end

with read_variable_pair {left ret right : Type}
  (e1 : Tezos_data_encoding.Encoding.t left)
  (e2 : Tezos_data_encoding.Encoding.t right) (state : state)
  (k : ((left * right) * state) -> status ret) : status ret :=
  let size := remaining_bytes state in
  match ((Encoding.classify e1), (Encoding.classify e2)) with
  | (Dynamic | Fixed _, Variable) =>
    apply (read_rec false e1 state)
      (fun function_parameter =>
        let '(left, state) := function_parameter in
        apply (read_rec true e2 state)
          (fun function_parameter =>
            let '(right, state) := function_parameter in
            k ((left, right), state)))
  | (Variable, Fixed n) =>
    if OCaml.Stdlib.gt n size then
      inr Tezos_data_encoding.Binary_error.Not_enough_data
    else
      let state :=
        (* ❌ Record substitution not handled *)
        record_substitution in
      apply (read_rec true e1 state)
        (fun function_parameter =>
          let '(left, state) := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (remaining_bytes state) (Some 0)) in
          let state :=
            (* ❌ Record substitution not handled *)
            record_substitution in
          apply (read_rec true e2 state)
            (fun function_parameter =>
              let '(right, state) := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Assert instruction is not handled. *)
                assert (equiv_decb (remaining_bytes state) (Some 0)) in
              k ((left, right), state)))
  | _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end

with read_list {a ret : Type}
  (error : Tezos_data_encoding.Binary_error.read_error) (max_length : Z)
  (e : Tezos_data_encoding.Encoding.t a) (state : state)
  (k : ((list a) * state) -> status ret) : status ret :=
  let fix loop (state : state) (acc : list a) (max_length : Z) : status ret :=
    let size := remaining_bytes state in
    if equiv_decb size 0 then
      k ((List.rev acc), state)
    else
      if equiv_decb max_length 0 then
        raise error
      else
        apply (read_rec false e state)
          (fun function_parameter =>
            let '(v, state) := function_parameter in
            loop state (cons v acc) (Z.sub max_length 1)) in
  loop state [] max_length.

Definition read_rec {A B : Type}
  (e : Tezos_data_encoding.Encoding.t A) (state : state)
  (k : (A * state) -> status B) : status B :=
  (* ❌ Try-with are not handled *)
  try (read_rec false e state k).

Definition success {A : Type} (function_parameter : A * state) : status A :=
  let '(v, state) := function_parameter in
  Success {| result := v; size := total_read state; stream := stream state |}.

Definition read_stream {A : Type}
  (op_staroptstar : option Tezos_data_encoding.Binary_stream.t)
  : (Tezos_data_encoding.Encoding.encoding A) -> status A :=
  let init :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Binary_stream.empty
    end in
  fun encoding =>
    match Encoding.classify encoding with
    | Variable =>
      OCaml.Stdlib.invalid_arg
        "Data_encoding.Binary.read_stream: variable encoding" % string
    | Dynamic | Fixed _ =>
      let state :=
        {| stream := init; remaining_bytes := None; allowed_bytes := None;
          total_read := 0 |} in
      read_rec encoding state success
    end.

src/lib_data_encoding/binary_writer.ml 80 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Binary_error

let raise error = raise (Write_error error)

(** Imperative state of the binary writer. *)
type state = {
  mutable buffer : Bytes.t;  (** The buffer where to write. *)
  mutable offset : int;
      (** The offset of the next byte to be written in [buffer]. *)
  mutable allowed_bytes : int option;
      (** Maximum number of bytes that are allowed to be write in [buffer]
      (after [offset]) before to fail (None = illimited). *)
}

let check_allowed_bytes state size =
  match state.allowed_bytes with
  | Some len when len < size ->
      raise Size_limit_exceeded
  | Some len ->
      state.allowed_bytes <- Some (len - size)
  | None ->
      ()

(** [may_resize state size] will first ensure there is enough
    space in [state.buffer] for writing [size] bytes (starting at
    [state.offset]).

    When the buffer does not have enough space for writing [size] bytes,
    but still has enough [allowed_bytes], it will replace the buffer
    with a buffer large enough.

    @raise [Binary_error.Write_error Size_limit_exceeded] when there is
           not enough allowed bytes to write [size] bytes. *)
let may_resize state size =
  check_allowed_bytes state size ;
  let buffer_len = Bytes.length state.buffer in
  if buffer_len - state.offset < size then (
    let new_buffer = Bytes.create (max (2 * buffer_len) (buffer_len + size)) in
    Bytes.blit state.buffer 0 new_buffer 0 state.offset ;
    state.buffer <- new_buffer ) ;
  state.offset <- state.offset + size

(** Writer for all the atomic types. *)
module Atom = struct
  let check_int_range min v max =
    if v < min || max < v then raise (Invalid_int {min; v; max})

  let check_float_range min v max =
    if v < min || max < v then raise (Invalid_float {min; v; max})

  let set_int kind buffer ofs v =
    match kind with
    | `Int31 | `Uint30 ->
        TzEndian.set_int32 buffer ofs (Int32.of_int v)
    | `Int16 | `Uint16 ->
        TzEndian.set_int16 buffer ofs v
    | `Int8 | `Uint8 ->
        TzEndian.set_int8 buffer ofs v

  let int kind state v =
    check_int_range (Binary_size.min_int kind) v (Binary_size.max_int kind) ;
    let ofs = state.offset in
    may_resize state (Binary_size.integer_to_size kind) ;
    set_int kind state.buffer ofs v

  let int8 = int `Int8

  let uint8 = int `Uint8

  let int16 = int `Int16

  let uint16 = int `Uint16

  let uint30 = int `Uint30

  let int31 = int `Int31

  let bool state v = uint8 state (if v then 255 else 0)

  let int32 state v =
    let ofs = state.offset in
    may_resize state Binary_size.int32 ;
    TzEndian.set_int32 state.buffer ofs v

  let int64 state v =
    let ofs = state.offset in
    may_resize state Binary_size.int64 ;
    TzEndian.set_int64 state.buffer ofs v

  let ranged_int ~minimum ~maximum state v =
    check_int_range minimum v maximum ;
    let v = if minimum >= 0 then v - minimum else v in
    match Binary_size.range_to_size ~minimum ~maximum with
    | `Uint8 ->
        uint8 state v
    | `Uint16 ->
        uint16 state v
    | `Uint30 ->
        uint30 state v
    | `Int8 ->
        int8 state v
    | `Int16 ->
        int16 state v
    | `Int31 ->
        int31 state v

  let n state v =
    if Z.sign v < 0 then raise Invalid_natural ;
    if Z.equal v Z.zero then uint8 state 0x00
    else
      let bits = Z.numbits v in
      let get_chunk pos len = Z.to_int (Z.extract v pos len) in
      let length = Binary_length.n_length v in
      let offset = state.offset in
      may_resize state length ;
      for i = 0 to length - 1 do
        let pos = i * 7 in
        let chunk_len = if i = length - 1 then bits - pos else 7 in
        TzEndian.set_int8
          state.buffer
          (offset + i)
          ((if i = length - 1 then 0x00 else 0x80) lor get_chunk pos chunk_len)
      done

  let z state v =
    let sign = Z.sign v < 0 in
    let bits = Z.numbits v in
    if Z.equal v Z.zero then uint8 state 0x00
    else
      let v = Z.abs v in
      let get_chunk pos len = Z.to_int (Z.extract v pos len) in
      let length = Binary_length.z_length v in
      let offset = state.offset in
      may_resize state length ;
      TzEndian.set_int8
        state.buffer
        offset
        ( (if sign then 0x40 else 0x00)
        lor (if bits > 6 then 0x80 else 0x00)
        lor get_chunk 0 6 ) ;
      for i = 1 to length - 1 do
        let pos = 6 + ((i - 1) * 7) in
        let chunk_len = if i = length - 1 then bits - pos else 7 in
        TzEndian.set_int8
          state.buffer
          (offset + i)
          ((if i = length - 1 then 0x00 else 0x80) lor get_chunk pos chunk_len)
      done

  let float state v =
    let ofs = state.offset in
    may_resize state Binary_size.float ;
    TzEndian.set_double state.buffer ofs v

  let ranged_float ~minimum ~maximum state v =
    check_float_range minimum v maximum ;
    float state v

  let string_enum tbl arr state v =
    let value =
      try snd (Hashtbl.find tbl v) with Not_found -> raise No_case_matched
    in
    match Binary_size.enum_size arr with
    | `Uint30 ->
        uint30 state value
    | `Uint16 ->
        uint16 state value
    | `Uint8 ->
        uint8 state value

  let fixed_kind_bytes length state s =
    if Bytes.length s <> length then
      raise (Invalid_bytes_length {expected = length; found = Bytes.length s}) ;
    let ofs = state.offset in
    may_resize state length ;
    Bytes.blit s 0 state.buffer ofs length

  let fixed_kind_string length state s =
    if String.length s <> length then
      raise
        (Invalid_string_length {expected = length; found = String.length s}) ;
    let ofs = state.offset in
    may_resize state length ;
    Bytes.blit_string s 0 state.buffer ofs length

  let tag = function `Uint8 -> uint8 | `Uint16 -> uint16
end

(** Main recursive writing function. *)
let rec write_rec : type a. a Encoding.t -> state -> a -> unit =
 fun e state value ->
  let open Encoding in
  match e.encoding with
  | Null ->
      ()
  | Empty ->
      ()
  | Constant _ ->
      ()
  | Ignore ->
      ()
  | Bool ->
      Atom.bool state value
  | Int8 ->
      Atom.int8 state value
  | Uint8 ->
      Atom.uint8 state value
  | Int16 ->
      Atom.int16 state value
  | Uint16 ->
      Atom.uint16 state value
  | Int31 ->
      Atom.int31 state value
  | Int32 ->
      Atom.int32 state value
  | Int64 ->
      Atom.int64 state value
  | N ->
      Atom.n state value
  | Z ->
      Atom.z state value
  | Float ->
      Atom.float state value
  | Bytes (`Fixed n) ->
      Atom.fixed_kind_bytes n state value
  | Bytes `Variable ->
      let length = Bytes.length value in
      Atom.fixed_kind_bytes length state value
  | String (`Fixed n) ->
      Atom.fixed_kind_string n state value
  | String `Variable ->
      let length = String.length value in
      Atom.fixed_kind_string length state value
  | Padded (e, n) ->
      write_rec e state value ;
      Atom.fixed_kind_string n state (String.make n '\000')
  | RangedInt {minimum; maximum} ->
      Atom.ranged_int ~minimum ~maximum state value
  | RangedFloat {minimum; maximum} ->
      Atom.ranged_float ~minimum ~maximum state value
  | String_enum (tbl, arr) ->
      Atom.string_enum tbl arr state value
  | Array (Some max_length, _e) when Array.length value > max_length ->
      raise Array_too_long
  | Array (_, e) ->
      Array.iter (write_rec e state) value
  | List (Some max_length, _e) when List.length value > max_length ->
      raise List_too_long
  | List (_, e) ->
      List.iter (write_rec e state) value
  | Obj (Req {encoding = e; _}) ->
      write_rec e state value
  | Obj (Opt {kind = `Dynamic; encoding = e; _}) -> (
    match value with
    | None ->
        Atom.bool state false
    | Some value ->
        Atom.bool state true ; write_rec e state value )
  | Obj (Opt {kind = `Variable; encoding = e; _}) -> (
    match value with None -> () | Some value -> write_rec e state value )
  | Obj (Dft {encoding = e; _}) ->
      write_rec e state value
  | Objs {left; right; _} ->
      let (v1, v2) = value in
      write_rec left state v1 ; write_rec right state v2
  | Tup e ->
      write_rec e state value
  | Tups {left; right; _} ->
      let (v1, v2) = value in
      write_rec left state v1 ; write_rec right state v2
  | Conv {encoding = e; proj; _} ->
      write_rec e state (proj value)
  | Union {tag_size; cases; _} ->
      let rec write_case = function
        | [] ->
            raise No_case_matched
        | Case {tag = Json_only; _} :: tl ->
            write_case tl
        | Case {encoding = e; proj; tag = Tag tag; _} :: tl -> (
          match proj value with
          | None ->
              write_case tl
          | Some value ->
              Atom.tag tag_size state tag ;
              write_rec e state value )
      in
      write_case cases
  | Dynamic_size {kind; encoding = e} ->
      let initial_offset = state.offset in
      Atom.int kind state 0 ;
      (* place holder for [size] *)
      write_with_limit (Binary_size.max_int kind) e state value ;
      (* patch the written [size] *)
      Atom.set_int
        kind
        state.buffer
        initial_offset
        (state.offset - initial_offset - Binary_size.integer_to_size kind)
  | Check_size {limit; encoding = e} ->
      write_with_limit limit e state value
  | Describe {encoding = e; _} ->
      write_rec e state value
  | Splitted {encoding = e; _} ->
      write_rec e state value
  | Mu {fix; _} ->
      write_rec (fix e) state value
  | Delayed f ->
      write_rec (f ()) state value

and write_with_limit : type a. int -> a Encoding.t -> state -> a -> unit =
 fun limit e state value ->
  (* backup the current limit *)
  let old_limit = state.allowed_bytes in
  (* install the new limit (only if smaller than the current limit) *)
  let limit =
    match state.allowed_bytes with
    | None ->
        limit
    | Some old_limit ->
        min old_limit limit
  in
  state.allowed_bytes <- Some limit ;
  write_rec e state value ;
  (* restore the previous limit (minus the read bytes) *)
  match old_limit with
  | None ->
      state.allowed_bytes <- None
  | Some old_limit ->
      let remaining =
        match state.allowed_bytes with None -> assert false | Some len -> len
      in
      let read = limit - remaining in
      state.allowed_bytes <- Some (old_limit - read)

(** ******************** *)

(** Various entry points *)

let write e v buffer offset len =
  (* By harcoding [allowed_bytes] with the buffer length,
       we ensure that [write] will never reallocate the buffer. *)
  let state = {buffer; offset; allowed_bytes = Some len} in
  try write_rec e state v ; Some state.offset with Write_error _ -> None

let to_bytes_exn e v =
  match Encoding.classify e with
  | `Fixed n ->
      (* Preallocate the complete buffer *)
      let state =
        {buffer = Bytes.create n; offset = 0; allowed_bytes = Some n}
      in
      write_rec e state v ; state.buffer
  | `Dynamic | `Variable ->
      (* Preallocate a minimal buffer and let's not hardcode a
         limit to its extension. *)
      let state =
        {buffer = Bytes.create 128; offset = 0; allowed_bytes = None}
      in
      write_rec e state v ;
      Bytes.sub state.buffer 0 state.offset

let to_bytes e v = try Some (to_bytes_exn e v) with Write_error _ -> None
src/lib_data_encoding/binary_writer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Binary_error.

Definition raise {A : Type}
  (error : Tezos_data_encoding.Binary_error.write_error) : A :=
  Stdlib.raise (Write_error error).

Record state := {
  buffer : Stdlib.Bytes.t;
  offset : Z;
  allowed_bytes : option Z }.

Definition check_allowed_bytes (state : state) (size : Z) : unit :=
  match allowed_bytes state with
  | Some len => raise Tezos_data_encoding.Binary_error.Size_limit_exceeded
  | Some len =>
    (* ❌ Set record field not handled. *)
    set_record_field state "allowed_bytes" % string (Some (Z.sub len size))
  | None => tt
  end.

Definition may_resize (state : state) (size : Z) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := check_allowed_bytes state size in
  let buffer_len := String.length (buffer state) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if OCaml.Stdlib.lt (Z.sub buffer_len (offset state)) size then
      let new_buffer :=
        Stdlib.Bytes.create
          (OCaml.Stdlib.max (Z.mul 2 buffer_len) (Z.add buffer_len size)) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.Bytes.blit (buffer state) 0 new_buffer 0 (offset state) in
      (* ❌ Set record field not handled. *)
      set_record_field state "buffer" % string new_buffer
    else
      tt in
  (* ❌ Set record field not handled. *)
  set_record_field state "offset" % string (Z.add (offset state) size).

Module Atom.
  Definition check_int_range (min : Z) (v : Z) (max : Z) : unit :=
    if orb (OCaml.Stdlib.lt v min) (OCaml.Stdlib.lt max v) then
      raise
        (Tezos_data_encoding.Binary_error.Invalid_int
          {| min := min; v := v; max := max |})
    else
      tt.
  
  Definition check_float_range (min : Z) (v : Z) (max : Z) : unit :=
    if orb (OCaml.Stdlib.lt v min) (OCaml.Stdlib.lt max v) then
      raise
        (Tezos_data_encoding.Binary_error.Invalid_float
          {| min := min; v := v; max := max |})
    else
      tt.
  
  Definition set_int (kind : variant) (buffer : string) (ofs : Z) (v : Z)
    : unit :=
    match kind with
    | Int31 | Uint30 => TzEndian.set_int32 buffer ofs (Int32.of_int v)
    | Int16 | Uint16 => TzEndian.set_int16 buffer ofs v
    | Int8 | Uint8 => TzEndian.set_int8 buffer ofs v
    end.
  
  Definition int (kind : variant) (state : state) (v : Z) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      check_int_range (Binary_size.min_int kind) v (Binary_size.max_int kind) in
    let ofs := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_resize state (Binary_size.integer_to_size kind) in
    set_int kind (buffer state) ofs v.
  
  Definition int8 : state -> Z -> unit :=
    Z
      (* ❌ Variants not supported *)
      variant.
  
  Definition uint8 : state -> Z -> unit :=
    Z
      (* ❌ Variants not supported *)
      variant.
  
  Definition int16 : state -> Z -> unit :=
    Z
      (* ❌ Variants not supported *)
      variant.
  
  Definition uint16 : state -> Z -> unit :=
    Z
      (* ❌ Variants not supported *)
      variant.
  
  Definition uint30 : state -> Z -> unit :=
    Z
      (* ❌ Variants not supported *)
      variant.
  
  Definition int31 : state -> Z -> unit :=
    Z
      (* ❌ Variants not supported *)
      variant.
  
  Definition bool (state : state) (v : bool) : unit :=
    uint8 state
      (if v then
        255
      else
        0).
  
  Definition int32 (state : state) (v : int32) : unit :=
    let ofs := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_resize state Binary_size.int32 in
    TzEndian.set_int32 (buffer state) ofs v.
  
  Definition int64 (state : state) (v : int64) : unit :=
    let ofs := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_resize state Binary_size.int64 in
    TzEndian.set_int64 (buffer state) ofs v.
  
  Definition ranged_int (minimum : Z) (maximum : Z) (state : state) (v : Z)
    : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_int_range minimum v maximum in
    let v :=
      if OCaml.Stdlib.ge minimum 0 then
        Z.sub v minimum
      else
        v in
    match Binary_size.range_to_size minimum maximum with
    | Uint8 => uint8 state v
    | Uint16 => uint16 state v
    | Uint30 => uint30 state v
    | Int8 => int8 state v
    | Int16 => int16 state v
    | Int31 => int31 state v
    end.
  
  Definition n (state : state) (v : Z.t) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.lt (Z.sign v) 0 then
        raise Tezos_data_encoding.Binary_error.Invalid_natural
      else
        tt in
    if Z.equal v Z.zero then
      uint8 state 0
    else
      let bits := Z.numbits v in
      let get_chunk (pos : Z) (len : Z) : Z :=
        Z.to_int (Z.extract v pos len) in
      let length := Binary_length.n_length v in
      let offset := offset state in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := may_resize state length in
      (* ❌ For loops not handled. *)
      for.
  
  Definition z (state : state) (v : Z.t) : unit :=
    let sign := OCaml.Stdlib.lt (Z.sign v) 0 in
    let bits := Z.numbits v in
    if Z.equal v Z.zero then
      uint8 state 0
    else
      let v := Z.abs v in
      let get_chunk (pos : Z) (len : Z) : Z :=
        Z.to_int (Z.extract v pos len) in
      let length := Binary_length.z_length v in
      let offset := offset state in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := may_resize state length in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        TzEndian.set_int8 (buffer state) offset
          (Z.lor
            (Z.lor
              (if sign then
                64
              else
                0)
              (if OCaml.Stdlib.gt bits 6 then
                128
              else
                0)) (get_chunk 0 6)) in
      (* ❌ For loops not handled. *)
      for.
  
  Definition float (state : state) (v : Z) : unit :=
    let ofs := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_resize state Binary_size.float in
    TzEndian.set_double (buffer state) ofs v.
  
  Definition ranged_float (minimum : Z) (maximum : Z) (state : state) (v : Z)
    : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_float_range minimum v maximum in
    Z state v.
  
  Definition string_enum {A B C : Type}
    (tbl : Stdlib.Hashtbl.t A (B * Z)) (arr : array C) (state : state) (v : A)
    : unit :=
    let value :=
      (* ❌ Try-with are not handled *)
      try (snd (Hashtbl.find tbl v)) in
    match Binary_size.enum_size arr with
    | Uint30 => uint30 state value
    | Uint16 => uint16 state value
    | Uint8 => uint8 state value
    end.
  
  Definition fixed_kind_bytes (length : Z) (state : state) (s : string)
    : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb (String.length s) length then
        raise
          (Tezos_data_encoding.Binary_error.Invalid_bytes_length
            {| expected := length; found := String.length s |})
      else
        tt in
    let ofs := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_resize state length in
    Stdlib.Bytes.blit s 0 (buffer state) ofs length.
  
  Definition fixed_kind_string (length : Z) (state : state) (s : string)
    : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb (OCaml.String.length s) length then
        raise
          (Tezos_data_encoding.Binary_error.Invalid_string_length
            {| expected := length; found := OCaml.String.length s |})
      else
        tt in
    let ofs := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := may_resize state length in
    Stdlib.Bytes.blit_string s 0 (buffer state) ofs length.
  
  Definition tag (function_parameter : variant) : state -> Z -> unit :=
    match function_parameter with
    | Uint8 => uint8
    | Uint16 => uint16
    end.
End Atom.

Fixpoint write_rec {a : Type}
  (e : Tezos_data_encoding.Encoding.t a) (state : state) (value : a) : unit :=
  match encoding e with
  | Tezos_data_encoding.Encoding.Null => tt
  | Tezos_data_encoding.Encoding.Empty => tt
  | Tezos_data_encoding.Encoding.Constant _ => tt
  | Tezos_data_encoding.Encoding.Ignore => tt
  | Tezos_data_encoding.Encoding.Bool => Atom.bool state value
  | Tezos_data_encoding.Encoding.Int8 => Atom.int8 state value
  | Tezos_data_encoding.Encoding.Uint8 => Atom.uint8 state value
  | Tezos_data_encoding.Encoding.Int16 => Atom.int16 state value
  | Tezos_data_encoding.Encoding.Uint16 => Atom.uint16 state value
  | Tezos_data_encoding.Encoding.Int31 => Atom.int31 state value
  | Tezos_data_encoding.Encoding.Int32 => Atom.int32 state value
  | Tezos_data_encoding.Encoding.Int64 => Atom.int64 state value
  | Tezos_data_encoding.Encoding.N => Atom.n state value
  | Tezos_data_encoding.Encoding.Z => Atom.z state value
  | Tezos_data_encoding.Encoding.Float => Atom.float state value
  | Tezos_data_encoding.Encoding.Bytes (Fixed n) =>
    Atom.fixed_kind_bytes n state value
  | Tezos_data_encoding.Encoding.Bytes Variable =>
    let length := String.length value in
    Atom.fixed_kind_bytes length state value
  | Tezos_data_encoding.Encoding.String (Fixed n) =>
    Atom.fixed_kind_string n state value
  | Tezos_data_encoding.Encoding.String Variable =>
    let length := OCaml.String.length value in
    Atom.fixed_kind_string length state value
  | Tezos_data_encoding.Encoding.Padded e n =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := write_rec e state value in
    Atom.fixed_kind_string n state (Stdlib.String.make n "000" % char)
  |
    Tezos_data_encoding.Encoding.RangedInt {|
      minimum := minimum; maximum := maximum |} =>
    Atom.ranged_int minimum maximum state value
  |
    Tezos_data_encoding.Encoding.RangedFloat {|
      minimum := minimum; maximum := maximum |} =>
    Atom.ranged_float minimum maximum state value
  | Tezos_data_encoding.Encoding.String_enum tbl arr =>
    Atom.string_enum tbl arr state value
  | Tezos_data_encoding.Encoding.Array (Some max_length) _e =>
    raise Tezos_data_encoding.Binary_error.Array_too_long
  | Tezos_data_encoding.Encoding.Array _ e =>
    Array.iter (write_rec e state) value
  | Tezos_data_encoding.Encoding.List (Some max_length) _e =>
    raise Tezos_data_encoding.Binary_error.List_too_long
  | Tezos_data_encoding.Encoding.List _ e =>
    Stdlib.List.iter (write_rec e state) value
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Req {| encoding := e |}) =>
    write_rec e state value
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Dynamic; encoding := e |}) =>
    match value with
    | None => Atom.bool state false
    | Some value =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Atom.bool state true in
      write_rec e state value
    end
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Opt {| kind := Variable; encoding := e |})
    =>
    match value with
    | None => tt
    | Some value => write_rec e state value
    end
  |
    Tezos_data_encoding.Encoding.Obj
      (Tezos_data_encoding.Encoding.Dft {| encoding := e |}) =>
    write_rec e state value
  | Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
    let '(v1, v2) := value in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := write_rec left state v1 in
    write_rec right state v2
  | Tezos_data_encoding.Encoding.Tup e => write_rec e state value
  | Tezos_data_encoding.Encoding.Tups {| left := left; right := right |} =>
    let '(v1, v2) := value in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := write_rec left state v1 in
    write_rec right state v2
  | Tezos_data_encoding.Encoding.Conv {| proj := proj; encoding := e |} =>
    write_rec e state (proj value)
  |
    Tezos_data_encoding.Encoding.Union {|
      tag_size := tag_size; cases := cases |} =>
    let fix write_case
      (function_parameter : list (Tezos_data_encoding.Encoding.case a))
      : unit :=
      match function_parameter with
      | [] => raise Tezos_data_encoding.Binary_error.No_case_matched
      |
        cons
          (Tezos_data_encoding.Encoding.Case {|
            tag := Tezos_data_encoding.Encoding.Json_only |}) tl =>
        write_case tl
      |
        cons
          (Tezos_data_encoding.Encoding.Case {|
            encoding := e;
              proj := proj;
              tag := Tezos_data_encoding.Encoding.Tag tag
              |}) tl =>
        match proj value with
        | None => write_case tl
        | Some value =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Atom.tag tag_size state tag in
          write_rec e state value
        end
      end in
    write_case cases
  | Tezos_data_encoding.Encoding.Dynamic_size {| kind := kind; encoding := e |}
    =>
    let initial_offset := offset state in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Atom.int kind state 0 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := write_with_limit (Binary_size.max_int kind) e state value in
    Atom.set_int kind (buffer state) initial_offset
      (Z.sub (Z.sub (offset state) initial_offset)
        (Binary_size.integer_to_size kind))
  | Tezos_data_encoding.Encoding.Check_size {| limit := limit; encoding := e |}
    => write_with_limit limit e state value
  | Tezos_data_encoding.Encoding.Describe {| encoding := e |} =>
    write_rec e state value
  | Tezos_data_encoding.Encoding.Splitted {| encoding := e |} =>
    write_rec e state value
  | Tezos_data_encoding.Encoding.Mu {| fix := fix |} =>
    write_rec (fix e) state value
  | Tezos_data_encoding.Encoding.Delayed f => write_rec (f tt) state value
  end

with write_with_limit {a : Type}
  (limit : Z) (e : Tezos_data_encoding.Encoding.t a) (state : state) (value : a)
  : unit :=
  let old_limit := allowed_bytes state in
  let limit :=
    match allowed_bytes state with
    | None => limit
    | Some old_limit => OCaml.Stdlib.min old_limit limit
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field state "allowed_bytes" % string (Some limit) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := write_rec e state value in
  match old_limit with
  | None =>
    (* ❌ Set record field not handled. *)
    set_record_field state "allowed_bytes" % string None
  | Some old_limit =>
    let remaining :=
      match allowed_bytes state with
      | None =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      | Some len => len
      end in
    let read := Z.sub limit remaining in
    (* ❌ Set record field not handled. *)
    set_record_field state "allowed_bytes" % string
      (Some (Z.sub old_limit read))
  end.

Definition write {A : Type}
  (e : Tezos_data_encoding.Encoding.t A) (v : A) (buffer : Stdlib.Bytes.t)
  (offset : Z) (len : Z) : option Z :=
  let state :=
    {| buffer := buffer; offset := offset; allowed_bytes := Some len |} in
  (* ❌ Try-with are not handled *)
  try
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    (let _ := write_rec e state v in
    Some (offset state)).

Definition to_bytes_exn {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) (v : A) : Stdlib.Bytes.t :=
  match Encoding.classify e with
  | Fixed n =>
    let state :=
      {| buffer := Stdlib.Bytes.create n; offset := 0; allowed_bytes := Some n
        |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := write_rec e state v in
    buffer state
  | Dynamic | Variable =>
    let state :=
      {| buffer := Stdlib.Bytes.create 128; offset := 0; allowed_bytes := None
        |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := write_rec e state v in
    String.sub (buffer state) 0 (offset state)
  end.

Definition to_bytes {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) (v : A)
  : option Stdlib.Bytes.t :=
  (* ❌ Try-with are not handled *)
  try (Some (to_bytes_exn e v)).

src/lib_data_encoding/bson.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bson = Json_repr_bson.bson

type t = bson

let construct e v = Json_repr_bson.Json_encoding.construct (Json.convert e) v

let destruct e v = Json_repr_bson.Json_encoding.destruct (Json.convert e) v
src/lib_data_encoding/bson.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bson := Json_repr_bson.bson.

Definition t := bson.

Definition construct {A : Type} (e : Tezos_data_encoding.Encoding.t A) (v : A)
  : Json_repr_bson.Repr.value :=
  Json_repr_bson.Json_encoding.construct (Json.convert e) v.

Definition destruct {A : Type}
  (e : Tezos_data_encoding.Encoding.t A) (v : Json_repr_bson.Repr.value) : A :=
  Json_repr_bson.Json_encoding.destruct (Json.convert e) v.

src/lib_data_encoding/bytes_encodings.ml success
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* this module is a temporary fix waiting for ocaml 4.08 *)

(** {1 Binary encoding/decoding of integers} *)

external get_uint8 : bytes -> int -> int = "%bytes_safe_get"

external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"

external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"

external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"

external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"

external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"

external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"

external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"

external swap16 : int -> int = "%bswap16"

external swap32 : int32 -> int32 = "%bswap_int32"

external swap64 : int64 -> int64 = "%bswap_int64"

let get_int8 b i = (get_uint8 b i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)

let get_uint16_le b i =
  if Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_uint16_be b i =
  if not Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_int16_ne b i =
  (get_uint16_ne b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_le b i =
  (get_uint16_le b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_be b i =
  (get_uint16_be b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int32_le b i =
  if Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int32_be b i =
  if not Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int64_le b i =
  if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let get_int64_be b i =
  if not Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let set_int16_le b i x =
  if Sys.big_endian then set_int16_ne b i (swap16 x) else set_int16_ne b i x

let set_int16_be b i x =
  if not Sys.big_endian then set_int16_ne b i (swap16 x)
  else set_int16_ne b i x

let set_int32_le b i x =
  if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x

let set_int32_be b i x =
  if not Sys.big_endian then set_int32_ne b i (swap32 x)
  else set_int32_ne b i x

let set_int64_le b i x =
  if Sys.big_endian then set_int64_ne b i (swap64 x) else set_int64_ne b i x

let set_int64_be b i x =
  if not Sys.big_endian then set_int64_ne b i (swap64 x)
  else set_int64_ne b i x

let set_uint8 = set_int8

let set_uint16_ne = set_int16_ne

let set_uint16_be = set_int16_be

let set_uint16_le = set_int16_le

module type S = sig
  (** {1 Binary encoding/decoding of integers} *)

  (** The functions in this section binary encode and decode integers to
      and from byte sequences.
      All following functions raise [Invalid_argument] if the space
      needed at index [i] to decode or encode the integer is not
      available.
      Little-endian (resp. big-endian) encoding means that least
      (resp. most) significant bytes are stored first.  Big-endian is
      also known as network byte order.  Native-endian encoding is
      either little-endian or big-endian depending on {!Sys.big_endian}.
      32-bit and 64-bit integers are represented by the [int32] and
      [int64] types, which can be interpreted either as signed or
      unsigned numbers.
      8-bit and 16-bit integers are represented by the [int] type,
      which has more bits than the binary encoding.  These extra bits
      are handled as follows:
        {ul
          {- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
          integers represented by [int] values sign-extend
          (resp. zero-extend) their result.}
          {- Functions that encode 8-bit or 16-bit integers represented by
          [int] values truncate their input to their least significant
          bytes.}
        }
  *)

  (** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_uint8 : bytes -> int -> int

  (** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_int8 : bytes -> int -> int

  (** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_ne : bytes -> int -> int

  (** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_be : bytes -> int -> int

  (** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_le : bytes -> int -> int

  (** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_ne : bytes -> int -> int

  (** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_be : bytes -> int -> int

  (** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_le : bytes -> int -> int

  (** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_ne : bytes -> int -> int32

  (** [get_int32_be b i] is [b]'s big-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_be : bytes -> int -> int32

  (** [get_int32_le b i] is [b]'s little-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_le : bytes -> int -> int32

  (** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_ne : bytes -> int -> int64

  (** [get_int64_be b i] is [b]'s big-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_be : bytes -> int -> int64

  (** [get_int64_le b i] is [b]'s little-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_le : bytes -> int -> int64

  (** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_uint8 : bytes -> int -> int -> unit

  (** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_int8 : bytes -> int -> int -> unit

  (** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_ne : bytes -> int -> int -> unit

  (** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_be : bytes -> int -> int -> unit

  (** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_le : bytes -> int -> int -> unit

  (** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_ne : bytes -> int -> int -> unit

  (** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_be : bytes -> int -> int -> unit

  (** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_le : bytes -> int -> int -> unit

  (** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_ne : bytes -> int -> int32 -> unit

  (** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_be : bytes -> int -> int32 -> unit

  (** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_le : bytes -> int -> int32 -> unit

  (** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_ne : bytes -> int -> int64 -> unit

  (** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_be : bytes -> int -> int64 -> unit

  (** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_le : bytes -> int -> int64 -> unit
end
src/lib_data_encoding/bytes_encodings.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_uint8 : string -> Z -> Z.

Parameter get_uint16_ne : string -> Z -> Z.

Parameter get_int32_ne : string -> Z -> int32.

Parameter get_int64_ne : string -> Z -> int64.

Parameter set_int8 : string -> Z -> Z -> unit.

Parameter set_int16_ne : string -> Z -> Z -> unit.

Parameter set_int32_ne : string -> Z -> int32 -> unit.

Parameter set_int64_ne : string -> Z -> int64 -> unit.

Parameter swap16 : Z -> Z.

Parameter swap32 : int32 -> int32.

Parameter swap64 : int64 -> int64.

Definition get_int8 (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint8 b i) (Z.sub Sys.int_size 8))
    (Z.sub Sys.int_size 8).

Definition get_uint16_le (b : string) (i : Z) : Z :=
  if Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_uint16_be (b : string) (i : Z) : Z :=
  if negb Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_int16_ne (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_ne b i) (Z.sub Sys.int_size 16))
    (Z.sub Sys.int_size 16).

Definition get_int16_le (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_le b i) (Z.sub Sys.int_size 16))
    (Z.sub Sys.int_size 16).

Definition get_int16_be (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_be b i) (Z.sub Sys.int_size 16))
    (Z.sub Sys.int_size 16).

Definition get_int32_le (b : string) (i : Z) : int32 :=
  if Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int32_be (b : string) (i : Z) : int32 :=
  if negb Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int64_le (b : string) (i : Z) : int64 :=
  if Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition get_int64_be (b : string) (i : Z) : int64 :=
  if negb Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition set_int16_le (b : string) (i : Z) (x : Z) : unit :=
  if Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int16_be (b : string) (i : Z) (x : Z) : unit :=
  if negb Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int32_le (b : string) (i : Z) (x : int32) : unit :=
  if Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int32_be (b : string) (i : Z) (x : int32) : unit :=
  if negb Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int64_le (b : string) (i : Z) (x : int64) : unit :=
  if Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_int64_be (b : string) (i : Z) (x : int64) : unit :=
  if negb Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_uint8 : string -> Z -> Z -> unit := set_int8.

Definition set_uint16_ne : string -> Z -> Z -> unit := set_int16_ne.

Definition set_uint16_be : string -> Z -> Z -> unit := set_int16_be.

Definition set_uint16_le : string -> Z -> Z -> unit := set_int16_le.

Module S.
  Record signature := {
    get_uint8 : string -> Z -> Z;
    get_int8 : string -> Z -> Z;
    get_uint16_ne : string -> Z -> Z;
    get_uint16_be : string -> Z -> Z;
    get_uint16_le : string -> Z -> Z;
    get_int16_ne : string -> Z -> Z;
    get_int16_be : string -> Z -> Z;
    get_int16_le : string -> Z -> Z;
    get_int32_ne : string -> Z -> int32;
    get_int32_be : string -> Z -> int32;
    get_int32_le : string -> Z -> int32;
    get_int64_ne : string -> Z -> int64;
    get_int64_be : string -> Z -> int64;
    get_int64_le : string -> Z -> int64;
    set_uint8 : string -> Z -> Z -> unit;
    set_int8 : string -> Z -> Z -> unit;
    set_uint16_ne : string -> Z -> Z -> unit;
    set_uint16_be : string -> Z -> Z -> unit;
    set_uint16_le : string -> Z -> Z -> unit;
    set_int16_ne : string -> Z -> Z -> unit;
    set_int16_be : string -> Z -> Z -> unit;
    set_int16_le : string -> Z -> Z -> unit;
    set_int32_ne : string -> Z -> int32 -> unit;
    set_int32_be : string -> Z -> int32 -> unit;
    set_int32_le : string -> Z -> int32 -> unit;
    set_int64_ne : string -> Z -> int64 -> unit;
    set_int64_be : string -> Z -> int64 -> unit;
    set_int64_le : string -> Z -> int64 -> unit;
  }.
End S.

src/lib_data_encoding/data_encoding.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Encoding = struct
  include Encoding

  let splitted ~json ~binary = raw_splitted ~json:(Json.convert json) ~binary

  let assoc enc =
    let json = Json_encoding.assoc (Json.convert enc) in
    let binary = list (tup2 string enc) in
    raw_splitted ~json ~binary

  module Bounded = struct
    let string length =
      raw_splitted
        ~binary:
          (let kind = Binary_size.unsigned_range_to_size length in
           check_size (length + Binary_size.integer_to_size kind)
           @@ dynamic_size ~kind Variable.string)
        ~json:
          (let open Json_encoding in
          conv
            (fun s ->
              if String.length s > length then invalid_arg "oversized string" ;
              s)
            (fun s ->
              if String.length s > length then
                raise
                  (Cannot_destruct ([], Invalid_argument "oversized string")) ;
              s)
            string)

    let bytes length =
      raw_splitted
        ~binary:
          (let kind = Binary_size.unsigned_range_to_size length in
           check_size (length + Binary_size.integer_to_size kind)
           @@ dynamic_size ~kind Variable.bytes)
        ~json:
          (let open Json_encoding in
          conv
            (fun s ->
              if Bytes.length s > length then invalid_arg "oversized string" ;
              s)
            (fun s ->
              if Bytes.length s > length then
                raise
                  (Cannot_destruct ([], Invalid_argument "oversized string")) ;
              s)
            Json.bytes_jsont)
  end

  type 'a lazy_state = Value of 'a | Bytes of Bytes.t | Both of Bytes.t * 'a

  type 'a lazy_t = {mutable state : 'a lazy_state; encoding : 'a t}

  let force_decode le =
    match le.state with
    | Value value ->
        Some value
    | Both (_, value) ->
        Some value
    | Bytes bytes -> (
      match Binary_reader.of_bytes le.encoding bytes with
      | Some expr ->
          le.state <- Both (bytes, expr) ;
          Some expr
      | None ->
          None )

  let force_bytes le =
    match le.state with
    | Bytes bytes ->
        bytes
    | Both (bytes, _) ->
        bytes
    | Value value ->
        let bytes = Binary_writer.to_bytes_exn le.encoding value in
        le.state <- Both (bytes, value) ;
        bytes

  let lazy_encoding encoding =
    let binary =
      Encoding.conv
        force_bytes
        (fun bytes -> {state = Bytes bytes; encoding})
        Encoding.bytes
    in
    let json =
      Encoding.conv
        (fun le ->
          match force_decode le with Some r -> r | None -> raise Exit)
        (fun value -> {state = Value value; encoding})
        encoding
    in
    splitted ~json ~binary

  let make_lazy encoding value = {encoding; state = Value value}

  let apply_lazy ~fun_value ~fun_bytes ~fun_combine le =
    match le.state with
    | Value value ->
        fun_value value
    | Bytes bytes ->
        fun_bytes bytes
    | Both (bytes, value) ->
        fun_combine (fun_value value) (fun_bytes bytes)
end

include Encoding
module With_version = With_version
module Registration = Registration
module Json = Json
module Bson = Bson
module Binary_schema = Binary_schema

module Binary = struct
  include Binary_error
  include Binary_length
  include Binary_writer
  include Binary_reader
  include Binary_stream_reader

  let describe = Binary_description.describe
end

type json = Json.t

let json = Json.encoding

type json_schema = Json.schema

let json_schema = Json.schema_encoding

type bson = Bson.t
src/lib_data_encoding/data_encoding.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Encoding.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition splitted {A : Type}
    (json : Tezos_data_encoding.Encoding.t A) (binary : encoding A)
    : encoding A := raw_splitted (Json.convert json) binary.
  
  Definition assoc {A : Type} (enc : Tezos_data_encoding.Encoding.t A)
    : encoding (list (string * A)) :=
    let json := Json_encoding.assoc (Json.convert enc) in
    let binary := list None (tup2 string enc) in
    raw_splitted json binary.
  
  Module Bounded.
    Definition string (length : Z) : encoding string :=
      raw_splitted
        (conv
          (fun s =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if OCaml.Stdlib.gt (OCaml.String.length s) length then
                OCaml.Stdlib.invalid_arg "oversized string" % string
              else
                tt in
            s)
          (fun s =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if OCaml.Stdlib.gt (OCaml.String.length s) length then
                Stdlib.raise
                  (Cannot_destruct
                    ([], (OCaml.Invalid_argument "oversized string" % string)))
              else
                tt in
            s) None string)
        (let kind := Binary_size.unsigned_range_to_size length in
        apply (check_size (Z.add length (Binary_size.integer_to_size kind)))
          (dynamic_size (Some kind) Variable.string)).
    
    Definition bytes (length : Z) : encoding Stdlib.Bytes.t :=
      raw_splitted
        (conv
          (fun s =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if OCaml.Stdlib.gt (String.length s) length then
                OCaml.Stdlib.invalid_arg "oversized string" % string
              else
                tt in
            s)
          (fun s =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if OCaml.Stdlib.gt (String.length s) length then
                Stdlib.raise
                  (Cannot_destruct
                    ([], (OCaml.Invalid_argument "oversized string" % string)))
              else
                tt in
            s) None Json.bytes_jsont)
        (let kind := Binary_size.unsigned_range_to_size length in
        apply (check_size (Z.add length (Binary_size.integer_to_size kind)))
          (dynamic_size (Some kind) Variable.bytes)).
  End Bounded.
  
  Inductive lazy_state (a : Type) : Type :=
  | Value : a -> lazy_state a
  | Bytes : Stdlib.Bytes.t -> lazy_state a
  | Both : Stdlib.Bytes.t -> a -> lazy_state a.
  
  Arguments Value {_}.
  Arguments Bytes {_}.
  Arguments Both {_}.
  
  Record lazy_t {a : Type} := {
    state : lazy_state a;
    encoding : t a }.
  Arguments lazy_t : clear implicits.
  
  Definition force_decode {A : Type} (le : lazy_t A) : option A :=
    match state le with
    | Value value => Some value
    | Both _ value => Some value
    | Bytes bytes =>
      match Binary_reader.of_bytes (encoding le) string with
      | Some expr =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field le "state" % string (Both string expr) in
        Some expr
      | None => None
      end
    end.
  
  Definition force_bytes {A : Type} (le : lazy_t A) : Stdlib.Bytes.t :=
    match state le with
    | Bytes bytes => string
    | Both bytes _ => string
    | Value value =>
      let bytes := Binary_writer.to_bytes_exn (encoding le) value in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field le "state" % string (Both string value) in
      string
    end.
  
  Definition lazy_encoding {A : Type} (encoding : t A) : encoding (lazy_t A) :=
    let binary :=
      Encoding.conv force_bytes
        (fun bytes => {| state := Bytes string; encoding := encoding |}) None
        Encoding.bytes in
    let json :=
      Encoding.conv
        (fun le =>
          match force_decode le with
          | Some r => r
          | None => Stdlib.raise Exit
          end) (fun value => {| state := Value value; encoding := encoding |})
        None encoding in
    splitted json binary.
  
  Definition make_lazy {A : Type} (encoding : t A) (value : A) : lazy_t A :=
    {| state := Value value; encoding := encoding |}.
  
  Definition apply_lazy {A B : Type}
    (fun_value : A -> B) (fun_bytes : Stdlib.Bytes.t -> B)
    (fun_combine : B -> B -> B) (le : lazy_t A) : B :=
    match state le with
    | Value value => fun_value value
    | Bytes bytes => fun_bytes string
    | Both bytes value => fun_combine (fun_value value) (fun_bytes string)
    end.
End Encoding.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Binary.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition describe {A : Type}
    : (Tezos_data_encoding.Encoding.t A) -> Tezos_data_encoding.Binary_schema.t :=
    Binary_description.describe.
End Binary.

Definition json := Json.t.

Definition json : Tezos_data_encoding.Encoding.t Json.json := Json.encoding.

Definition json_schema := Json.schema.

Definition json_schema : Tezos_data_encoding.Encoding.t Json.schema :=
  Json.schema_encoding.

Definition bson := Bson.t.

src/lib_data_encoding/encoding.ml 135 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Kind = struct
  type t = [`Fixed of int | `Dynamic | `Variable]

  type length = [`Fixed of int | `Variable]

  type enum = [`Dynamic | `Variable]

  let combine name : t -> t -> t =
   fun k1 k2 ->
    match (k1, k2) with
    | (`Fixed n1, `Fixed n2) ->
        `Fixed (n1 + n2)
    | (`Dynamic, `Dynamic) | (`Fixed _, `Dynamic) | (`Dynamic, `Fixed _) ->
        `Dynamic
    | (`Variable, `Fixed _) | ((`Dynamic | `Fixed _), `Variable) ->
        `Variable
    | (`Variable, `Dynamic) ->
        Printf.ksprintf
          invalid_arg
          "Cannot merge two %s when the left element is of variable length \
           and the right one of dynamic length. You should use the reverse \
           order, or wrap the second one with Data_encoding.dynamic_size."
          name
    | (`Variable, `Variable) ->
        Printf.ksprintf
          invalid_arg
          "Cannot merge two %s with variable length. You should wrap one of \
           them with Data_encoding.dynamic_size."
          name

  let merge : t -> t -> t =
   fun k1 k2 ->
    match (k1, k2) with
    | (`Fixed n1, `Fixed n2) when n1 = n2 ->
        `Fixed n1
    | (`Fixed _, `Fixed _) ->
        `Dynamic
    | (`Dynamic, `Dynamic) | (`Fixed _, `Dynamic) | (`Dynamic, `Fixed _) ->
        `Dynamic
    | (`Variable, (`Dynamic | `Fixed _))
    | ((`Dynamic | `Fixed _), `Variable)
    | (`Variable, `Variable) ->
        `Variable

  let merge_list sz : t list -> t = function
    | [] ->
        assert false (* should be rejected by Data_encoding.union *)
    | k :: ks -> (
      match List.fold_left merge k ks with
      | `Fixed n ->
          `Fixed (n + Binary_size.tag_size sz)
      | k ->
          k )
end

type case_tag = Tag of int | Json_only

type 'a desc =
  | Null : unit desc
  | Empty : unit desc
  | Ignore : unit desc
  | Constant : string -> unit desc
  | Bool : bool desc
  | Int8 : int desc
  | Uint8 : int desc
  | Int16 : int desc
  | Uint16 : int desc
  | Int31 : int desc
  | Int32 : Int32.t desc
  | Int64 : Int64.t desc
  | N : Z.t desc
  | Z : Z.t desc
  | RangedInt : {minimum : int; maximum : int} -> int desc
  | RangedFloat : {minimum : float; maximum : float} -> float desc
  | Float : float desc
  | Bytes : Kind.length -> Bytes.t desc
  | String : Kind.length -> string desc
  | Padded : 'a t * int -> 'a desc
  | String_enum : ('a, string * int) Hashtbl.t * 'a array -> 'a desc
  | Array : int option * 'a t -> 'a array desc
  | List : int option * 'a t -> 'a list desc
  | Obj : 'a field -> 'a desc
  | Objs : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
  | Tup : 'a t -> 'a desc
  | Tups : {kind : Kind.t; left : 'a t; right : 'b t} -> ('a * 'b) desc
  | Union : {
      kind : Kind.t;
      tag_size : Binary_size.tag_size;
      cases : 'a case list;
    }
      -> 'a desc
  | Mu : {
      kind : Kind.enum;
      name : string;
      title : string option;
      description : string option;
      fix : 'a t -> 'a t;
    }
      -> 'a desc
  | Conv : {
      proj : 'a -> 'b;
      inj : 'b -> 'a;
      encoding : 'b t;
      schema : Json_schema.schema option;
    }
      -> 'a desc
  | Describe : {
      id : string;
      title : string option;
      description : string option;
      encoding : 'a t;
    }
      -> 'a desc
  | Splitted : {
      encoding : 'a t;
      json_encoding : 'a Json_encoding.encoding;
      is_obj : bool;
      is_tup : bool;
    }
      -> 'a desc
  | Dynamic_size : {
      kind : Binary_size.unsigned_integer;
      encoding : 'a t;
    }
      -> 'a desc
  | Check_size : {limit : int; encoding : 'a t} -> 'a desc
  | Delayed : (unit -> 'a t) -> 'a desc

and _ field =
  | Req : {
      name : string;
      encoding : 'a t;
      title : string option;
      description : string option;
    }
      -> 'a field
  | Opt : {
      name : string;
      kind : Kind.enum;
      encoding : 'a t;
      title : string option;
      description : string option;
    }
      -> 'a option field
  | Dft : {
      name : string;
      encoding : 'a t;
      default : 'a;
      title : string option;
      description : string option;
    }
      -> 'a field

and 'a case =
  | Case : {
      title : string;
      description : string option;
      encoding : 'a t;
      proj : 't -> 'a option;
      inj : 'a -> 't;
      tag : case_tag;
    }
      -> 't case

and 'a t = {
  encoding : 'a desc;
  mutable json_encoding : 'a Json_encoding.encoding option;
}

type 'a encoding = 'a t

let rec classify : type a. a t -> Kind.t = fun e -> classify_desc e.encoding

and classify_desc : type a. a desc -> Kind.t =
 fun e ->
  match e with
  (* Fixed *)
  | Null ->
      `Fixed 0
  | Empty ->
      `Fixed 0
  | Constant _ ->
      `Fixed 0
  | Bool ->
      `Fixed Binary_size.bool
  | Int8 ->
      `Fixed Binary_size.int8
  | Uint8 ->
      `Fixed Binary_size.uint8
  | Int16 ->
      `Fixed Binary_size.int16
  | Uint16 ->
      `Fixed Binary_size.uint16
  | Int31 ->
      `Fixed Binary_size.int31
  | Int32 ->
      `Fixed Binary_size.int32
  | Int64 ->
      `Fixed Binary_size.int64
  | N ->
      `Dynamic
  | Z ->
      `Dynamic
  | RangedInt {minimum; maximum} ->
      `Fixed Binary_size.(integer_to_size @@ range_to_size ~minimum ~maximum)
  | Float ->
      `Fixed Binary_size.float
  | RangedFloat _ ->
      `Fixed Binary_size.float
  (* Tagged *)
  | Bytes kind ->
      (kind :> Kind.t)
  | String kind ->
      (kind :> Kind.t)
  | Padded ({encoding; _}, n) -> (
    match classify_desc encoding with
    | `Fixed m ->
        `Fixed (n + m)
    | _ ->
        assert false (* by construction (see [Fixed.padded]) *) )
  | String_enum (_, cases) ->
      `Fixed Binary_size.(integer_to_size @@ enum_size cases)
  | Obj (Opt {kind; _}) ->
      (kind :> Kind.t)
  | Objs {kind; _} ->
      kind
  | Tups {kind; _} ->
      kind
  | Union {kind; _} ->
      (kind :> Kind.t)
  | Mu {kind; _} ->
      (kind :> Kind.t)
  (* Variable *)
  | Ignore ->
      `Fixed 0
  | Array _ ->
      `Variable
  | List _ ->
      `Variable
  (* Recursive *)
  | Obj (Req {encoding; _}) ->
      classify encoding
  | Obj (Dft {encoding; _}) ->
      classify encoding
  | Tup encoding ->
      classify encoding
  | Conv {encoding; _} ->
      classify encoding
  | Describe {encoding; _} ->
      classify encoding
  | Splitted {encoding; _} ->
      classify encoding
  | Dynamic_size _ ->
      `Dynamic
  | Check_size {encoding; _} ->
      classify encoding
  | Delayed f ->
      classify (f ())

let make ?json_encoding encoding = {encoding; json_encoding}

module Fixed = struct
  let string n =
    if n <= 0 then
      invalid_arg
        "Cannot create a string encoding of negative or null fixed length." ;
    make @@ String (`Fixed n)

  let bytes n =
    if n <= 0 then
      invalid_arg
        "Cannot create a byte encoding of negative or null fixed length." ;
    make @@ Bytes (`Fixed n)

  let add_padding e n =
    if n <= 0 then
      invalid_arg "Cannot create a padding of negative or null fixed length." ;
    match classify e with
    | `Fixed _ ->
        make @@ Padded (e, n)
    | _ ->
        invalid_arg "Cannot pad non-fixed size encoding"
end

let rec is_zeroable : type t. t encoding -> bool =
 fun e ->
  (* Whether an encoding can ever produce zero-byte of encoding. It is dnagerous
     to place zero-size elements in a collection (list/array) because
     they are indistinguishable from the abscence of elements. *)
  match e.encoding with
  (* trivially true *)
  | Null ->
      true (* always true *)
  | Empty ->
      true (* always true *)
  | Ignore ->
      true (* always true *)
  | Constant _ ->
      true (* always true *)
  (* trivially false *)
  | Bool ->
      false
  | Int8 ->
      false
  | Uint8 ->
      false
  | Int16 ->
      false
  | Uint16 ->
      false
  | Int31 ->
      false
  | Int32 ->
      false
  | Int64 ->
      false
  | N ->
      false
  | Z ->
      false
  | RangedInt _ ->
      false
  | RangedFloat _ ->
      false
  | Float ->
      false
  | Bytes _ ->
      false
  | String _ ->
      false
  | Padded _ ->
      false
  | String_enum _ ->
      false
  (* true in some cases, but in practice always protected by Dynamic *)
  | Array _ ->
      true (* 0-element array *)
  | List _ ->
      true (* 0-element list *)
  (* represented as whatever is inside: truth mostly propagates *)
  | Obj (Req {encoding = e; _}) ->
      is_zeroable e (* represented as-is *)
  | Obj (Opt {kind = `Variable; _}) ->
      true (* optional field ommited *)
  | Obj (Dft {encoding = e; _}) ->
      is_zeroable e (* represented as-is *)
  | Obj _ ->
      false
  | Objs {left; right; _} ->
      is_zeroable left && is_zeroable right
  | Tup e ->
      is_zeroable e
  | Tups {left; right; _} ->
      is_zeroable left && is_zeroable right
  | Union _ ->
      false (* includes a tag *)
  (* other recursive cases: truth propagates *)
  | Mu {kind = `Dynamic; _} ->
      false (* size prefix *)
  | Mu {kind = `Variable; fix; _} ->
      is_zeroable (fix e)
  | Conv {encoding; _} ->
      is_zeroable encoding
  | Describe {encoding; _} ->
      is_zeroable encoding
  | Splitted {encoding; _} ->
      is_zeroable encoding
  | Check_size {encoding; _} ->
      is_zeroable encoding
  (* Unscrutable: true by default *)
  | Delayed f ->
      is_zeroable (f ())
  (* Protected against zeroable *)
  | Dynamic_size _ ->
      false

(* always some data for size *)

module Variable = struct
  let string = make @@ String `Variable

  let bytes = make @@ Bytes `Variable

  let check_not_variable name e =
    match classify e with
    | `Variable ->
        Printf.ksprintf
          invalid_arg
          "Cannot insert variable length element in %s. You should wrap the \
           contents using Data_encoding.dynamic_size."
          name
    | `Dynamic | `Fixed _ ->
        ()

  let check_not_zeroable name e =
    if is_zeroable e then
      Printf.ksprintf
        invalid_arg
        "Cannot insert potentially zero-sized element in %s."
        name
    else ()

  let array ?max_length e =
    check_not_variable "an array" e ;
    check_not_zeroable "an array" e ;
    let encoding = make @@ Array (max_length, e) in
    match (classify e, max_length) with
    | (`Fixed n, Some max_length) ->
        let limit = n * max_length in
        make @@ Check_size {limit; encoding}
    | (_, _) ->
        encoding

  let list ?max_length e =
    check_not_variable "a list" e ;
    check_not_zeroable "a list" e ;
    let encoding = make @@ List (max_length, e) in
    match (classify e, max_length) with
    | (`Fixed n, Some max_length) ->
        let limit = n * max_length in
        make @@ Check_size {limit; encoding}
    | (_, _) ->
        encoding
end

let dynamic_size ?(kind = `Uint30) e =
  make @@ Dynamic_size {kind; encoding = e}

let check_size limit encoding = make @@ Check_size {limit; encoding}

let delayed f = make @@ Delayed f

let null = make @@ Null

let empty = make @@ Empty

let unit = make @@ Ignore

let constant s = make @@ Constant s

let bool = make @@ Bool

let int8 = make @@ Int8

let uint8 = make @@ Uint8

let int16 = make @@ Int16

let uint16 = make @@ Uint16

let int31 = make @@ Int31

let int32 = make @@ Int32

let ranged_int minimum maximum =
  let minimum = min minimum maximum and maximum = max minimum maximum in
  if minimum < -(1 lsl 30) || (1 lsl 30) - 1 < maximum then
    invalid_arg "Data_encoding.ranged_int" ;
  make @@ RangedInt {minimum; maximum}

let ranged_float minimum maximum =
  let minimum = min minimum maximum and maximum = max minimum maximum in
  make @@ RangedFloat {minimum; maximum}

let int64 = make @@ Int64

let n = make @@ N

let z = make @@ Z

let float = make @@ Float

let string = dynamic_size Variable.string

let bytes = dynamic_size Variable.bytes

let array ?max_length e = dynamic_size (Variable.array ?max_length e)

let list ?max_length e = dynamic_size (Variable.list ?max_length e)

let string_enum = function
  | [] ->
      invalid_arg "data_encoding.string_enum: cannot have zero cases"
  | [_case] ->
      invalid_arg
        "data_encoding.string_enum: cannot have a single case, use constant \
         instead"
  | _ :: _ as cases ->
      let arr = Array.of_list (List.map snd cases) in
      let tbl = Hashtbl.create (Array.length arr) in
      List.iteri (fun ind (str, a) -> Hashtbl.add tbl a (str, ind)) cases ;
      make @@ String_enum (tbl, arr)

let conv proj inj ?schema encoding = make @@ Conv {proj; inj; encoding; schema}

let def id ?title ?description encoding =
  make @@ Describe {id; title; description; encoding}

let req ?title ?description n t =
  Req {name = n; encoding = t; title; description}

let opt ?title ?description n encoding =
  let kind =
    match classify encoding with
    | `Variable ->
        `Variable
    | `Fixed _ | `Dynamic ->
        `Dynamic
  in
  Opt {name = n; kind; encoding; title; description}

let varopt ?title ?description n encoding =
  Opt {name = n; kind = `Variable; encoding; title; description}

let dft ?title ?description n t d =
  Dft {name = n; encoding = t; default = d; title; description}

let raw_splitted ~json ~binary =
  make
  @@ Splitted
       {
         encoding = binary;
         json_encoding = json;
         is_obj = false;
         is_tup = false;
       }

let rec is_obj : type a. a t -> bool =
 fun e ->
  match e.encoding with
  | Obj _ ->
      true
  | Objs _ (* by construction *) ->
      true
  | Conv {encoding = e; _} ->
      is_obj e
  | Dynamic_size {encoding = e; _} ->
      is_obj e
  | Union {cases; _} ->
      List.for_all (fun (Case {encoding = e; _}) -> is_obj e) cases
  | Empty ->
      true
  | Ignore ->
      true
  | Mu {fix; _} ->
      is_obj (fix e)
  | Splitted {is_obj; _} ->
      is_obj
  | Delayed f ->
      is_obj (f ())
  | Describe {encoding; _} ->
      is_obj encoding
  | _ ->
      false

let rec is_tup : type a. a t -> bool =
 fun e ->
  match e.encoding with
  | Tup _ ->
      true
  | Tups _ (* by construction *) ->
      true
  | Conv {encoding = e; _} ->
      is_tup e
  | Dynamic_size {encoding = e; _} ->
      is_tup e
  | Union {cases; _} ->
      List.for_all (function Case {encoding = e; _} -> is_tup e) cases
  | Mu {fix; _} ->
      is_tup (fix e)
  | Splitted {is_tup; _} ->
      is_tup
  | Delayed f ->
      is_tup (f ())
  | Describe {encoding; _} ->
      is_tup encoding
  | _ ->
      false

let raw_merge_objs left right =
  let kind = Kind.combine "objects" (classify left) (classify right) in
  make @@ Objs {kind; left; right}

let obj1 f1 = make @@ Obj f1

let obj2 f2 f1 = raw_merge_objs (obj1 f2) (obj1 f1)

let obj3 f3 f2 f1 = raw_merge_objs (obj1 f3) (obj2 f2 f1)

let obj4 f4 f3 f2 f1 = raw_merge_objs (obj2 f4 f3) (obj2 f2 f1)

let obj5 f5 f4 f3 f2 f1 = raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1)

let obj6 f6 f5 f4 f3 f2 f1 = raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1)

let obj7 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1)

let obj8 f8 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1)

let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)

let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1)

let merge_objs o1 o2 =
  if is_obj o1 && is_obj o2 then raw_merge_objs o1 o2
  else invalid_arg "Json_encoding.merge_objs"

let raw_merge_tups left right =
  let kind = Kind.combine "tuples" (classify left) (classify right) in
  make @@ Tups {kind; left; right}

let tup1 e1 = make @@ Tup e1

let tup2 e2 e1 = raw_merge_tups (tup1 e2) (tup1 e1)

let tup3 e3 e2 e1 = raw_merge_tups (tup1 e3) (tup2 e2 e1)

let tup4 e4 e3 e2 e1 = raw_merge_tups (tup2 e4 e3) (tup2 e2 e1)

let tup5 e5 e4 e3 e2 e1 = raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1)

let tup6 e6 e5 e4 e3 e2 e1 = raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1)

let tup7 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1)

let tup8 e8 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1)

let tup9 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)

let tup10 e10 e9 e8 e7 e6 e5 e4 e3 e2 e1 =
  raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1)

let merge_tups t1 t2 =
  if is_tup t1 && is_tup t2 then raw_merge_tups t1 t2
  else invalid_arg "Tezos_serial.Encoding.merge_tups"

let conv3 ty =
  conv (fun (c, b, a) -> (c, (b, a))) (fun (c, (b, a)) -> (c, b, a)) ty

let obj3 f3 f2 f1 = conv3 (obj3 f3 f2 f1)

let tup3 f3 f2 f1 = conv3 (tup3 f3 f2 f1)

let conv4 ty =
  conv
    (fun (d, c, b, a) -> ((d, c), (b, a)))
    (fun ((d, c), (b, a)) -> (d, c, b, a))
    ty

let obj4 f4 f3 f2 f1 = conv4 (obj4 f4 f3 f2 f1)

let tup4 f4 f3 f2 f1 = conv4 (tup4 f4 f3 f2 f1)

let conv5 ty =
  conv
    (fun (e, d, c, b, a) -> (e, ((d, c), (b, a))))
    (fun (e, ((d, c), (b, a))) -> (e, d, c, b, a))
    ty

let obj5 f5 f4 f3 f2 f1 = conv5 (obj5 f5 f4 f3 f2 f1)

let tup5 f5 f4 f3 f2 f1 = conv5 (tup5 f5 f4 f3 f2 f1)

let conv6 ty =
  conv
    (fun (f, e, d, c, b, a) -> ((f, e), ((d, c), (b, a))))
    (fun ((f, e), ((d, c), (b, a))) -> (f, e, d, c, b, a))
    ty

let obj6 f6 f5 f4 f3 f2 f1 = conv6 (obj6 f6 f5 f4 f3 f2 f1)

let tup6 f6 f5 f4 f3 f2 f1 = conv6 (tup6 f6 f5 f4 f3 f2 f1)

let conv7 ty =
  conv
    (fun (g, f, e, d, c, b, a) -> ((g, (f, e)), ((d, c), (b, a))))
    (fun ((g, (f, e)), ((d, c), (b, a))) -> (g, f, e, d, c, b, a))
    ty

let obj7 f7 f6 f5 f4 f3 f2 f1 = conv7 (obj7 f7 f6 f5 f4 f3 f2 f1)

let tup7 f7 f6 f5 f4 f3 f2 f1 = conv7 (tup7 f7 f6 f5 f4 f3 f2 f1)

let conv8 ty =
  conv
    (fun (h, g, f, e, d, c, b, a) -> (((h, g), (f, e)), ((d, c), (b, a))))
    (fun (((h, g), (f, e)), ((d, c), (b, a))) -> (h, g, f, e, d, c, b, a))
    ty

let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1)

let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1)

let conv9 ty =
  conv
    (fun (i, h, g, f, e, d, c, b, a) ->
      (i, (((h, g), (f, e)), ((d, c), (b, a)))))
    (fun (i, (((h, g), (f, e)), ((d, c), (b, a)))) ->
      (i, h, g, f, e, d, c, b, a))
    ty

let obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1 = conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let conv10 ty =
  conv
    (fun (j, i, h, g, f, e, d, c, b, a) ->
      ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))))
    (fun ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) ->
      (j, i, h, g, f, e, d, c, b, a))
    ty

let obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1 =
  conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1)

let check_cases tag_size cases =
  if cases = [] then invalid_arg "Data_encoding.union: empty list of cases." ;
  let max_tag = match tag_size with `Uint8 -> 256 | `Uint16 -> 256 * 256 in
  ignore
  @@ List.fold_left
       (fun others (Case {tag; _}) ->
         match tag with
         | Json_only ->
             others
         | Tag tag ->
             if List.mem tag others then
               Format.kasprintf
                 invalid_arg
                 "The tag %d appears twice in an union."
                 tag ;
             if tag < 0 || max_tag <= tag then
               Format.kasprintf invalid_arg "The tag %d is invalid." tag ;
             tag :: others)
       []
       cases

let union ?(tag_size = `Uint8) cases =
  check_cases tag_size cases ;
  let kinds = List.map (fun (Case {encoding; _}) -> classify encoding) cases in
  let kind = Kind.merge_list tag_size kinds in
  make @@ Union {kind; tag_size; cases}

let case ~title ?description tag encoding proj inj =
  Case {title; description; encoding; proj; inj; tag}

let rec is_nullable : type t. t encoding -> bool =
 fun e ->
  match e.encoding with
  | Null ->
      true
  | Empty ->
      false
  | Ignore ->
      true
  | Constant _ ->
      false
  | Bool ->
      false
  | Int8 ->
      false
  | Uint8 ->
      false
  | Int16 ->
      false
  | Uint16 ->
      false
  | Int31 ->
      false
  | Int32 ->
      false
  | Int64 ->
      false
  | N ->
      false
  | Z ->
      false
  | RangedInt _ ->
      false
  | RangedFloat _ ->
      false
  | Float ->
      false
  | Bytes _ ->
      false
  | String _ ->
      false
  | Padded (e, _) ->
      is_nullable e
  | String_enum _ ->
      false
  | Array _ ->
      false
  | List _ ->
      false
  | Obj _ ->
      false
  | Objs _ ->
      false
  | Tup _ ->
      false
  | Tups _ ->
      false
  | Union {cases; _} ->
      List.exists (fun (Case {encoding = e; _}) -> is_nullable e) cases
  | Mu {fix; _} ->
      is_nullable (fix e)
  | Conv {encoding = e; _} ->
      is_nullable e
  | Describe {encoding = e; _} ->
      is_nullable e
  | Splitted {json_encoding; _} ->
      Json_encoding.is_nullable json_encoding
  | Dynamic_size {encoding = e; _} ->
      is_nullable e
  | Check_size {encoding = e; _} ->
      is_nullable e
  | Delayed _ ->
      true

let option ty =
  if is_nullable ty then
    invalid_arg "Data_encoding.option: cannot nest nullable encodings" ;
  (* TODO add a special construct `Option` in the GADT *)
  union
    ~tag_size:`Uint8
    [ case (Tag 1) ty ~title:"Some" (fun x -> x) (fun x -> Some x);
      case
        (Tag 0)
        null
        ~title:"None"
        (function None -> Some () | Some _ -> None)
        (fun () -> None) ]

let mu name ?title ?description fix =
  let kind =
    try
      let precursor =
        make @@ Mu {kind = `Dynamic; name; title; description; fix}
      in
      match classify @@ fix precursor with
      | `Fixed _ | `Dynamic ->
          `Dynamic
      | `Variable ->
          raise Exit
    with Exit | _ (* TODO variability error *) ->
      let precursor =
        make @@ Mu {kind = `Variable; name; title; description; fix}
      in
      ignore (classify @@ fix precursor) ;
      `Variable
  in
  make @@ Mu {kind; name; title; description; fix}

let result ok_enc error_enc =
  union
    ~tag_size:`Uint8
    [ case
        (Tag 1)
        ok_enc
        ~title:"Ok"
        (function Ok x -> Some x | Error _ -> None)
        (fun x -> Ok x);
      case
        (Tag 0)
        error_enc
        ~title:"Result"
        (function Ok _ -> None | Error x -> Some x)
        (fun x -> Error x) ]
src/lib_data_encoding/encoding.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Kind.
  Definition t := variant.
  
  Definition length := variant.
  
  Definition enum := variant.
  
  Definition combine (name : string) (k1 : t) (k2 : t) : t :=
    match (k1, k2) with
    | (Fixed n1, Fixed n2) =>
      (* ❌ Variants not supported *)
      variant
    | (Dynamic, Dynamic) | (Fixed _, Dynamic) | (Dynamic, Fixed _) =>
      (* ❌ Variants not supported *)
      variant
    | (Variable, Fixed _) | (Dynamic | Fixed _, Variable) =>
      (* ❌ Variants not supported *)
      variant
    | (Variable, Dynamic) =>
      Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Cannot merge two " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " when the left element is of variable length and the right one of dynamic length. You should use the reverse order, or wrap the second one with Data_encoding.dynamic_size."
                  % string CamlinternalFormatBasics.End_of_format)))
          "Cannot merge two %s when the left element is of variable length and the right one of dynamic length. You should use the reverse order, or wrap the second one with Data_encoding.dynamic_size."
            % string) name
    | (Variable, Variable) =>
      Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Cannot merge two " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " with variable length. You should wrap one of them with Data_encoding.dynamic_size."
                  % string CamlinternalFormatBasics.End_of_format)))
          "Cannot merge two %s with variable length. You should wrap one of them with Data_encoding.dynamic_size."
            % string) name
    end.
  
  Definition merge (k1 : t) (k2 : t) : t :=
    match (k1, k2) with
    | (Fixed n1, Fixed n2) =>
      (* ❌ Variants not supported *)
      variant
    | (Fixed _, Fixed _) =>
      (* ❌ Variants not supported *)
      variant
    | (Dynamic, Dynamic) | (Fixed _, Dynamic) | (Dynamic, Fixed _) =>
      (* ❌ Variants not supported *)
      variant
    |
      (Variable, Dynamic | Fixed _) | (Dynamic | Fixed _, Variable) |
        (Variable, Variable) =>
      (* ❌ Variants not supported *)
      variant
    end.
  
  Definition merge_list
    (sz : Tezos_data_encoding.Binary_size.tag_size)
    (function_parameter : list t) : t :=
    match function_parameter with
    | [] =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | cons k ks =>
      match Stdlib.List.fold_left merge k ks with
      | Fixed n =>
        (* ❌ Variants not supported *)
        variant
      | k => k
      end
    end.
End Kind.

Inductive case_tag : Type :=
| Tag : Z -> case_tag
| Json_only : case_tag.

Inductive desc : forall (a : Type), Type :=
| Null : desc unit
| Empty : desc unit
| Ignore : desc unit
| Constant : string -> desc unit
| Bool : desc bool
| Int8 : desc Z
| Uint8 : desc Z
| Int16 : desc Z
| Uint16 : desc Z
| Int31 : desc Z
| Int32 : desc Stdlib.Int32.t
| Int64 : desc Stdlib.Int64.t
| N : desc Z.t
| Z : desc Z.t
| RangedInt : Z -> Z -> desc Z
| RangedFloat : Z -> Z -> desc Z
| Float : desc Z
| Bytes : Kind.length -> desc Stdlib.Bytes.t
| String : Kind.length -> desc string
| Padded : forall {a : Type}, (t a) -> Z -> desc a
| String_enum : forall {a : Type}, (Stdlib.Hashtbl.t a (string * Z)) ->
  (array a) -> desc a
| Array : forall {a : Type}, (option Z) -> (t a) -> desc (array a)
| List : forall {a : Type}, (option Z) -> (t a) -> desc (list a)
| Obj : forall {a : Type}, (field a) -> desc a
| Objs : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Tup : forall {a : Type}, (t a) -> desc a
| Tups : forall {a b : Type}, Kind.t -> (t a) -> (t b) -> desc (a * b)
| Union : forall {a : Type}, Kind.t -> Tezos_data_encoding.Binary_size.tag_size
  -> (list (case a)) -> desc a
| Mu : forall {a : Type}, Kind.enum -> string -> (option string) ->
  (option string) -> ((t a) -> t a) -> desc a
| Conv : forall {a b : Type}, (a -> b) -> (b -> a) -> (t b) ->
  (option Json_schema.schema) -> desc a
| Describe : forall {a : Type}, string -> (option string) -> (option string) ->
  (t a) -> desc a
| Splitted : forall {a : Type}, (t a) -> (Json_encoding.encoding a) -> bool ->
  bool -> desc a
| Dynamic_size : forall {a : Type},
  Tezos_data_encoding.Binary_size.unsigned_integer -> (t a) -> desc a
| Check_size : forall {a : Type}, Z -> (t a) -> desc a
| Delayed : forall {a : Type}, (unit -> t a) -> desc a

with field : forall (_ : Type), Type :=
| Req : forall {a : Type}, string -> (t a) -> (option string) -> (option string)
  -> field a
| Opt : forall {a : Type}, string -> Kind.enum -> (t a) -> (option string) ->
  (option string) -> field (option a)
| Dft : forall {a : Type}, string -> (t a) -> a -> (option string) ->
  (option string) -> field a

with case : forall (a : Type), Type :=
| Case : forall {a t : Type}, string -> (option string) -> (t a) ->
  (t -> option a) -> (a -> t) -> case_tag -> case t.

Definition encoding (a : Type) := t a.

Fixpoint classify {a : Type} (e : t a) : Kind.t := classify_desc (encoding e)

with classify_desc {a : Type} (e : desc a) : Kind.t :=
  match e with
  | Null =>
    (* ❌ Variants not supported *)
    variant
  | Empty =>
    (* ❌ Variants not supported *)
    variant
  | Constant _ =>
    (* ❌ Variants not supported *)
    variant
  | Bool =>
    (* ❌ Variants not supported *)
    variant
  | Int8 =>
    (* ❌ Variants not supported *)
    variant
  | Uint8 =>
    (* ❌ Variants not supported *)
    variant
  | Int16 =>
    (* ❌ Variants not supported *)
    variant
  | Uint16 =>
    (* ❌ Variants not supported *)
    variant
  | Int31 =>
    (* ❌ Variants not supported *)
    variant
  | Int32 =>
    (* ❌ Variants not supported *)
    variant
  | Int64 =>
    (* ❌ Variants not supported *)
    variant
  | N =>
    (* ❌ Variants not supported *)
    variant
  | Z =>
    (* ❌ Variants not supported *)
    variant
  | RangedInt {| minimum := minimum; maximum := maximum |} =>
    (* ❌ Variants not supported *)
    variant
  | Float =>
    (* ❌ Variants not supported *)
    variant
  | RangedFloat _ =>
    (* ❌ Variants not supported *)
    variant
  | Bytes kind => kind
  | String kind => kind
  | Padded {| encoding := encoding |} n =>
    match classify_desc encoding with
    | Fixed m =>
      (* ❌ Variants not supported *)
      variant
    | _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end
  | String_enum _ cases =>
    (* ❌ Variants not supported *)
    variant
  | Obj (Opt {| kind := kind |}) => kind
  | Objs {| kind := kind |} => kind
  | Tups {| kind := kind |} => kind
  | Union {| kind := kind |} => kind
  | Mu {| kind := kind |} => kind
  | Ignore =>
    (* ❌ Variants not supported *)
    variant
  | Array _ _ =>
    (* ❌ Variants not supported *)
    variant
  | List _ _ =>
    (* ❌ Variants not supported *)
    variant
  | Obj (Req {| encoding := encoding |}) => classify encoding
  | Obj (Dft {| encoding := encoding |}) => classify encoding
  | Tup encoding => classify encoding
  | Conv {| encoding := encoding |} => classify encoding
  | Describe {| encoding := encoding |} => classify encoding
  | Splitted {| encoding := encoding |} => classify encoding
  | Dynamic_size _ =>
    (* ❌ Variants not supported *)
    variant
  | Check_size {| encoding := encoding |} => classify encoding
  | Delayed f => classify (f tt)
  end.

Definition make {A : Type}
  (json_encoding : option (Json_encoding.encoding A)) (encoding : desc A)
  : t A := {| encoding := encoding; json_encoding := json_encoding |}.

Module Fixed.
  Definition string (n : Z) : t string :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.le n 0 then
        OCaml.Stdlib.invalid_arg
          "Cannot create a string encoding of negative or null fixed length." %
            string
      else
        tt in
    apply
      (let arg := make in
      fun eta => arg None eta)
      (String
        (* ❌ Variants not supported *)
        variant).
  
  Definition bytes (n : Z) : t Stdlib.Bytes.t :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.le n 0 then
        OCaml.Stdlib.invalid_arg
          "Cannot create a byte encoding of negative or null fixed length." %
            string
      else
        tt in
    apply
      (let arg := make in
      fun eta => arg None eta)
      (Bytes
        (* ❌ Variants not supported *)
        variant).
  
  Definition add_padding {A : Type} (e : t A) (n : Z) : t A :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.le n 0 then
        OCaml.Stdlib.invalid_arg
          "Cannot create a padding of negative or null fixed length." % string
      else
        tt in
    match classify e with
    | Fixed _ =>
      apply
        (let arg := make in
        fun eta => arg None eta) (Padded e n)
    | _ =>
      OCaml.Stdlib.invalid_arg "Cannot pad non-fixed size encoding" % string
    end.
End Fixed.

Fixpoint is_zeroable {t : Type} (e : encoding t) : bool :=
  match encoding e with
  | Null => true
  | Empty => true
  | Ignore => true
  | Constant _ => true
  | Bool => false
  | Int8 => false
  | Uint8 => false
  | Int16 => false
  | Uint16 => false
  | Int31 => false
  | Int32 => false
  | Int64 => false
  | N => false
  | Z => false
  | RangedInt _ => false
  | RangedFloat _ => false
  | Float => false
  | Bytes _ => false
  | String _ => false
  | Padded _ _ => false
  | String_enum _ _ => false
  | Array _ _ => true
  | List _ _ => true
  | Obj (Req {| encoding := e |}) => is_zeroable e
  | Obj (Opt {| kind := Variable |}) => true
  | Obj (Dft {| encoding := e |}) => is_zeroable e
  | Obj _ => false
  | Objs {| left := left; right := right |} =>
    andb (is_zeroable left) (is_zeroable right)
  | Tup e => is_zeroable e
  | Tups {| left := left; right := right |} =>
    andb (is_zeroable left) (is_zeroable right)
  | Union _ => false
  | Mu {| kind := Dynamic |} => false
  | Mu {| kind := Variable; fix := fix |} => is_zeroable (fix e)
  | Conv {| encoding := encoding |} => is_zeroable encoding
  | Describe {| encoding := encoding |} => is_zeroable encoding
  | Splitted {| encoding := encoding |} => is_zeroable encoding
  | Check_size {| encoding := encoding |} => is_zeroable encoding
  | Delayed f => is_zeroable (f tt)
  | Dynamic_size _ => false
  end.

Module Variable.
  Definition string : t string :=
    apply
      (let arg := make in
      fun eta => arg None eta)
      (String
        (* ❌ Variants not supported *)
        variant).
  
  Definition bytes : t Stdlib.Bytes.t :=
    apply
      (let arg := make in
      fun eta => arg None eta)
      (Bytes
        (* ❌ Variants not supported *)
        variant).
  
  Definition check_not_variable {A : Type} (name : string) (e : t A) : unit :=
    match classify e with
    | Variable =>
      Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot insert variable length element in " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                ". You should wrap the contents using Data_encoding.dynamic_size."
                  % string CamlinternalFormatBasics.End_of_format)))
          "Cannot insert variable length element in %s. You should wrap the contents using Data_encoding.dynamic_size."
            % string) name
    | Dynamic | Fixed _ => tt
    end.
  
  Definition check_not_zeroable {A : Type} (name : string) (e : encoding A)
    : unit :=
    if is_zeroable e then
      Printf.ksprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot insert potentially zero-sized element in " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                CamlinternalFormatBasics.End_of_format)))
          "Cannot insert potentially zero-sized element in %s." % string) name
    else
      tt.
  
  Definition array {A : Type} (max_length : option Z) (e : encoding A)
    : t (array A) :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_not_variable "an array" % string e in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_not_zeroable "an array" % string e in
    let encoding :=
      apply
        (let arg := make in
        fun eta => arg None eta) (Array max_length e) in
    match ((classify e), max_length) with
    | (Fixed n, Some max_length) =>
      let limit := Z.mul n max_length in
      apply
        (let arg := make in
        fun eta => arg None eta)
        (Check_size {| limit := limit; encoding := encoding |})
    | (_, _) => encoding
    end.
  
  Definition list {A : Type} (max_length : option Z) (e : encoding A)
    : t (list A) :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_not_variable "a list" % string e in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_not_zeroable "a list" % string e in
    let encoding :=
      apply
        (let arg := make in
        fun eta => arg None eta) (List max_length e) in
    match ((classify e), max_length) with
    | (Fixed n, Some max_length) =>
      let limit := Z.mul n max_length in
      apply
        (let arg := make in
        fun eta => arg None eta)
        (Check_size {| limit := limit; encoding := encoding |})
    | (_, _) => encoding
    end.
End Variable.

Definition dynamic_size {A : Type}
  (op_staroptstar : option Tezos_data_encoding.Binary_size.unsigned_integer)
  : (t A) -> t A :=
  let kind :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun e =>
    apply
      (let arg := make in
      fun eta => arg None eta) (Dynamic_size {| kind := kind; encoding := e |}).

Definition check_size {A : Type} (limit : Z) (encoding : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Check_size {| limit := limit; encoding := encoding |}).

Definition delayed {A : Type} (f : unit -> t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Delayed f).

Definition null : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) Null.

Definition empty : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) Empty.

Definition unit : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) Ignore.

Definition constant (s : string) : t unit :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Constant s).

Definition bool : t bool :=
  apply
    (let arg := make in
    fun eta => arg None eta) Bool.

Definition int8 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int8.

Definition uint8 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Uint8.

Definition int16 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int16.

Definition uint16 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Uint16.

Definition int31 : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int31.

Definition int32 : t Stdlib.Int32.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int32.

Definition ranged_int (minimum : Z) (maximum : Z) : t Z :=
  let minimum : Z :=
    OCaml.Stdlib.min minimum maximum
  with maximum : Z :=
    OCaml.Stdlib.max minimum maximum in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      orb (OCaml.Stdlib.lt minimum (Z.opp (Z.shiftl 1 30)))
        (OCaml.Stdlib.lt (Z.sub (Z.shiftl 1 30) 1) maximum) then
      OCaml.Stdlib.invalid_arg "Data_encoding.ranged_int" % string
    else
      tt in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (RangedInt {| minimum := minimum; maximum := maximum |}).

Definition ranged_float (minimum : Z) (maximum : Z) : t Z :=
  let minimum : Z :=
    OCaml.Stdlib.min minimum maximum
  with maximum : Z :=
    OCaml.Stdlib.max minimum maximum in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (RangedFloat {| minimum := minimum; maximum := maximum |}).

Definition int64 : t Stdlib.Int64.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) Int64.

Definition n : t Z.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) N.

Definition z : t Z.t :=
  apply
    (let arg := make in
    fun eta => arg None eta) Z.

Definition float : t Z :=
  apply
    (let arg := make in
    fun eta => arg None eta) Float.

Definition string : t string := dynamic_size None Variable.string.

Definition bytes : t Stdlib.Bytes.t := dynamic_size None Variable.bytes.

Definition array {A : Type} (max_length : option Z) (e : encoding A)
  : t (array A) := dynamic_size None (Variable.array max_length e).

Definition list {A : Type} (max_length : option Z) (e : encoding A)
  : t (list A) := dynamic_size None (Variable.list max_length e).

Definition string_enum {A : Type} (function_parameter : list (string * A))
  : t A :=
  match function_parameter with
  | [] =>
    OCaml.Stdlib.invalid_arg
      "data_encoding.string_enum: cannot have zero cases" % string
  | cons _case [] =>
    OCaml.Stdlib.invalid_arg
      "data_encoding.string_enum: cannot have a single case, use constant instead"
        % string
  | (cons _ _) as cases =>
    let arr := Array.of_list (List.map snd cases) in
    let tbl := Hashtbl.create None (Array.length arr) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Stdlib.List.iteri
        (fun ind =>
          fun function_parameter =>
            let '(str, a) := function_parameter in
            Hashtbl.add tbl a (str, ind)) cases in
    apply
      (let arg := make in
      fun eta => arg None eta) (String_enum tbl arr)
  end.

Definition conv {A B : Type}
  (proj : A -> B) (inj : B -> A) (schema : option Json_schema.schema)
  (encoding : t B) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Conv {| proj := proj; inj := inj; encoding := encoding; schema := schema |}).

Definition def {A : Type}
  (id : string) (title : option string) (description : option string)
  (encoding : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Describe
      {| id := id; title := title; description := description;
        encoding := encoding |}).

Definition req {A : Type}
  (title : option string) (description : option string) (n : string) (t : t A)
  : field A :=
  Req {| name := n; encoding := t; title := title; description := description |}.

Definition opt {A : Type}
  (title : option string) (description : option string) (n : string)
  (encoding : t A) : field (option A) :=
  let kind :=
    match classify encoding with
    | Variable =>
      (* ❌ Variants not supported *)
      variant
    | Fixed _ | Dynamic =>
      (* ❌ Variants not supported *)
      variant
    end in
  Opt
    {| name := n; kind := kind; encoding := encoding; title := title;
      description := description |}.

Definition varopt {A : Type}
  (title : option string) (description : option string) (n : string)
  (encoding : t A) : field (option A) :=
  Opt
    {| name := n;
      kind :=
        (* ❌ Variants not supported *)
        variant; encoding := encoding; title := title;
      description := description |}.

Definition dft {A : Type}
  (title : option string) (description : option string) (n : string) (t : t A)
  (d : A) : field A :=
  Dft
    {| name := n; encoding := t; default := d; title := title;
      description := description |}.

Definition raw_splitted {A : Type}
  (json : Json_encoding.encoding A) (binary : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Splitted
      {| encoding := binary; json_encoding := json; is_obj := false;
        is_tup := false |}).

Fixpoint is_obj {a : Type} (e : t a) : bool :=
  match encoding e with
  | Obj _ => true
  | Objs _ => true
  | Conv {| encoding := e |} => is_obj e
  | Dynamic_size {| encoding := e |} => is_obj e
  | Union {| cases := cases |} =>
    Stdlib.List.for_all
      (fun function_parameter =>
        let 'Case {| encoding := e |} := function_parameter in
        is_obj e) cases
  | Empty => true
  | Ignore => true
  | Mu {| fix := fix |} => is_obj (fix e)
  | Splitted {| is_obj := is_obj |} => is_obj
  | Delayed f => is_obj (f tt)
  | Describe {| encoding := encoding |} => is_obj encoding
  | _ => false
  end.

Fixpoint is_tup {a : Type} (e : t a) : bool :=
  match encoding e with
  | Tup _ => true
  | Tups _ => true
  | Conv {| encoding := e |} => is_tup e
  | Dynamic_size {| encoding := e |} => is_tup e
  | Union {| cases := cases |} =>
    Stdlib.List.for_all
      (fun function_parameter =>
        let 'Case {| encoding := e |} := function_parameter in
        is_tup e) cases
  | Mu {| fix := fix |} => is_tup (fix e)
  | Splitted {| is_tup := is_tup |} => is_tup
  | Delayed f => is_tup (f tt)
  | Describe {| encoding := encoding |} => is_tup encoding
  | _ => false
  end.

Definition raw_merge_objs {A B : Type} (left : t A) (right : t B) : t (A * B) :=
  let kind := Kind.combine "objects" % string (classify left) (classify right)
    in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Objs {| kind := kind; left := left; right := right |}).

Definition obj1 {A : Type} (f1 : field A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Obj f1).

Definition obj2 {A B : Type} (f2 : field A) (f1 : field B) : t (A * B) :=
  raw_merge_objs (obj1 f2) (obj1 f1).

Definition obj3 {A B C : Type} (f3 : field A) (f2 : field B) (f1 : field C)
  : t (A * (B * C)) := raw_merge_objs (obj1 f3) (obj2 f2 f1).

Definition obj4 {A B C D : Type}
  (f4 : field A) (f3 : field B) (f2 : field C) (f1 : field D)
  : t ((A * B) * (C * D)) := raw_merge_objs (obj2 f4 f3) (obj2 f2 f1).

Definition obj5 {A B C D E : Type}
  (f5 : field A) (f4 : field B) (f3 : field C) (f2 : field D) (f1 : field E)
  : t (A * ((B * C) * (D * E))) := raw_merge_objs (obj1 f5) (obj4 f4 f3 f2 f1).

Definition obj6 {A B C D E F : Type}
  (f6 : field A) (f5 : field B) (f4 : field C) (f3 : field D) (f2 : field E)
  (f1 : field F) : t ((A * B) * ((C * D) * (E * F))) :=
  raw_merge_objs (obj2 f6 f5) (obj4 f4 f3 f2 f1).

Definition obj7 {A B C D E F G : Type}
  (f7 : field A) (f6 : field B) (f5 : field C) (f4 : field D) (f3 : field E)
  (f2 : field F) (f1 : field G) : t ((A * (B * C)) * ((D * E) * (F * G))) :=
  raw_merge_objs (obj3 f7 f6 f5) (obj4 f4 f3 f2 f1).

Definition obj8 {A B C D E F G H : Type}
  (f8 : field A) (f7 : field B) (f6 : field C) (f5 : field D) (f4 : field E)
  (f3 : field F) (f2 : field G) (f1 : field H)
  : t (((A * B) * (C * D)) * ((E * F) * (G * H))) :=
  raw_merge_objs (obj4 f8 f7 f6 f5) (obj4 f4 f3 f2 f1).

Definition obj9 {A B C D E F G H I : Type}
  (f9 : field A) (f8 : field B) (f7 : field C) (f6 : field D) (f5 : field E)
  (f4 : field F) (f3 : field G) (f2 : field H) (f1 : field I)
  : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))) :=
  raw_merge_objs (obj1 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition obj10 {A B C D E F G H I J : Type}
  (f10 : field A) (f9 : field B) (f8 : field C) (f7 : field D) (f6 : field E)
  (f5 : field F) (f4 : field G) (f3 : field H) (f2 : field I) (f1 : field J)
  : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))) :=
  raw_merge_objs (obj2 f10 f9) (obj8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition merge_objs {A B : Type} (o1 : t A) (o2 : t B) : t (A * B) :=
  if andb (is_obj o1) (is_obj o2) then
    raw_merge_objs o1 o2
  else
    OCaml.Stdlib.invalid_arg "Json_encoding.merge_objs" % string.

Definition raw_merge_tups {A B : Type} (left : t A) (right : t B) : t (A * B) :=
  let kind := Kind.combine "tuples" % string (classify left) (classify right) in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Tups {| kind := kind; left := left; right := right |}).

Definition tup1 {A : Type} (e1 : t A) : t A :=
  apply
    (let arg := make in
    fun eta => arg None eta) (Tup e1).

Definition tup2 {A B : Type} (e2 : t A) (e1 : t B) : t (A * B) :=
  raw_merge_tups (tup1 e2) (tup1 e1).

Definition tup3 {A B C : Type} (e3 : t A) (e2 : t B) (e1 : t C)
  : t (A * (B * C)) := raw_merge_tups (tup1 e3) (tup2 e2 e1).

Definition tup4 {A B C D : Type} (e4 : t A) (e3 : t B) (e2 : t C) (e1 : t D)
  : t ((A * B) * (C * D)) := raw_merge_tups (tup2 e4 e3) (tup2 e2 e1).

Definition tup5 {A B C D E : Type}
  (e5 : t A) (e4 : t B) (e3 : t C) (e2 : t D) (e1 : t E)
  : t (A * ((B * C) * (D * E))) := raw_merge_tups (tup1 e5) (tup4 e4 e3 e2 e1).

Definition tup6 {A B C D E F : Type}
  (e6 : t A) (e5 : t B) (e4 : t C) (e3 : t D) (e2 : t E) (e1 : t F)
  : t ((A * B) * ((C * D) * (E * F))) :=
  raw_merge_tups (tup2 e6 e5) (tup4 e4 e3 e2 e1).

Definition tup7 {A B C D E F G : Type}
  (e7 : t A) (e6 : t B) (e5 : t C) (e4 : t D) (e3 : t E) (e2 : t F) (e1 : t G)
  : t ((A * (B * C)) * ((D * E) * (F * G))) :=
  raw_merge_tups (tup3 e7 e6 e5) (tup4 e4 e3 e2 e1).

Definition tup8 {A B C D E F G H : Type}
  (e8 : t A) (e7 : t B) (e6 : t C) (e5 : t D) (e4 : t E) (e3 : t F) (e2 : t G)
  (e1 : t H) : t (((A * B) * (C * D)) * ((E * F) * (G * H))) :=
  raw_merge_tups (tup4 e8 e7 e6 e5) (tup4 e4 e3 e2 e1).

Definition tup9 {A B C D E F G H I : Type}
  (e9 : t A) (e8 : t B) (e7 : t C) (e6 : t D) (e5 : t E) (e4 : t F) (e3 : t G)
  (e2 : t H) (e1 : t I) : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))) :=
  raw_merge_tups (tup1 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1).

Definition tup10 {A B C D E F G H I J : Type}
  (e10 : t A) (e9 : t B) (e8 : t C) (e7 : t D) (e6 : t E) (e5 : t F) (e4 : t G)
  (e3 : t H) (e2 : t I) (e1 : t J)
  : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))) :=
  raw_merge_tups (tup2 e10 e9) (tup8 e8 e7 e6 e5 e4 e3 e2 e1).

Definition merge_tups {A B : Type} (t1 : t A) (t2 : t B) : t (A * B) :=
  if andb (is_tup t1) (is_tup t2) then
    raw_merge_tups t1 t2
  else
    OCaml.Stdlib.invalid_arg "Tezos_serial.Encoding.merge_tups" % string.

Definition conv3 {A B C : Type} (ty : t (A * (B * C))) : t (A * B * C) :=
  conv
    (fun function_parameter =>
      let '(c, b, a) := function_parameter in
      (c, (b, a)))
    (fun function_parameter =>
      let '(c, (b, a)) := function_parameter in
      (c, b, a)) None ty.

Definition obj3 {A B C : Type} (f3 : field A) (f2 : field B) (f1 : field C)
  : t (A * B * C) := conv3 (obj3 f3 f2 f1).

Definition tup3 {A B C : Type} (f3 : t A) (f2 : t B) (f1 : t C)
  : t (A * B * C) := conv3 (tup3 f3 f2 f1).

Definition conv4 {A B C D : Type} (ty : t ((A * B) * (C * D)))
  : t (A * B * C * D) :=
  conv
    (fun function_parameter =>
      let '(d, c, b, a) := function_parameter in
      ((d, c), (b, a)))
    (fun function_parameter =>
      let '((d, c), (b, a)) := function_parameter in
      (d, c, b, a)) None ty.

Definition obj4 {A B C D : Type}
  (f4 : field A) (f3 : field B) (f2 : field C) (f1 : field D)
  : t (A * B * C * D) := conv4 (obj4 f4 f3 f2 f1).

Definition tup4 {A B C D : Type} (f4 : t A) (f3 : t B) (f2 : t C) (f1 : t D)
  : t (A * B * C * D) := conv4 (tup4 f4 f3 f2 f1).

Definition conv5 {A B C D E : Type} (ty : t (A * ((B * C) * (D * E))))
  : t (A * B * C * D * E) :=
  conv
    (fun function_parameter =>
      let '(e, d, c, b, a) := function_parameter in
      (e, ((d, c), (b, a))))
    (fun function_parameter =>
      let '(e, ((d, c), (b, a))) := function_parameter in
      (e, d, c, b, a)) None ty.

Definition obj5 {A B C D E : Type}
  (f5 : field A) (f4 : field B) (f3 : field C) (f2 : field D) (f1 : field E)
  : t (A * B * C * D * E) := conv5 (obj5 f5 f4 f3 f2 f1).

Definition tup5 {A B C D E : Type}
  (f5 : t A) (f4 : t B) (f3 : t C) (f2 : t D) (f1 : t E)
  : t (A * B * C * D * E) := conv5 (tup5 f5 f4 f3 f2 f1).

Definition conv6 {A B C D E F : Type} (ty : t ((A * B) * ((C * D) * (E * F))))
  : t (A * B * C * D * E * F) :=
  conv
    (fun function_parameter =>
      let '(f, e, d, c, b, a) := function_parameter in
      ((f, e), ((d, c), (b, a))))
    (fun function_parameter =>
      let '((f, e), ((d, c), (b, a))) := function_parameter in
      (f, e, d, c, b, a)) None ty.

Definition obj6 {A B C D E F : Type}
  (f6 : field A) (f5 : field B) (f4 : field C) (f3 : field D) (f2 : field E)
  (f1 : field F) : t (A * B * C * D * E * F) := conv6 (obj6 f6 f5 f4 f3 f2 f1).

Definition tup6 {A B C D E F : Type}
  (f6 : t A) (f5 : t B) (f4 : t C) (f3 : t D) (f2 : t E) (f1 : t F)
  : t (A * B * C * D * E * F) := conv6 (tup6 f6 f5 f4 f3 f2 f1).

Definition conv7 {A B C D E F G : Type}
  (ty : t ((A * (B * C)) * ((D * E) * (F * G))))
  : t (A * B * C * D * E * F * G) :=
  conv
    (fun function_parameter =>
      let '(g, f, e, d, c, b, a) := function_parameter in
      ((g, (f, e)), ((d, c), (b, a))))
    (fun function_parameter =>
      let '((g, (f, e)), ((d, c), (b, a))) := function_parameter in
      (g, f, e, d, c, b, a)) None ty.

Definition obj7 {A B C D E F G : Type}
  (f7 : field A) (f6 : field B) (f5 : field C) (f4 : field D) (f3 : field E)
  (f2 : field F) (f1 : field G) : t (A * B * C * D * E * F * G) :=
  conv7 (obj7 f7 f6 f5 f4 f3 f2 f1).

Definition tup7 {A B C D E F G : Type}
  (f7 : t A) (f6 : t B) (f5 : t C) (f4 : t D) (f3 : t E) (f2 : t F) (f1 : t G)
  : t (A * B * C * D * E * F * G) := conv7 (tup7 f7 f6 f5 f4 f3 f2 f1).

Definition conv8 {A B C D E F G H : Type}
  (ty : t (((A * B) * (C * D)) * ((E * F) * (G * H))))
  : t (A * B * C * D * E * F * G * H) :=
  conv
    (fun function_parameter =>
      let '(h, g, f, e, d, c, b, a) := function_parameter in
      (((h, g), (f, e)), ((d, c), (b, a))))
    (fun function_parameter =>
      let '(((h, g), (f, e)), ((d, c), (b, a))) := function_parameter in
      (h, g, f, e, d, c, b, a)) None ty.

Definition obj8 {A B C D E F G H : Type}
  (f8 : field A) (f7 : field B) (f6 : field C) (f5 : field D) (f4 : field E)
  (f3 : field F) (f2 : field G) (f1 : field H)
  : t (A * B * C * D * E * F * G * H) := conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition tup8 {A B C D E F G H : Type}
  (f8 : t A) (f7 : t B) (f6 : t C) (f5 : t D) (f4 : t E) (f3 : t F) (f2 : t G)
  (f1 : t H) : t (A * B * C * D * E * F * G * H) :=
  conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1).

Definition conv9 {A B C D E F G H I : Type}
  (ty : t (A * (((B * C) * (D * E)) * ((F * G) * (H * I)))))
  : t (A * B * C * D * E * F * G * H * I) :=
  conv
    (fun function_parameter =>
      let '(i, h, g, f, e, d, c, b, a) := function_parameter in
      (i, (((h, g), (f, e)), ((d, c), (b, a)))))
    (fun function_parameter =>
      let '(i, (((h, g), (f, e)), ((d, c), (b, a)))) := function_parameter in
      (i, h, g, f, e, d, c, b, a)) None ty.

Definition obj9 {A B C D E F G H I : Type}
  (f9 : field A) (f8 : field B) (f7 : field C) (f6 : field D) (f5 : field E)
  (f4 : field F) (f3 : field G) (f2 : field H) (f1 : field I)
  : t (A * B * C * D * E * F * G * H * I) :=
  conv9 (obj9 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition tup9 {A B C D E F G H I : Type}
  (f9 : t A) (f8 : t B) (f7 : t C) (f6 : t D) (f5 : t E) (f4 : t F) (f3 : t G)
  (f2 : t H) (f1 : t I) : t (A * B * C * D * E * F * G * H * I) :=
  conv9 (tup9 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition conv10 {A B C D E F G H I J : Type}
  (ty : t ((A * B) * (((C * D) * (E * F)) * ((G * H) * (I * J)))))
  : t (A * B * C * D * E * F * G * H * I * J) :=
  conv
    (fun function_parameter =>
      let '(j, i, h, g, f, e, d, c, b, a) := function_parameter in
      ((j, i), (((h, g), (f, e)), ((d, c), (b, a)))))
    (fun function_parameter =>
      let '((j, i), (((h, g), (f, e)), ((d, c), (b, a)))) := function_parameter
        in
      (j, i, h, g, f, e, d, c, b, a)) None ty.

Definition obj10 {A B C D E F G H I J : Type}
  (f10 : field A) (f9 : field B) (f8 : field C) (f7 : field D) (f6 : field E)
  (f5 : field F) (f4 : field G) (f3 : field H) (f2 : field I) (f1 : field J)
  : t (A * B * C * D * E * F * G * H * I * J) :=
  conv10 (obj10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition tup10 {A B C D E F G H I J : Type}
  (f10 : t A) (f9 : t B) (f8 : t C) (f7 : t D) (f6 : t E) (f5 : t F) (f4 : t G)
  (f3 : t H) (f2 : t I) (f1 : t J)
  : t (A * B * C * D * E * F * G * H * I * J) :=
  conv10 (tup10 f10 f9 f8 f7 f6 f5 f4 f3 f2 f1).

Definition check_cases {A : Type} (tag_size : variant) (cases : list (case A))
  : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if equiv_decb cases [] then
      OCaml.Stdlib.invalid_arg
        "Data_encoding.union: empty list of cases." % string
    else
      tt in
  let max_tag :=
    match tag_size with
    | Uint8 => 256
    | Uint16 => Z.mul 256 256
    end in
  apply OCaml.Stdlib.ignore
    (Stdlib.List.fold_left
      (fun others =>
        fun function_parameter =>
          let 'Case {| tag := tag |} := function_parameter in
          match tag with
          | Json_only => others
          | Tag tag =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if Stdlib.List.mem tag others then
                Format.kasprintf OCaml.Stdlib.invalid_arg
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "The tag " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " appears twice in an union." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "The tag %d appears twice in an union." % string) tag
              else
                tt in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if orb (OCaml.Stdlib.lt tag 0) (OCaml.Stdlib.le max_tag tag) then
                Format.kasprintf OCaml.Stdlib.invalid_arg
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "The tag " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " is invalid." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "The tag %d is invalid." % string) tag
              else
                tt in
            cons tag others
          end) [] cases).

Definition union {A : Type}
  (op_staroptstar : option Tezos_data_encoding.Binary_size.tag_size)
  : (list (case A)) -> t A :=
  let tag_size :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun cases =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := check_cases tag_size cases in
    let kinds :=
      List.map
        (fun function_parameter =>
          let 'Case {| encoding := encoding |} := function_parameter in
          classify encoding) cases in
    let kind := Kind.merge_list tag_size kinds in
    apply
      (let arg := make in
      fun eta => arg None eta)
      (Union {| kind := kind; tag_size := tag_size; cases := cases |}).

Definition case {A B : Type}
  (title : string) (description : option string) (tag : case_tag)
  (encoding : t A) (proj : B -> option A) (inj : A -> B) : case B :=
  Case
    {| title := title; description := description; encoding := encoding;
      proj := proj; inj := inj; tag := tag |}.

Fixpoint is_nullable {t : Type} (e : encoding t) : bool :=
  match encoding e with
  | Null => true
  | Empty => false
  | Ignore => true
  | Constant _ => false
  | Bool => false
  | Int8 => false
  | Uint8 => false
  | Int16 => false
  | Uint16 => false
  | Int31 => false
  | Int32 => false
  | Int64 => false
  | N => false
  | Z => false
  | RangedInt _ => false
  | RangedFloat _ => false
  | Float => false
  | Bytes _ => false
  | String _ => false
  | Padded e _ => is_nullable e
  | String_enum _ _ => false
  | Array _ _ => false
  | List _ _ => false
  | Obj _ => false
  | Objs _ => false
  | Tup _ => false
  | Tups _ => false
  | Union {| cases := cases |} =>
    Stdlib.List._exists
      (fun function_parameter =>
        let 'Case {| encoding := e |} := function_parameter in
        is_nullable e) cases
  | Mu {| fix := fix |} => is_nullable (fix e)
  | Conv {| encoding := e |} => is_nullable e
  | Describe {| encoding := e |} => is_nullable e
  | Splitted {| json_encoding := json_encoding |} =>
    Json_encoding.is_nullable json_encoding
  | Dynamic_size {| encoding := e |} => is_nullable e
  | Check_size {| encoding := e |} => is_nullable e
  | Delayed _ => true
  end.

Definition option {A : Type} (ty : encoding A) : t (option A) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if is_nullable ty then
      OCaml.Stdlib.invalid_arg
        "Data_encoding.option: cannot nest nullable encodings" % string
    else
      tt in
  union
    (Some
      (* ❌ Variants not supported *)
      variant)
    (cons (case "Some" % string None (Tag 1) ty (fun x => x) (fun x => Some x))
      (cons
        (case "None" % string None (Tag 0) null
          (fun function_parameter =>
            match function_parameter with
            | None => Some tt
            | Some _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            None)) [])).

Definition mu {A : Type}
  (name : string) (title : option string) (description : option string)
  (fix : (t A) -> t A) : t A :=
  let kind :=
    (* ❌ Try-with are not handled *)
    try
      (let precursor :=
        apply
          (let arg := make in
          fun eta => arg None eta)
          (Mu
            {|
              kind :=
                (* ❌ Variants not supported *)
                variant; name := name; title := title;
              description := description; fix := fix |}) in
      match apply classify (fix precursor) with
      | Fixed _ | Dynamic =>
        (* ❌ Variants not supported *)
        variant
      | Variable => Stdlib.raise Exit
      end) in
  apply
    (let arg := make in
    fun eta => arg None eta)
    (Mu
      {| kind := kind; name := name; title := title; description := description;
        fix := fix |}).

Definition result {A B : Type} (ok_enc : t A) (error_enc : t B) : t (sum A B) :=
  union
    (Some
      (* ❌ Variants not supported *)
      variant)
    (cons
      (case "Ok" % string None (Tag 1) ok_enc
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok x => Some x
          | Stdlib.Error _ => None
          end) (fun x => Stdlib.Ok x))
      (cons
        (case "Result" % string None (Tag 0) error_enc
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok _ => None
            | Stdlib.Error x => Some x
            end) (fun x => Stdlib.Error x)) [])).

src/lib_data_encoding/json.ml 33 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type json =
  [ `O of (string * json) list
  | `Bool of bool
  | `Float of float
  | `A of json list
  | `Null
  | `String of string ]

type schema = Json_schema.schema

type pair_builder = {
  build :
    'a 'b. Encoding.Kind.t -> 'a Encoding.t -> 'b Encoding.t ->
    ('a * 'b) Encoding.t;
}

exception Parse_error of string

let wrap_error f str =
  try f str with exn -> raise (Json_encoding.Cannot_destruct ([], exn))

let int64_encoding =
  let open Json_encoding in
  def
    "int64"
    ~title:"64 bit integers"
    ~description:"Decimal representation of 64 bit integers"
  @@ conv Int64.to_string (wrap_error Int64.of_string) string

let n_encoding =
  let open Json_encoding in
  def
    "positive_bignum"
    ~title:"Positive big number"
    ~description:"Decimal representation of a positive big number"
  @@ conv
       (fun z ->
         if Z.sign z < 0 then invalid_arg "negative natural" ;
         Z.to_string z)
       (fun s ->
         let n = Z.of_string s in
         if Z.sign n < 0 then
           raise
             (Json_encoding.Cannot_destruct ([], Failure "negative natural")) ;
         n)
       string

let z_encoding =
  let open Json_encoding in
  def
    "bignum"
    ~title:"Big number"
    ~description:"Decimal representation of a big number"
  @@ conv Z.to_string Z.of_string string

let bytes_jsont =
  let open Json_encoding in
  let schema =
    let open Json_schema in
    create
      {
        title = None;
        description = None;
        default = None;
        enum = None;
        kind =
          String
            {
              pattern = Some "^[a-zA-Z0-9]+$";
              min_length = 0;
              max_length = None;
            };
        format = None;
        id = None;
      }
  in
  conv
    ~schema
    Hex.of_bytes
    (wrap_error Hex.to_bytes)
    (conv (fun (`Hex h) -> h) (fun h -> `Hex h) string)

let check_utf8 s =
  Uutf.String.fold_utf_8
    (fun valid _pos -> function `Uchar _ -> valid | `Malformed _ -> false)
    true
    s

let raw_string_encoding =
  let open Json_encoding in
  let utf8_case =
    case string (fun s -> if check_utf8 s then Some s else None) (fun s -> s)
  in
  let obj_case =
    case
      (obj1
         (req
            "invalid_utf8_string"
            (array (ranged_int ~minimum:0 ~maximum:255 "byte"))))
      (fun s -> Some (Array.init (String.length s) (fun i -> Char.code s.[i])))
      (fun a -> String.init (Array.length a) (fun i -> Char.chr a.(i)))
  in
  def
    "unistring"
    ~title:"Universal string representation"
    ~description:
      "Either a plain UTF8 string, or a sequence of bytes for strings that \
       contain invalid byte sequences."
    (union [utf8_case; obj_case])

let rec lift_union : type a. a Encoding.t -> a Encoding.t =
 fun e ->
  let open Encoding in
  match e.encoding with
  | Conv {proj; inj; encoding = e; schema} -> (
    match lift_union e with
    | {encoding = Union {kind; tag_size; cases}; _} ->
        make
        @@ Union
             {
               kind;
               tag_size;
               cases =
                 List.map
                   (fun (Case
                          { title;
                            description;
                            encoding;
                            proj = proj';
                            inj = inj';
                            tag }) ->
                     Case
                       {
                         encoding;
                         title;
                         description;
                         proj = (fun x -> proj' (proj x));
                         inj = (fun x -> inj (inj' x));
                         tag;
                       })
                   cases;
             }
    | e ->
        make @@ Conv {proj; inj; encoding = e; schema} )
  | Objs {kind; left; right} ->
      lift_union_in_pair
        {build = (fun kind left right -> make @@ Objs {kind; left; right})}
        kind
        left
        right
  | Tups {kind; left; right} ->
      lift_union_in_pair
        {build = (fun kind left right -> make @@ Tups {kind; left; right})}
        kind
        left
        right
  | _ ->
      e

and lift_union_in_pair :
    type a b.
    pair_builder ->
    Encoding.Kind.t ->
    a Encoding.t ->
    b Encoding.t ->
    (a * b) Encoding.t =
 fun b p e1 e2 ->
  let open Encoding in
  match (lift_union e1, lift_union e2) with
  | (e1, {encoding = Union {tag_size; cases; _}; _}) ->
      make
      @@ Union
           {
             kind = `Dynamic (* ignored *);
             tag_size;
             cases =
               List.map
                 (fun (Case
                        {title; description; encoding = e2; proj; inj; tag}) ->
                   Case
                     {
                       encoding = lift_union_in_pair b p e1 e2;
                       title;
                       description;
                       proj =
                         (fun (x, y) ->
                           match proj y with
                           | None ->
                               None
                           | Some y ->
                               Some (x, y));
                       inj = (fun (x, y) -> (x, inj y));
                       tag;
                     })
                 cases;
           }
  | ({encoding = Union {tag_size; cases; _}; _}, e2) ->
      make
      @@ Union
           {
             kind = `Dynamic (* ignored *);
             tag_size;
             cases =
               List.map
                 (fun (Case
                        {title; description; encoding = e1; proj; inj; tag}) ->
                   Case
                     {
                       encoding = lift_union_in_pair b p e1 e2;
                       title;
                       description;
                       proj =
                         (fun (x, y) ->
                           match proj x with
                           | None ->
                               None
                           | Some x ->
                               Some (x, y));
                       inj = (fun (x, y) -> (inj x, y));
                       tag;
                     })
                 cases;
           }
  | (e1, e2) ->
      b.build p e1 e2

let rec json : type a. a Encoding.desc -> a Json_encoding.encoding =
  let open Encoding in
  let open Json_encoding in
  function
  | Null ->
      null
  | Empty ->
      empty
  | Constant s ->
      constant s
  | Ignore ->
      unit
  | Int8 ->
      ranged_int ~minimum:~-(1 lsl 7) ~maximum:((1 lsl 7) - 1) "int8"
  | Uint8 ->
      ranged_int ~minimum:0 ~maximum:((1 lsl 8) - 1) "uint8"
  | Int16 ->
      ranged_int ~minimum:~-(1 lsl 15) ~maximum:((1 lsl 15) - 1) "int16"
  | Uint16 ->
      ranged_int ~minimum:0 ~maximum:((1 lsl 16) - 1) "uint16"
  | RangedInt {minimum; maximum} ->
      ranged_int ~minimum ~maximum "rangedInt"
  | Int31 ->
      int
  | Int32 ->
      int32
  | Int64 ->
      int64_encoding
  | N ->
      n_encoding
  | Z ->
      z_encoding
  | Bool ->
      bool
  | Float ->
      float
  | RangedFloat {minimum; maximum} ->
      ranged_float ~minimum ~maximum "rangedFloat"
  | String (`Fixed expected) ->
      let check s =
        let found = String.length s in
        if found <> expected then
          raise
            (Cannot_destruct
               ( [],
                 Unexpected
                   ( Format.asprintf "string (len %d)" found,
                     Format.asprintf "string (len %d)" expected ) )) ;
        s
      in
      conv check check raw_string_encoding
  | String _ ->
      raw_string_encoding
  | Padded (e, _) ->
      get_json e
  | Bytes (`Fixed expected) ->
      let check s =
        let found = Bytes.length s in
        if found <> expected then
          raise
            (Cannot_destruct
               ( [],
                 Unexpected
                   ( Format.asprintf "string (len %d)" found,
                     Format.asprintf "string (len %d)" expected ) )) ;
        s
      in
      conv check check bytes_jsont
  | Bytes _ ->
      bytes_jsont
  | String_enum (tbl, _) ->
      string_enum (Hashtbl.fold (fun a (str, _) acc -> (str, a) :: acc) tbl [])
  | Array (_, e) ->
      array (get_json e) (* FIXME TODO enforce max_length *)
  | List (_, e) ->
      list (get_json e)
  | Obj f ->
      obj1 (field_json f)
  | Objs {left; right; _} ->
      merge_objs (get_json left) (get_json right)
  | Tup e ->
      tup1 (get_json e)
  | Tups {left; right; _} ->
      merge_tups (get_json left) (get_json right)
  | Conv {proj; inj; encoding = e; schema} ->
      conv ?schema proj inj (get_json e)
  | Describe {id; title; description; encoding = e} ->
      def id ?title ?description (get_json e)
  | Mu {name; fix; _} as ty ->
      mu name (fun json_encoding -> get_json @@ fix (make ~json_encoding ty))
  | Union {cases; _} ->
      union (List.map case_json cases)
  | Splitted {json_encoding; _} ->
      json_encoding
  | Dynamic_size {encoding = e; _} ->
      get_json e
  | Check_size {encoding; _} ->
      get_json encoding
  | Delayed f ->
      get_json (f ())

and field_json : type a. a Encoding.field -> a Json_encoding.field =
  let open Json_encoding in
  function
  | Encoding.Req {name; encoding = e; _} ->
      req name (get_json e)
  | Encoding.Opt {name; encoding = e; _} ->
      opt name (get_json e)
  | Encoding.Dft {name; encoding = e; default = d; _} ->
      dft name (get_json e) d

and case_json : type a. a Encoding.case -> a Json_encoding.case =
  let open Json_encoding in
  function
  | Encoding.Case {encoding = e; proj; inj; _} -> case (get_json e) proj inj

and get_json : type a. a Encoding.t -> a Json_encoding.encoding =
 fun e ->
  match e.json_encoding with
  | None ->
      let json_encoding = json (lift_union e).encoding in
      e.json_encoding <- Some json_encoding ;
      json_encoding
  | Some json_encoding ->
      json_encoding

let convert = get_json

type path = path_item list

and path_item =
  [ `Field of string  (** A field in an object. *)
  | `Index of int  (** An index in an array. *)
  | `Star  (** Any / every field or index. *)
  | `Next  (** The next element after an array. *) ]

include Json_encoding

let construct e v = construct (get_json e) v

let destruct e v = destruct (get_json e) v

let schema ?definitions_path e = schema ?definitions_path (get_json e)

let cannot_destruct fmt =
  Format.kasprintf (fun msg -> raise (Cannot_destruct ([], Failure msg))) fmt

type t = json

let to_string ?(newline = false) ?minify j =
  Format.asprintf
    "%a%s"
    Json_repr.(pp ?compact:minify (module Ezjsonm))
    j
    (if newline then "\n" else "")

let pp = Json_repr.(pp (module Ezjsonm))

let from_string s =
  match Ezjsonm.from_string ("[" ^ s ^ "]") with
  | exception Ezjsonm.Parse_error (_, msg) ->
      Error msg
  | `A [json] ->
      Ok json
  | _ ->
      Error "Malformed value"

let from_stream (stream : string Lwt_stream.t) =
  let buffer = ref "" in
  Lwt_stream.filter_map
    (fun str ->
      buffer := !buffer ^ str ;
      try
        let json = Ezjsonm.from_string !buffer in
        buffer := "" ;
        Some (Ok json)
      with Ezjsonm.Parse_error _ -> None)
    stream

let encoding =
  let binary : Json_repr.ezjsonm Encoding.t =
    Encoding.conv
      (fun json ->
        Json_repr.convert
          (module Json_repr.Ezjsonm)
          (module Json_repr_bson.Repr)
          json
        |> Json_repr_bson.bson_to_bytes |> Bytes.to_string)
      (fun s ->
        try
          Bytes.of_string s
          |> Json_repr_bson.bytes_to_bson ~copy:false
          |> Json_repr.convert
               (module Json_repr_bson.Repr)
               (module Json_repr.Ezjsonm)
        with Json_repr_bson.Bson_decoding_error (msg, _, _) ->
          raise (Parse_error msg))
      Encoding.string
  in
  let json = Json_encoding.any_ezjson_value in
  Encoding.raw_splitted ~binary ~json

let schema_encoding =
  Encoding.conv Json_schema.to_json Json_schema.of_json encoding
src/lib_data_encoding/json.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json := variant.

Definition schema := Json_schema.schema.

Record pair_builder := {
  build :
    (Tezos_data_encoding.Encoding.Kind.t ->
      (Tezos_data_encoding.Encoding.t a) ->
        (Tezos_data_encoding.Encoding.t b) ->
          Tezos_data_encoding.Encoding.t (a * b)) * (a * b) }.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition wrap_error {A B : Type} (f : A -> B) (str : A) : B :=
  (* ❌ Try-with are not handled *)
  try (f str).

Definition int64_encoding : Json_encoding.encoding int64 :=
  apply
    (def "int64" % string (Some "64 bit integers" % string)
      (Some "Decimal representation of 64 bit integers" % string))
    (conv Int64.to_string (wrap_error Int64.of_string) None string).

Definition n_encoding : Json_encoding.encoding Z.t :=
  apply
    (def "positive_bignum" % string (Some "Positive big number" % string)
      (Some "Decimal representation of a positive big number" % string))
    (conv
      (fun z =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if OCaml.Stdlib.lt (Z.sign z) 0 then
            OCaml.Stdlib.invalid_arg "negative natural" % string
          else
            tt in
        Z.to_string z)
      (fun s =>
        let n := Z.of_string s in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if OCaml.Stdlib.lt (Z.sign n) 0 then
            Stdlib.raise
              (Cannot_destruct ([], (OCaml.Failure "negative natural" % string)))
          else
            tt in
        n) None string).

Definition z_encoding : Json_encoding.encoding Z.t :=
  apply
    (def "bignum" % string (Some "Big number" % string)
      (Some "Decimal representation of a big number" % string))
    (conv Z.to_string Z.of_string None string).

Definition bytes_jsont : Json_encoding.encoding string :=
  let schema :=
    create
      {| title := None; description := None; default := None; enum := None;
        kind :=
          Json_schema.String
            {| pattern := Some "^[a-zA-Z0-9]+$" % string; min_length := 0;
              max_length := None |}; format := None; id := None |} in
  conv
    (let arg := Hex.of_bytes in
    fun eta => arg None eta) (wrap_error Hex.to_bytes) (Some schema)
    (conv
      (fun function_parameter =>
        let 'Hex h := function_parameter in
        h)
      (fun h =>
        (* ❌ Variants not supported *)
        variant) None string).

Definition check_utf8 (s : string) : bool :=
  Uutf.String.fold_utf_8 None None
    (fun valid =>
      fun _pos =>
        fun function_parameter =>
          match function_parameter with
          | Uchar _ => valid
          | Malformed _ => false
          end) true s.

Definition raw_string_encoding : Json_encoding.encoding string :=
  let utf8_case :=
    case string
      (fun s =>
        if check_utf8 s then
          Some s
        else
          None) (fun s => s) in
  let obj_case :=
    case
      (obj1
        (req None None "invalid_utf8_string" % string
          (array (ranged_int 0 255 "byte" % string))))
      (fun s =>
        Some
          (Array.init (OCaml.String.length s)
            (fun i => Char.code (Stdlib.String.get s i))))
      (fun a =>
        Stdlib.String.init (Array.length a) (fun i => Char.chr (Array.get a i)))
    in
  def "unistring" % string (Some "Universal string representation" % string)
    (Some
      "Either a plain UTF8 string, or a sequence of bytes for strings that contain invalid byte sequences."
        % string) (union (cons utf8_case (cons obj_case []))).

Fixpoint lift_union {a : Type} (e : Tezos_data_encoding.Encoding.t a)
  : Tezos_data_encoding.Encoding.t a :=
  match encoding e with
  |
    Tezos_data_encoding.Encoding.Conv {|
      proj := proj; inj := inj; encoding := e; schema := schema |} =>
    match lift_union e with
    | {|
      encoding :=
        Tezos_data_encoding.Encoding.Union {|
          kind := kind; tag_size := tag_size; cases := cases |}
        |} =>
      apply
        (let arg := make in
        fun eta => arg None eta)
        (Tezos_data_encoding.Encoding.Union
          {| kind := kind; tag_size := tag_size;
            cases :=
              List.map
                (fun function_parameter =>
                  let
                    'Tezos_data_encoding.Encoding.Case {|
                      title := title;
                        description := description;
                        encoding := encoding;
                        proj := proj';
                        inj := inj';
                        tag := tag
                        |} := function_parameter in
                  Tezos_data_encoding.Encoding.Case
                    {| title := title; description := description;
                      encoding := encoding; proj := fun x => proj' (proj x);
                      inj := fun x => inj (inj' x); tag := tag |}) cases |})
    | e =>
      apply
        (let arg := make in
        fun eta => arg None eta)
        (Tezos_data_encoding.Encoding.Conv
          {| proj := proj; inj := inj; encoding := e; schema := schema |})
    end
  |
    Tezos_data_encoding.Encoding.Objs {|
      kind := kind; left := left; right := right |} =>
    lift_union_in_pair
      {|
        build :=
          fun kind =>
            fun left =>
              fun right =>
                apply
                  (let arg := make in
                  fun eta => arg None eta)
                  (Tezos_data_encoding.Encoding.Objs
                    {| kind := kind; left := left; right := right |}) |} kind
      left right
  |
    Tezos_data_encoding.Encoding.Tups {|
      kind := kind; left := left; right := right |} =>
    lift_union_in_pair
      {|
        build :=
          fun kind =>
            fun left =>
              fun right =>
                apply
                  (let arg := make in
                  fun eta => arg None eta)
                  (Tezos_data_encoding.Encoding.Tups
                    {| kind := kind; left := left; right := right |}) |} kind
      left right
  | _ => e
  end

with lift_union_in_pair {a b : Type}
  (b : pair_builder) (p : Tezos_data_encoding.Encoding.Kind.t)
  (e1 : Tezos_data_encoding.Encoding.t a)
  (e2 : Tezos_data_encoding.Encoding.t b)
  : Tezos_data_encoding.Encoding.t (a * b) :=
  match ((lift_union e1), (lift_union e2)) with
  |
    (e1, {|
      encoding :=
        Tezos_data_encoding.Encoding.Union {|
          tag_size := tag_size; cases := cases |}
        |}) =>
    apply
      (let arg := make in
      fun eta => arg None eta)
      (Tezos_data_encoding.Encoding.Union
        {|
          kind :=
            (* ❌ Variants not supported *)
            variant; tag_size := tag_size;
          cases :=
            List.map
              (fun function_parameter =>
                let
                  'Tezos_data_encoding.Encoding.Case {|
                    title := title;
                      description := description;
                      encoding := e2;
                      proj := proj;
                      inj := inj;
                      tag := tag
                      |} := function_parameter in
                Tezos_data_encoding.Encoding.Case
                  {| title := title; description := description;
                    encoding := lift_union_in_pair b p e1 e2;
                    proj :=
                      fun function_parameter =>
                        let '(x, y) := function_parameter in
                        match proj y with
                        | None => None
                        | Some y => Some (x, y)
                        end;
                    inj :=
                      fun function_parameter =>
                        let '(x, y) := function_parameter in
                        (x, (inj y)); tag := tag |}) cases |})
  |
    ({|
      encoding :=
        Tezos_data_encoding.Encoding.Union {|
          tag_size := tag_size; cases := cases |}
        |}, e2) =>
    apply
      (let arg := make in
      fun eta => arg None eta)
      (Tezos_data_encoding.Encoding.Union
        {|
          kind :=
            (* ❌ Variants not supported *)
            variant; tag_size := tag_size;
          cases :=
            List.map
              (fun function_parameter =>
                let
                  'Tezos_data_encoding.Encoding.Case {|
                    title := title;
                      description := description;
                      encoding := e1;
                      proj := proj;
                      inj := inj;
                      tag := tag
                      |} := function_parameter in
                Tezos_data_encoding.Encoding.Case
                  {| title := title; description := description;
                    encoding := lift_union_in_pair b p e1 e2;
                    proj :=
                      fun function_parameter =>
                        let '(x, y) := function_parameter in
                        match proj x with
                        | None => None
                        | Some x => Some (x, y)
                        end;
                    inj :=
                      fun function_parameter =>
                        let '(x, y) := function_parameter in
                        ((inj x), y); tag := tag |}) cases |})
  | (e1, e2) => (build b) p e1 e2
  end.

Fixpoint json {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.desc a)
  : Json_encoding.encoding a :=
  match function_parameter with
  | Tezos_data_encoding.Encoding.Null => null
  | Tezos_data_encoding.Encoding.Empty => empty
  | Tezos_data_encoding.Encoding.Constant s => constant s
  | Tezos_data_encoding.Encoding.Ignore => unit
  | Tezos_data_encoding.Encoding.Int8 =>
    ranged_int (Z.opp (Z.shiftl 1 7)) (Z.sub (Z.shiftl 1 7) 1) "int8" % string
  | Tezos_data_encoding.Encoding.Uint8 =>
    ranged_int 0 (Z.sub (Z.shiftl 1 8) 1) "uint8" % string
  | Tezos_data_encoding.Encoding.Int16 =>
    ranged_int (Z.opp (Z.shiftl 1 15)) (Z.sub (Z.shiftl 1 15) 1)
      "int16" % string
  | Tezos_data_encoding.Encoding.Uint16 =>
    ranged_int 0 (Z.sub (Z.shiftl 1 16) 1) "uint16" % string
  |
    Tezos_data_encoding.Encoding.RangedInt {|
      minimum := minimum; maximum := maximum |} =>
    ranged_int minimum maximum "rangedInt" % string
  | Tezos_data_encoding.Encoding.Int31 => int
  | Tezos_data_encoding.Encoding.Int32 => int32
  | Tezos_data_encoding.Encoding.Int64 => int64_encoding
  | Tezos_data_encoding.Encoding.N => n_encoding
  | Tezos_data_encoding.Encoding.Z => z_encoding
  | Tezos_data_encoding.Encoding.Bool => bool
  | Tezos_data_encoding.Encoding.Float => float
  |
    Tezos_data_encoding.Encoding.RangedFloat {|
      minimum := minimum; maximum := maximum |} =>
    ranged_float minimum maximum "rangedFloat" % string
  | Tezos_data_encoding.Encoding.String (Fixed expected) =>
    let check (s : string) : string :=
      let found := OCaml.String.length s in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb found expected then
          Stdlib.raise
            (Cannot_destruct
              ([],
                (Unexpected
                  (Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "string (len " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))
                      "string (len %d)" % string) found)
                  (Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "string (len " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))
                      "string (len %d)" % string) expected))))
        else
          tt in
      s in
    conv check check None raw_string_encoding
  | Tezos_data_encoding.Encoding.String _ => raw_string_encoding
  | Tezos_data_encoding.Encoding.Padded e _ => get_json e
  | Tezos_data_encoding.Encoding.Bytes (Fixed expected) =>
    let check (s : string) : string :=
      let found := String.length s in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb found expected then
          Stdlib.raise
            (Cannot_destruct
              ([],
                (Unexpected
                  (Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "string (len " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))
                      "string (len %d)" % string) found)
                  (Format.asprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "string (len " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))
                      "string (len %d)" % string) expected))))
        else
          tt in
      s in
    conv check check None bytes_jsont
  | Tezos_data_encoding.Encoding.Bytes _ => bytes_jsont
  | Tezos_data_encoding.Encoding.String_enum tbl _ =>
    string_enum
      (Hashtbl.fold
        (fun a =>
          fun function_parameter =>
            let '(str, _) := function_parameter in
            fun acc => cons (str, a) acc) tbl [])
  | Tezos_data_encoding.Encoding.Array _ e => array (get_json e)
  | Tezos_data_encoding.Encoding.List _ e => list (get_json e)
  | Tezos_data_encoding.Encoding.Obj f => obj1 (field_json f)
  | Tezos_data_encoding.Encoding.Objs {| left := left; right := right |} =>
    merge_objs (get_json left) (get_json right)
  | Tezos_data_encoding.Encoding.Tup e => tup1 (get_json e)
  | Tezos_data_encoding.Encoding.Tups {| left := left; right := right |} =>
    merge_tups (get_json left) (get_json right)
  |
    Tezos_data_encoding.Encoding.Conv {|
      proj := proj; inj := inj; encoding := e; schema := schema |} =>
    conv proj inj schema (get_json e)
  |
    Tezos_data_encoding.Encoding.Describe {|
      id := id; title := title; description := description; encoding := e |}
    => def id title description (get_json e)
  | (Tezos_data_encoding.Encoding.Mu {| name := name; fix := fix |}) as ty =>
    mu name None None
      (fun json_encoding => apply get_json (fix (make (Some json_encoding) ty)))
  | Tezos_data_encoding.Encoding.Union {| cases := cases |} =>
    union (List.map case_json cases)
  | Tezos_data_encoding.Encoding.Splitted {| json_encoding := json_encoding |}
    => json_encoding
  | Tezos_data_encoding.Encoding.Dynamic_size {| encoding := e |} => get_json e
  | Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
    get_json encoding
  | Tezos_data_encoding.Encoding.Delayed f => get_json (f tt)
  end

with field_json {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.field a)
  : Json_encoding.field a :=
  match function_parameter with
  | Tezos_data_encoding.Encoding.Req {| name := name; encoding := e |} =>
    req None None name (get_json e)
  | Tezos_data_encoding.Encoding.Opt {| name := name; encoding := e |} =>
    opt None None name (get_json e)
  |
    Tezos_data_encoding.Encoding.Dft {|
      name := name; encoding := e; default := d |} =>
    dft None None name (get_json e) d
  end

with case_json {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.case a)
  : Json_encoding.case a :=
  let
    'Tezos_data_encoding.Encoding.Case {|
      encoding := e; proj := proj; inj := inj |} := function_parameter in
  case (get_json e) proj inj

with get_json {a : Type} (e : Tezos_data_encoding.Encoding.t a)
  : Json_encoding.encoding a :=
  match json_encoding e with
  | None =>
    let json_encoding := json (encoding (lift_union e)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field e "json_encoding" % string (Some json_encoding) in
    json_encoding
  | Some json_encoding => json_encoding
  end.

Definition convert {A : Type}
  : (Tezos_data_encoding.Encoding.t A) -> Json_encoding.encoding A := get_json.

Reserved Notation "'path".
Reserved Notation "'path_item".



where "'path" := ( list 'path_item)

and "'path_item" := ( variant).

Definition path := 'path.
Definition path_item := 'path_item.

(* ❌ Structure item `include` not handled. *)
include

Definition construct {A : Type} (e : Tezos_data_encoding.Encoding.t A) (v : A)
  : Json_repr.ezjsonm := construct (get_json e) v.

Definition destruct {A : Type}
  (e : Tezos_data_encoding.Encoding.t A) (v : Json_repr.ezjsonm) : A :=
  destruct (get_json e) v.

Definition schema {A : Type}
  (definitions_path : option string) (e : Tezos_data_encoding.Encoding.t A)
  : Json_schema.schema := schema definitions_path (get_json e).

Definition cannot_destruct {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Format.kasprintf
    (fun msg => Stdlib.raise (Cannot_destruct ([], (OCaml.Failure msg)))) fmt.

Definition t := json.

Definition to_string (op_staroptstar : option bool)
  : (option bool) -> Json_repr.Ezjsonm.(Json_repr.Repr.value) -> string :=
  let newline :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun minify =>
    fun j =>
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) "%a%s" % string)
        (pp minify None Ezjsonm) j
        (if newline then
          "
" % string
        else
          "" % string).

Definition pp
  : Stdlib.Format.formatter -> Json_repr.Ezjsonm.(Json_repr.Repr.value) -> unit :=
  pp None None Ezjsonm.

Definition from_string (s : string) : sum Ezjsonm.value string :=
  match
    Ezjsonm.from_string
      (String.append "[" % string (String.append s "]" % string)) with
  | A (cons json []) => Stdlib.Ok json
  | _ => Stdlib.Error "Malformed value" % string
  end.

Definition from_stream {A : Type} (stream : Lwt_stream.t string)
  : Lwt_stream.t (sum variant A) :=
  let buffer := Stdlib.ref "" % string in
  Lwt_stream.filter_map
    (fun str =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq buffer
          (String.append (Stdlib.op_exclamation buffer) str) in
      (* ❌ Try-with are not handled *)
      try
        (let json := Ezjsonm.from_string (Stdlib.op_exclamation buffer) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Stdlib.op_coloneq buffer "" % string in
        Some (Stdlib.Ok json))) stream.

Definition encoding : Tezos_data_encoding.Encoding.encoding Json_repr.ezjsonm :=
  let binary :=
    Encoding.conv
      (fun json =>
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (Json_repr.convert Json_repr.Ezjsonm Json_repr_bson.Repr json)
            (let arg := Json_repr_bson.bson_to_bytes in
            fun eta => arg None None eta)) Stdlib.Bytes.to_string)
      (fun s =>
        (* ❌ Try-with are not handled *)
        try
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply (Stdlib.Bytes.of_string s)
              (let arg :=
                Json_repr_bson.bytes_to_bson
                  (* ❌ expected an argument *)
                  expected_argument
                  (* ❌ expected an argument *)
                  expected_argument
                  (* ❌ expected an argument *)
                  expected_argument false in
              fun eta => arg None None None eta))
            (Json_repr.convert Json_repr_bson.Repr Json_repr.Ezjsonm))) None
      Encoding.string in
  let json := Json_encoding.any_ezjson_value in
  Encoding.raw_splitted json binary.

Definition schema_encoding
  : Tezos_data_encoding.Encoding.encoding Json_schema.schema :=
  Encoding.conv Json_schema.to_json Json_schema.of_json None encoding.

src/lib_data_encoding/registration.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type id = string

type t =
  | Record : {
      encoding : 'a Encoding.t;
      description : string option;
      pp : (Format.formatter -> 'a -> unit) option;
    }
      -> t

module EncodingTable = Map.Make (String)

let table = ref EncodingTable.empty

let description (Record {description; _}) = description

let json_schema (Record {encoding; _}) =
  let json_schema = Json.schema encoding in
  json_schema

let binary_schema (Record {encoding; _}) =
  let binary_schema = Binary_description.describe encoding in
  binary_schema

let json_pretty_printer (Record {encoding; pp; _}) fmt json =
  match pp with
  | Some pp ->
      let json = Json.destruct encoding json in
      Format.fprintf fmt "%a" pp json
  | None ->
      Format.fprintf fmt "%a" Json.pp json

let binary_pretty_printer (Record {encoding; pp; _}) fmt bytes =
  let data = Binary_reader.of_bytes_exn encoding bytes in
  match pp with
  | Some pp ->
      Format.fprintf fmt "%a" pp data
  | None ->
      let json = Json.construct encoding data in
      Format.fprintf fmt "%a" Json.pp json

let rec lookup_id_descr ({encoding; _} : 'a Encoding.t) =
  match encoding with
  | Splitted {encoding; _}
  | Dynamic_size {encoding; _}
  | Check_size {encoding; _} ->
      lookup_id_descr encoding
  | Describe {id; description; _} ->
      Some (id, description)
  | _ ->
      None

let register ?pp encoding =
  match lookup_id_descr encoding with
  | None ->
      invalid_arg "Data_encoding.Registration.register: non def(in)ed encoding"
  | Some (id, description) ->
      table :=
        EncodingTable.update
          id
          (function
            | None ->
                let record = Record {encoding; description; pp} in
                Some record
            | Some _ ->
                Format.kasprintf
                  Pervasives.invalid_arg
                  "Encoding %s previously registered"
                  id)
          !table

let find id = EncodingTable.find_opt id !table

let list () = EncodingTable.bindings !table

let bytes_of_json (Record {encoding; _}) json =
  let data = Json.destruct encoding json in
  Binary_writer.to_bytes encoding data

let json_of_bytes (Record {encoding; _}) bytes =
  match Binary_reader.of_bytes encoding bytes with
  | Some v ->
      Some (Json.construct encoding v)
  | None ->
      None
src/lib_data_encoding/registration.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition id := string.

Inductive t : Type :=
| Record : forall {a : Type}, (Tezos_data_encoding.Encoding.t a) ->
  (option string) -> (option (Stdlib.Format.formatter -> a -> unit)) -> t.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition table : Stdlib.ref (EncodingTable.t t) :=
  Stdlib.ref EncodingTable.empty.

Definition description (function_parameter : t) : option string :=
  let 'Record {| description := description |} := function_parameter in
  description.

Definition json_schema (function_parameter : t)
  : Tezos_data_encoding.Json.schema :=
  let 'Record {| encoding := encoding |} := function_parameter in
  let json_schema := Json.schema None encoding in
  json_schema.

Definition binary_schema (function_parameter : t)
  : Tezos_data_encoding.Binary_schema.t :=
  let 'Record {| encoding := encoding |} := function_parameter in
  let binary_schema := Binary_description.describe encoding in
  binary_schema.

Definition json_pretty_printer (function_parameter : t)
  : Stdlib.Format.formatter -> Tezos_data_encoding.Json.json -> unit :=
  let 'Record {| encoding := encoding; pp := pp |} := function_parameter in
  fun fmt =>
    fun json =>
      match pp with
      | Some pp =>
        let json := Json.destruct encoding json in
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string) pp json
      | None =>
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string) Json.pp
          json
      end.

Definition binary_pretty_printer (function_parameter : t)
  : Stdlib.Format.formatter -> Stdlib.Bytes.t -> unit :=
  let 'Record {| encoding := encoding; pp := pp |} := function_parameter in
  fun fmt =>
    fun bytes =>
      let data := Binary_reader.of_bytes_exn encoding string in
      match pp with
      | Some pp =>
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string) pp data
      | None =>
        let json := Json.construct encoding data in
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string) Json.pp
          json
      end.

Fixpoint lookup_id_descr {a : Type}
  (function_parameter : Tezos_data_encoding.Encoding.t a)
  : option (string * (option string)) :=
  let '{| encoding := encoding |} := function_parameter in
  match encoding with
  |
    Tezos_data_encoding.Encoding.Splitted {| encoding := encoding |} |
      Tezos_data_encoding.Encoding.Dynamic_size {| encoding := encoding |} |
      Tezos_data_encoding.Encoding.Check_size {| encoding := encoding |} =>
    lookup_id_descr encoding
  |
    Tezos_data_encoding.Encoding.Describe {|
      id := id; description := description |} => Some (id, description)
  | _ => None
  end.

Definition register {A : Type}
  (pp : option (Stdlib.Format.formatter -> A -> unit))
  (encoding : Tezos_data_encoding.Encoding.t A) : unit :=
  match lookup_id_descr encoding with
  | None =>
    OCaml.Stdlib.invalid_arg
      "Data_encoding.Registration.register: non def(in)ed encoding" % string
  | Some (id, description) =>
    Stdlib.op_coloneq table
      (EncodingTable.update id
        (fun function_parameter =>
          match function_parameter with
          | None =>
            let record :=
              Record
                {| encoding := encoding; description := description; pp := pp |}
              in
            Some record
          | Some _ =>
            Format.kasprintf Pervasives.invalid_arg
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Encoding " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " previously registered" % string
                      CamlinternalFormatBasics.End_of_format)))
                "Encoding %s previously registered" % string) id
          end) (Stdlib.op_exclamation table))
  end.

Definition find (id : EncodingTable.key) : option t :=
  EncodingTable.find_opt id (Stdlib.op_exclamation table).

Definition list (function_parameter : unit) : list (EncodingTable.key * t) :=
  let 'tt := function_parameter in
  EncodingTable.bindings (Stdlib.op_exclamation table).

Definition bytes_of_json (function_parameter : t)
  : Tezos_data_encoding.Json.json -> option Stdlib.Bytes.t :=
  let 'Record {| encoding := encoding |} := function_parameter in
  fun json =>
    let data := Json.destruct encoding json in
    Binary_writer.to_bytes encoding data.

Definition json_of_bytes (function_parameter : t)
  : Stdlib.Bytes.t -> option Tezos_data_encoding.Json.json :=
  let 'Record {| encoding := encoding |} := function_parameter in
  fun bytes =>
    match Binary_reader.of_bytes encoding string with
    | Some v => Some (Json.construct encoding v)
    | None => None
    end.

src/lib_data_encoding/test/bench_data_encoding.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let bench ?(num_iterations = 1000) name thunk =
  Gc.full_major () ;
  Gc.compact () ;
  let start_time = Sys.time () in
  for _i = 0 to num_iterations - 1 do
    thunk ()
  done ;
  let end_time = Sys.time () in
  Format.printf
    "Benchmark: %s took %f for %d iterations.@."
    name
    (end_time -. start_time)
    num_iterations

let read_stream encoding bytes =
  let rec loop bytes status =
    match (bytes, status) with
    | ([], Data_encoding.Binary.Success _) ->
        ()
    | (bytes :: bytess, Await f) ->
        loop bytess (f bytes)
    | (_, _) ->
        assert false
  in
  loop bytes (Data_encoding.Binary.read_stream encoding)

let bench_all ?(num_iterations = 1000) name encoding value =
  bench
    ~num_iterations
    ("writing " ^ name ^ " json")
    (fun () ->
      ignore @@ Data_encoding.Json.to_string
      @@ Data_encoding.Json.construct encoding value) ;
  bench
    ~num_iterations
    ("writing " ^ name ^ " binary")
    (fun () -> ignore @@ Data_encoding.Binary.to_bytes_exn encoding value) ;
  let encoded_json =
    Data_encoding.Json.to_string @@ Data_encoding.Json.construct encoding value
  in
  bench
    ~num_iterations
    ("reading " ^ name ^ " json")
    (fun () ->
      ignore
        (Data_encoding.Json.destruct
           encoding
           (Ezjsonm.from_string encoded_json))) ;
  let encoded_binary = Data_encoding.Binary.to_bytes_exn encoding value in
  bench
    ~num_iterations
    ("reading " ^ name ^ " binary")
    (fun () -> ignore @@ Data_encoding.Binary.of_bytes encoding encoded_binary) ;
  bench
    ~num_iterations
    ("reading " ^ name ^ " streamed binary (one chunk)")
    (fun () -> read_stream encoding [encoded_binary]) ;
  bench
    ~num_iterations
    ("reading " ^ name ^ " streamed binary (small chunks)")
    (fun () -> read_stream encoding (Helpers.cut 1 encoded_binary)) ;
  ()

type t = A of string | B of bool | I of int | F of float | R of t * t

let cases_encoding : t Data_encoding.t =
  let open Data_encoding in
  mu "recursive" (fun recursive ->
      union
        [ case
            (Tag 0)
            ~title:"A"
            string
            (function A s -> Some s | _ -> None)
            (fun s -> A s);
          case
            (Tag 1)
            ~title:"B"
            bool
            (function B bool -> Some bool | _ -> None)
            (fun bool -> B bool);
          case
            (Tag 2)
            ~title:"I"
            int31
            (function I int -> Some int | _ -> None)
            (fun int -> I int);
          case
            (Tag 3)
            ~title:"F"
            float
            (function F float -> Some float | _ -> None)
            (fun float -> F float);
          case
            (Tag 4)
            ~title:"R"
            (obj2 (req "field1" recursive) (req "field2" recursive))
            (function R (a, b) -> Some (a, b) | _ -> None)
            (fun (a, b) -> R (a, b)) ])

let () =
  bench_all
    "10000_element_int_list"
    Data_encoding.(list int31)
    ~num_iterations:1000
    (Array.to_list (Array.make 10000 0)) ;
  bench_all
    "option_element_int_list"
    Data_encoding.(list (option int31))
    (Array.to_list (Array.make 10000 (Some 0))) ;
  let encoding = Data_encoding.(list (result (option int31) string)) in
  let value = Array.to_list (Array.make 10000 (Error "hello")) in
  bench_all "option_result_element_list" encoding value ;
  let encoding = Data_encoding.(list cases_encoding) in
  let value =
    Array.to_list (Array.make 1000 (R (R (A "asdf", B true), F 1.0)))
  in
  bench ~num_iterations:1000 "binary_encoding" (fun () ->
      ignore @@ Data_encoding.Binary.to_bytes encoding value) ;
  bench_all
    "binary_encoding_large_list"
    Data_encoding.(list cases_encoding)
    (Array.to_list (Array.make 2000 (R (R (A "asdf", B true), F 1.0))))
src/lib_data_encoding/test/bench_data_encoding.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition bench (op_staroptstar : option Z)
  : string -> (unit -> unit) -> unit :=
  let num_iterations :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 1000
    end in
  fun name =>
    fun thunk =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Gc.full_major tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Gc.compact tt in
      let start_time := Sys.time tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ For loops not handled. *)
        for in
      let end_time := Sys.time tt in
      Format.printf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Benchmark: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal " took " % string
                (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " for " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        " iterations." % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Flush_newline
                          CamlinternalFormatBasics.End_of_format))))))))
          "Benchmark: %s took %f for %d iterations.@." % string) name
        (Stdlib.op_minuspoint end_time start_time) num_iterations.

Definition read_stream {A : Type}
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (bytes : list Stdlib.Bytes.t) : unit :=
  let fix loop {B : Type}
    (bytes : list Stdlib.Bytes.t) (status :
    Tezos_data_encoding.Data_encoding.Binary.status B) : unit :=
    match (string, status) with
    | ([], Tezos_data_encoding.Data_encoding.Binary.Success _) => tt
    | (cons bytes bytess, Tezos_data_encoding.Data_encoding.Binary.Await f) =>
      loop bytess (f string)
    | (_, _) =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  loop string (Data_encoding.Binary.read_stream None encoding).

Definition bench_all {A : Type} (op_staroptstar : option Z)
  : string -> (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit :=
  let num_iterations :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 1000
    end in
  fun name =>
    fun encoding =>
      fun value =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          bench (Some num_iterations)
            (String.append "writing " % string
              (String.append name " json" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              apply OCaml.Stdlib.ignore
                (apply
                  (let arg := Data_encoding.Json.to_string in
                  fun eta => arg None None eta)
                  (Data_encoding.Json.construct encoding value))) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          bench (Some num_iterations)
            (String.append "writing " % string
              (String.append name " binary" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              apply OCaml.Stdlib.ignore
                (Data_encoding.Binary.to_bytes_exn encoding value)) in
        let encoded_json :=
          apply
            (let arg := Data_encoding.Json.to_string in
            fun eta => arg None None eta)
            (Data_encoding.Json.construct encoding value) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          bench (Some num_iterations)
            (String.append "reading " % string
              (String.append name " json" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              OCaml.Stdlib.ignore
                (Data_encoding.Json.destruct encoding
                  (Ezjsonm.from_string encoded_json))) in
        let encoded_binary := Data_encoding.Binary.to_bytes_exn encoding value
          in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          bench (Some num_iterations)
            (String.append "reading " % string
              (String.append name " binary" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              apply OCaml.Stdlib.ignore
                (Data_encoding.Binary.of_bytes encoding encoded_binary)) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          bench (Some num_iterations)
            (String.append "reading " % string
              (String.append name " streamed binary (one chunk)" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              read_stream encoding (cons encoded_binary [])) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          bench (Some num_iterations)
            (String.append "reading " % string
              (String.append name " streamed binary (small chunks)" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              read_stream encoding (op_startypeminuserrorstar 1 encoded_binary))
          in
        tt.

Inductive t : Type :=
| A : string -> t
| B : bool -> t
| I : Z -> t
| F : Z -> t
| R : t -> t -> t.

Definition cases_encoding : Tezos_data_encoding.Data_encoding.t t :=
  mu "recursive" % string None None
    (fun recursive =>
      union None
        (cons
          (case "A" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
            string
            (fun function_parameter =>
              match function_parameter with
              | A s => Some s
              | _ => None
              end) (fun s => A s))
          (cons
            (case "B" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
              bool
              (fun function_parameter =>
                match function_parameter with
                | B bool => Some bool
                | _ => None
                end) (fun bool => B bool))
            (cons
              (case "I" % string None (Tezos_data_encoding.Data_encoding.Tag 2)
                int31
                (fun function_parameter =>
                  match function_parameter with
                  | I int => Some Z
                  | _ => None
                  end) (fun int => I Z))
              (cons
                (case "F" % string None
                  (Tezos_data_encoding.Data_encoding.Tag 3) float
                  (fun function_parameter =>
                    match function_parameter with
                    | F float => Some Z
                    | _ => None
                    end) (fun float => F Z))
                (cons
                  (case "R" % string None
                    (Tezos_data_encoding.Data_encoding.Tag 4)
                    (obj2 (req None None "field1" % string recursive)
                      (req None None "field2" % string recursive))
                    (fun function_parameter =>
                      match function_parameter with
                      | R a b => Some (a, b)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let '(a, b) := function_parameter in
                      R a b)) [])))))).



src/lib_data_encoding/test/helpers.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

let cut ?(copy = false) sz bytes =
  let length = Bytes.length bytes in
  if length <= sz then [bytes] (* if the result fits in the given sz *)
  else
    let may_copy = if copy then Bytes.copy else fun t -> t in
    let nb_full = length / sz in
    (* nb of blocks of size sz *)
    let sz_full = nb_full * sz in
    (* size of the full part *)
    let acc =
      (* eventually init acc with a non-full block *)
      if sz_full = length then []
      else [may_copy (Bytes.sub bytes sz_full (length - sz_full))]
    in
    let rec split_full_blocks curr_upper_limit acc =
      let start = curr_upper_limit - sz in
      assert (start >= 0) ;
      (* copy the block [ start, curr_upper_limit [ of size sz *)
      let acc = may_copy (Bytes.sub bytes start sz) :: acc in
      if start = 0 then acc else split_full_blocks start acc
    in
    split_full_blocks sz_full acc

let no_exception f =
  try f () with
  | ( Json_encoding.Cannot_destruct _
    | Json_encoding.Unexpected _
    | Json_encoding.No_case_matched _
    | Json_encoding.Bad_array_size _
    | Json_encoding.Missing_field _
    | Json_encoding.Unexpected_field _
    | Json_encoding.Bad_schema _ ) as exn ->
      Alcotest.failf
        "@[v 2>json failed:@ %a@]"
        (fun ppf -> Json_encoding.print_error ppf)
        exn
  | Binary.Read_error error ->
      Alcotest.failf
        "@[v 2>bytes reading failed:@ %a@]"
        Binary.pp_read_error
        error
  | Binary.Write_error error ->
      Alcotest.failf
        "@[v 2>bytes writing failed:@ %a@]"
        Binary.pp_write_error
        error

let check_raises expected f =
  match f () with
  | exception exn when expected exn ->
      ()
  | exception exn ->
      Alcotest.failf "Unexpected exception: %s." (Printexc.to_string exn)
  | _ ->
      Alcotest.failf "Expecting exception, got success."

let chunked_read sz encoding bytes =
  let status =
    List.fold_left
      (fun status chunk ->
        match status with
        | Binary.Await f ->
            f chunk
        | Success _ when Bytes.length chunk <> 0 ->
            Error Extra_bytes
        | Success _ | Error _ ->
            status)
      (Binary.read_stream encoding)
      (cut sz bytes)
  in
  match status with
  | Success {stream; _} when not (Binary_stream.is_empty stream) ->
      Binary.Error Extra_bytes
  | _ ->
      status

let streamed_read encoding bytes =
  List.fold_left
    (fun ((status, count) as acc) chunk ->
      match status with
      | Binary.Await f ->
          (f chunk, succ count)
      | Success _ | Error _ ->
          acc)
    (Binary.read_stream encoding, 0)
    (cut 1 bytes)
src/lib_data_encoding/test/helpers.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition cut (op_staroptstar : option bool) : Z -> string -> list string :=
  let copy :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun sz =>
    fun bytes =>
      let length := String.length string in
      if OCaml.Stdlib.le length sz then
        cons string []
      else
        let may_copy :=
          if copy then
            Stdlib.Bytes.copy
          else
            fun t => t in
        let nb_full := Z.div length sz in
        let sz_full := Z.mul nb_full sz in
        let acc :=
          if equiv_decb sz_full length then
            []
          else
            cons (may_copy (String.sub string sz_full (Z.sub length sz_full)))
              [] in
        let fix split_full_blocks (curr_upper_limit : Z) (acc : list string)
          : list string :=
          let start := Z.sub curr_upper_limit sz in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (OCaml.Stdlib.ge start 0) in
          let acc := cons (may_copy (String.sub string start sz)) acc in
          if equiv_decb start 0 then
            acc
          else
            split_full_blocks start acc in
        split_full_blocks sz_full acc.

Definition no_exception {A : Type} (f : unit -> A) : A :=
  (* ❌ Try-with are not handled *)
  try (f tt).

Definition check_raises {A : Type} (expected : exn -> bool) (f : unit -> A)
  : unit :=
  let '_ := f tt in
  op_startypeminuserrorstar "Expecting exception, got success." % string.

Definition chunked_read {A : Type}
  (sz : Z) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (bytes : Stdlib.Bytes.t)
  : Tezos_data_encoding.Data_encoding.Binary.status A :=
  let status :=
    Stdlib.List.fold_left
      (fun status =>
        fun chunk =>
          match status with
          | Tezos_data_encoding.Data_encoding.Binary.Await f => f chunk
          | Tezos_data_encoding.Data_encoding.Binary.Success _ =>
            Tezos_data_encoding.Data_encoding.Binary.Error
              Tezos_data_encoding.Data_encoding.Binary.Extra_bytes
          |
            Tezos_data_encoding.Data_encoding.Binary.Success _ |
              Tezos_data_encoding.Data_encoding.Binary.Error _ => status
          end) (Binary.read_stream None encoding) (cut None sz string) in
  match status with
  | Tezos_data_encoding.Data_encoding.Binary.Success {| stream := stream |} =>
    Tezos_data_encoding.Data_encoding.Binary.Error
      Tezos_data_encoding.Data_encoding.Binary.Extra_bytes
  | _ => status
  end.

Definition streamed_read {A : Type}
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (bytes : Stdlib.Bytes.t)
  : (Tezos_data_encoding.Data_encoding.Binary.status A) * Z :=
  Stdlib.List.fold_left
    (fun function_parameter =>
      let '(status, count) as acc := function_parameter in
      fun chunk =>
        match status with
        | Tezos_data_encoding.Data_encoding.Binary.Await f =>
          ((f chunk), (Z.succ count))
        |
          Tezos_data_encoding.Data_encoding.Binary.Success _ |
            Tezos_data_encoding.Data_encoding.Binary.Error _ => acc
        end) ((Binary.read_stream None encoding), 0) (cut None 1 string).

src/lib_data_encoding/test/invalid_encoding.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding
open Helpers

let test ?(expected = fun _ -> true) name f =
  (name, `Quick, fun () -> check_raises expected f)

let tests =
  [ test "multi_variable_tup" (fun () -> tup2 Variable.string Variable.string);
    test "variable_in_list" (fun () -> list Variable.string);
    test "nested_option" (fun () -> option (option int8));
    test "merge_non_objs" (fun () -> merge_objs int8 string);
    test "empty_union" (fun () -> union []);
    test "duplicated_tag" (fun () ->
        union
          [ case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ());
            case (Tag 0) ~title:"" empty (fun () -> None) (fun () -> ()) ]);
    test "fixed_negative_size" (fun () -> Fixed.string ~-1);
    test "fixed_null_size" (fun () -> Fixed.bytes 0);
    test "array_null_size" (fun () -> Variable.list empty);
    test "list_null_size" (fun () -> Variable.list null);
    test "zeroable_in_list" (fun () -> list (obj1 (varopt "x" int8))) ]
src/lib_data_encoding/test/invalid_encoding.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition test {A B C D : Type} (op_staroptstar : option (A -> bool))
  : B -> C -> B * variant * (unit -> D) :=
  let expected :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        true
    end in
  fun name =>
    fun f =>
      (name,
        (* ❌ Variants not supported *)
        variant,
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar expected f)).

Definition tests {A : Type} : list (string * variant * (unit -> A)) :=
  cons
    (test None "multi_variable_tup" % string
      (fun function_parameter =>
        let 'tt := function_parameter in
        tup2 Variable.string Variable.string))
    (cons
      (test None "variable_in_list" % string
        (fun function_parameter =>
          let 'tt := function_parameter in
          list None Variable.string))
      (cons
        (test None "nested_option" % string
          (fun function_parameter =>
            let 'tt := function_parameter in
            option (option int8)))
        (cons
          (test None "merge_non_objs" % string
            (fun function_parameter =>
              let 'tt := function_parameter in
              merge_objs int8 string))
          (cons
            (test None "empty_union" % string
              (fun function_parameter =>
                let 'tt := function_parameter in
                union None []))
            (cons
              (test None "duplicated_tag" % string
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  union None
                    (cons
                      (case "" % string None
                        (Tezos_data_encoding.Data_encoding.Tag 0) empty
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          None)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          tt))
                      (cons
                        (case "" % string None
                          (Tezos_data_encoding.Data_encoding.Tag 0) empty
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            None)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            tt)) []))))
              (cons
                (test None "fixed_negative_size" % string
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Fixed.string (Z.opp 1)))
                (cons
                  (test None "fixed_null_size" % string
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Fixed.bytes 0))
                  (cons
                    (test None "array_null_size" % string
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Variable.list None empty))
                    (cons
                      (test None "list_null_size" % string
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Variable.list None null))
                      (cons
                        (test None "zeroable_in_list" % string
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            list None
                              (obj1 (varopt None None "x" % string int8)))) [])))))))))).

src/lib_data_encoding/test/randomized.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Various randomly generated data. *)

open Data_encoding

(** Generate encodings of the encoding and the randomized generator *)
let test_generator ?(iterations = 50) ty encoding generator =
  for _ = 0 to iterations - 1 do
    let value = generator () in
    Success.json ty encoding value () ;
    Success.bson ty encoding value () ;
    Success.binary ty encoding value () ;
    Success.stream ty encoding value ()
  done

let rec make_int_list acc len () =
  if len = 0 then acc
  else make_int_list (Random.int64 Int64.max_int :: acc) (len - 1) ()

let test_randomized_int_list () =
  test_generator Alcotest.(list int64) (list int64) (make_int_list [] 100)

let test_randomized_string_list () =
  test_generator
    Alcotest.(list string)
    (list string)
    (fun () -> List.map Int64.to_string (make_int_list [] 20 ()))

let test_randomized_variant_list () =
  test_generator
    Alcotest.(list (result (option string) string))
    (list (result (option string) (obj1 (req "failure" string))))
    (fun () ->
      List.map
        (fun x ->
          let str = Int64.to_string x in
          if Random.bool () then
            if Random.bool () then Ok (Some str) else Ok None
          else Error str)
        (make_int_list [] 20 ()))

let tests =
  [ ("int_list", `Quick, test_randomized_int_list);
    ("string_list", `Quick, test_randomized_string_list);
    ("variant_list", `Quick, test_randomized_variant_list) ]
src/lib_data_encoding/test/randomized.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition test_generator {A B C : Type} (op_staroptstar : option Z)
  : A -> B -> (unit -> C) -> unit :=
  let iterations :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 50
    end in
  fun ty =>
    fun encoding =>
      fun generator =>
        (* ❌ For loops not handled. *)
        for.

Fixpoint make_int_list
  (acc : list Stdlib.Int64.t) (len : Z) (function_parameter : unit)
  : list Stdlib.Int64.t :=
  let 'tt := function_parameter in
  if equiv_decb len 0 then
    acc
  else
    make_int_list (cons (Random.int64 Int64.max_int) acc) (Z.sub len 1) tt.

Definition test_randomized_int_list (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  test_generator None op_startypeminuserrorstar (list None int64)
    (make_int_list [] 100).

Definition test_randomized_string_list (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  test_generator None op_startypeminuserrorstar (list None string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      List.map Int64.to_string (make_int_list [] 20 tt)).

Definition test_randomized_variant_list (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  test_generator None op_startypeminuserrorstar
    (list None
      (result (option string) (obj1 (req None None "failure" % string string))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      List.map
        (fun x =>
          let str := Int64.to_string x in
          if Random.bool tt then
            if Random.bool tt then
              Stdlib.Ok (Some str)
            else
              Stdlib.Ok None
          else
            Stdlib.Error str) (make_int_list [] 20 tt)).

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("int_list" % string,
      (* ❌ Variants not supported *)
      variant, test_randomized_int_list)
    (cons
      ("string_list" % string,
        (* ❌ Variants not supported *)
        variant, test_randomized_string_list)
      (cons
        ("variant_list" % string,
          (* ❌ Variants not supported *)
          variant, test_randomized_variant_list) [])).

src/lib_data_encoding/test/success.ml 204 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Trivial back-and-forth test: a value is serialized, then
    unserialized and compared to the original value. All backend
    (json, bson, binary, and streamed binary) are tested for each of
    the basic encoding described here. No serialization or
    deserialization failure are expected in these tests. *)

(* TODO `varopt` ; `assoc` ; `Data_encoding.json` *)

open Data_encoding
open Helpers
open Types

let json ty encoding value () =
  no_exception (fun () ->
      let json = Json.construct encoding value in
      let result = Json.destruct encoding json in
      Alcotest.check ty "json" value result)

let bson ty encoding value () =
  no_exception (fun () ->
      let json = Bson.construct encoding value in
      let result = Bson.destruct encoding json in
      Alcotest.check ty "bson" value result)

let binary ty encoding value () =
  no_exception (fun () ->
      let bytes = Binary.to_bytes_exn encoding value in
      let result = Binary.of_bytes_exn encoding bytes in
      Alcotest.check ty "binary" value result)

let stream ty encoding value () =
  no_exception (fun () ->
      let bytes = Binary.to_bytes_exn encoding value in
      let len_data = Bytes.length bytes in
      for sz = 1 to max 1 len_data do
        let name = Format.asprintf "stream (%d)" sz in
        match chunked_read sz encoding bytes with
        | Binary.Success {result; size; stream} ->
            if
              size <> Bytes.length bytes || not (Binary_stream.is_empty stream)
            then Alcotest.failf "%s failed: remaining data" name ;
            Alcotest.check ty name value result
        | Binary.Await _ ->
            Alcotest.failf "%s failed: not enough data" name
        | Binary.Error error ->
            Alcotest.failf
              "@[<v 2>%s failed: read error@ %a@]"
              name
              Binary.pp_read_error
              error
      done)

let all name ty encoding value =
  let stream_encoding =
    match Data_encoding.classify encoding with
    | `Variable ->
        dynamic_size encoding
    | `Dynamic | `Fixed _ ->
        encoding
  in
  [ (name ^ ".json", `Quick, json ty encoding value);
    (name ^ ".bson", `Quick, bson ty encoding value);
    (name ^ ".binary", `Quick, binary ty encoding value);
    (name ^ ".binary_stream", `Quick, stream ty stream_encoding value) ]

let all_int encoding size =
  let name = Format.asprintf "int%d" size in
  all (name ^ ".min") Alcotest.int encoding ~-(1 lsl (size - 1))
  @ all (name ^ ".mean") Alcotest.int encoding 0
  @ all (name ^ ".max") Alcotest.int encoding ((1 lsl (size - 1)) - 1)

let all_uint encoding size =
  let name = Format.asprintf "uint%d" size in
  all (name ^ ".min") Alcotest.int encoding 0
  @ all (name ^ ".mean") Alcotest.int encoding (1 lsl (size - 1))
  @ all (name ^ ".max") Alcotest.int encoding ((1 lsl size) - 1)

let all_ranged_int minimum maximum =
  let encoding = ranged_int minimum maximum in
  let name = Format.asprintf "ranged_int.%d" minimum in
  all (name ^ ".min") Alcotest.int encoding minimum
  @ all (name ^ ".mean") Alcotest.int encoding ((minimum + maximum) / 2)
  @ all (name ^ ".max") Alcotest.int encoding maximum

let all_ranged_float minimum maximum =
  let encoding = ranged_float minimum maximum in
  let name = Format.asprintf "ranged_float.%f" minimum in
  all (name ^ ".min") Alcotest.float encoding minimum
  @ all (name ^ ".mean") Alcotest.float encoding ((minimum +. maximum) /. 2.)
  @ all (name ^ ".max") Alcotest.float encoding maximum

let test_n_sequence () =
  let test i = binary Alcotest.z z i () ; stream Alcotest.z z i () in
  for i = 0 to 10_000 do
    test (Z.of_int i)
  done ;
  for i = 100_000_000 to 100_010_000 do
    test (Z.of_int i)
  done

let test_z_sequence () =
  let test i = binary Alcotest.z z i () ; stream Alcotest.z z i () in
  for i = -10_000 to 10_000 do
    test (Z.of_int i)
  done ;
  for i = 100_000_000 to 100_010_000 do
    test (Z.of_int i)
  done ;
  for i = -100_000_000 downto -100_010_000 do
    test (Z.of_int i)
  done

let test_string_enum_boundary () =
  let entries =
    List.rev_map (fun x -> (string_of_int x, x)) (List.init 255 (fun i -> i))
  in
  let run_test cases =
    List.iter
      (fun (_, num) ->
        let enc = string_enum cases in
        json Alcotest.int enc num () ;
        bson Alcotest.int enc num () ;
        binary Alcotest.int enc num () ;
        stream Alcotest.int enc num ())
      cases
  in
  run_test entries ;
  let entries2 = ("255", 255) :: entries in
  run_test entries2 ;
  run_test (("256", 256) :: entries2)

let test_bounded_string_list =
  let test name ~total ~elements v =
    ( "bounded_string_list." ^ name,
      `Quick,
      binary Alcotest.(list string) (bounded_list ~total ~elements string) v )
  in
  [ test "a" ~total:0 ~elements:0 [];
    test "b" ~total:4 ~elements:4 [""];
    test "c" ~total:20 ~elements:4 [""; ""; ""; ""; ""];
    test "d" ~total:21 ~elements:5 [""; ""; ""; ""; "a"];
    test "e" ~total:31 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] ]

let tests =
  all "null" Alcotest.pass null ()
  @ all "empty" Alcotest.pass empty ()
  @ all "constant" Alcotest.pass (constant "toto") ()
  @ all_int int8 8 @ all_uint uint8 8 @ all_int int16 16 @ all_uint uint16 16
  @ all_int int31 31
  @ all "int32.min" Alcotest.int32 int32 Int32.min_int
  @ all "int32.max" Alcotest.int32 int32 Int32.max_int
  @ all "int64.min" Alcotest.int64 int64 Int64.min_int
  @ all "int64.max" Alcotest.int64 int64 Int64.max_int
  @ all_ranged_int 100 400 @ all_ranged_int 19000 19254
  @ all_ranged_int ~-100 300
  @ all_ranged_int ~-300_000_000 300_000_000
  @ all "bool.true" Alcotest.bool bool true
  @ all "bool.false" Alcotest.bool bool false
  @ all "string" Alcotest.string string "tutu"
  @ all "string.fixed" Alcotest.string (Fixed.string 4) "tutu"
  @ all "string.variable" Alcotest.string Variable.string "tutu"
  @ all "string.bounded1" Alcotest.string (Bounded.string 4) "tu"
  @ all "string.bounded2" Alcotest.string (Bounded.string 4) "tutu"
  @ all "bytes" Alcotest.bytes bytes (Bytes.of_string "titi")
  @ all "bytes.fixed" Alcotest.bytes (Fixed.bytes 4) (Bytes.of_string "titi")
  @ all "bytes.variable" Alcotest.bytes Variable.bytes (Bytes.of_string "titi")
  @ all
      "bytes.bounded1"
      Alcotest.bytes
      (Bounded.bytes 4)
      (Bytes.of_string "tu")
  @ all
      "bytes.bounded2"
      Alcotest.bytes
      (Bounded.bytes 4)
      (Bytes.of_string "tutu")
  @ all "float" Alcotest.float float 42.
  @ all "float.max" Alcotest.float float max_float
  @ all "float.min" Alcotest.float float min_float
  @ all "float.neg_zero" Alcotest.float float (-0.)
  @ all "float.zero" Alcotest.float float 0.
  @ all "float.infinity" Alcotest.float float infinity
  @ all "float.neg_infity" Alcotest.float float neg_infinity
  @ all "float.epsilon" Alcotest.float float epsilon_float
  @ all "float.nan" Alcotest.float float nan
  @ all_ranged_float ~-.100. 300.
  @ all "n.zero" Alcotest.n n Z.zero
  @ all "n.one" Alcotest.n n Z.one
  @ [("n.sequence", `Quick, test_n_sequence)]
  @
  let rec fact i l =
    if i < 1 then []
    else
      let l = Z.mul l (Z.of_int i) in
      fact (i - 1) l @ all (Format.asprintf "n.fact.%d" i) Alcotest.n n l
  in
  fact 35 Z.one
  @ all
      "n.a"
      Alcotest.n
      n
      (Z.of_string "123574503164821730218493275982143254986574985328")
  @ all "n.b" Alcotest.n n (Z.of_string "8493275982143254986574985328")
  @ all "n.c" Alcotest.n n (Z.of_string "123574503164821730218474985328")
  @ all
      "n.d"
      Alcotest.n
      n
      (Z.of_string
         "10000000000100000000001000003050000000060600000000000777000008")
  @ all "z.zero" Alcotest.z z Z.zero
  @ all "z.one" Alcotest.z z Z.one
  @ [("z.sequence", `Quick, test_z_sequence)]
  @
  let rec fact n l =
    if n < 1 then []
    else
      let l = Z.mul l (Z.of_int n) in
      fact (n - 1) l @ all (Format.asprintf "z.fact.%d" n) Alcotest.z z l
  in
  fact 35 Z.one
  @ all
      "z.a"
      Alcotest.z
      z
      (Z.of_string "123574503164821730218493275982143254986574985328")
  @ all "z.b" Alcotest.z z (Z.of_string "8493275982143254986574985328")
  @ all "z.c" Alcotest.z z (Z.of_string "123574503164821730218474985328")
  @ all
      "z.d"
      Alcotest.z
      z
      (Z.of_string
         "10000000000100000000001000003050000000060600000000000777000008")
  @ all
      "z.e"
      Alcotest.z
      z
      (Z.of_string "-123574503164821730218493275982143254986574985328")
  @ all "z.f" Alcotest.z z (Z.of_string "-8493275982143254986574985328")
  @ all "z.g" Alcotest.z z (Z.of_string "-123574503164821730218474985328")
  @ all
      "z.h"
      Alcotest.z
      z
      (Z.of_string
         "-10000000000100000000001000003050000000060600000000000777000008")
  @ all "none" Alcotest.(option string) (option string) None
  @ all "some.string" Alcotest.(option string) (option string) (Some "thing")
  @ all "enum" Alcotest.int enum_enc 4
  @ all "obj" Alcotest.record record_obj_enc default_record
  @ all
      "obj.dft"
      Alcotest.record
      record_obj_enc
      {default_record with b = false}
  @ all "obj.req" Alcotest.record record_obj_enc {default_record with c = None}
  @ all "tup" Alcotest.record record_tup_enc default_record
  @ all
      "obj.variable"
      Alcotest.variable_record
      variable_record_obj_enc
      default_variable_record
  @ all
      "tup.variable"
      Alcotest.variable_record
      variable_record_tup_enc
      default_variable_record
  @ all
      "obj.variable_left"
      Alcotest.variable_left_record
      variable_left_record_obj_enc
      default_variable_left_record
  @ all
      "tup.variable_left"
      Alcotest.variable_left_record
      variable_left_record_tup_enc
      default_variable_left_record
  @ all "union.A" Alcotest.union union_enc (A 1)
  @ all "union.B" Alcotest.union union_enc (B "2")
  @ all "union.C" Alcotest.union union_enc (C 3)
  @ all "union.D" Alcotest.union union_enc (D "4")
  @ all "union.E" Alcotest.union union_enc E
  @ all "variable_list.empty" Alcotest.(list int) (Variable.list int31) []
  @ all
      "variable_list"
      Alcotest.(list int)
      (Variable.list int31)
      [1; 2; 3; 4; 5]
  @ all "variable_array.empty" Alcotest.(array int) (Variable.array int31) [||]
  @ all
      "variable_array"
      Alcotest.(array int)
      (Variable.array int31)
      [|1; 2; 3; 4; 5|]
  @ all "list.empty" Alcotest.(list int) (list int31) []
  @ all "list" Alcotest.(list int) (list int31) [1; 2; 3; 4; 5]
  @ all "array.empty" Alcotest.(array int) (array int31) [||]
  @ all "array" Alcotest.(array int) (array int31) [|1; 2; 3; 4; 5|]
  @ all "mu_list.empty" Alcotest.(list int) (mu_list_enc int31) []
  @ all "mu_list" Alcotest.(list int) (mu_list_enc int31) [1; 2; 3; 4; 5]
  @ test_bounded_string_list
  @ [("string_enum_boundary", `Quick, test_string_enum_boundary)]
src/lib_data_encoding/test/success.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition json {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (fun function_parameter =>
      let 'tt := function_parameter in
      let json := Json.construct encoding value in
      let result := Json.destruct encoding json in
      op_startypeminuserrorstar ty "json" % string value result).

Definition bson {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (fun function_parameter =>
      let 'tt := function_parameter in
      let json := Bson.construct encoding value in
      let result := Bson.destruct encoding json in
      op_startypeminuserrorstar ty "bson" % string value result).

Definition binary {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (fun function_parameter =>
      let 'tt := function_parameter in
      let bytes := Binary.to_bytes_exn encoding value in
      let result := Binary.of_bytes_exn encoding string in
      op_startypeminuserrorstar ty "binary" % string value result).

Definition stream {A B C : Type}
  (ty : A) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t B)
  (value : B) (function_parameter : unit) : C :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (fun function_parameter =>
      let 'tt := function_parameter in
      let bytes := Binary.to_bytes_exn encoding value in
      let len_data := String.length string in
      (* ❌ For loops not handled. *)
      for).

Definition all {A B C : Type}
  (name : string) (ty : A)
  (encoding : Tezos_data_encoding.Data_encoding.encoding B) (value : B)
  : list (string * variant * (unit -> C)) :=
  let stream_encoding :=
    match Data_encoding.classify encoding with
    | Variable => dynamic_size None encoding
    | Dynamic | Fixed _ => encoding
    end in
  cons
    ((String.append name ".json" % string),
      (* ❌ Variants not supported *)
      variant, (json ty encoding value))
    (cons
      ((String.append name ".bson" % string),
        (* ❌ Variants not supported *)
        variant, (bson ty encoding value))
      (cons
        ((String.append name ".binary" % string),
          (* ❌ Variants not supported *)
          variant, (binary ty encoding value))
        (cons
          ((String.append name ".binary_stream" % string),
            (* ❌ Variants not supported *)
            variant, (stream ty stream_encoding value)) []))).

Definition all_int {A : Type}
  (encoding : Tezos_data_encoding.Data_encoding.encoding Z) (size : Z)
  : list (string * variant * (unit -> A)) :=
  let name :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "int" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "int%d" % string) size in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) op_startypeminuserrorstar encoding
      (Z.opp (Z.shiftl 1 (Z.sub size 1))))
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string) op_startypeminuserrorstar
        encoding 0)
      (all (String.append name ".max" % string) op_startypeminuserrorstar
        encoding (Z.sub (Z.shiftl 1 (Z.sub size 1)) 1))).

Definition all_uint {A : Type}
  (encoding : Tezos_data_encoding.Data_encoding.encoding Z) (size : Z)
  : list (string * variant * (unit -> A)) :=
  let name :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "uint" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "uint%d" % string) size in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) op_startypeminuserrorstar encoding
      0)
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string) op_startypeminuserrorstar
        encoding (Z.shiftl 1 (Z.sub size 1)))
      (all (String.append name ".max" % string) op_startypeminuserrorstar
        encoding (Z.sub (Z.shiftl 1 size) 1))).

Definition all_ranged_int {A : Type} (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> A)) :=
  let encoding := ranged_int minimum maximum in
  let name :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_int." % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) op_startypeminuserrorstar encoding
      minimum)
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string) op_startypeminuserrorstar
        encoding (Z.div (Z.add minimum maximum) 2))
      (all (String.append name ".max" % string) op_startypeminuserrorstar
        encoding maximum)).

Definition all_ranged_float {A : Type} (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> A)) :=
  let encoding := ranged_float minimum maximum in
  let name :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_float." % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) op_startypeminuserrorstar encoding
      minimum)
    (OCaml.Stdlib.app
      (all (String.append name ".mean" % string) op_startypeminuserrorstar
        encoding
        (Stdlib.op_divpoint (Stdlib.op_pluspoint minimum maximum)
          (* ❌ Float constant 2. is approximated by the integer 2 *)
          2))
      (all (String.append name ".max" % string) op_startypeminuserrorstar
        encoding maximum)).

Definition test_n_sequence (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let test {A : Type} (i : Z.t) : A :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := binary op_startypeminuserrorstar z i tt in
    stream op_startypeminuserrorstar z i tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ For loops not handled. *)
    for in
  (* ❌ For loops not handled. *)
  for.

Definition test_z_sequence (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let test {A : Type} (i : Z.t) : A :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := binary op_startypeminuserrorstar z i tt in
    stream op_startypeminuserrorstar z i tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ For loops not handled. *)
    for in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ For loops not handled. *)
    for in
  (* ❌ For loops not handled. *)
  for.

Definition test_string_enum_boundary (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let entries :=
    Stdlib.List.rev_map (fun x => ((OCaml.Stdlib.string_of_int x), x))
      (Stdlib.List.init 255 (fun i => i)) in
  let run_test {A : Type} (cases : list (string * A)) : unit :=
    Stdlib.List.iter
      (fun function_parameter =>
        let '(_, num) := function_parameter in
        let enc := string_enum cases in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := json op_startypeminuserrorstar enc num tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := bson op_startypeminuserrorstar enc num tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := binary op_startypeminuserrorstar enc num tt in
        stream op_startypeminuserrorstar enc num tt) cases in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := run_test entries in
  let entries2 := cons ("255" % string, 255) entries in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := run_test entries2 in
  run_test (cons ("256" % string, 256) entries2).

Definition test_bounded_string_list {A : Type}
  : list (string * variant * (unit -> A)) :=
  let test {B C D E : Type} (name : string) (total : B) (elements : C) (v : D)
    : string * variant * (unit -> E) :=
    ((String.append "bounded_string_list." % string name),
      (* ❌ Variants not supported *)
      variant,
      (binary op_startypeminuserrorstar
        (op_startypeminuserrorstar total elements string) v)) in
  cons (test "a" % string 0 0 [])
    (cons (test "b" % string 4 4 (cons "" % string []))
      (cons
        (test "c" % string 20 4
          (cons "" % string
            (cons "" % string
              (cons "" % string (cons "" % string (cons "" % string []))))))
        (cons
          (test "d" % string 21 5
            (cons "" % string
              (cons "" % string
                (cons "" % string (cons "" % string (cons "a" % string []))))))
          (cons
            (test "e" % string 31 10
              (cons "ab" % string
                (cons "c" % string
                  (cons "def" % string
                    (cons "gh" % string (cons "ijk" % string [])))))) [])))).

Definition tests : list (string * variant * (unit -> unit)) :=
  OCaml.Stdlib.app (all "null" % string op_startypeminuserrorstar null tt)
    (OCaml.Stdlib.app (all "empty" % string op_startypeminuserrorstar empty tt)
      (OCaml.Stdlib.app
        (all "constant" % string op_startypeminuserrorstar
          (constant "toto" % string) tt)
        (OCaml.Stdlib.app (all_int int8 8)
          (OCaml.Stdlib.app (all_uint uint8 8)
            (OCaml.Stdlib.app (all_int int16 16)
              (OCaml.Stdlib.app (all_uint uint16 16)
                (OCaml.Stdlib.app (all_int int31 31)
                  (OCaml.Stdlib.app
                    (all "int32.min" % string op_startypeminuserrorstar int32
                      Int32.min_int)
                    (OCaml.Stdlib.app
                      (all "int32.max" % string op_startypeminuserrorstar int32
                        Int32.max_int)
                      (OCaml.Stdlib.app
                        (all "int64.min" % string op_startypeminuserrorstar
                          int64 Int64.min_int)
                        (OCaml.Stdlib.app
                          (all "int64.max" % string op_startypeminuserrorstar
                            int64 Int64.max_int)
                          (OCaml.Stdlib.app (all_ranged_int 100 400)
                            (OCaml.Stdlib.app (all_ranged_int 19000 19254)
                              (OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
                                (OCaml.Stdlib.app
                                  (all_ranged_int (Z.opp 300000000) 300000000)
                                  (OCaml.Stdlib.app
                                    (all "bool.true" % string
                                      op_startypeminuserrorstar bool true)
                                    (OCaml.Stdlib.app
                                      (all "bool.false" % string
                                        op_startypeminuserrorstar bool false)
                                      (OCaml.Stdlib.app
                                        (all "string" % string
                                          op_startypeminuserrorstar string
                                          "tutu" % string)
                                        (OCaml.Stdlib.app
                                          (all "string.fixed" % string
                                            op_startypeminuserrorstar
                                            (Fixed.string 4) "tutu" % string)
                                          (OCaml.Stdlib.app
                                            (all "string.variable" % string
                                              op_startypeminuserrorstar
                                              Variable.string "tutu" % string)
                                            (OCaml.Stdlib.app
                                              (all "string.bounded1" % string
                                                op_startypeminuserrorstar
                                                (Bounded.string 4) "tu" % string)
                                              (OCaml.Stdlib.app
                                                (all "string.bounded2" % string
                                                  op_startypeminuserrorstar
                                                  (Bounded.string 4)
                                                  "tutu" % string)
                                                (OCaml.Stdlib.app
                                                  (all "bytes" % string
                                                    op_startypeminuserrorstar
                                                    bytes
                                                    (Stdlib.Bytes.of_string
                                                      "titi" % string))
                                                  (OCaml.Stdlib.app
                                                    (all "bytes.fixed" % string
                                                      op_startypeminuserrorstar
                                                      (Fixed.bytes 4)
                                                      (Stdlib.Bytes.of_string
                                                        "titi" % string))
                                                    (OCaml.Stdlib.app
                                                      (all
                                                        "bytes.variable" %
                                                          string
                                                        op_startypeminuserrorstar
                                                        Variable.bytes
                                                        (Stdlib.Bytes.of_string
                                                          "titi" % string))
                                                      (OCaml.Stdlib.app
                                                        (all
                                                          "bytes.bounded1" %
                                                            string
                                                          op_startypeminuserrorstar
                                                          (Bounded.bytes 4)
                                                          (Stdlib.Bytes.of_string
                                                            "tu" % string))
                                                        (OCaml.Stdlib.app
                                                          (all
                                                            "bytes.bounded2" %
                                                              string
                                                            op_startypeminuserrorstar
                                                            (Bounded.bytes 4)
                                                            (Stdlib.Bytes.of_string
                                                              "tutu" % string))
                                                          (OCaml.Stdlib.app
                                                            (all
                                                              "float" % string
                                                              op_startypeminuserrorstar
                                                              float
                                                              (* ❌ Float constant 42. is approximated by the integer 42 *)
                                                              42)
                                                            (OCaml.Stdlib.app
                                                              (all
                                                                "float.max" %
                                                                  string
                                                                op_startypeminuserrorstar
                                                                float
                                                                Stdlib.max_float)
                                                              (OCaml.Stdlib.app
                                                                (all
                                                                  "float.min" %
                                                                    string
                                                                  op_startypeminuserrorstar
                                                                  float
                                                                  Stdlib.min_float)
                                                                (OCaml.Stdlib.app
                                                                  (all
                                                                    "float.neg_zero"
                                                                      % string
                                                                    op_startypeminuserrorstar
                                                                    float
                                                                    (* ❌ Float constant -0. is approximated by the integer 0 *)
                                                                    0)
                                                                  (OCaml.Stdlib.app
                                                                    (all
                                                                      "float.zero"
                                                                        % string
                                                                      op_startypeminuserrorstar
                                                                      float
                                                                      (* ❌ Float constant 0. is approximated by the integer 0 *)
                                                                      0)
                                                                    (OCaml.Stdlib.app
                                                                      (all
                                                                        "float.infinity"
                                                                          %
                                                                          string
                                                                        op_startypeminuserrorstar
                                                                        float
                                                                        Stdlib.infinity)
                                                                      (OCaml.Stdlib.app
                                                                        (all
                                                                          "float.neg_infity"
                                                                            %
                                                                            string
                                                                          op_startypeminuserrorstar
                                                                          float
                                                                          Stdlib.neg_infinity)
                                                                        (OCaml.Stdlib.app
                                                                          (all
                                                                            "float.epsilon"
                                                                              %
                                                                              string
                                                                            op_startypeminuserrorstar
                                                                            float
                                                                            Stdlib.epsilon_float)
                                                                          (OCaml.Stdlib.app
                                                                            (all
                                                                              "float.nan"
                                                                                %
                                                                                string
                                                                              op_startypeminuserrorstar
                                                                              float
                                                                              Stdlib.nan)
                                                                            (OCaml.Stdlib.app
                                                                              (all_ranged_float
                                                                                (Stdlib.op_tildeminuspoint
                                                                                  (* ❌ Float constant 100. is approximated by the integer 100 *)
                                                                                  100)
                                                                                (* ❌ Float constant 300. is approximated by the integer 300 *)
                                                                                300)
                                                                              (OCaml.Stdlib.app
                                                                                (all
                                                                                  "n.zero"
                                                                                    %
                                                                                    string
                                                                                  op_startypeminuserrorstar
                                                                                  n
                                                                                  Z.zero)
                                                                                (OCaml.Stdlib.app
                                                                                  (all
                                                                                    "n.one"
                                                                                      %
                                                                                      string
                                                                                    op_startypeminuserrorstar
                                                                                    n
                                                                                    Z.one)
                                                                                  (OCaml.Stdlib.app
                                                                                    (cons
                                                                                      ("n.sequence"
                                                                                        %
                                                                                        string,
                                                                                        (* ❌ Variants not supported *)
                                                                                        variant,
                                                                                        test_n_sequence)
                                                                                      [])
                                                                                    (let
                                                                                      fix
                                                                                      fact
                                                                                      {A
                                                                                      :
                                                                                      Type}
                                                                                      (i
                                                                                      :
                                                                                      Z)
                                                                                      (l
                                                                                      :
                                                                                      Z.t)
                                                                                      : list
                                                                                        (string
                                                                                          *
                                                                                          variant
                                                                                          *
                                                                                          (unit
                                                                                            ->
                                                                                            A)) :=
                                                                                      if
                                                                                        OCaml.Stdlib.lt
                                                                                          i
                                                                                          1
                                                                                        then
                                                                                        []
                                                                                      else
                                                                                        let
                                                                                          l :=
                                                                                          Z.mul
                                                                                            l
                                                                                            (Z.of_int
                                                                                              i)
                                                                                          in
                                                                                        OCaml.Stdlib.app
                                                                                          (fact
                                                                                            (Z.sub
                                                                                              i
                                                                                              1)
                                                                                            l)
                                                                                          (all
                                                                                            (Format.asprintf
                                                                                              (CamlinternalFormatBasics.Format
                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                  "n.fact."
                                                                                                    %
                                                                                                    string
                                                                                                  (CamlinternalFormatBasics.Int
                                                                                                    CamlinternalFormatBasics.Int_d
                                                                                                    CamlinternalFormatBasics.No_padding
                                                                                                    CamlinternalFormatBasics.No_precision
                                                                                                    CamlinternalFormatBasics.End_of_format))
                                                                                                "n.fact.%d"
                                                                                                  %
                                                                                                  string)
                                                                                              i)
                                                                                            op_startypeminuserrorstar
                                                                                            n
                                                                                            l)
                                                                                      in
                                                                                    OCaml.Stdlib.app
                                                                                      (fact
                                                                                        35
                                                                                        Z.one)
                                                                                      (OCaml.Stdlib.app
                                                                                        (all
                                                                                          "n.a"
                                                                                            %
                                                                                            string
                                                                                          op_startypeminuserrorstar
                                                                                          n
                                                                                          (Z.of_string
                                                                                            "123574503164821730218493275982143254986574985328"
                                                                                              %
                                                                                              string))
                                                                                        (OCaml.Stdlib.app
                                                                                          (all
                                                                                            "n.b"
                                                                                              %
                                                                                              string
                                                                                            op_startypeminuserrorstar
                                                                                            n
                                                                                            (Z.of_string
                                                                                              "8493275982143254986574985328"
                                                                                                %
                                                                                                string))
                                                                                          (OCaml.Stdlib.app
                                                                                            (all
                                                                                              "n.c"
                                                                                                %
                                                                                                string
                                                                                              op_startypeminuserrorstar
                                                                                              n
                                                                                              (Z.of_string
                                                                                                "123574503164821730218474985328"
                                                                                                  %
                                                                                                  string))
                                                                                            (OCaml.Stdlib.app
                                                                                              (all
                                                                                                "n.d"
                                                                                                  %
                                                                                                  string
                                                                                                op_startypeminuserrorstar
                                                                                                n
                                                                                                (Z.of_string
                                                                                                  "10000000000100000000001000003050000000060600000000000777000008"
                                                                                                    %
                                                                                                    string))
                                                                                              (OCaml.Stdlib.app
                                                                                                (all
                                                                                                  "z.zero"
                                                                                                    %
                                                                                                    string
                                                                                                  op_startypeminuserrorstar
                                                                                                  z
                                                                                                  Z.zero)
                                                                                                (OCaml.Stdlib.app
                                                                                                  (all
                                                                                                    "z.one"
                                                                                                      %
                                                                                                      string
                                                                                                    op_startypeminuserrorstar
                                                                                                    z
                                                                                                    Z.one)
                                                                                                  (OCaml.Stdlib.app
                                                                                                    (cons
                                                                                                      ("z.sequence"
                                                                                                        %
                                                                                                        string,
                                                                                                        (* ❌ Variants not supported *)
                                                                                                        variant,
                                                                                                        test_z_sequence)
                                                                                                      [])
                                                                                                    (let
                                                                                                      fix
                                                                                                      fact
                                                                                                      {A
                                                                                                      :
                                                                                                      Type}
                                                                                                      (n
                                                                                                      :
                                                                                                      Z)
                                                                                                      (l
                                                                                                      :
                                                                                                      Z.t)
                                                                                                      : list
                                                                                                        (string
                                                                                                          *
                                                                                                          variant
                                                                                                          *
                                                                                                          (unit
                                                                                                            ->
                                                                                                            A)) :=
                                                                                                      if
                                                                                                        OCaml.Stdlib.lt
                                                                                                          n
                                                                                                          1
                                                                                                        then
                                                                                                        []
                                                                                                      else
                                                                                                        let
                                                                                                          l :=
                                                                                                          Z.mul
                                                                                                            l
                                                                                                            (Z.of_int
                                                                                                              n)
                                                                                                          in
                                                                                                        OCaml.Stdlib.app
                                                                                                          (fact
                                                                                                            (Z.sub
                                                                                                              n
                                                                                                              1)
                                                                                                            l)
                                                                                                          (all
                                                                                                            (Format.asprintf
                                                                                                              (CamlinternalFormatBasics.Format
                                                                                                                (CamlinternalFormatBasics.String_literal
                                                                                                                  "z.fact."
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (CamlinternalFormatBasics.Int
                                                                                                                    CamlinternalFormatBasics.Int_d
                                                                                                                    CamlinternalFormatBasics.No_padding
                                                                                                                    CamlinternalFormatBasics.No_precision
                                                                                                                    CamlinternalFormatBasics.End_of_format))
                                                                                                                "z.fact.%d"
                                                                                                                  %
                                                                                                                  string)
                                                                                                              n)
                                                                                                            op_startypeminuserrorstar
                                                                                                            z
                                                                                                            l)
                                                                                                      in
                                                                                                    OCaml.Stdlib.app
                                                                                                      (fact
                                                                                                        35
                                                                                                        Z.one)
                                                                                                      (OCaml.Stdlib.app
                                                                                                        (all
                                                                                                          "z.a"
                                                                                                            %
                                                                                                            string
                                                                                                          op_startypeminuserrorstar
                                                                                                          z
                                                                                                          (Z.of_string
                                                                                                            "123574503164821730218493275982143254986574985328"
                                                                                                              %
                                                                                                              string))
                                                                                                        (OCaml.Stdlib.app
                                                                                                          (all
                                                                                                            "z.b"
                                                                                                              %
                                                                                                              string
                                                                                                            op_startypeminuserrorstar
                                                                                                            z
                                                                                                            (Z.of_string
                                                                                                              "8493275982143254986574985328"
                                                                                                                %
                                                                                                                string))
                                                                                                          (OCaml.Stdlib.app
                                                                                                            (all
                                                                                                              "z.c"
                                                                                                                %
                                                                                                                string
                                                                                                              op_startypeminuserrorstar
                                                                                                              z
                                                                                                              (Z.of_string
                                                                                                                "123574503164821730218474985328"
                                                                                                                  %
                                                                                                                  string))
                                                                                                            (OCaml.Stdlib.app
                                                                                                              (all
                                                                                                                "z.d"
                                                                                                                  %
                                                                                                                  string
                                                                                                                op_startypeminuserrorstar
                                                                                                                z
                                                                                                                (Z.of_string
                                                                                                                  "10000000000100000000001000003050000000060600000000000777000008"
                                                                                                                    %
                                                                                                                    string))
                                                                                                              (OCaml.Stdlib.app
                                                                                                                (all
                                                                                                                  "z.e"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  op_startypeminuserrorstar
                                                                                                                  z
                                                                                                                  (Z.of_string
                                                                                                                    "-123574503164821730218493275982143254986574985328"
                                                                                                                      %
                                                                                                                      string))
                                                                                                                (OCaml.Stdlib.app
                                                                                                                  (all
                                                                                                                    "z.f"
                                                                                                                      %
                                                                                                                      string
                                                                                                                    op_startypeminuserrorstar
                                                                                                                    z
                                                                                                                    (Z.of_string
                                                                                                                      "-8493275982143254986574985328"
                                                                                                                        %
                                                                                                                        string))
                                                                                                                  (OCaml.Stdlib.app
                                                                                                                    (all
                                                                                                                      "z.g"
                                                                                                                        %
                                                                                                                        string
                                                                                                                      op_startypeminuserrorstar
                                                                                                                      z
                                                                                                                      (Z.of_string
                                                                                                                        "-123574503164821730218474985328"
                                                                                                                          %
                                                                                                                          string))
                                                                                                                    (OCaml.Stdlib.app
                                                                                                                      (all
                                                                                                                        "z.h"
                                                                                                                          %
                                                                                                                          string
                                                                                                                        op_startypeminuserrorstar
                                                                                                                        z
                                                                                                                        (Z.of_string
                                                                                                                          "-10000000000100000000001000003050000000060600000000000777000008"
                                                                                                                            %
                                                                                                                            string))
                                                                                                                      (OCaml.Stdlib.app
                                                                                                                        (all
                                                                                                                          "none"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          op_startypeminuserrorstar
                                                                                                                          (option
                                                                                                                            string)
                                                                                                                          None)
                                                                                                                        (OCaml.Stdlib.app
                                                                                                                          (all
                                                                                                                            "some.string"
                                                                                                                              %
                                                                                                                              string
                                                                                                                            op_startypeminuserrorstar
                                                                                                                            (option
                                                                                                                              string)
                                                                                                                            (Some
                                                                                                                              "thing"
                                                                                                                                %
                                                                                                                                string))
                                                                                                                          (OCaml.Stdlib.app
                                                                                                                            (all
                                                                                                                              "enum"
                                                                                                                                %
                                                                                                                                string
                                                                                                                              op_startypeminuserrorstar
                                                                                                                              op_startypeminuserrorstar
                                                                                                                              4)
                                                                                                                            (OCaml.Stdlib.app
                                                                                                                              (all
                                                                                                                                "obj"
                                                                                                                                  %
                                                                                                                                  string
                                                                                                                                op_startypeminuserrorstar
                                                                                                                                op_startypeminuserrorstar
                                                                                                                                op_startypeminuserrorstar)
                                                                                                                              (OCaml.Stdlib.app
                                                                                                                                (all
                                                                                                                                  "obj.dft"
                                                                                                                                    %
                                                                                                                                    string
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                  op_startypeminuserrorstar)
                                                                                                                                (OCaml.Stdlib.app
                                                                                                                                  (all
                                                                                                                                    "obj.req"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                  (OCaml.Stdlib.app
                                                                                                                                    (all
                                                                                                                                      "tup"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                      op_startypeminuserrorstar)
                                                                                                                                    (OCaml.Stdlib.app
                                                                                                                                      (all
                                                                                                                                        "obj.variable"
                                                                                                                                          %
                                                                                                                                          string
                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                        op_startypeminuserrorstar)
                                                                                                                                      (OCaml.Stdlib.app
                                                                                                                                        (all
                                                                                                                                          "tup.variable"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                        (OCaml.Stdlib.app
                                                                                                                                          (all
                                                                                                                                            "obj.variable_left"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                            op_startypeminuserrorstar)
                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                            (all
                                                                                                                                              "tup.variable_left"
                                                                                                                                                %
                                                                                                                                                string
                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                              op_startypeminuserrorstar)
                                                                                                                                            (OCaml.Stdlib.app
                                                                                                                                              (all
                                                                                                                                                "union.A"
                                                                                                                                                  %
                                                                                                                                                  string
                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                op_startypeminuserrorstar)
                                                                                                                                              (OCaml.Stdlib.app
                                                                                                                                                (all
                                                                                                                                                  "union.B"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                  op_startypeminuserrorstar)
                                                                                                                                                (OCaml.Stdlib.app
                                                                                                                                                  (all
                                                                                                                                                    "union.C"
                                                                                                                                                      %
                                                                                                                                                      string
                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                                  (OCaml.Stdlib.app
                                                                                                                                                    (all
                                                                                                                                                      "union.D"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                      op_startypeminuserrorstar)
                                                                                                                                                    (OCaml.Stdlib.app
                                                                                                                                                      (all
                                                                                                                                                        "union.E"
                                                                                                                                                          %
                                                                                                                                                          string
                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                        op_startypeminuserrorstar)
                                                                                                                                                      (OCaml.Stdlib.app
                                                                                                                                                        (all
                                                                                                                                                          "variable_list.empty"
                                                                                                                                                            %
                                                                                                                                                            string
                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                          (Variable.list
                                                                                                                                                            None
                                                                                                                                                            int31)
                                                                                                                                                          [])
                                                                                                                                                        (OCaml.Stdlib.app
                                                                                                                                                          (all
                                                                                                                                                            "variable_list"
                                                                                                                                                              %
                                                                                                                                                              string
                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                            (Variable.list
                                                                                                                                                              None
                                                                                                                                                              int31)
                                                                                                                                                            (cons
                                                                                                                                                              1
                                                                                                                                                              (cons
                                                                                                                                                                2
                                                                                                                                                                (cons
                                                                                                                                                                  3
                                                                                                                                                                  (cons
                                                                                                                                                                    4
                                                                                                                                                                    (cons
                                                                                                                                                                      5
                                                                                                                                                                      []))))))
                                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                                            (all
                                                                                                                                                              "variable_array.empty"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                              (Variable.array
                                                                                                                                                                None
                                                                                                                                                                int31)
                                                                                                                                                              (* ❌ Arrays not handled. *)
                                                                                                                                                              [
                                                                                                                                                              ])
                                                                                                                                                            (OCaml.Stdlib.app
                                                                                                                                                              (all
                                                                                                                                                                "variable_array"
                                                                                                                                                                  %
                                                                                                                                                                  string
                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                (Variable.array
                                                                                                                                                                  None
                                                                                                                                                                  int31)
                                                                                                                                                                (* ❌ Arrays not handled. *)
                                                                                                                                                                [
                                                                                                                                                                  1;
                                                                                                                                                                  2;
                                                                                                                                                                  3;
                                                                                                                                                                  4;
                                                                                                                                                                  5
                                                                                                                                                                ])
                                                                                                                                                              (OCaml.Stdlib.app
                                                                                                                                                                (all
                                                                                                                                                                  "list.empty"
                                                                                                                                                                    %
                                                                                                                                                                    string
                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                  (list
                                                                                                                                                                    None
                                                                                                                                                                    int31)
                                                                                                                                                                  [])
                                                                                                                                                                (OCaml.Stdlib.app
                                                                                                                                                                  (all
                                                                                                                                                                    "list"
                                                                                                                                                                      %
                                                                                                                                                                      string
                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                    (list
                                                                                                                                                                      None
                                                                                                                                                                      int31)
                                                                                                                                                                    (cons
                                                                                                                                                                      1
                                                                                                                                                                      (cons
                                                                                                                                                                        2
                                                                                                                                                                        (cons
                                                                                                                                                                          3
                                                                                                                                                                          (cons
                                                                                                                                                                            4
                                                                                                                                                                            (cons
                                                                                                                                                                              5
                                                                                                                                                                              []))))))
                                                                                                                                                                  (OCaml.Stdlib.app
                                                                                                                                                                    (all
                                                                                                                                                                      "array.empty"
                                                                                                                                                                        %
                                                                                                                                                                        string
                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                      (array
                                                                                                                                                                        None
                                                                                                                                                                        int31)
                                                                                                                                                                      (* ❌ Arrays not handled. *)
                                                                                                                                                                      [
                                                                                                                                                                      ])
                                                                                                                                                                    (OCaml.Stdlib.app
                                                                                                                                                                      (all
                                                                                                                                                                        "array"
                                                                                                                                                                          %
                                                                                                                                                                          string
                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                        (array
                                                                                                                                                                          None
                                                                                                                                                                          int31)
                                                                                                                                                                        (* ❌ Arrays not handled. *)
                                                                                                                                                                        [
                                                                                                                                                                          1;
                                                                                                                                                                          2;
                                                                                                                                                                          3;
                                                                                                                                                                          4;
                                                                                                                                                                          5
                                                                                                                                                                        ])
                                                                                                                                                                      (OCaml.Stdlib.app
                                                                                                                                                                        (all
                                                                                                                                                                          "mu_list.empty"
                                                                                                                                                                            %
                                                                                                                                                                            string
                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                          (op_startypeminuserrorstar
                                                                                                                                                                            int31)
                                                                                                                                                                          [])
                                                                                                                                                                        (OCaml.Stdlib.app
                                                                                                                                                                          (all
                                                                                                                                                                            "mu_list"
                                                                                                                                                                              %
                                                                                                                                                                              string
                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                              int31)
                                                                                                                                                                            (cons
                                                                                                                                                                              1
                                                                                                                                                                              (cons
                                                                                                                                                                                2
                                                                                                                                                                                (cons
                                                                                                                                                                                  3
                                                                                                                                                                                  (cons
                                                                                                                                                                                    4
                                                                                                                                                                                    (cons
                                                                                                                                                                                      5
                                                                                                                                                                                      []))))))
                                                                                                                                                                          (OCaml.Stdlib.app
                                                                                                                                                                            test_bounded_string_list
                                                                                                                                                                            (cons
                                                                                                                                                                              ("string_enum_boundary"
                                                                                                                                                                                %
                                                                                                                                                                                string,
                                                                                                                                                                                (* ❌ Variants not supported *)
                                                                                                                                                                                variant,
                                                                                                                                                                                test_string_enum_boundary)
                                                                                                                                                                              []))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).

src/lib_data_encoding/test/test.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Random.init 100 ;
  Alcotest.run
    "tezos-data-encoding"
    [ ("success", Success.tests);
      ("invalid_encoding", Invalid_encoding.tests);
      ("read_failure", Read_failure.tests);
      ("write_failure", Write_failure.tests);
      ("randomized", Randomized.tests);
      ("versioned", Versioned.tests) ]
src/lib_data_encoding/test/test.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/lib_data_encoding/test/test_generated.ml 202 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* NOTE: the current release of Crowbar, v0.1, is quite limited. Several
 * improvements have been made to the dev version which will make it possible to
 * simplify this file and increase coverage.
 * For now, this is a limited test-suite. *)

let char = Crowbar.map [Crowbar.uint8] Char.chr

let string = Crowbar.bytes

(* The v0.1 of Crowbar doesn't have fixed-size string generation. When we
 * update Crowbar, we can improve this generator. *)
let short_string =
  let open Crowbar in
  choose
    [ const "";
      map [char] (fun c -> String.make 1 c);
      map [char; char; char; char] (fun c1 c2 c3 c4 ->
          let s = Bytes.make 4 c1 in
          Bytes.set s 1 c2 ;
          Bytes.set s 2 c3 ;
          Bytes.set s 3 c4 ;
          Bytes.to_string s) ]

let short_string1 =
  let open Crowbar in
  choose
    [ map [char] (fun c -> String.make 1 c);
      map [char; char; char; char] (fun c1 c2 c3 c4 ->
          let s = Bytes.make 4 c1 in
          Bytes.set s 1 c2 ;
          Bytes.set s 2 c3 ;
          Bytes.set s 3 c4 ;
          Bytes.to_string s) ]

let mbytes = Crowbar.map [Crowbar.bytes] Bytes.of_string

let short_mbytes = Crowbar.map [short_string] Bytes.of_string

let short_mbytes1 = Crowbar.map [short_string1] Bytes.of_string

(* We need to hide the type parameter of `Encoding.t` to avoid the generator
 * combinator `choose` from complaining about different types. We use first
 * level modules (for now) to encode existentials.
 *
 * An alternative is used in https://gitlab.com/gasche/fuzz-data-encoding *)

module type TESTABLE = sig
  type t

  val v : t

  val ding : t Data_encoding.t

  val pp : t Crowbar.printer
end

type testable = (module TESTABLE)

let null : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.null

    let pp ppf () = Crowbar.pp ppf "(null)"
  end )

let empty : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.empty

    let pp ppf () = Crowbar.pp ppf "(empty)"
  end )

let unit : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.unit

    let pp ppf () = Crowbar.pp ppf "(unit)"
  end )

let map_constant (s : string) : testable =
  ( module struct
    type t = unit

    let v = ()

    let ding = Data_encoding.constant s

    let pp ppf () = Crowbar.pp ppf "\"%s\"" s
  end )

let map_int8 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.int8

    let pp = Crowbar.pp_int
  end )

let map_uint8 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.uint8

    let pp = Crowbar.pp_int
  end )

let map_int16 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.int16

    let pp = Crowbar.pp_int
  end )

let map_uint16 (i : int) : testable =
  ( module struct
    type t = int

    let v = i

    let ding = Data_encoding.uint16

    let pp = Crowbar.pp_int
  end )

let map_int32 (i : int32) : testable =
  ( module struct
    type t = int32

    let v = i

    let ding = Data_encoding.int32

    let pp = Crowbar.pp_int32
  end )

let map_int64 (i : int64) : testable =
  ( module struct
    type t = int64

    let v = i

    let ding = Data_encoding.int64

    let pp = Crowbar.pp_int64
  end )

let map_range_int a b c : testable =
  let (small, middle, big) =
    match List.sort compare [a; b; c] with
    | [small; middle; big] ->
        assert (small <= middle) ;
        assert (middle <= big) ;
        (small, middle, big)
    | _ ->
        assert false
  in
  ( module struct
    type t = int

    let v = middle

    let ding = Data_encoding.ranged_int small big

    let pp ppf i = Crowbar.pp ppf "(%d :[%d;%d])" i small big
  end )

let map_range_float a b c : testable =
  if compare a nan = 0 || compare b nan = 0 || compare c nan = 0 then
    (* copout *)
    null
  else
    let (small, middle, big) =
      match List.sort compare [a; b; c] with
      | [small; middle; big] ->
          assert (small <= middle) ;
          assert (middle <= big) ;
          (small, middle, big)
      | _ ->
          assert false
    in
    ( module struct
      type t = float

      let v = middle

      let ding = Data_encoding.ranged_float small big

      let pp ppf i = Crowbar.pp ppf "(%f :[%f;%f])" i small big
    end )

let map_bool b : testable =
  ( module struct
    type t = bool

    let v = b

    let ding = Data_encoding.bool

    let pp = Crowbar.pp_bool
  end )

let map_string s : testable =
  ( module struct
    type t = string

    let v = s

    let ding = Data_encoding.string

    let pp = Crowbar.pp_string
  end )

let map_bytes s : testable =
  ( module struct
    type t = Bytes.t

    let v = s

    let ding = Data_encoding.bytes

    let pp ppf m =
      if Bytes.length m > 40 then
        Crowbar.pp
          ppf
          "@[<hv 1>%a … (%d more bytes)@]"
          Hex.pp
          (Hex.of_bytes (Bytes.sub m 1 30))
          (Bytes.length m)
      else Hex.pp ppf (Hex.of_bytes m)
  end )

let map_float f : testable =
  ( module struct
    type t = float

    let v = f

    let ding = Data_encoding.float

    let pp = Crowbar.pp_float
  end )

let map_fixed_string s : testable =
  ( module struct
    type t = string

    let v = s

    let ding = Data_encoding.Fixed.string (String.length s)

    let pp ppf s = Crowbar.pp ppf "\"%s\"" s
  end )

let map_fixed_bytes s : testable =
  ( module struct
    type t = Bytes.t

    let v = s

    let ding = Data_encoding.Fixed.bytes (Bytes.length s)

    let pp fmt x = Hex.pp fmt (Hex.of_bytes x)
  end )

let map_variable_string s : testable =
  ( module struct
    type t = string

    let v = s

    let ding = Data_encoding.Variable.string

    let pp ppf s = Crowbar.pp ppf "\"%s\"" s
  end )

let map_variable_bytes s : testable =
  ( module struct
    type t = Bytes.t

    let v = s

    let ding = Data_encoding.Variable.bytes

    let pp fmt x = Hex.pp fmt (Hex.of_bytes x)
  end )

(* And now combinators *)

let dyn_if_not ding =
  match Data_encoding.classify ding with
  | `Fixed _ | `Dynamic ->
      ding
  | `Variable ->
      Data_encoding.dynamic_size ding

let map_some (t : testable) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t option

    let v = Some T.v

    let ding =
      try Data_encoding.option T.ding
      with Invalid_argument _ -> Crowbar.bad_test ()

    let pp ppf o =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt v ->
          match v with
          | None ->
              Format.fprintf fmt "None"
          | Some v ->
              Format.fprintf fmt "Some(%a)" T.pp v)
        o
  end )

let map_none (t : testable) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t option

    let v = None

    let ding =
      try Data_encoding.option T.ding
      with Invalid_argument _ -> Crowbar.bad_test ()

    let pp ppf o =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt v ->
          match v with
          | None ->
              Format.fprintf fmt "None"
          | Some v ->
              Format.fprintf fmt "Some(%a)" T.pp v)
        o
  end )

let map_ok (t_o : testable) (t_e : testable) : testable =
  let module T_O = (val t_o) in
  let module T_E = (val t_e) in
  ( module struct
    type t = (T_O.t, T_E.t) result

    let v = Ok T_O.v

    let ding = Data_encoding.result T_O.ding T_E.ding

    let pp ppf r =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt r ->
          match r with
          | Ok o ->
              Format.fprintf fmt "Ok(%a)" T_O.pp o
          | Error e ->
              Format.fprintf fmt "Error(%a)" T_E.pp e)
        r
  end )

let map_error (t_o : testable) (t_e : testable) : testable =
  let module T_O = (val t_o) in
  let module T_E = (val t_e) in
  ( module struct
    type t = (T_O.t, T_E.t) result

    let v = Error T_E.v

    let ding = Data_encoding.result T_O.ding T_E.ding

    let pp ppf r =
      Crowbar.pp
        ppf
        "@[<hv 1>%a@]"
        (fun fmt r ->
          match r with
          | Ok o ->
              Format.fprintf fmt "Ok(%a)" T_O.pp o
          | Error e ->
              Format.fprintf fmt "Error(%a)" T_E.pp e)
        r
  end )

let map_variable_list (t : testable) (ts : testable list) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t list

    let ding = Data_encoding.Variable.list (dyn_if_not T.ding)

    let v =
      List.fold_left
        (fun acc (t : testable) ->
          let module T = (val t) in
          (* We can get rid of this Obj when we update Crowbar *)
          Obj.magic T.v :: acc)
        []
        ts

    let pp = Crowbar.pp_list T.pp
  end )

let map_variable_array (t : testable) (ts : testable array) : testable =
  let module T = (val t) in
  ( module struct
    type t = T.t array

    let ding = Data_encoding.Variable.array (dyn_if_not T.ding)

    let v =
      Array.of_list
        (Array.fold_left
           (fun acc (t : testable) ->
             let module T = (val t) in
             Obj.magic T.v :: acc)
           []
           ts)

    let pp ppf a =
      if Array.length a > 40 then
        Crowbar.pp
          ppf
          "@[<hv 1>[|%a … (%d more elements)|]@]"
          (Format.pp_print_list
             ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
             T.pp)
          (Array.to_list (Array.sub a 0 30))
          (Array.length a)
      else
        Crowbar.pp
          ppf
          "@[<hv 1>[|%a|]@]"
          (Format.pp_print_list
             ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ")
             T.pp)
          (Array.to_list a)
  end )

let map_dynamic_size (t : testable) : testable =
  let module T = (val t) in
  ( module struct
    include T

    let ding = Data_encoding.dynamic_size T.ding
  end )

let map_tup1 (t1 : testable) : testable =
  let module T1 = (val t1) in
  ( module struct
    include T1

    let ding = Data_encoding.tup1 T1.ding

    let pp ppf v1 = Crowbar.pp ppf "@[<hv 1>(%a)@]" T1.pp v1
  end )

let map_tup2 (t1 : testable) (t2 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  ( module struct
    type t = T1.t * T2.t

    let ding = Data_encoding.tup2 (dyn_if_not T1.ding) T2.ding

    let v = (T1.v, T2.v)

    let pp ppf (v1, v2) = Crowbar.pp ppf "@[<hv 1>(%a, %a)@]" T1.pp v1 T2.pp v2
  end )

let map_tup3 (t1 : testable) (t2 : testable) (t3 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  ( module struct
    type t = T1.t * T2.t * T3.t

    let ding =
      Data_encoding.tup3 (dyn_if_not T1.ding) (dyn_if_not T2.ding) T3.ding

    let v = (T1.v, T2.v, T3.v)

    let pp ppf (v1, v2, v3) =
      Crowbar.pp ppf "@[<hv 1>(%a, %a, %a)@]" T1.pp v1 T2.pp v2 T3.pp v3
  end )

let map_tup4 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable) :
    testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t

    let ding =
      Data_encoding.tup4
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        T4.ding

    let v = (T1.v, T2.v, T3.v, T4.v)

    let pp ppf (v1, v2, v3, v4) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
  end )

let map_tup5 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t

    let ding =
      Data_encoding.tup5
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        T5.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v)

    let pp ppf (v1, v2, v3, v4, v5) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
  end )

let map_tup6 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t

    let ding =
      Data_encoding.tup6
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        T6.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v)

    let pp ppf (v1, v2, v3, v4, v5, v6) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
  end )

let map_tup7 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t

    let ding =
      Data_encoding.tup7
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        T7.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
  end )

let map_tup8 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable) : testable
    =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  let module T8 = (val t8) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t

    let ding =
      Data_encoding.tup8
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        (dyn_if_not T7.ding)
        T8.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
        T8.pp
        v8
  end )

let map_tup9 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
    (t9 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  let module T8 = (val t8) in
  let module T9 = (val t9) in
  ( module struct
    type t = T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t * T9.t

    let ding =
      Data_encoding.tup9
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        (dyn_if_not T7.ding)
        (dyn_if_not T8.ding)
        T9.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v, T9.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8, v9) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
        T8.pp
        v8
        T9.pp
        v9
  end )

let map_tup10 (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
    (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
    (t9 : testable) (t10 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  let module T3 = (val t3) in
  let module T4 = (val t4) in
  let module T5 = (val t5) in
  let module T6 = (val t6) in
  let module T7 = (val t7) in
  let module T8 = (val t8) in
  let module T9 = (val t9) in
  let module T10 = (val t10) in
  ( module struct
    type t =
      T1.t * T2.t * T3.t * T4.t * T5.t * T6.t * T7.t * T8.t * T9.t * T10.t

    let ding =
      Data_encoding.tup10
        (dyn_if_not T1.ding)
        (dyn_if_not T2.ding)
        (dyn_if_not T3.ding)
        (dyn_if_not T4.ding)
        (dyn_if_not T5.ding)
        (dyn_if_not T6.ding)
        (dyn_if_not T7.ding)
        (dyn_if_not T8.ding)
        (dyn_if_not T9.ding)
        T10.ding

    let v = (T1.v, T2.v, T3.v, T4.v, T5.v, T6.v, T7.v, T8.v, T9.v, T10.v)

    let pp ppf (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) =
      Crowbar.pp
        ppf
        "@[<hv 1>(%a, %a, %a, %a, %a, %a, %a, %a, %a, %a)@]"
        T1.pp
        v1
        T2.pp
        v2
        T3.pp
        v3
        T4.pp
        v4
        T5.pp
        v5
        T6.pp
        v6
        T7.pp
        v7
        T8.pp
        v8
        T9.pp
        v9
        T10.pp
        v10
  end )

let map_merge_tups (t1 : testable) (t2 : testable) : testable =
  let module T1 = (val t1) in
  let module T2 = (val t2) in
  ( module struct
    type t = T1.t * T2.t

    let ding =
      Data_encoding.merge_tups (dyn_if_not T1.ding) (dyn_if_not T2.ding)

    let v = (T1.v, T2.v)

    let pp ppf (v1, v2) = Crowbar.pp ppf "@[<hv 1>(%a, %a)@]" T1.pp v1 T2.pp v2
  end )

let testable_printer : testable Crowbar.printer =
 fun ppf (t : testable) ->
  let module T = (val t) in
  T.pp ppf T.v

(* helpers to construct values tester values *)

(* Generator for testable values *)

let tup_gen (tgen : testable Crowbar.gen) : testable Crowbar.gen =
  let open Crowbar in
  (* Stack overflow if there are more levels *)
  with_printer testable_printer
  @@ choose
       [ map [tgen] map_tup1;
         map [tgen; tgen] map_tup2;
         map [tgen; tgen; tgen] map_tup3;
         map [tgen; tgen; tgen; tgen] map_tup4;
         map [tgen; tgen; tgen; tgen; tgen] map_tup5;
         map [tgen; tgen; tgen; tgen; tgen; tgen] map_tup6 ]

let gen =
  let open Crowbar in
  let g : testable Crowbar.gen =
    fix (fun g ->
        choose
          [ const null;
            const empty;
            const unit;
            map [short_string] map_constant;
            map [int8] map_int8;
            map [uint8] map_uint8;
            (* TODO: use newer version of crowbar to get these generators
              map [int16] map_int16;
              map [uint16] map_uint16;
        *)
            map [int32] map_int32;
            map [int64] map_int64;
            (* NOTE: the int encoding require ranges to be 30-bit compatible *)
            map [int8; int8; int8] map_range_int;
            map [float; float; float] map_range_float;
            map [bool] map_bool;
            map [short_string] map_string;
            map [short_mbytes] map_bytes;
            map [float] map_float;
            map [short_string1] map_fixed_string;
            map [short_mbytes1] map_fixed_bytes;
            map [short_string] map_variable_string;
            map [short_mbytes] map_variable_bytes;
            map [g] map_some;
            map [g] map_none;
            map [g] map_dynamic_size;
            map [g] map_tup1;
            map [g; g] map_tup2;
            map [g; g; g] map_tup3;
            map [g; g; g; g] map_tup4;
            map [g; g; g; g; g] map_tup5;
            map [g; g; g; g; g; g] map_tup6;
            map [g; g] (fun t1 t2 ->
                map_merge_tups (map_tup1 t1) (map_tup1 t2));
            map [g; g; g] (fun t1 t2 t3 ->
                map_merge_tups (map_tup2 t1 t2) (map_tup1 t3));
            map [g; g; g] (fun t1 t2 t3 ->
                map_merge_tups (map_tup1 t1) (map_tup2 t2 t3))
            (* NOTE: we cannot use lists/arrays for now. They require the
           data-inside to be homogeneous (e.g., same rangedness of ranged
           numbers) which we cannot guarantee right now. This can be fixed once
           we update Crowbar and get access to the new `dynamic_bind` generator
           combinator.

           map [g; list g] map_variable_list;
           map [g; list g] (fun t ts -> map_variable_array t (Array.of_list ts));
        *)
           ])
  in
  with_printer testable_printer g

(* TODO: The following features are not yet tested
   val string_enum : (string * 'a) list -> 'a encoding
   val delayed : (unit -> 'a encoding) -> 'a encoding
   val json : json encoding
   val json_schema : json_schema encoding
   type 'a field
   val req :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't field
   val opt :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't option field
   val varopt :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't option field
   val dft :
   ?title:string -> ?description:string ->
   string -> 't encoding -> 't -> 't field
   val obj1 : 'f1 field -> 'f1 encoding
   val obj2 : 'f1 field -> 'f2 field -> ('f1 * 'f2) encoding
   val obj3 : 'f1 field -> 'f2 field -> 'f3 field -> ('f1 * 'f2 * 'f3) encoding
   val obj4 :
   val obj5 :
   val obj6 :
   val obj7 :
   val obj8 :
   val obj9 :
   val obj10 :
   val merge_objs : 'o1 encoding -> 'o2 encoding -> ('o1 * 'o2) encoding
   val array : 'a encoding -> 'a array encoding
   val list : 'a encoding -> 'a list encoding
   val assoc : 'a encoding -> (string * 'a) list encoding
   type 't case
   type case_tag = Tag of int | Json_only
   val case : case_tag -> 'a encoding -> ('t -> 'a option) -> ('a -> 't) -> 't case
   val union : ?tag_size:[ `Uint8 | `Uint16 ] -> 't case list -> 't encoding

*)

(* Basic functions for executing tests on a given input *)
let roundtrip_json pp ding v =
  let json =
    try Data_encoding.Json.construct ding v
    with Invalid_argument m ->
      Crowbar.fail (Format.asprintf "Cannot construct: %a (%s)" pp v m)
  in
  let vv =
    try Data_encoding.Json.destruct ding json
    with Data_encoding.Json.Cannot_destruct (_, _) ->
      Crowbar.fail "Cannot destruct"
  in
  Crowbar.check_eq ~pp v vv

let roundtrip_binary pp ding v =
  let bin =
    try Data_encoding.Binary.to_bytes_exn ding v
    with Data_encoding.Binary.Write_error we ->
      Format.kasprintf
        Crowbar.fail
        "Cannot construct: %a (%a)"
        pp
        v
        Data_encoding.Binary.pp_write_error
        we
  in
  let vv =
    try Data_encoding.Binary.of_bytes_exn ding bin
    with Data_encoding.Binary.Read_error re ->
      Format.kasprintf
        Crowbar.fail
        "Cannot destruct: %a (%a)"
        pp
        v
        Data_encoding.Binary.pp_read_error
        re
  in
  Crowbar.check_eq ~pp v vv

(* Setting up the actual tests *)
let test_testable_json (testable : testable) =
  let module T = (val testable) in
  roundtrip_json T.pp T.ding T.v

let test_testable_binary (testable : testable) =
  let module T = (val testable) in
  roundtrip_binary T.pp T.ding T.v

let () =
  Crowbar.add_test ~name:"binary roundtrips" [gen] test_testable_binary ;
  Crowbar.add_test ~name:"json roundtrips" [gen] test_testable_json ;
  ()
src/lib_data_encoding/test/test_generated.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition char {A : Type} : A :=
  op_startypeminuserrorstar (cons op_startypeminuserrorstar []) Char.chr.

Definition string {A : Type} : A := op_startypeminuserrorstar.

Definition short_string {A : Type} : A := op_startypeminuserrorstar.

Definition short_string1 {A : Type} : A := op_startypeminuserrorstar.

Definition mbytes {A : Type} : A :=
  op_startypeminuserrorstar (cons op_startypeminuserrorstar [])
    Stdlib.Bytes.of_string.

Definition short_mbytes {A : Type} : A :=
  op_startypeminuserrorstar (cons short_string []) Stdlib.Bytes.of_string.

Definition short_mbytes1 {A : Type} : A :=
  op_startypeminuserrorstar (cons short_string1 []) Stdlib.Bytes.of_string.

Module TESTABLE.
  Record signature {t : Type} := {
    t := t;
    v : t;
    ding : Tezos_data_encoding.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End TESTABLE.

Definition testable := {t : _ & TESTABLE.signature t}.

Definition null : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Data_encoding.null;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition empty : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Data_encoding.empty;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition unit : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Data_encoding.unit;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_constant (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := tt;
      TESTABLE.ding := Data_encoding.constant s;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_int8 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Data_encoding.int8;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_uint8 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Data_encoding.uint8;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_int16 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Data_encoding.int16;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_uint16 (i : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Data_encoding.uint16;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_int32 (i : int32) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Data_encoding.int32;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_int64 (i : int64) : testable :=
  existT _ _
    {|
      TESTABLE.v := i;
      TESTABLE.ding := Data_encoding.int64;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_range_int (a : Z) (b : Z) (c : Z) : testable :=
  let '(small, middle, big) :=
    match Stdlib.List.sort OCaml.Stdlib.compare (cons a (cons b (cons c [])))
      with
    | cons small (cons middle (cons big [])) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert (OCaml.Stdlib.le small middle) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert (OCaml.Stdlib.le middle big) in
      (small, middle, big)
    | _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  existT _ _
    {|
      TESTABLE.v := middle;
      TESTABLE.ding := Data_encoding.ranged_int small big;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_range_float (a : Z) (b : Z) (c : Z) : testable :=
  if
    orb (equiv_decb (OCaml.Stdlib.compare a Stdlib.nan) 0)
      (orb (equiv_decb (OCaml.Stdlib.compare b Stdlib.nan) 0)
        (equiv_decb (OCaml.Stdlib.compare c Stdlib.nan) 0)) then
    null
  else
    let '(small, middle, big) :=
      match Stdlib.List.sort OCaml.Stdlib.compare (cons a (cons b (cons c [])))
        with
      | cons small (cons middle (cons big [])) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert (OCaml.Stdlib.le small middle) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert (OCaml.Stdlib.le middle big) in
        (small, middle, big)
      | _ =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      end in
    existT _ _
      {|
        TESTABLE.v := middle;
        TESTABLE.ding := Data_encoding.ranged_float small big;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        TESTABLE.pp := unhandled
        |}.

Definition map_bool (b : bool) : testable :=
  existT _ _
    {|
      TESTABLE.v := b;
      TESTABLE.ding := Data_encoding.bool;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_string (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Data_encoding.string;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_bytes (s : Stdlib.Bytes.t) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Data_encoding.bytes;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_float (f : Z) : testable :=
  existT _ _
    {|
      TESTABLE.v := f;
      TESTABLE.ding := Data_encoding.float;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_fixed_string (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Data_encoding.Fixed.string (OCaml.String.length s);
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_fixed_bytes (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Data_encoding.Fixed.bytes (String.length s);
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_variable_string (s : string) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Data_encoding.Variable.string;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_variable_bytes (s : Stdlib.Bytes.t) : testable :=
  existT _ _
    {|
      TESTABLE.v := s;
      TESTABLE.ding := Data_encoding.Variable.bytes;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition dyn_if_not {A : Type}
  (ding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding A :=
  match Data_encoding.classify ding with
  | Fixed _ | Dynamic => ding
  | Variable => Data_encoding.dynamic_size None ding
  end.

Definition map_some (t : testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.v := Some T.(TESTABLE.v);
      TESTABLE.ding :=
        (* ❌ Try-with are not handled *)
        try (Data_encoding.option T.(TESTABLE.ding));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_none (t : testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.v := unhandled;
      TESTABLE.ding :=
        (* ❌ Try-with are not handled *)
        try (Data_encoding.option T.(TESTABLE.ding));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_ok (t_o : testable) (t_e : testable) : testable :=
  let T_O := projT2 t_o in
  let T_E := projT2 t_e in
  existT _ _
    {|
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.v := unhandled;
      TESTABLE.ding :=
        Data_encoding.result T_O.(TESTABLE.ding) T_E.(TESTABLE.ding);
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_error (t_o : testable) (t_e : testable) : testable :=
  let T_O := projT2 t_o in
  let T_E := projT2 t_e in
  existT _ _
    {|
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.v := unhandled;
      TESTABLE.ding :=
        Data_encoding.result T_O.(TESTABLE.ding) T_E.(TESTABLE.ding);
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_variable_list (t : testable) (ts : list testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.Variable.list None (dyn_if_not T.(TESTABLE.ding));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.v := unhandled;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_variable_array (t : testable) (ts : array testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.Variable.array None (dyn_if_not T.(TESTABLE.ding));
      TESTABLE.v :=
        Array.of_list
          (Array.fold_left
            (fun acc =>
              fun t =>
                let T := projT2 t in
                cons (Obj.magic T.(TESTABLE.v)) acc) [] ts);
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_dynamic_size (t : testable) : testable :=
  let T := projT2 t in
  existT _ _
    {|
      (* ❌ Include is not handled inside first-class module values *)
      TESTABLE._ := include;
      TESTABLE.ding := Data_encoding.dynamic_size None T.(TESTABLE.ding)
      |}.

Definition map_tup1 (t1 : testable) : testable :=
  let T1 := projT2 t1 in
  existT _ _
    {|
      (* ❌ Include is not handled inside first-class module values *)
      TESTABLE._ := include;
      TESTABLE.ding := Data_encoding.tup1 T1.(TESTABLE.ding);
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup2 (t1 : testable) (t2 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup2 (dyn_if_not T1.(TESTABLE.ding)) T2.(TESTABLE.ding);
      TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup3 (t1 : testable) (t2 : testable) (t3 : testable)
  : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup3 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) T3.(TESTABLE.ding);
      TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup4
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup4 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          T4.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup5
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup5 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) T5.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup6
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup6 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          T6.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup7
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup7 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) T7.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup8
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  let T8 := projT2 t8 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup8 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
          T8.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup9
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
  (t9 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  let T8 := projT2 t8 in
  let T9 := projT2 t9 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup9 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
          (dyn_if_not T8.(TESTABLE.ding)) T9.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v),
          T9.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_tup10
  (t1 : testable) (t2 : testable) (t3 : testable) (t4 : testable)
  (t5 : testable) (t6 : testable) (t7 : testable) (t8 : testable)
  (t9 : testable) (t10 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  let T3 := projT2 t3 in
  let T4 := projT2 t4 in
  let T5 := projT2 t5 in
  let T6 := projT2 t6 in
  let T7 := projT2 t7 in
  let T8 := projT2 t8 in
  let T9 := projT2 t9 in
  let T10 := projT2 t10 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.tup10 (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding)) (dyn_if_not T3.(TESTABLE.ding))
          (dyn_if_not T4.(TESTABLE.ding)) (dyn_if_not T5.(TESTABLE.ding))
          (dyn_if_not T6.(TESTABLE.ding)) (dyn_if_not T7.(TESTABLE.ding))
          (dyn_if_not T8.(TESTABLE.ding)) (dyn_if_not T9.(TESTABLE.ding))
          T10.(TESTABLE.ding);
      TESTABLE.v :=
        (T1.(TESTABLE.v), T2.(TESTABLE.v), T3.(TESTABLE.v), T4.(TESTABLE.v),
          T5.(TESTABLE.v), T6.(TESTABLE.v), T7.(TESTABLE.v), T8.(TESTABLE.v),
          T9.(TESTABLE.v), T10.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.

Definition map_merge_tups (t1 : testable) (t2 : testable) : testable :=
  let T1 := projT2 t1 in
  let T2 := projT2 t2 in
  existT _ _
    {|
      TESTABLE.ding :=
        Data_encoding.merge_tups (dyn_if_not T1.(TESTABLE.ding))
          (dyn_if_not T2.(TESTABLE.ding));
      TESTABLE.v := (T1.(TESTABLE.v), T2.(TESTABLE.v));
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      TESTABLE.pp := unhandled
      |}.



Definition tup_gen {A B : Type} (function_parameter : A) : B :=
  let '_ := function_parameter in
  op_startypeminuserrorstar.

Definition gen {A : Type} : A := op_startypeminuserrorstar.

Definition roundtrip_json {A B : Type}
  (pp : Stdlib.Format.formatter -> A -> unit)
  (ding : Tezos_data_encoding__Data_encoding.Encoding.t A) (v : A) : B :=
  let json :=
    (* ❌ Try-with are not handled *)
    try (Data_encoding.Json.construct ding v) in
  let vv :=
    (* ❌ Try-with are not handled *)
    try (Data_encoding.Json.destruct ding json) in
  op_startypeminuserrorstar pp v vv.

Definition roundtrip_binary {A B : Type}
  (pp : Stdlib.Format.formatter -> A -> unit)
  (ding : Tezos_data_encoding__Data_encoding.Encoding.t A) (v : A) : B :=
  let bin :=
    (* ❌ Try-with are not handled *)
    try (Data_encoding.Binary.to_bytes_exn ding v) in
  let vv :=
    (* ❌ Try-with are not handled *)
    try (Data_encoding.Binary.of_bytes_exn ding bin) in
  op_startypeminuserrorstar pp v vv.

Definition test_testable_json {A : Type} (testable : testable) : A :=
  let T := projT2 testable in
  roundtrip_json op_startypeminuserrorstar T.(TESTABLE.ding) T.(TESTABLE.v).

Definition test_testable_binary {A : Type} (testable : testable) : A :=
  let T := projT2 testable in
  roundtrip_binary op_startypeminuserrorstar T.(TESTABLE.ding) T.(TESTABLE.v).



src/lib_data_encoding/test/types.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

type record = {a : int; b : bool; c : Z.t option; d : float}

let default_record = {a = 32; b = true; c = Some Z.one; d = 12.34}

let record_obj_enc =
  conv
    (fun {a; b; c; d} -> ((a, b), (c, d)))
    (fun ((a, b), (c, d)) -> {a; b; c; d})
    (merge_objs
       (obj2 (req "a" int31) (dft "b" bool false))
       (obj2 (opt "c" z) (req "d" float)))

let record_tup_enc =
  conv
    (fun {a; b; c; d} -> ((a, b, c), d))
    (fun ((a, b, c), d) -> {a; b; c; d})
    (merge_tups (tup3 int31 bool (option z)) (tup1 float))

let record_to_string {a; b; c; d} =
  let c = match c with None -> "none" | Some c -> Z.to_string c in
  Format.asprintf "(%d, %B, %s, %f)" a b c d

type variable_record = {p : int; q : Bytes.t}

let default_variable_record = {p = 23; q = Bytes.of_string "wwwxxyyzzz"}

let variable_record_obj_enc =
  conv
    (fun {p; q} -> (p, q))
    (fun (p, q) -> {p; q})
    (obj2 (req "p" int31) (req "q" Variable.bytes))

let variable_record_tup_enc =
  conv
    (fun {p; q} -> (p, q))
    (fun (p, q) -> {p; q})
    (tup2 int31 Variable.bytes)

let variable_record_to_string {p; q} =
  Format.asprintf "(%d, %a)" p Hex.pp (Hex.of_bytes q)

type variable_left_record = {x : int; y : Bytes.t; z : int}

let default_variable_left_record =
  {x = 98; y = Bytes.of_string "765"; z = 4321}

let variable_left_record_obj_enc =
  conv
    (fun {x; y; z} -> (x, y, z))
    (fun (x, y, z) -> {x; y; z})
    (obj3 (req "x" int31) (req "y" Variable.bytes) (req "z" int31))

let variable_left_record_tup_enc =
  conv
    (fun {x; y; z} -> (x, y, z))
    (fun (x, y, z) -> {x; y; z})
    (tup3 int31 Variable.bytes int31)

let variable_left_record_to_string {x; y; z} =
  Format.asprintf "(%d, %a, %d)" x Hex.pp (Hex.of_bytes y) z

type union = A of int | B of string | C of int | D of string | E

let union_enc =
  union
    [ case
        (Tag 1)
        ~title:"A"
        int8
        (function A i -> Some i | _ -> None)
        (fun i -> A i);
      case
        (Tag 2)
        ~title:"B"
        string
        (function B s -> Some s | _ -> None)
        (fun s -> B s);
      case
        (Tag 3)
        ~title:"C"
        (obj1 (req "C" int8))
        (function C i -> Some i | _ -> None)
        (fun i -> C i);
      case
        (Tag 4)
        ~title:"D"
        (obj2 (req "kind" (constant "D")) (req "data" string))
        (function D s -> Some ((), s) | _ -> None)
        (fun ((), s) -> D s);
      case
        (Tag 5)
        ~title:"E"
        empty
        (function E -> Some () | _ -> None)
        (fun () -> E) ]

let mini_union_enc =
  union
    [ case
        (Tag 1)
        ~title:"A"
        int8
        (function A i -> Some i | _ -> None)
        (fun i -> A i) ]

let union_to_string = function
  | A i ->
      Printf.sprintf "A %d" i
  | B s ->
      Printf.sprintf "B %s" s
  | C i ->
      Printf.sprintf "C %d" i
  | D s ->
      Printf.sprintf "D %s" s
  | E ->
      "E"

let enum_enc =
  string_enum
    [("one", 1); ("two", 2); ("three", 3); ("four", 4); ("five", 5); ("six", 6)]

let mini_enum_enc = string_enum [("one", 1); ("two", 2)]

let mu_list_enc enc =
  mu "list"
  @@ fun mu_list_enc ->
  union
    [ case
        (Tag 0)
        ~title:"Nil"
        empty
        (function [] -> Some () | _ :: _ -> None)
        (fun () -> []);
      case
        (Tag 1)
        ~title:"Cons"
        (obj2 (req "value" enc) (req "next" mu_list_enc))
        (function x :: xs -> Some (x, xs) | [] -> None)
        (fun (x, xs) -> x :: xs) ]

let bounded_list ~total ~elements enc =
  check_size total (Variable.list (check_size elements enc))

module Alcotest = struct
  include Alcotest

  let float =
    testable Fmt.float (fun f1 f2 ->
        match (classify_float f1, classify_float f2) with
        | (FP_nan, FP_nan) ->
            true
        | _ ->
            f1 = f2)

  let bytes =
    testable
      (Fmt.of_to_string (fun s ->
           let (`Hex s) = Hex.of_bytes s in
           s))
      Bytes.equal

  let z = testable (Fmt.of_to_string Z.to_string) Z.equal

  let n = z

  let record = testable (Fmt.of_to_string record_to_string) ( = )

  let variable_record =
    testable (Fmt.of_to_string variable_record_to_string) ( = )

  let variable_left_record =
    testable (Fmt.of_to_string variable_left_record_to_string) ( = )

  let union = testable (Fmt.of_to_string union_to_string) ( = )
end
src/lib_data_encoding/test/types.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Record record := {
  a : Z;
  b : bool;
  c : option Z.t;
  d : Z }.

Definition default_record : record :=
  {| a := 32; b := true; c := Some Z.one;
    d :=
      (* ❌ Float constant 12.34 is approximated by the integer 12 *)
      12 |}.

Definition record_obj_enc : Tezos_data_encoding.Data_encoding.encoding record :=
  conv
    (fun function_parameter =>
      let '{| a := a; b := b; c := c; d := d |} := function_parameter in
      ((a, b), (c, d)))
    (fun function_parameter =>
      let '((a, b), (c, d)) := function_parameter in
      {| a := a; b := b; c := c; d := d |}) None
    (merge_objs
      (obj2 (req None None "a" % string int31)
        (dft None None "b" % string bool false))
      (obj2 (opt None None "c" % string z) (req None None "d" % string float))).

Definition record_tup_enc : Tezos_data_encoding.Data_encoding.encoding record :=
  conv
    (fun function_parameter =>
      let '{| a := a; b := b; c := c; d := d |} := function_parameter in
      ((a, b, c), d))
    (fun function_parameter =>
      let '((a, b, c), d) := function_parameter in
      {| a := a; b := b; c := c; d := d |}) None
    (merge_tups (tup3 int31 bool (option z)) (tup1 float)).

Definition record_to_string (function_parameter : record) : string :=
  let '{| a := a; b := b; c := c; d := d |} := function_parameter in
  let c :=
    match c with
    | None => "none" % string
    | Some c => Z.to_string c
    end in
  Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "(" % char
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal ", " % string
            (CamlinternalFormatBasics.Bool CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal ", " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ", " % string
                    (CamlinternalFormatBasics.Float
                      CamlinternalFormatBasics.Float_f
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))))))
      "(%d, %B, %s, %f)" % string) a b c d.

Record variable_record := {
  p : Z;
  q : Stdlib.Bytes.t }.

Definition default_variable_record : variable_record :=
  {| p := 23; q := Stdlib.Bytes.of_string "wwwxxyyzzz" % string |}.

Definition variable_record_obj_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_record :=
  conv
    (fun function_parameter =>
      let '{| p := p; q := q |} := function_parameter in
      (p, q))
    (fun function_parameter =>
      let '(p, q) := function_parameter in
      {| p := p; q := q |}) None
    (obj2 (req None None "p" % string int31)
      (req None None "q" % string Variable.bytes)).

Definition variable_record_tup_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_record :=
  conv
    (fun function_parameter =>
      let '{| p := p; q := q |} := function_parameter in
      (p, q))
    (fun function_parameter =>
      let '(p, q) := function_parameter in
      {| p := p; q := q |}) None (tup2 int31 Variable.bytes).

Definition variable_record_to_string (function_parameter : variable_record)
  : string :=
  let '{| p := p; q := q |} := function_parameter in
  Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "(" % char
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal ", " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))))) "(%d, %a)" % string)
    p Hex.pp (Hex.of_bytes None q).

Record variable_left_record := {
  x : Z;
  y : Stdlib.Bytes.t;
  z : Z }.

Definition default_variable_left_record : variable_left_record :=
  {| x := 98; y := Stdlib.Bytes.of_string "765" % string; z := 4321 |}.

Definition variable_left_record_obj_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_left_record :=
  conv
    (fun function_parameter =>
      let '{| x := x; y := y; z := z |} := function_parameter in
      (x, y, z))
    (fun function_parameter =>
      let '(x, y, z) := function_parameter in
      {| x := x; y := y; z := z |}) None
    (obj3 (req None None "x" % string int31)
      (req None None "y" % string Variable.bytes)
      (req None None "z" % string int31)).

Definition variable_left_record_tup_enc
  : Tezos_data_encoding.Data_encoding.encoding variable_left_record :=
  conv
    (fun function_parameter =>
      let '{| x := x; y := y; z := z |} := function_parameter in
      (x, y, z))
    (fun function_parameter =>
      let '(x, y, z) := function_parameter in
      {| x := x; y := y; z := z |}) None (tup3 int31 Variable.bytes int31).

Definition variable_left_record_to_string
  (function_parameter : variable_left_record) : string :=
  let '{| x := x; y := y; z := z |} := function_parameter in
  Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "(" % char
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal ", " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal ", " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))))))
      "(%d, %a, %d)" % string) x Hex.pp (Hex.of_bytes None y) z.

Inductive union : Type :=
| A : Z -> union
| B : string -> union
| C : Z -> union
| D : string -> union
| E : union.

Definition union_enc : Tezos_data_encoding.Data_encoding.encoding union :=
  union None
    (cons
      (case "A" % string None (Tezos_data_encoding.Data_encoding.Tag 1) int8
        (fun function_parameter =>
          match function_parameter with
          | A i => Some i
          | _ => None
          end) (fun i => A i))
      (cons
        (case "B" % string None (Tezos_data_encoding.Data_encoding.Tag 2) string
          (fun function_parameter =>
            match function_parameter with
            | B s => Some s
            | _ => None
            end) (fun s => B s))
        (cons
          (case "C" % string None (Tezos_data_encoding.Data_encoding.Tag 3)
            (obj1 (req None None "C" % string int8))
            (fun function_parameter =>
              match function_parameter with
              | C i => Some i
              | _ => None
              end) (fun i => C i))
          (cons
            (case "D" % string None (Tezos_data_encoding.Data_encoding.Tag 4)
              (obj2 (req None None "kind" % string (constant "D" % string))
                (req None None "data" % string string))
              (fun function_parameter =>
                match function_parameter with
                | D s => Some (tt, s)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, s) := function_parameter in
                D s))
            (cons
              (case "E" % string None (Tezos_data_encoding.Data_encoding.Tag 5)
                empty
                (fun function_parameter =>
                  match function_parameter with
                  | E => Some tt
                  | _ => None
                  end)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  E)) []))))).

Definition mini_union_enc : Tezos_data_encoding.Data_encoding.encoding union :=
  union None
    (cons
      (case "A" % string None (Tezos_data_encoding.Data_encoding.Tag 1) int8
        (fun function_parameter =>
          match function_parameter with
          | A i => Some i
          | _ => None
          end) (fun i => A i)) []).

Definition union_to_string (function_parameter : union) : string :=
  match function_parameter with
  | A i =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "A " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "A %d" % string) i
  | B s =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "B " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "B %s" % string) s
  | C i =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "C " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "C %d" % string) i
  | D s =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "D " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "D %s" % string) s
  | E => "E" % string
  end.

Definition enum_enc : Tezos_data_encoding.Data_encoding.encoding Z :=
  string_enum
    (cons ("one" % string, 1)
      (cons ("two" % string, 2)
        (cons ("three" % string, 3)
          (cons ("four" % string, 4)
            (cons ("five" % string, 5) (cons ("six" % string, 6) [])))))).

Definition mini_enum_enc : Tezos_data_encoding.Data_encoding.encoding Z :=
  string_enum (cons ("one" % string, 1) (cons ("two" % string, 2) [])).

Definition mu_list_enc {A : Type}
  (enc : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (list A) :=
  apply
    (let arg := mu "list" % string in
    fun eta => arg None None eta)
    (fun mu_list_enc =>
      union None
        (cons
          (case "Nil" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
            empty
            (fun function_parameter =>
              match function_parameter with
              | [] => Some tt
              | cons _ _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              []))
          (cons
            (case "Cons" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
              (obj2 (req None None "value" % string enc)
                (req None None "next" % string mu_list_enc))
              (fun function_parameter =>
                match function_parameter with
                | cons x xs => Some (x, xs)
                | [] => None
                end)
              (fun function_parameter =>
                let '(x, xs) := function_parameter in
                cons x xs)) []))).

Definition bounded_list {A : Type}
  (total : Z) (elements : Z)
  (enc : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (list A) :=
  check_size total (Variable.list None (check_size elements enc)).

Module Alcotest.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition float {A : Type} : A :=
    op_startypeminuserrorstar op_startypeminuserrorstar
      (fun f1 =>
        fun f2 =>
          match ((Stdlib.classify_float f1), (Stdlib.classify_float f2)) with
          | (Stdlib.FP_nan, Stdlib.FP_nan) => true
          | _ => equiv_decb f1 f2
          end).
  
  Definition bytes {A : Type} : A :=
    op_startypeminuserrorstar
      (op_startypeminuserrorstar
        (fun s =>
          let 'Hex s := Hex.of_bytes None s in
          s)) Stdlib.Bytes.equal.
  
  Definition z {A : Type} : A :=
    op_startypeminuserrorstar (op_startypeminuserrorstar Z.to_string) Z.equal.
  
  Definition n {A : Type} : A := z.
  
  Definition record {A : Type} : A :=
    op_startypeminuserrorstar (op_startypeminuserrorstar record_to_string)
      equiv_decb.
  
  Definition variable_record {A : Type} : A :=
    op_startypeminuserrorstar
      (op_startypeminuserrorstar variable_record_to_string) equiv_decb.
  
  Definition variable_left_record {A : Type} : A :=
    op_startypeminuserrorstar
      (op_startypeminuserrorstar variable_left_record_to_string) equiv_decb.
  
  Definition union {A : Type} : A :=
    op_startypeminuserrorstar (op_startypeminuserrorstar union_to_string)
      equiv_decb.
End Alcotest.

src/lib_data_encoding/test/versioned.ml 56 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(**
   Tests for the {!Data_encoding.With_version} module.
*)

(** This module is a simple example of use of {!With_version}. *)
module Documented_example = struct
  (** Here we show how to {i "versionize"} a given random encoding (which
      just happens to be very similar to {!Internal_event.Debug_event}). *)

  (** We are going to provide successive versions of a module
      implementing {!INTENDED_SIGNATURE} (which is similar to a
      simplified {!Internal_event.EVENT_DEFINITION}): *)
  module type INTENDED_SIGNATURE = sig
    type t

    val encoding : t Data_encoding.t

    val pp : Format.formatter -> t -> unit
  end

  (** The name, once used with {!With_version.encoding}, appears in
      the serialized values, it has to remain constant across versions: *)
  let name = "versioned-documented-example"

  (** The first version has a [(string * string) list] field. *)
  module V0 = struct
    type t = {message : string; attachment : (string * string) list}

    (** This is the "naked" (i.e. non-versioned) encoding of version-0: *)
    let encoding =
      let open Data_encoding in
      conv
        (fun {message; attachment} -> (message, attachment))
        (fun (message, attachment) -> {message; attachment})
        (obj2 (req "message" string) (req "attach" (list (tup2 string string))))
  end

  (** The versioned implementation of {!INTENDED_SIGNATURE}: *)
  module First_version : INTENDED_SIGNATURE with type t = V0.t = struct
    include V0

    (** The encoding with the version tagging: *)
    let encoding =
      Data_encoding.With_version.(encoding ~name (first_version V0.encoding))

    let pp ppf {message; attachment} =
      let open Format in
      fprintf ppf "%s:@ %s@ [" name message ;
      pp_open_box ppf 2 ;
      pp_print_list
        ~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
        (fun fmt (k, v) -> fprintf fmt "%s: %S" k v)
        ppf
        attachment ;
      pp_close_box ppf () ;
      fprintf ppf "]" ;
      ()
  end

  (** In a later version we want the attachment to be any piece of
      Json and not just a key-value list: *)
  module V1 = struct
    (** Version 1 is very similar to {!Internal_event.Debug_event}: *)
    type t = {message : string; attachment : Data_encoding.Json.t}

    let make ?(attach = `Null) message () = {message; attachment = attach}

    (** Note the "upgrade" function which can make a {!V1.t} from a {!V0.t}: *)
    let of_v0 {V0.message; attachment} =
      {
        message;
        attachment = `O (List.map (fun (k, v) -> (k, `String v)) attachment);
      }

    (** Again we build first a version-free encoding: *)
    let encoding =
      let open Data_encoding in
      conv
        (fun {message; attachment} -> (message, attachment))
        (fun (message, attachment) -> {message; attachment})
        (obj2 (req "message" string) (req "attachment" json))
  end

  (** The second version exports {!V1.t} while being able to parse
      (and upgrade from) {!First_version.t} values. *)
  module Second_version : INTENDED_SIGNATURE with type t = V1.t = struct
    include V1

    (** Here is the interesting use of {!Data_encoding.With_version}: the
        encoding uses both {!V0.encoding} and {!V1.encoding} and
        provides {!V1.of_v0} as an upgrade function. *)
    let encoding =
      Data_encoding.With_version.(
        encoding
          ~name
          (first_version V0.encoding |> next_version V1.encoding V1.of_v0))

    let pp ppf {message; attachment} =
      let open Format in
      fprintf ppf "%s:@ %s@ %a" name message Data_encoding.Json.pp attachment
  end

  (** This test "serializes" successively using
      {!First_version.encoding} and {!Second_version.encoding}, and then
      shows that the former's output can be parsed with the later. *)
  let actual_test () =
    let v0_thing : First_version.t =
      {
        V0.message = "The v0 message";
        attachment = [("k1", "v1"); ("k2", "v2")];
      }
    in
    let json_v0 =
      Data_encoding.Json.construct First_version.encoding v0_thing
    in
    let expected_json_v0 =
      `O
        [ ( name ^ ".v0",
            (* -> here we see how the [~name] is used. *)
            `O
              [ ("message", `String v0_thing.V0.message);
                ( "attach",
                  `A
                    (List.map
                       (fun (k, v) -> `A [`String k; `String v])
                       v0_thing.V0.attachment) ) ] ) ]
    in
    if json_v0 <> expected_json_v0 then
      Alcotest.failf
        "Json-v0: %a@ Vs@ %a"
        Data_encoding.Json.pp
        json_v0
        Data_encoding.Json.pp
        expected_json_v0 ;
    (* Up to here we only used the {!First_version} module. Now the
       same process with {!Second_version}: *)
    let v1_thing : Second_version.t =
      {
        V1.message = "The v1 message";
        attachment = `O [("k1", `String "v1"); ("kn", `Float 42.)];
      }
    in
    let json_v1 =
      Data_encoding.Json.construct Second_version.encoding v1_thing
    in
    let expected_json_v1 =
      `O
        [ ( name ^ ".v1",
            `O
              [ ("message", `String v1_thing.V1.message);
                ("attachment", v1_thing.V1.attachment) ] ) ]
    in
    if json_v1 <> expected_json_v1 then
      Alcotest.failf
        "Json-v1: %a@ Vs@ %a"
        Data_encoding.Json.pp
        json_v1
        Data_encoding.Json.pp
        expected_json_v1 ;
    (* Now the {b interesting part}, we decode ("destruct") the JSON from
       {!First_version} with {!Second_version}: *)
    let v0_decoded_later : Second_version.t =
      Data_encoding.Json.destruct Second_version.encoding json_v0
    in
    (* And we check that going through JSON is equivalent to just
       calling the upgrade function directly on the {!First_version.t}
       value: *)
    let expected_v1 = V1.of_v0 v0_thing in
    if v0_decoded_later <> expected_v1 then
      Alcotest.failf
        "Parsing v0 with v1: %a@ Vs@ %a"
        Second_version.pp
        v0_decoded_later
        Second_version.pp
        expected_v1 ;
    ()
end

(** This test builds a few successive versions of encodings and tries
    out parsing/printing with successive encapsulated
    versioned-encodings.

    Check out ["_build/_tests/versioned.001.output"] to see how they look.
*)
let test_n_encapsulated_versions () =
  let open Data_encoding in
  let name = "test0" in
  let version_0 = obj2 (req "left" string) (req "right" string) in
  let versioned_0 = With_version.(encoding ~name @@ first_version version_0) in
  let value_0 = ("v0", "k0") in
  let json_0 = Json.construct versioned_0 value_0 in
  Helpers.no_exception (fun () ->
      let result = Json.destruct versioned_0 json_0 in
      if result <> value_0 then Alcotest.failf "value-0") ;
  let module Ex = struct
    type v0 = string * string

    type t =
      | Hide : 'a Data_encoding.t * 'a With_version.t * 'a * (v0 -> 'a) -> t
  end in
  let make_next (Ex.Hide (enc, versioned, example, from_v0)) index =
    let new_tag = Printf.sprintf "left-%d" index in
    let version_n = obj2 (req new_tag string) (req "right" enc) in
    let upgrade vn = ("some-random-extra-string", vn) in
    let versioned_n =
      With_version.(next_version version_n upgrade versioned)
    in
    let encoding = With_version.(encoding ~name versioned_n) in
    let example_n = ("val4" ^ new_tag, example) in
    let json_example_n = Json.construct encoding example_n in
    Helpers.no_exception (fun () ->
        let result = Json.destruct encoding json_example_n in
        if result <> example_n then Alcotest.failf "value-%d" index) ;
    let json_example_p =
      Json.construct With_version.(encoding ~name versioned) example
    in
    Helpers.no_exception (fun () ->
        let result = Json.destruct encoding json_example_p in
        if result <> upgrade example then
          Alcotest.failf "value-%d-previous-encoding" index) ;
    let next_upgrade x = upgrade (from_v0 x) in
    Helpers.no_exception (fun () ->
        let result = Json.destruct encoding json_0 in
        if result <> next_upgrade value_0 then
          Alcotest.failf "value-%d-from-v0-encoding" index) ;
    Format.eprintf "json_example_%d:@ %a\n%!" index Json.pp json_example_n ;
    Format.eprintf
      "json_example_%d-from-v0:@ %a\n%!"
      index
      Json.pp
      (Json.construct encoding (next_upgrade value_0)) ;
    Ex.Hide (version_n, versioned_n, example_n, next_upgrade)
  in
  let (Ex.Hide _) =
    ListLabels.fold_left
      (List.init 10 (( + ) 1))
      ~init:
        (Ex.Hide
           ( version_0,
             With_version.(first_version version_0),
             value_0,
             fun x -> x ))
      ~f:make_next
  in
  ()

let tests =
  [ ("example-test", `Quick, Documented_example.actual_test);
    ("test-encapsulated-versions", `Quick, test_n_encapsulated_versions) ]
src/lib_data_encoding/test/versioned.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Documented_example.
  Module INTENDED_SIGNATURE.
    Record signature {t : Type} := {
      t := t;
      encoding : Tezos_data_encoding.Data_encoding.t t;
      pp : Stdlib.Format.formatter -> t -> unit;
    }.
    Arguments signature : clear implicits.
  End INTENDED_SIGNATURE.
  
  Definition name : string := "versioned-documented-example" % string.
  
  Module V0.
    Record t := {
      message : string;
      attachment : list (string * string) }.
    
    Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
      conv
        (fun function_parameter =>
          let '{| message := message; attachment := attachment |} :=
            function_parameter in
          (message, attachment))
        (fun function_parameter =>
          let '(message, attachment) := function_parameter in
          {| message := message; attachment := attachment |}) None
        (obj2 (req None None "message" % string string)
          (req None None "attach" % string (list None (tup2 string string)))).
  End V0.
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
  
  Module V1.
    Record t := {
      message : string;
      attachment : Tezos_data_encoding.Data_encoding.Json.t }.
    
    Definition make (op_staroptstar : option variant) : string -> unit -> t :=
      let attach :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Variants not supported *)
          variant
        end in
      fun message =>
        fun function_parameter =>
          let 'tt := function_parameter in
          {| message := message; attachment := attach |}.
    
    Definition of_v0 (function_parameter : V0.t) : t :=
      let '{| V0.message := message; V0.attachment := attachment |} :=
        function_parameter in
      {| message := message;
        attachment :=
          (* ❌ Variants not supported *)
          variant |}.
    
    Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
      conv
        (fun function_parameter =>
          let '{| message := message; attachment := attachment |} :=
            function_parameter in
          (message, attachment))
        (fun function_parameter =>
          let '(message, attachment) := function_parameter in
          {| message := message; attachment := attachment |}) None
        (obj2 (req None None "message" % string string)
          (req None None "attachment" % string json)).
  End V1.
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
  
  Definition actual_test (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    let v0_thing :=
      {| V0.message := "The v0 message" % string;
        V0.attachment :=
          cons ("k1" % string, "v1" % string)
            (cons ("k2" % string, "v2" % string) []) |} in
    let json_v0 :=
      Data_encoding.Json.construct First_version.(INTENDED_SIGNATURE.encoding)
        v0_thing in
    let expected_json_v0 :=
      (* ❌ Variants not supported *)
      variant in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb json_v0 expected_json_v0 then
        op_startypeminuserrorstar "Json-v0: %a@ Vs@ %a" % string
          Data_encoding.Json.pp json_v0 Data_encoding.Json.pp expected_json_v0
      else
        tt in
    let v1_thing :=
      {| V1.message := "The v1 message" % string;
        V1.attachment :=
          (* ❌ Variants not supported *)
          variant |} in
    let json_v1 :=
      Data_encoding.Json.construct Second_version.(INTENDED_SIGNATURE.encoding)
        v1_thing in
    let expected_json_v1 :=
      (* ❌ Variants not supported *)
      variant in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb json_v1 expected_json_v1 then
        op_startypeminuserrorstar "Json-v1: %a@ Vs@ %a" % string
          Data_encoding.Json.pp json_v1 Data_encoding.Json.pp expected_json_v1
      else
        tt in
    let v0_decoded_later :=
      Data_encoding.Json.destruct Second_version.(INTENDED_SIGNATURE.encoding)
        json_v0 in
    let expected_v1 := V1.of_v0 v0_thing in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb v0_decoded_later expected_v1 then
        op_startypeminuserrorstar "Parsing v0 with v1: %a@ Vs@ %a" % string
          Second_version.(INTENDED_SIGNATURE.pp) v0_decoded_later
          Second_version.(INTENDED_SIGNATURE.pp) expected_v1
      else
        tt in
    tt.
End Documented_example.

Definition test_n_encapsulated_versions (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let name := "test0" % string in
  let version_0 :=
    obj2 (req None None "left" % string string)
      (req None None "right" % string string) in
  let versioned_0 := apply (encoding name) (first_version version_0) in
  let value_0 := ("v0" % string, "k0" % string) in
  let json_0 := Json.construct versioned_0 value_0 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    op_startypeminuserrorstar
      (fun function_parameter =>
        let 'tt := function_parameter in
        let result := Json.destruct versioned_0 json_0 in
        if nequiv_decb result value_0 then
          op_startypeminuserrorstar "value-0" % string
        else
          tt) in
  let Ex :=
    (* ❌ The signature name of this module could not be found *)
    existT _ _
      {|
        
        |} in
  let make_next (function_parameter : Ex.t) : Z -> Ex.t :=
    let 'Ex.Hide enc versioned example from_v0 := function_parameter in
    fun index =>
      let new_tag :=
        Printf.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "left-" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format)) "left-%d" % string)
          index in
      let version_n :=
        obj2 (req None None new_tag string) (req None None "right" % string enc)
        in
      let upgrade {A : Type} (vn : A) : string * A :=
        ("some-random-extra-string" % string, vn) in
      let versioned_n := next_version version_n upgrade versioned in
      let encoding := encoding name versioned_n in
      let example_n := ((String.append "val4" % string new_tag), example) in
      let json_example_n := Json.construct encoding example_n in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar
          (fun function_parameter =>
            let 'tt := function_parameter in
            let result := Json.destruct encoding json_example_n in
            if nequiv_decb result example_n then
              op_startypeminuserrorstar "value-%d" % string index
            else
              tt) in
      let json_example_p := Json.construct (encoding name versioned) example in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar
          (fun function_parameter =>
            let 'tt := function_parameter in
            let result := Json.destruct encoding json_example_p in
            if nequiv_decb result (upgrade example) then
              op_startypeminuserrorstar "value-%d-previous-encoding" % string
                index
            else
              tt) in
      let next_upgrade (x : Ex.v0) : string * op_dollarHide_'a :=
        upgrade (from_v0 x) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar
          (fun function_parameter =>
            let 'tt := function_parameter in
            let result := Json.destruct encoding json_0 in
            if nequiv_decb result (next_upgrade value_0) then
              op_startypeminuserrorstar "value-%d-from-v0-encoding" % string
                index
            else
              tt) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "json_example_" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal ":" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format)))))))
            "json_example_%d:@ %a
%!" % string) index Json.pp json_example_n in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "json_example_" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal "-from-v0:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format)))))))
            "json_example_%d-from-v0:@ %a
%!" % string) index Json.pp
          (Json.construct encoding (next_upgrade value_0)) in
      Ex.Hide version_n versioned_n example_n next_upgrade in
  let 'Ex.Hide _ _ _ _ :=
    ListLabels.fold_left make_next
      (Ex.Hide version_0 (first_version version_0) value_0 (fun x => x))
      (Stdlib.List.init 10 (Z.add 1)) in
  tt.

Definition tests : list (string * variant * (unit -> unit)) :=
  cons
    ("example-test" % string,
      (* ❌ Variants not supported *)
      variant, Documented_example.actual_test)
    (cons
      ("test-encapsulated-versions" % string,
        (* ❌ Variants not supported *)
        variant, test_n_encapsulated_versions) []).

src/lib_data_encoding/test/write_failure.ml 27 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Test expected errors while serializing data. *)

open Data_encoding
open Types

let check_raises expected f =
  match f () with
  | exception exn when expected exn ->
      ()
  | exception exn ->
      Alcotest.failf "Unexpected exception: %s." (Printexc.to_string exn)
  | _ ->
      Alcotest.failf "Expecting exception, got success."

let json ?(expected = fun _ -> true) encoding value () =
  check_raises expected (fun () ->
      ignore (Json.construct encoding value : Json.t))

let bson ?(expected = fun _ -> true) encoding value () =
  check_raises expected (fun () ->
      ignore (Bson.construct encoding value : Bson.t))

let binary ?(expected = fun _ -> true) encoding value () =
  check_raises expected (fun () ->
      ignore (Binary.to_bytes_exn encoding value : Bytes.t))

let all name encoding value =
  [ (name ^ ".json", `Quick, json encoding value);
    (name ^ ".bson", `Quick, bson encoding value);
    (name ^ ".bytes", `Quick, binary encoding value) ]

let all_ranged_int minimum maximum =
  let encoding = ranged_int minimum maximum in
  let name = Format.asprintf "ranged_int.%d" minimum in
  all (name ^ ".min") encoding (minimum - 1)
  @ all (name ^ ".max") encoding (maximum + 1)

let all_ranged_float minimum maximum =
  let encoding = ranged_float minimum maximum in
  let name = Format.asprintf "ranged_float.%f" minimum in
  all (name ^ ".min") encoding (minimum -. 1.)
  @ all (name ^ ".max") encoding (maximum +. 1.)

let test_bounded_string_list =
  let expected = function
    | Binary_error.Write_error Size_limit_exceeded ->
        true
    | _ ->
        false
  in
  let test name ~total ~elements v =
    ( "bounded_string_list." ^ name,
      `Quick,
      binary ~expected (bounded_list ~total ~elements string) v )
  in
  [ test "a" ~total:0 ~elements:0 [""];
    test "b1" ~total:3 ~elements:4 [""];
    test "b2" ~total:4 ~elements:3 [""];
    test "c1" ~total:19 ~elements:4 [""; ""; ""; ""; ""];
    test "c2" ~total:20 ~elements:3 [""; ""; ""; ""; ""];
    test "d1" ~total:20 ~elements:5 [""; ""; ""; ""; "a"];
    test "d2" ~total:21 ~elements:4 [""; ""; ""; ""; "a"];
    test "e" ~total:30 ~elements:10 ["ab"; "c"; "def"; "gh"; "ijk"] ]

let tests =
  all_ranged_int 100 400 @ all_ranged_int 19000 19254
  @ all_ranged_int ~-100 300
  @ all_ranged_int ~-300_000_000 300_000_000
  @ all_ranged_float ~-.100. 300.
  @ all "string.fixed" (Fixed.string 4) "turlututu"
  @ all "string.bounded" (Bounded.string 4) "turlututu"
  @ all "bytes.fixed" (Fixed.bytes 4) (Bytes.of_string "turlututu")
  @ all "bytes.bounded" (Bounded.bytes 4) (Bytes.of_string "turlututu")
  @ all "unknown_case.B" mini_union_enc (B "2")
  @ all "unknown_case.E" mini_union_enc E
  @ test_bounded_string_list
  @ all "n" n (Z.of_string "-12")
  @ []
src/lib_data_encoding/test/write_failure.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition check_raises {A : Type} (expected : exn -> bool) (f : unit -> A)
  : unit :=
  let '_ := f tt in
  op_startypeminuserrorstar "Expecting exception, got success." % string.

Definition json {A : Type} (op_staroptstar : option (exn -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
  let expected :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        true
    end in
  fun encoding =>
    fun value =>
      fun function_parameter =>
        let 'tt := function_parameter in
        check_raises expected
          (fun function_parameter =>
            let 'tt := function_parameter in
            OCaml.Stdlib.ignore (Json.construct encoding value)).

Definition bson {A : Type} (op_staroptstar : option (exn -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
  let expected :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        true
    end in
  fun encoding =>
    fun value =>
      fun function_parameter =>
        let 'tt := function_parameter in
        check_raises expected
          (fun function_parameter =>
            let 'tt := function_parameter in
            OCaml.Stdlib.ignore (Bson.construct encoding value)).

Definition binary {A : Type} (op_staroptstar : option (exn -> bool))
  : (Tezos_data_encoding__Data_encoding.Encoding.t A) -> A -> unit -> unit :=
  let expected :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        true
    end in
  fun encoding =>
    fun value =>
      fun function_parameter =>
        let 'tt := function_parameter in
        check_raises expected
          (fun function_parameter =>
            let 'tt := function_parameter in
            OCaml.Stdlib.ignore (Binary.to_bytes_exn encoding value)).

Definition all {A : Type}
  (name : string) (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (value : A) : list (string * variant * (unit -> unit)) :=
  cons
    ((String.append name ".json" % string),
      (* ❌ Variants not supported *)
      variant, (json None encoding value))
    (cons
      ((String.append name ".bson" % string),
        (* ❌ Variants not supported *)
        variant, (bson None encoding value))
      (cons
        ((String.append name ".bytes" % string),
          (* ❌ Variants not supported *)
          variant, (binary None encoding value)) [])).

Definition all_ranged_int (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> unit)) :=
  let encoding := ranged_int minimum maximum in
  let name :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_int." % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_int.%d" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) encoding (Z.sub minimum 1))
    (all (String.append name ".max" % string) encoding (Z.add maximum 1)).

Definition all_ranged_float (minimum : Z) (maximum : Z)
  : list (string * variant * (unit -> unit)) :=
  let encoding := ranged_float minimum maximum in
  let name :=
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "ranged_float." % string
          (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "ranged_float.%f" % string)
      minimum in
  OCaml.Stdlib.app
    (all (String.append name ".min" % string) encoding
      (Stdlib.op_minuspoint minimum
        (* ❌ Float constant 1. is approximated by the integer 1 *)
        1))
    (all (String.append name ".max" % string) encoding
      (Stdlib.op_pluspoint maximum
        (* ❌ Float constant 1. is approximated by the integer 1 *)
        1)).

Definition test_bounded_string_list
  : list (string * variant * (unit -> unit)) :=
  let expected (function_parameter : exn) : bool :=
    match function_parameter with
    | Write_error Tezos_data_encoding.Binary_error.Size_limit_exceeded => true
    | _ => false
    end in
  let test {A B C : Type} (name : string) (total : A) (elements : B) (v : C)
    : string * variant * (unit -> unit) :=
    ((String.append "bounded_string_list." % string name),
      (* ❌ Variants not supported *)
      variant,
      (binary (Some expected) (op_startypeminuserrorstar total elements string)
        v)) in
  cons (test "a" % string 0 0 (cons "" % string []))
    (cons (test "b1" % string 3 4 (cons "" % string []))
      (cons (test "b2" % string 4 3 (cons "" % string []))
        (cons
          (test "c1" % string 19 4
            (cons "" % string
              (cons "" % string
                (cons "" % string (cons "" % string (cons "" % string []))))))
          (cons
            (test "c2" % string 20 3
              (cons "" % string
                (cons "" % string
                  (cons "" % string (cons "" % string (cons "" % string []))))))
            (cons
              (test "d1" % string 20 5
                (cons "" % string
                  (cons "" % string
                    (cons "" % string (cons "" % string (cons "a" % string []))))))
              (cons
                (test "d2" % string 21 4
                  (cons "" % string
                    (cons "" % string
                      (cons "" % string
                        (cons "" % string (cons "a" % string []))))))
                (cons
                  (test "e" % string 30 10
                    (cons "ab" % string
                      (cons "c" % string
                        (cons "def" % string
                          (cons "gh" % string (cons "ijk" % string [])))))) []))))))).

Definition tests : list (string * variant * (unit -> unit)) :=
  OCaml.Stdlib.app (all_ranged_int 100 400)
    (OCaml.Stdlib.app (all_ranged_int 19000 19254)
      (OCaml.Stdlib.app (all_ranged_int (Z.opp 100) 300)
        (OCaml.Stdlib.app (all_ranged_int (Z.opp 300000000) 300000000)
          (OCaml.Stdlib.app
            (all_ranged_float
              (Stdlib.op_tildeminuspoint
                (* ❌ Float constant 100. is approximated by the integer 100 *)
                100)
              (* ❌ Float constant 300. is approximated by the integer 300 *)
              300)
            (OCaml.Stdlib.app
              (all "string.fixed" % string (Fixed.string 4) "turlututu" % string)
              (OCaml.Stdlib.app
                (all "string.bounded" % string (Bounded.string 4)
                  "turlututu" % string)
                (OCaml.Stdlib.app
                  (all "bytes.fixed" % string (Fixed.bytes 4)
                    (Stdlib.Bytes.of_string "turlututu" % string))
                  (OCaml.Stdlib.app
                    (all "bytes.bounded" % string (Bounded.bytes 4)
                      (Stdlib.Bytes.of_string "turlututu" % string))
                    (OCaml.Stdlib.app
                      (all "unknown_case.B" % string op_startypeminuserrorstar
                        op_startypeminuserrorstar)
                      (OCaml.Stdlib.app
                        (all "unknown_case.E" % string op_startypeminuserrorstar
                          op_startypeminuserrorstar)
                        (OCaml.Stdlib.app test_bounded_string_list
                          (OCaml.Stdlib.app
                            (all "n" % string n (Z.of_string "-12" % string)) [])))))))))))).

src/lib_data_encoding/tzEndian.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Bytes_encodings

let set_int32 = set_int32_be

let get_int32 = get_int32_be

let set_int8 = set_int8

let get_int8 = get_int8

let set_int16 = set_int16_be

let get_int16 = get_int16_be

let set_int64 = set_int64_be

let get_int64 = get_int64_be

let get_uint8 = get_uint8

let get_uint16 = get_uint16_be

let get_double buff i = Int64.float_of_bits (get_int64_be buff i)

let set_double buff i v = set_int64_be buff i (Int64.bits_of_float v)
src/lib_data_encoding/tzEndian.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Bytes_encodings.

Definition set_int32 : string -> Z -> int32 -> unit := set_int32_be.

Definition get_int32 : string -> Z -> int32 := get_int32_be.

Definition set_int8 : string -> Z -> Z -> unit := set_int8.

Definition get_int8 : string -> Z -> Z := get_int8.

Definition set_int16 : string -> Z -> Z -> unit := set_int16_be.

Definition get_int16 : string -> Z -> Z := get_int16_be.

Definition set_int64 : string -> Z -> int64 -> unit := set_int64_be.

Definition get_int64 : string -> Z -> int64 := get_int64_be.

Definition get_uint8 : string -> Z -> Z := get_uint8.

Definition get_uint16 : string -> Z -> Z := get_uint16_be.

Definition get_double (buff : string) (i : Z) : Z :=
  Int64.float_of_bits (get_int64_be buff i).

Definition set_double (buff : string) (i : Z) (v : Z) : unit :=
  set_int64_be buff i (Int64.bits_of_float v).

src/lib_data_encoding/with_version.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Encoding

let version_case enc choose wrap name nth =
  case
    ~title:(Printf.sprintf "%s version %d" name nth)
    Json_only
    (obj1 (req (Printf.sprintf "%s.v%d" name nth) enc))
    choose
    wrap

let make_encoding ~name l =
  union ~tag_size:`Uint8 (List.mapi (fun nth f -> f name nth) l)

type _ t =
  | Version_0 : 'v0 encoding -> 'v0 t
  | Version_S : {
      previous : 'vn t;
      encoding : 'vnp1 encoding;
      upgrade : 'vn -> 'vnp1;
    }
      -> 'vnp1 t

let first_version e = Version_0 e

let next_version encoding upgrade previous =
  Version_S {encoding; upgrade; previous}

let encoding : type a. name:string -> a t -> a encoding =
 fun ~name version ->
  match version with
  | Version_0 e ->
      make_encoding ~name [version_case e (fun x -> Some x) (fun x -> x)]
  | Version_S {previous; encoding; upgrade} ->
      let rec mk_nones :
          type (* This function generates encoding cases for all the
             outdated versions.
             These versions are never encoded to
             (hence [fun _ -> None]) but are safely decoded with
             the use of the upgrade functions. *)
          b.
          (b -> a) -> b t -> (string -> int -> a case) list =
       fun upgr -> function
        | Version_0 e ->
            [version_case e (fun _ -> None) (fun x -> upgr x)]
        | Version_S {previous; encoding; upgrade} ->
            let others = mk_nones (fun x -> upgr (upgrade x)) previous in
            version_case encoding (fun _ -> None) (fun x -> upgr x) :: others
      in
      let nones = mk_nones upgrade previous in
      let cases =
        version_case encoding (fun x -> Some x) (fun x -> x) :: nones
        |> List.rev
      in
      make_encoding ~name cases
src/lib_data_encoding/with_version.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Encoding.

Definition version_case {A B : Type}
  (enc : Tezos_data_encoding.Encoding.encoding A) (choose : B -> option A)
  (wrap : A -> B) (name : string) (nth : Z)
  : Tezos_data_encoding.Encoding.case B :=
  case
    (Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal " version " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s version %d" % string)
      name nth) None Tezos_data_encoding.Encoding.Json_only
    (obj1
      (req None None
        (Printf.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal ".v" % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))) "%s.v%d" % string)
          name nth) enc)) choose wrap.

Definition make_encoding {A B : Type}
  (name : A) (l : list (A -> Z -> Tezos_data_encoding.Encoding.case B))
  : Tezos_data_encoding.Encoding.encoding B :=
  union
    (Some
      (* ❌ Variants not supported *)
      variant) (Stdlib.List.mapi (fun nth => fun f => f name nth) l).

Inductive t : forall (_ : Type), Type :=
| Version_0 : forall {v0 : Type}, (Tezos_data_encoding.Encoding.encoding v0) ->
  t v0
| Version_S : forall {vn vnp1 : Type}, (t vn) ->
  (Tezos_data_encoding.Encoding.encoding vnp1) -> (vn -> vnp1) -> t vnp1.

Definition first_version {A : Type}
  (e : Tezos_data_encoding.Encoding.encoding A) : t A := Version_0 e.

Definition next_version {A B : Type}
  (encoding : Tezos_data_encoding.Encoding.encoding A) (upgrade : B -> A)
  (previous : t B) : t A :=
  Version_S {| previous := previous; encoding := encoding; upgrade := upgrade |}.

Definition encoding {a : Type} (name : string) (version : t a)
  : Tezos_data_encoding.Encoding.encoding a :=
  match version with
  | Version_0 e =>
    make_encoding name (cons (version_case e (fun x => Some x) (fun x => x)) [])
  |
    Version_S {|
      previous := previous; encoding := encoding; upgrade := upgrade |} =>
    let fix mk_nones {b : Type} (upgr : b -> a) (function_parameter : t b)
      : list (string -> Z -> Tezos_data_encoding.Encoding.case a) :=
      match function_parameter with
      | Version_0 e =>
        cons
          (version_case e
            (fun function_parameter =>
              let '_ := function_parameter in
              None) (fun x => upgr x)) []
      |
        Version_S {|
          previous := previous; encoding := encoding; upgrade := upgrade |}
        =>
        let others := mk_nones (fun x => upgr (upgrade x)) previous in
        cons
          (version_case encoding
            (fun function_parameter =>
              let '_ := function_parameter in
              None) (fun x => upgr x)) others
      end in
    let nones := mk_nones upgrade previous in
    let cases :=
      OCaml.Stdlib.reverse_apply
        (cons (version_case encoding (fun x => Some x) (fun x => x)) nones)
        List.rev in
    make_encoding name cases
  end.

src/lib_error_monad/core.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Error Monad *)

(*-- Error classification ----------------------------------------------------*)

include Core_maker.Make (struct
  let id = ""
end)
src/lib_error_monad/core.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_error_monad/core_maker.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* hack: forward reference from [Data_encoding_ezjsonm] *)
let json_to_string = ref (fun _ -> "")

let json_pp id encoding ppf x =
  Format.pp_print_string ppf @@ !json_to_string
  @@
  let encoding =
    Data_encoding.(merge_objs (obj1 (req "id" string)) encoding)
  in
  Data_encoding.Json.construct encoding (id, x)

let set_error_encoding_cache_dirty = ref (fun () -> ())

module Make (Prefix : Sig.PREFIX) : sig
  include Sig.CORE

  include Sig.EXT with type error := error

  include Sig.WITH_WRAPPED with type error := error
end = struct
  type error = ..

  module type Wrapped_error_monad = sig
    type unwrapped = ..

    include Sig.CORE with type error := unwrapped

    include Sig.EXT with type error := unwrapped

    val unwrap : error -> unwrapped option

    val wrap : unwrapped -> error
  end

  type full_error_category =
    | Main of Sig.error_category
    | Wrapped of (module Wrapped_error_monad)

  (* the toplevel store for error kinds *)
  type error_kind =
    | Error_kind : {
        id : string;
        title : string;
        description : string;
        from_error : error -> 'err option;
        category : full_error_category;
        encoding_case : error Data_encoding.case;
        pp : Format.formatter -> 'err -> unit;
      }
        -> error_kind

  type error_info = {
    category : Sig.error_category;
    id : string;
    title : string;
    description : string;
    schema : Data_encoding.json_schema;
  }

  let error_kinds : error_kind list ref = ref []

  let get_registered_errors () : error_info list =
    List.flatten
      (List.map
         (function
           | Error_kind {id = ""; _} ->
               []
           | Error_kind
               { id;
                 title;
                 description;
                 category = Main category;
                 encoding_case;
                 _ } ->
               [ {
                   id;
                   title;
                   description;
                   category;
                   schema =
                     Data_encoding.Json.schema
                       (Data_encoding.union [encoding_case]);
                 } ]
           | Error_kind {category = Wrapped (module WEM); _} ->
               List.map
                 (fun {WEM.id; title; description; category; schema} ->
                   {id; title; description; category; schema})
                 (WEM.get_registered_errors ()))
         !error_kinds)

  let error_encoding_cache = ref None

  let () =
    let cont = !set_error_encoding_cache_dirty in
    set_error_encoding_cache_dirty :=
      fun () ->
        cont () ;
        error_encoding_cache := None

  let string_of_category = function
    | `Permanent ->
        "permanent"
    | `Temporary ->
        "temporary"
    | `Branch ->
        "branch"

  let pp_info ppf {category; id; title; description; schema} =
    Format.fprintf
      ppf
      "@[<v 2>category : %s\n\
       id : %s\n\
       title : %s\n\
       description : %s\n\
       schema : %a@]"
      (string_of_category category)
      id
      title
      description
      (Json_repr.pp (module Json_repr.Ezjsonm))
      (Json_schema.to_json schema)

  (* Catch all error when 'serializing' an error. *)
  type error += Unclassified of string

  let () =
    let id = "" in
    let category = Main `Temporary in
    let to_error msg = Unclassified msg in
    let from_error = function
      | Unclassified msg ->
          Some msg
      | error ->
          let msg = Obj.(extension_name @@ extension_constructor error) in
          Some ("Unclassified error: " ^ msg ^ ". Was the error registered?")
    in
    let title = "Generic error" in
    let description = "An unclassified error" in
    let encoding_case =
      let open Data_encoding in
      case
        Json_only
        ~title:"Generic error"
        ( def "generic_error" ~title ~description
        @@ conv (fun x -> ((), x)) (fun ((), x) -> x)
        @@ obj2 (req "kind" (constant "generic")) (req "error" string) )
        from_error
        to_error
    in
    let pp ppf s = Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s in
    error_kinds :=
      Error_kind
        {id; title; description; from_error; category; encoding_case; pp}
      :: !error_kinds

  (* Catch all error when 'deserializing' an error. *)
  type error += Unregistred_error of Data_encoding.json

  let () =
    let id = "" in
    let category = Main `Temporary in
    let to_error msg = Unregistred_error msg in
    let from_error = function
      | Unregistred_error json ->
          Some json
      | _ ->
          None
    in
    let encoding_case =
      let open Data_encoding in
      case Json_only ~title:"Unregistred error" json from_error to_error
    in
    let pp ppf json =
      Format.fprintf
        ppf
        "@[<v 2>Unregistred error:@ %a@]"
        Data_encoding.Json.pp
        json
    in
    error_kinds :=
      Error_kind
        {
          id;
          title = "";
          description = "";
          from_error;
          category;
          encoding_case;
          pp;
        }
      :: !error_kinds

  let raw_register_error_kind category ~id:name ~title ~description ?pp
      encoding from_error to_error =
    let name = Prefix.id ^ name in
    if List.exists (fun (Error_kind {id; _}) -> name = id) !error_kinds then
      invalid_arg
        (Printf.sprintf "register_error_kind: duplicate error name: %s" name) ;
    let encoding_case =
      let open Data_encoding in
      match category with
      | Wrapped (module WEM) ->
          let unwrap err =
            match WEM.unwrap err with
            | Some (WEM.Unclassified _) ->
                None
            | Some (WEM.Unregistred_error _) ->
                Format.eprintf "What %s@." name ;
                None
            | res ->
                res
          in
          let wrap err =
            match err with
            | WEM.Unclassified _ ->
                failwith "ignore wrapped error when serializing"
            | WEM.Unregistred_error _ ->
                failwith "ignore wrapped error when deserializing"
            | res ->
                WEM.wrap res
          in
          case Json_only ~title:name WEM.error_encoding unwrap wrap
      | Main category ->
          let with_id_and_kind_encoding =
            merge_objs
              (obj2
                 (req "kind" (constant (string_of_category category)))
                 (req "id" (constant name)))
              encoding
          in
          case
            Json_only
            ~title
            ~description
            (conv
               (fun x -> (((), ()), x))
               (fun (((), ()), x) -> x)
               with_id_and_kind_encoding)
            from_error
            to_error
    in
    !set_error_encoding_cache_dirty () ;
    error_kinds :=
      Error_kind
        {
          id = name;
          category;
          title;
          description;
          from_error;
          encoding_case;
          pp = Option.unopt ~default:(json_pp name encoding) pp;
        }
      :: !error_kinds

  let register_wrapped_error_kind (module WEM : Wrapped_error_monad) ~id ~title
      ~description =
    raw_register_error_kind
      (Wrapped (module WEM))
      ~id
      ~title
      ~description
      ~pp:WEM.pp
      WEM.error_encoding
      WEM.unwrap
      WEM.wrap

  let register_error_kind category ~id ~title ~description ?pp encoding
      from_error to_error =
    if not (Data_encoding.is_obj encoding) then
      invalid_arg
        (Printf.sprintf
           "Specified encoding for \"%s%s\" is not an object, but error \
            encodings must be objects."
           Prefix.id
           id) ;
    raw_register_error_kind
      (Main category)
      ~id
      ~title
      ~description
      ?pp
      encoding
      from_error
      to_error

  let error_encoding () =
    match !error_encoding_cache with
    | None ->
        let cases =
          List.map
            (fun (Error_kind {encoding_case; _}) -> encoding_case)
            !error_kinds
        in
        let union_encoding = Data_encoding.union cases in
        let encoding =
          let open Data_encoding in
          dynamic_size
          @@ splitted
               ~json:union_encoding
               ~binary:
                 (conv
                    (Json.construct union_encoding)
                    (Json.destruct union_encoding)
                    json)
        in
        error_encoding_cache := Some encoding ;
        encoding
    | Some encoding ->
        encoding

  let error_encoding = Data_encoding.delayed error_encoding

  let json_of_error error = Data_encoding.Json.construct error_encoding error

  let error_of_json json = Data_encoding.Json.destruct error_encoding json

  let classify_error error =
    let rec find e = function
      | [] ->
          `Temporary
      (* assert false (\* See "Generic error" *\) *)
      | Error_kind {from_error; category; _} :: rest -> (
        match from_error e with
        | Some _ -> (
          match category with
          | Main error_category ->
              error_category
          | Wrapped (module WEM) -> (
            match WEM.unwrap e with
            | Some e ->
                WEM.classify_error e
            | None ->
                find e rest ) )
        | None ->
            find e rest )
    in
    find error !error_kinds

  let pp ppf error =
    let rec find = function
      | [] ->
          assert false (* See "Generic error" *)
      | Error_kind {from_error; pp; _} :: errors -> (
        match from_error error with None -> find errors | Some x -> pp ppf x )
    in
    find !error_kinds
end
src/lib_error_monad/core_maker.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition json_to_string
  : Stdlib.ref (Tezos_data_encoding.Data_encoding.Json.json -> string) :=
  Stdlib.ref
    (fun function_parameter =>
      let '_ := function_parameter in
      "" % string).

Definition json_pp {A : Type}
  (id : string) (encoding : Tezos_data_encoding.Data_encoding.encoding A)
  (ppf : Stdlib.Format.formatter) (x : A) : unit :=
  apply (Format.pp_print_string ppf)
    (apply (Stdlib.op_exclamation json_to_string)
      (let encoding :=
        merge_objs (obj1 (req None None "id" % string string)) encoding in
      Data_encoding.Json.construct encoding (id, x))).

Definition set_error_encoding_cache_dirty : Stdlib.ref (unit -> unit) :=
  Stdlib.ref
    (fun function_parameter =>
      let 'tt := function_parameter in
      tt).

(* ❌ Functors are not handled. *)
functor

src/lib_error_monad/error_monad.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Error Monad *)

(*-- Error classification ----------------------------------------------------*)

type error_category = [`Branch | `Temporary | `Permanent]

include Core
include Monad

module Make (Prefix : Sig.PREFIX) : sig
  include Sig.CORE

  include Sig.EXT with type error := error

  include Sig.WITH_WRAPPED with type error := error
end = struct
  include Core_maker.Make (Prefix)
end

type error += Exn of exn

let () =
  register_error_kind
    `Temporary
    ~id:"failure"
    ~title:"Exception"
    ~description:"Exception safely wrapped in an error"
    ~pp:(fun ppf s -> Format.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s)
    Data_encoding.(obj1 (req "msg" string))
    (function
      | Exn (Failure msg) ->
          Some msg
      | Exn exn ->
          Some (Printexc.to_string exn)
      | _ ->
          None)
    (fun msg -> Exn (Failure msg))

let generic_error fmt = Format.kasprintf (fun s -> error (Exn (Failure s))) fmt

let failwith fmt = Format.kasprintf (fun s -> fail (Exn (Failure s))) fmt

let error_exn s = Error [Exn s]

let trace_exn exn f = trace (Exn exn) f

let generic_trace fmt =
  Format.kasprintf (fun str -> trace_exn (Failure str)) fmt

let record_trace_exn exn f = record_trace (Exn exn) f

let failure fmt = Format.kasprintf (fun str -> Exn (Failure str)) fmt

let pp_exn ppf exn = pp ppf (Exn exn)

type error += Canceled

let () =
  register_error_kind
    `Temporary
    ~id:"utils.Canceled"
    ~title:"Canceled"
    ~description:"Canceled"
    Data_encoding.unit
    (function Canceled -> Some () | _ -> None)
    (fun () -> Canceled)

let () =
  register_error_kind
    `Temporary
    ~id:"canceled"
    ~title:"Canceled"
    ~description:"A promise was unexpectedly canceled"
    ~pp:(fun f () ->
      Format.pp_print_string f "The promise was unexpectedly canceled")
    Data_encoding.unit
    (function Canceled -> Some () | _ -> None)
    (fun () -> Canceled)

let protect ?on_error ?canceler t =
  let cancellation =
    match canceler with
    | None ->
        Lwt_utils.never_ending ()
    | Some canceler ->
        Lwt_canceler.cancellation canceler >>= fun () -> fail Canceled
  in
  let res = Lwt.pick [cancellation; Lwt.catch t (fun exn -> fail (Exn exn))] in
  res
  >>= function
  | Ok _ ->
      res
  | Error err -> (
      let canceled =
        Option.unopt_map canceler ~default:false ~f:Lwt_canceler.canceled
      in
      let err = if canceled then [Canceled] else err in
      match on_error with
      | None ->
          Lwt.return_error err
      | Some on_error ->
          Lwt.catch (fun () -> on_error err) (fun exn -> fail (Exn exn)) )

type error += Timeout

let () =
  register_error_kind
    `Temporary
    ~id:"utils.Timeout"
    ~title:"Timeout"
    ~description:"Timeout"
    ~pp:(fun f () -> Format.pp_print_string f "The request has timed out")
    Data_encoding.unit
    (function Timeout -> Some () | _ -> None)
    (fun () -> Timeout)

let with_timeout ?(canceler = Lwt_canceler.create ()) timeout f =
  let target = f canceler in
  Lwt.choose [timeout; (target >|= fun _ -> ())]
  >>= fun () ->
  if Lwt.state target <> Lwt.Sleep then (Lwt.cancel timeout ; target)
  else Lwt_canceler.cancel canceler >>= fun () -> fail Timeout

let errs_tag = Tag.def ~doc:"Errors" "errs" pp_print_error

let json_to_string = Core_maker.json_to_string
src/lib_error_monad/error_monad.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition error_category := variant.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Functors are not handled. *)
functor

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition generic_error {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (tzresult B)) : A :=
  Format.kasprintf (fun s => error (Exn (OCaml.Failure s))) fmt.

Definition failwith {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t (tzresult B)))
  : A := Format.kasprintf (fun s => fail (Exn (OCaml.Failure s))) fmt.

Definition error_exn {A : Type} (s : exn) : sum A (list error) :=
  Stdlib.Error (cons (Exn s) []).

Definition trace_exn {A : Type} (exn : exn) (f : Lwt.t (tzresult A))
  : Lwt.t (tzresult A) := trace (Exn exn) f.

Definition generic_trace {A B : Type}
  (fmt :
    Stdlib.format4 A Stdlib.Format.formatter unit
      ((Lwt.t (tzresult B)) -> Lwt.t (tzresult B))) : A :=
  Format.kasprintf (fun str => trace_exn (OCaml.Failure str)) fmt.

Definition record_trace_exn {A : Type} (exn : exn) (f : tzresult A)
  : tzresult A := record_trace (Exn exn) f.

Definition failure {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit error) : A :=
  Format.kasprintf (fun str => Exn (OCaml.Failure str)) fmt.

Definition pp_exn (ppf : Stdlib.Format.formatter) (exn : exn) : unit :=
  pp ppf (Exn exn).

(* ❌ Structure item `typext` not handled. *)
type_extension





Definition protect {A : Type}
  (on_error : option (trace -> Lwt.t (tzresult A)))
  (canceler : option Tezos_stdlib.Lwt_canceler.t)
  (t : unit -> Lwt.t (tzresult A)) : Lwt.t (tzresult A) :=
  let cancellation :=
    match canceler with
    | None => Lwt_utils.never_ending tt
    | Some canceler =>
      op_gtgteq (Lwt_canceler.cancellation canceler)
        (fun function_parameter =>
          let 'tt := function_parameter in
          fail Canceled)
    end in
  let res :=
    Lwt.pick
      (cons cancellation (cons (Lwt.catch t (fun exn => fail (Exn exn))) [])) in
  op_gtgteq res
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok _ => res
      | Stdlib.Error err =>
        let canceled := Option.unopt_map Lwt_canceler.canceled false canceler in
        let err :=
          if canceled then
            cons Canceled []
          else
            err in
        match on_error with
        | None => Lwt.return_error err
        | Some on_error =>
          Lwt.catch
            (fun function_parameter =>
              let 'tt := function_parameter in
              on_error err) (fun exn => fail (Exn exn))
        end
      end).

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition with_timeout {A : Type}
  (op_staroptstar : option Tezos_stdlib.Lwt_canceler.t)
  : (Lwt.t unit) ->
    (Tezos_stdlib.Lwt_canceler.t -> Lwt.t (tzresult A)) -> Lwt.t (tzresult A) :=
  let canceler :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Lwt_canceler.create tt
    end in
  fun timeout =>
    fun f =>
      let target := f canceler in
      op_gtgteq
        (Lwt.choose
          (cons timeout
            (cons
              (op_gtpipeeq target
                (fun function_parameter =>
                  let '_ := function_parameter in
                  tt)) [])))
        (fun function_parameter =>
          let 'tt := function_parameter in
          if nequiv_decb (Lwt.state target) Lwt.Sleep then
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Lwt.cancel timeout in
            target
          else
            op_gtgteq (Lwt_canceler.cancel canceler)
              (fun function_parameter =>
                let 'tt := function_parameter in
                fail Timeout)).

Definition errs_tag : Tezos_stdlib.Tag.def trace :=
  Tag.def (Some "Errors" % string) "errs" % string pp_print_error.

Definition json_to_string
  : Stdlib.ref (Tezos_data_encoding.Data_encoding.json -> string) :=
  Core_maker.json_to_string.

src/lib_error_monad/error_table.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module type S = sig
  type key

  type 'a t

  val create : int -> 'a t

  val clear : 'a t -> unit

  val reset : 'a t -> unit

  val find_or_make :
    'a t -> key -> (unit -> 'a tzresult Lwt.t) -> 'a tzresult Lwt.t

  val remove : 'a t -> key -> unit

  val find_opt : 'a t -> key -> 'a tzresult Lwt.t option

  val mem : 'a t -> key -> bool

  val iter_s : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t

  val iter_p : (key -> 'a -> unit Lwt.t) -> 'a t -> unit Lwt.t

  val fold : (key -> 'a -> 'b -> 'b Lwt.t) -> 'a t -> 'b -> 'b Lwt.t

  val fold_promises :
    (key -> 'a tzresult Lwt.t -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val fold_resolved : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val fold_keys : (key -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val length : 'a t -> int
end

module Make (T : Hashtbl.S) : S with type key = T.key = struct
  type key = T.key

  type 'a t = {table : 'a tzresult Lwt.t T.t; cleaners : unit Lwt.t T.t}

  let create n = {table = T.create n; cleaners = T.create n}

  let clear t =
    T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ;
    T.iter (fun _ a -> Lwt.cancel a) t.table ;
    T.clear t.cleaners ;
    T.clear t.table

  let reset t =
    T.iter (fun _ cleaner -> Lwt.cancel cleaner) t.cleaners ;
    T.iter (fun _ a -> Lwt.cancel a) t.table ;
    T.reset t.cleaners ;
    T.reset t.table

  let find_or_make t k i =
    match T.find_opt t.table k with
    | Some a ->
        a
    | None ->
        let p = i () in
        T.add t.table k p ;
        T.add
          t.cleaners
          k
          ( p
          >>= function
          | Ok _ ->
              T.remove t.cleaners k ; Lwt.return_unit
          | Error _ ->
              T.remove t.table k ; T.remove t.cleaners k ; Lwt.return_unit ) ;
        p

  let remove t k =
    (match T.find_opt t.cleaners k with None -> () | Some a -> Lwt.cancel a) ;
    T.remove t.cleaners k ;
    (match T.find_opt t.table k with None -> () | Some a -> Lwt.cancel a) ;
    T.remove t.table k

  let find_opt t k = T.find_opt t.table k

  let mem t k = T.mem t.table k

  let iter_s f t =
    T.fold (fun k a acc -> (k, a) :: acc) t.table []
    |> Lwt_list.iter_s (fun (k, a) ->
           a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a)

  let iter_p f t =
    T.fold (fun k a acc -> (k, a) :: acc) t.table []
    |> Lwt_list.iter_p (fun (k, a) ->
           a >>= function Error _ -> Lwt.return_unit | Ok a -> f k a)

  let fold f t acc =
    T.fold (fun k a acc -> (k, a) :: acc) t.table []
    |> Lwt_list.fold_left_s
         (fun acc (k, a) ->
           a >>= function Error _ -> Lwt.return acc | Ok a -> f k a acc)
         acc

  let fold_promises f t acc = T.fold f t.table acc

  let fold_resolved f t acc =
    T.fold
      (fun k a acc ->
        match Lwt.state a with
        | Lwt.Sleep | Lwt.Fail _ | Lwt.Return (Error _) ->
            acc
        | Lwt.Return (Ok a) ->
            f k a acc)
      t.table
      acc

  let fold_keys f t acc = T.fold (fun k _ acc -> f k acc) t.table acc

  let length t = T.length t.table
end
src/lib_error_monad/error_table.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module S.
  Record signature {key t : Type} := {
    key := key;
    polymorphic_abstract_type;
    create : forall {a : Type}, Z -> t a;
    clear : forall {a : Type}, (t a) -> unit;
    reset : forall {a : Type}, (t a) -> unit;
    find_or_make : forall {a : Type}, (t a) ->
      key ->
        (unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) ->
          Lwt.t (Tezos_error_monad.Error_monad.tzresult a);
    remove : forall {a : Type}, (t a) -> key -> unit;
    find_opt : forall {a : Type}, (t a) ->
      key -> option (Lwt.t (Tezos_error_monad.Error_monad.tzresult a));
    mem : forall {a : Type}, (t a) -> key -> bool;
    iter_s : forall {a : Type}, (key -> a -> Lwt.t unit) -> (t a) -> Lwt.t unit;
    iter_p : forall {a : Type}, (key -> a -> Lwt.t unit) -> (t a) -> Lwt.t unit;
    fold : forall {a b : Type}, (key -> a -> b -> Lwt.t b) ->
      (t a) -> b -> Lwt.t b;
    fold_promises : forall {a b : Type}, (key ->
      (Lwt.t (Tezos_error_monad.Error_monad.tzresult a)) -> b -> b) ->
      (t a) -> b -> b;
    fold_resolved : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    fold_keys : forall {a b : Type}, (key -> b -> b) -> (t a) -> b -> b;
    length : forall {a : Type}, (t a) -> Z;
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

src/lib_error_monad/monad.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Monad_maker.Make (Core)
src/lib_error_monad/monad.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_error_monad/monad_maker.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make (Error : Sig.CORE) : Sig.MONAD with type error := Error.error =
struct
  (* INVARIANT: traces are never empty, they must contain at least one error *)

  type trace = Error.error list

  let trace_encoding = Data_encoding.list Error.error_encoding

  let pp_print_error ppf = function
    | [] ->
        assert false
    | [error] ->
        Format.fprintf ppf "@[<v 2>Error:@ %a@]@." Error.pp error
    | error :: _ as errors ->
        Format.fprintf
          ppf
          "@[<v 2>Error:@ %a,@ trace:@ %a@]@."
          Error.pp
          error
          (Format.pp_print_list Error.pp)
          (List.rev errors)

  let classify_errors trace =
    List.fold_left
      (fun r e ->
        match (r, Error.classify_error e) with
        | (`Permanent, _) | (_, `Permanent) ->
            `Permanent
        | (`Branch, _) | (_, `Branch) ->
            `Branch
        | (`Temporary, `Temporary) ->
            `Temporary)
      `Temporary
      trace

  type 'a tzresult = ('a, trace) result

  let result_encoding a_encoding =
    let open Data_encoding in
    let errors_encoding = obj1 (req "error" trace_encoding) in
    let a_encoding = obj1 (req "result" a_encoding) in
    union
      ~tag_size:`Uint8
      [ case
          (Tag 0)
          a_encoding
          ~title:"Ok"
          (function Ok x -> Some x | _ -> None)
          (function res -> Ok res);
        case
          (Tag 1)
          errors_encoding
          ~title:"Error"
          (function Error x -> Some x | _ -> None)
          (function [] -> assert false | _ :: _ as errs -> Error errs) ]

  let ( >>= ) = Lwt.( >>= )

  let return v = Lwt.return_ok v

  let return_unit = Lwt.return (Ok ())

  let return_none = Lwt.return (Ok None)

  let return_some x = Lwt.return (Ok (Some x))

  let return_nil = Lwt.return (Ok [])

  let return_true = Lwt.return (Ok true)

  let return_false = Lwt.return (Ok false)

  let error s = Error [s]

  let ok v = Ok v

  let fail s = Lwt.return_error [s]

  let ( >>? ) v f = match v with Error _ as err -> err | Ok v -> f v

  let ( >>=? ) v f =
    v >>= function Error _ as err -> Lwt.return err | Ok v -> f v

  let ( >>|? ) v f = v >>=? fun v -> Lwt.return_ok (f v)

  let ( >|= ) = Lwt.( >|= )

  let ( >|? ) v f = v >>? fun v -> Ok (f v)

  let rec map_s f l =
    match l with
    | [] ->
        return_nil
    | h :: t ->
        f h >>=? fun rh -> map_s f t >>=? fun rt -> return (rh :: rt)

  let mapi_s f l =
    let rec mapi_s f i l =
      match l with
      | [] ->
          return_nil
      | h :: t ->
          f i h
          >>=? fun rh -> mapi_s f (i + 1) t >>=? fun rt -> return (rh :: rt)
    in
    mapi_s f 0 l

  let rec rev_map_append_s acc f = function
    | [] ->
        return acc
    | hd :: tl ->
        f hd >>=? fun v -> rev_map_append_s (v :: acc) f tl

  let rev_map_s f l = rev_map_append_s [] f l

  let rec map_p f l =
    match l with
    | [] ->
        return_nil
    | x :: l -> (
        let tx = f x and tl = map_p f l in
        tx
        >>= fun x ->
        tl
        >>= fun l ->
        match (x, l) with
        | (Ok x, Ok l) ->
            Lwt.return_ok (x :: l)
        | (Error exn1, Error exn2) ->
            Lwt.return_error (exn1 @ exn2)
        | (Ok _, Error exn) | (Error exn, Ok _) ->
            Lwt.return_error exn )

  let mapi_p f l =
    let rec mapi_p f i l =
      match l with
      | [] ->
          return_nil
      | x :: l -> (
          let tx = f i x and tl = mapi_p f (i + 1) l in
          tx
          >>= fun x ->
          tl
          >>= fun l ->
          match (x, l) with
          | (Ok x, Ok l) ->
              Lwt.return_ok (x :: l)
          | (Error exn1, Error exn2) ->
              Lwt.return_error (exn1 @ exn2)
          | (Ok _, Error exn) | (Error exn, Ok _) ->
              Lwt.return_error exn )
    in
    mapi_p f 0 l

  let rec map2_s f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        return_nil
    | (_ :: _, []) | ([], _ :: _) ->
        invalid_arg "Error_monad.map2_s"
    | (h1 :: t1, h2 :: t2) ->
        f h1 h2 >>=? fun rh -> map2_s f t1 t2 >>=? fun rt -> return (rh :: rt)

  let mapi2_s f l1 l2 =
    let rec mapi2_s i f l1 l2 =
      match (l1, l2) with
      | ([], []) ->
          return_nil
      | (_ :: _, []) | ([], _ :: _) ->
          invalid_arg "Error_monad.mapi2_s"
      | (h1 :: t1, h2 :: t2) ->
          f i h1 h2
          >>=? fun rh ->
          mapi2_s (i + 1) f t1 t2 >>=? fun rt -> return (rh :: rt)
    in
    mapi2_s 0 f l1 l2

  let rec map2 f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        Ok []
    | (_ :: _, []) | ([], _ :: _) ->
        invalid_arg "Error_monad.map2"
    | (h1 :: t1, h2 :: t2) ->
        f h1 h2 >>? fun rh -> map2 f t1 t2 >>? fun rt -> Ok (rh :: rt)

  let rec filter_map_s f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        f h
        >>=? function
        | None ->
            filter_map_s f t
        | Some rh ->
            filter_map_s f t >>=? fun rt -> return (rh :: rt) )

  let rec filter_map_p f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        let th = f h and tt = filter_map_p f t in
        th
        >>=? function
        | None -> tt | Some rh -> tt >>=? fun rt -> return (rh :: rt) )

  let rec filter_s f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        f h
        >>=? function
        | false ->
            filter_s f t
        | true ->
            filter_s f t >>=? fun t -> return (h :: t) )

  let rec filter_p f l =
    match l with
    | [] ->
        return_nil
    | h :: t -> (
        let jh = f h and t = filter_p f t in
        jh >>=? function false -> t | true -> t >>=? fun t -> return (h :: t) )

  let rec iter_s f l =
    match l with [] -> return_unit | h :: t -> f h >>=? fun () -> iter_s f t

  let rec iter_p f l =
    match l with
    | [] ->
        return_unit
    | x :: l -> (
        let tx = f x and tl = iter_p f l in
        tx
        >>= fun tx_res ->
        tl
        >>= fun tl_res ->
        match (tx_res, tl_res) with
        | (Ok (), Ok ()) ->
            Lwt.return_ok ()
        | (Error exn1, Error exn2) ->
            Lwt.return_error (exn1 @ exn2)
        | (Ok (), Error exn) | (Error exn, Ok ()) ->
            Lwt.return_error exn )

  let iteri_p f l =
    let rec iteri_p i f l =
      match l with
      | [] ->
          return_unit
      | x :: l -> (
          let tx = f i x and tl = iteri_p (i + 1) f l in
          tx
          >>= fun tx_res ->
          tl
          >>= fun tl_res ->
          match (tx_res, tl_res) with
          | (Ok (), Ok ()) ->
              Lwt.return (Ok ())
          | (Error exn1, Error exn2) ->
              Lwt.return (Error (exn1 @ exn2))
          | (Ok (), Error exn) | (Error exn, Ok ()) ->
              Lwt.return (Error exn) )
    in
    iteri_p 0 f l

  let rec iter2_p f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        return_unit
    | ([], _) | (_, []) ->
        invalid_arg "Error_monad.iter2_p"
    | (x1 :: l1, x2 :: l2) -> (
        let tx = f x1 x2 and tl = iter2_p f l1 l2 in
        tx
        >>= fun tx_res ->
        tl
        >>= fun tl_res ->
        match (tx_res, tl_res) with
        | (Ok (), Ok ()) ->
            Lwt.return_ok ()
        | (Error exn1, Error exn2) ->
            Lwt.return_error (exn1 @ exn2)
        | (Ok (), Error exn) | (Error exn, Ok ()) ->
            Lwt.return_error exn )

  let iteri2_p f l1 l2 =
    let rec iteri2_p i f l1 l2 =
      match (l1, l2) with
      | ([], []) ->
          return_unit
      | ([], _) | (_, []) ->
          invalid_arg "Error_monad.iteri2_p"
      | (x1 :: l1, x2 :: l2) -> (
          let tx = f i x1 x2 and tl = iteri2_p (i + 1) f l1 l2 in
          tx
          >>= fun tx_res ->
          tl
          >>= fun tl_res ->
          match (tx_res, tl_res) with
          | (Ok (), Ok ()) ->
              Lwt.return_ok ()
          | (Error exn1, Error exn2) ->
              Lwt.return_error (exn1 @ exn2)
          | (Ok (), Error exn) | (Error exn, Ok ()) ->
              Lwt.return_error exn )
    in
    iteri2_p 0 f l1 l2

  let rec fold_left_s f init l =
    match l with
    | [] ->
        return init
    | h :: t ->
        f init h >>=? fun acc -> fold_left_s f acc t

  let rec fold_right_s f l init =
    match l with
    | [] ->
        return init
    | h :: t ->
        fold_right_s f t init >>=? fun acc -> f h acc

  let rec join = function
    | [] ->
        return_unit
    | t :: ts -> (
        t
        >>= function
        | Error _ as err ->
            join ts >>=? fun () -> Lwt.return err
        | Ok () ->
            join ts )

  let record_trace err result =
    match result with Ok _ as res -> res | Error errs -> Error (err :: errs)

  let trace err f =
    f
    >>= function
    | Error errs -> Lwt.return_error (err :: errs) | ok -> Lwt.return ok

  let record_trace_eval mk_err result =
    match result with
    | Ok _ as res ->
        res
    | Error errs ->
        mk_err () >>? fun err -> Error (err :: errs)

  let trace_eval mk_err f =
    f
    >>= function
    | Error errs ->
        mk_err () >>=? fun err -> Lwt.return_error (err :: errs)
    | ok ->
        Lwt.return ok

  let fail_unless cond exn = if cond then return_unit else fail exn

  let fail_when cond exn = if cond then fail exn else return_unit

  let unless cond f = if cond then return_unit else f ()

  let _when cond f = if cond then f () else return_unit

  type Error.error += Assert_error of string * string

  let () =
    Error.register_error_kind
      `Permanent
      ~id:"assertion"
      ~title:"Assertion failure"
      ~description:"A fatal assertion failed"
      ~pp:(fun ppf (loc, msg) ->
        Format.fprintf
          ppf
          "Assert failure (%s)%s"
          loc
          (if msg = "" then "." else ": " ^ msg))
      Data_encoding.(obj2 (req "loc" string) (req "msg" string))
      (function Assert_error (loc, msg) -> Some (loc, msg) | _ -> None)
      (fun (loc, msg) -> Assert_error (loc, msg))

  let _assert b loc fmt =
    if b then Format.ikfprintf (fun _ -> return_unit) Format.str_formatter fmt
    else Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt
end
src/lib_error_monad/monad_maker.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Functors are not handled. *)
functor

src/lib_error_monad/sig.ml 13 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Categories of error *)
type error_category =
  [ `Branch  (** Errors that may not happen in another context *)
  | `Temporary  (** Errors that may not happen in a later context *)
  | `Permanent  (** Errors that will happen no matter the context *) ]

let string_of_category = function
  | `Permanent ->
      "permanent"
  | `Temporary ->
      "temporary"
  | `Branch ->
      "branch"

module type PREFIX = sig
  val id : string
end

module type CORE = sig
  type error = ..

  val error_encoding : error Data_encoding.t

  val pp : Format.formatter -> error -> unit

  (** The error data type is extensible. Each module can register specialized
      error serializers
      [id] unique name of this error. Ex.: overflow_time_counter
      [title] more readable name. Ex.: Overflow of time counter
      [description] human readable description. Ex.: The time counter overflowed while computing delta increase
      [pp] formatter used to pretty print additional arguments. Ex.: The time counter overflowed while computing delta increase. Previous value %d. Delta: %d
      [encoder] [decoder] data encoding for this error. If the error has no value, specify Data_encoding.empty
  *)
  val register_error_kind :
    error_category ->
    id:string ->
    title:string ->
    description:string ->
    ?pp:(Format.formatter -> 'err -> unit) ->
    'err Data_encoding.t ->
    (error -> 'err option) ->
    ('err -> error) ->
    unit

  (** Classify an error using the registered kinds *)
  val classify_error : error -> error_category
end

module type EXT = sig
  type error = ..

  (** Catch all error when 'serializing' an error. *)
  type error +=
    private
    | Unclassified of string
          (** Catch all error when 'deserializing' an error. *)

  type error += private Unregistred_error of Data_encoding.json

  (** An error serializer *)
  val json_of_error : error -> Data_encoding.json

  val error_of_json : Data_encoding.json -> error

  (** {2 Error documentation} *)

  (** Error information *)
  type error_info = {
    category : error_category;
    id : string;
    title : string;
    description : string;
    schema : Data_encoding.json_schema;
  }

  val pp_info : Format.formatter -> error_info -> unit

  (** Retrieves information of registered errors *)
  val get_registered_errors : unit -> error_info list
end

module type WITH_WRAPPED = sig
  type error

  module type Wrapped_error_monad = sig
    type unwrapped = ..

    include CORE with type error := unwrapped

    include EXT with type error := unwrapped

    val unwrap : error -> unwrapped option

    val wrap : unwrapped -> error
  end

  val register_wrapped_error_kind :
    (module Wrapped_error_monad) ->
    id:string ->
    title:string ->
    description:string ->
    unit
end

module type MONAD = sig
  (** This type is meant to be substituted/constrained. The intended use is
      along the following lines:

      [module Foo : sig
         include CORE
         include MONAD with type error := error
       end = struct
         ...
       end]

      See core.mli and monad.mli as examples.
      *)
  type error

  (** A [trace] is a stack of [error]s. It is implemented as an [error list]
      but such a list MUST NEVER be empty.

      It is implemented as a concrete [error list] for backwards compatibility
      but future improvements might modify the type or render the type
      abstract. *)
  type trace = error list

  (* NOTE: Right now we leave this [pp_print_error] named as is. Later on we
     might rename it to [pp_print_trace]. *)
  val pp_print_error : Format.formatter -> trace -> unit

  val trace_encoding : trace Data_encoding.t

  (* NOTE: Right now we leave this [classify_errors] named as is. Later on we
     might rename it to [classify_trace]. *)
  val classify_errors : trace -> error_category

  (** The error monad wrapper type, the error case holds a stack of
      error, initialized by the first call to {!fail} and completed by
      each call to {!trace} as the stack is rewinded. The most general
      error is thus at the top of the error stack, going down to the
      specific error that actually caused the failure. *)
  type 'a tzresult = ('a, trace) result

  (** A serializer for result of a given type *)
  val result_encoding : 'a Data_encoding.t -> 'a tzresult Data_encoding.t

  (** Sucessful result *)
  val ok : 'a -> 'a tzresult

  (** Sucessful return *)
  val return : 'a -> 'a tzresult Lwt.t

  (** Sucessful return of [()] *)
  val return_unit : unit tzresult Lwt.t

  (** Sucessful return of [None] *)
  val return_none : 'a option tzresult Lwt.t

  (** [return_some x] is a sucessful return of [Some x] *)
  val return_some : 'a -> 'a option tzresult Lwt.t

  (** Sucessful return of [[]] *)
  val return_nil : 'a list tzresult Lwt.t

  (** Sucessful return of [true] *)
  val return_true : bool tzresult Lwt.t

  (** Sucessful return of [false] *)
  val return_false : bool tzresult Lwt.t

  (** Erroneous result *)
  val error : error -> 'a tzresult

  (** Erroneous return *)
  val fail : error -> 'a tzresult Lwt.t

  (** Non-Lwt bind operator *)
  val ( >>? ) : 'a tzresult -> ('a -> 'b tzresult) -> 'b tzresult

  (** Bind operator *)
  val ( >>=? ) :
    'a tzresult Lwt.t -> ('a -> 'b tzresult Lwt.t) -> 'b tzresult Lwt.t

  (** Lwt's bind reexported *)
  val ( >>= ) : 'a Lwt.t -> ('a -> 'b Lwt.t) -> 'b Lwt.t

  val ( >|= ) : 'a Lwt.t -> ('a -> 'b) -> 'b Lwt.t

  (** To operator *)
  val ( >>|? ) : 'a tzresult Lwt.t -> ('a -> 'b) -> 'b tzresult Lwt.t

  (** Non-Lwt to operator *)
  val ( >|? ) : 'a tzresult -> ('a -> 'b) -> 'b tzresult

  (** Enrich an error report (or do nothing on a successful result) manually *)
  val record_trace : error -> 'a tzresult -> 'a tzresult

  (** Automatically enrich error reporting on stack rewind *)
  val trace : error -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

  (** Same as record_trace, for unevaluated error *)
  val record_trace_eval :
    (unit -> error tzresult) -> 'a tzresult -> 'a tzresult

  (** Same as trace, for unevaluated Lwt error *)
  val trace_eval :
    (unit -> error tzresult Lwt.t) -> 'b tzresult Lwt.t -> 'b tzresult Lwt.t

  (** Erroneous return on failed assertion *)
  val fail_unless : bool -> error -> unit tzresult Lwt.t

  val fail_when : bool -> error -> unit tzresult Lwt.t

  val unless : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t

  val _when : bool -> (unit -> unit tzresult Lwt.t) -> unit tzresult Lwt.t

  (* Usage: [_assert cond __LOC__ "<fmt>" ...] *)
  val _assert :
    bool ->
    string ->
    ('a, Format.formatter, unit, unit tzresult Lwt.t) format4 ->
    'a

  (** {2 In-monad list iterators} *)

  (** A {!List.iter} in the monad *)
  val iter_s : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

  val iter_p : ('a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

  val iteri_p :
    (int -> 'a -> unit tzresult Lwt.t) -> 'a list -> unit tzresult Lwt.t

  val iter2_p :
    ('a -> 'b -> unit tzresult Lwt.t) ->
    'a list ->
    'b list ->
    unit tzresult Lwt.t

  val iteri2_p :
    (int -> 'a -> 'b -> unit tzresult Lwt.t) ->
    'a list ->
    'b list ->
    unit tzresult Lwt.t

  (** A {!List.map} in the monad *)
  val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val rev_map_s :
    ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val mapi_s :
    (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val mapi_p :
    (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  (** A {!List.map2} in the monad *)
  val map2 :
    ('a -> 'b -> 'c tzresult) -> 'a list -> 'b list -> 'c list tzresult

  val map2_s :
    ('a -> 'b -> 'c tzresult Lwt.t) ->
    'a list ->
    'b list ->
    'c list tzresult Lwt.t

  val mapi2_s :
    (int -> 'a -> 'b -> 'c tzresult Lwt.t) ->
    'a list ->
    'b list ->
    'c list tzresult Lwt.t

  (** A {!List.filter_map} in the monad *)
  val filter_map_s :
    ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  val filter_map_p :
    ('a -> 'b option tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t

  (** A {!List.filter} in the monad *)
  val filter_s :
    ('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t

  val filter_p :
    ('a -> bool tzresult Lwt.t) -> 'a list -> 'a list tzresult Lwt.t

  (** A {!List.fold_left} in the monad *)
  val fold_left_s :
    ('a -> 'b -> 'a tzresult Lwt.t) -> 'a -> 'b list -> 'a tzresult Lwt.t

  (** A {!List.fold_right} in the monad *)
  val fold_right_s :
    ('a -> 'b -> 'b tzresult Lwt.t) -> 'a list -> 'b -> 'b tzresult Lwt.t

  (** A {!Lwt.join} in the monad *)
  val join : unit tzresult Lwt.t list -> unit tzresult Lwt.t
end
src/lib_error_monad/sig.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition error_category := variant.

Definition string_of_category (function_parameter : variant) : string :=
  match function_parameter with
  | Permanent => "permanent" % string
  | Temporary => "temporary" % string
  | Branch => "branch" % string
  end.

Module PREFIX.
  Record signature := {
    id : string;
  }.
End PREFIX.

Module CORE.
  Record signature {error : Type} := {
    error := error;
    error_encoding : Tezos_data_encoding.Data_encoding.t error;
    pp : Stdlib.Format.formatter -> error -> unit;
    register_error_kind : forall {err : Type}, error_category ->
      string ->
        string ->
          string ->
            (option (Stdlib.Format.formatter -> err -> unit)) ->
              (Tezos_data_encoding.Data_encoding.t err) ->
                (error -> option err) -> (err -> error) -> unit;
    classify_error : error -> error_category;
  }.
  Arguments signature : clear implicits.
End CORE.

Module EXT.
  Record signature {error error_info : Type} := {
    error := error;
    extensible_type;
    extensible_type;
    json_of_error : error -> Tezos_data_encoding.Data_encoding.json;
    error_of_json : Tezos_data_encoding.Data_encoding.json -> error;
    error_info := error_info;
    pp_info : Stdlib.Format.formatter -> error_info -> unit;
    get_registered_errors : unit -> list error_info;
  }.
  Arguments signature : clear implicits.
End EXT.

Module WITH_WRAPPED.
  Record signature {error : Type} := {
    error := error;
    module_type;
    register_wrapped_error_kind : {'(unwrapped, error_info) : _ &
      Wrapped_error_monad.signature unwrapped error_info} ->
      string -> string -> string -> unit;
  }.
  Arguments signature : clear implicits.
End WITH_WRAPPED.

Module MONAD.
  Record signature {error : Type} := {
    error := error;
    trace := list error;
    pp_print_error : Stdlib.Format.formatter -> trace -> unit;
    trace_encoding : Tezos_data_encoding.Data_encoding.t trace;
    classify_errors : trace -> error_category;
    tzresult (a : Type) := sum a trace;
    result_encoding : forall {a : Type}, (Tezos_data_encoding.Data_encoding.t a)
      -> Tezos_data_encoding.Data_encoding.t (tzresult a);
    ok : forall {a : Type}, a -> tzresult a;
    _return : forall {a : Type}, a -> Lwt.t (tzresult a);
    return_unit : Lwt.t (tzresult unit);
    return_none : forall {a : Type}, Lwt.t (tzresult (option a));
    return_some : forall {a : Type}, a -> Lwt.t (tzresult (option a));
    return_nil : forall {a : Type}, Lwt.t (tzresult (list a));
    return_true : Lwt.t (tzresult bool);
    return_false : Lwt.t (tzresult bool);
    error : forall {a : Type}, error -> tzresult a;
    fail : forall {a : Type}, error -> Lwt.t (tzresult a);
    op_gtgtquestion : forall {a b : Type}, (tzresult a) ->
      (a -> tzresult b) -> tzresult b;
    op_gtgteqquestion : forall {a b : Type}, (Lwt.t (tzresult a)) ->
      (a -> Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
    op_gtgteq : forall {a b : Type}, (Lwt.t a) -> (a -> Lwt.t b) -> Lwt.t b;
    op_gtpipeeq : forall {a b : Type}, (Lwt.t a) -> (a -> b) -> Lwt.t b;
    op_gtgtpipequestion : forall {a b : Type}, (Lwt.t (tzresult a)) ->
      (a -> b) -> Lwt.t (tzresult b);
    op_gtpipequestion : forall {a b : Type}, (tzresult a) ->
      (a -> b) -> tzresult b;
    record_trace : forall {a : Type}, error -> (tzresult a) -> tzresult a;
    trace : forall {b : Type}, error ->
      (Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
    record_trace_eval : forall {a : Type}, (unit -> tzresult error) ->
      (tzresult a) -> tzresult a;
    trace_eval : forall {b : Type}, (unit -> Lwt.t (tzresult error)) ->
      (Lwt.t (tzresult b)) -> Lwt.t (tzresult b);
    fail_unless : bool -> error -> Lwt.t (tzresult unit);
    fail_when : bool -> error -> Lwt.t (tzresult unit);
    unless : bool -> (unit -> Lwt.t (tzresult unit)) -> Lwt.t (tzresult unit);
    _when : bool -> (unit -> Lwt.t (tzresult unit)) -> Lwt.t (tzresult unit);
    _assert : forall {a : Type}, bool ->
      string ->
        (Stdlib.format4 a Stdlib.Format.formatter unit (Lwt.t (tzresult unit)))
          -> a;
    iter_s : forall {a : Type}, (a -> Lwt.t (tzresult unit)) ->
      (list a) -> Lwt.t (tzresult unit);
    iter_p : forall {a : Type}, (a -> Lwt.t (tzresult unit)) ->
      (list a) -> Lwt.t (tzresult unit);
    iteri_p : forall {a : Type}, (Z -> a -> Lwt.t (tzresult unit)) ->
      (list a) -> Lwt.t (tzresult unit);
    iter2_p : forall {a b : Type}, (a -> b -> Lwt.t (tzresult unit)) ->
      (list a) -> (list b) -> Lwt.t (tzresult unit);
    iteri2_p : forall {a b : Type}, (Z -> a -> b -> Lwt.t (tzresult unit)) ->
      (list a) -> (list b) -> Lwt.t (tzresult unit);
    map_s : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    rev_map_s : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    map_p : forall {a b : Type}, (a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    mapi_s : forall {a b : Type}, (Z -> a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    mapi_p : forall {a b : Type}, (Z -> a -> Lwt.t (tzresult b)) ->
      (list a) -> Lwt.t (tzresult (list b));
    map2 : forall {a b c : Type}, (a -> b -> tzresult c) ->
      (list a) -> (list b) -> tzresult (list c);
    map2_s : forall {a b c : Type}, (a -> b -> Lwt.t (tzresult c)) ->
      (list a) -> (list b) -> Lwt.t (tzresult (list c));
    mapi2_s : forall {a b c : Type}, (Z -> a -> b -> Lwt.t (tzresult c)) ->
      (list a) -> (list b) -> Lwt.t (tzresult (list c));
    filter_map_s : forall {a b : Type}, (a -> Lwt.t (tzresult (option b))) ->
      (list a) -> Lwt.t (tzresult (list b));
    filter_map_p : forall {a b : Type}, (a -> Lwt.t (tzresult (option b))) ->
      (list a) -> Lwt.t (tzresult (list b));
    filter_s : forall {a : Type}, (a -> Lwt.t (tzresult bool)) ->
      (list a) -> Lwt.t (tzresult (list a));
    filter_p : forall {a : Type}, (a -> Lwt.t (tzresult bool)) ->
      (list a) -> Lwt.t (tzresult (list a));
    fold_left_s : forall {a b : Type}, (a -> b -> Lwt.t (tzresult a)) ->
      a -> (list b) -> Lwt.t (tzresult a);
    fold_right_s : forall {a b : Type}, (a -> b -> Lwt.t (tzresult b)) ->
      (list a) -> b -> Lwt.t (tzresult b);
    join : (list (Lwt.t (tzresult unit))) -> Lwt.t (tzresult unit);
  }.
  Arguments signature : clear implicits.
End MONAD.

src/lib_error_monad/test/assert.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf failwith "@[%s@ expected: %s@ got: %s@]" msg expected given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg
src/lib_error_monad/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf OCaml.Stdlib.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let prn :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

src/lib_error_monad/test/test_error_tables.ml 37 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module IntErrorTable = Error_table.Make (Hashtbl.Make (struct
  type t = int

  let equal x y = x = y

  let hash x = x
end))

let test_add_remove _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
  >>= function
  | Error _ ->
      Assert.fail "Ok 0" "Error _" "find_or_make"
  | Ok n -> (
      if not (n = 0) then
        Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make"
      else
        match IntErrorTable.find_opt t 0 with
        | None ->
            Assert.fail "Some (Ok 0)" "None" "find_opt"
        | Some p -> (
            p
            >>= function
            | Error _ ->
                Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt"
            | Ok n ->
                if not (n = 0) then
                  Assert.fail
                    "Some (Ok 0)"
                    (Format.asprintf "Some (Ok %d)" n)
                    "find_opt"
                else (
                  IntErrorTable.remove t 0 ;
                  match IntErrorTable.find_opt t 0 with
                  | Some _ ->
                      Assert.fail "None" "Some _" "remove;find_opt"
                  | None ->
                      Lwt.return_unit ) ) )

let test_add_add _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
  >>= fun _ ->
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 1)
  >>= fun _ ->
  match IntErrorTable.find_opt t 0 with
  | None ->
      Assert.fail "Some (Ok 0)" "None" "find_opt"
  | Some p -> (
      p
      >>= function
      | Error _ ->
          Assert.fail "Some (Ok 0)" "Some (Error _)" "find_opt"
      | Ok n ->
          if not (n = 0) then
            Assert.fail
              "Some (Ok 0)"
              (Format.asprintf "Some (Ok %d)" n)
              "find_opt"
          else Lwt.return_unit )

let test_length _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Error_monad.return 0)
  >>= fun _ ->
  IntErrorTable.find_or_make t 1 (fun () -> Error_monad.return 1)
  >>= fun _ ->
  IntErrorTable.find_or_make t 2 (fun () -> Error_monad.return 2)
  >>= fun _ ->
  IntErrorTable.find_or_make t 3 (fun () -> Error_monad.return 3)
  >>= fun _ ->
  let l = IntErrorTable.length t in
  if not (l = 4) then Assert.fail "4" (Format.asprintf "%d" l) "length"
  else Lwt.return_unit

let test_self_clean _ _ =
  let t = IntErrorTable.create 2 in
  IntErrorTable.find_or_make t 0 (fun () -> Lwt.return (Ok 0))
  >>= fun _ ->
  IntErrorTable.find_or_make t 1 (fun () -> Lwt.return (Error []))
  >>= fun _ ->
  IntErrorTable.find_or_make t 2 (fun () -> Lwt.return (Error []))
  >>= fun _ ->
  IntErrorTable.find_or_make t 3 (fun () -> Lwt.return (Ok 3))
  >>= fun _ ->
  IntErrorTable.find_or_make t 4 (fun () -> Lwt.return (Ok 4))
  >>= fun _ ->
  IntErrorTable.find_or_make t 5 (fun () -> Lwt.return (Error []))
  >>= fun _ ->
  let l = IntErrorTable.length t in
  if not (l = 3) then Assert.fail "3" (Format.asprintf "%d" l) "length"
  else Lwt.return_unit

let test_order _ _ =
  let t = IntErrorTable.create 2 in
  let (wter, wker) = Lwt.task () in
  let world = ref [] in
  (* PROMISE A *)
  let p_a =
    IntErrorTable.find_or_make t 0 (fun () ->
        wter
        >>= fun r ->
        world := "a_inner" :: !world ;
        Lwt.return r)
    >>= fun r_a ->
    world := "a_outer" :: !world ;
    Lwt.return r_a
  in
  Lwt_main.yield ()
  >>= fun () ->
  (* PROMISE B *)
  let p_b =
    IntErrorTable.find_or_make t 0 (fun () ->
        world := "b_inner" :: !world ;
        Lwt.return (Ok 1024))
    >>= fun r_b ->
    world := "b_outer" :: !world ;
    Lwt.return r_b
  in
  Lwt_main.yield ()
  >>= fun () ->
  (* Wake up A *)
  Lwt.wakeup wker (Ok 0) ;
  (* Check that both A and B get expected results *)
  p_a
  >>= (function
        | Error _ ->
            Assert.fail "Ok 0" "Error _" "find_or_make(a)"
        | Ok n ->
            if not (n = 0) then
              Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make(a)"
            else Lwt.return_unit)
  >>= fun () ->
  p_b
  >>= (function
        | Error _ ->
            Assert.fail "Ok 0" "Error _" "find_or_make(b)"
        | Ok n ->
            if not (n = 0) then
              Assert.fail "Ok 0" (Format.asprintf "Ok %d" n) "find_or_make(b)"
            else Lwt.return_unit)
  >>= fun () ->
  (* Check that the `world` record is as expected *)
  match !world with
  | ["b_outer"; "a_outer"; "a_inner"] | ["a_outer"; "b_outer"; "a_inner"] ->
      Lwt.return ()
  | world ->
      Assert.fail
        "[outers;a_inner]"
        Format.(asprintf "[%a]" (pp_print_list pp_print_string) world)
        "world"

let tests =
  [ Alcotest_lwt.test_case "add_remove" `Quick test_add_remove;
    Alcotest_lwt.test_case "add_add" `Quick test_add_add;
    Alcotest_lwt.test_case "length" `Quick test_length;
    Alcotest_lwt.test_case "self_clean" `Quick test_length;
    Alcotest_lwt.test_case "order" `Quick test_order ]

let () = Alcotest.run "error_tables" [("error_tables", tests)]
src/lib_error_monad/test/test_error_tables.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition test_add_remove {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    let t := IntErrorTable.create 2 in
    op_gtgteq
      (IntErrorTable.find_or_make t 0
        (fun function_parameter =>
          let 'tt := function_parameter in
          Error_monad._return 0))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Error _ =>
          op_startypeminuserrorstar "Ok 0" % string "Error _" % string
            "find_or_make" % string
        | Stdlib.Ok n =>
          if negb (equiv_decb n 0) then
            op_startypeminuserrorstar "Ok 0" % string
              (Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "Ok " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format)) "Ok %d" % string)
                n) "find_or_make" % string
          else
            match IntErrorTable.find_opt t 0 with
            | None =>
              op_startypeminuserrorstar "Some (Ok 0)" % string "None" % string
                "find_opt" % string
            | Some p =>
              op_gtgteq p
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Error _ =>
                    op_startypeminuserrorstar "Some (Ok 0)" % string
                      "Some (Error _)" % string "find_opt" % string
                  | Stdlib.Ok n =>
                    if negb (equiv_decb n 0) then
                      op_startypeminuserrorstar "Some (Ok 0)" % string
                        (Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Some (Ok " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.Char_literal
                                  ")" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "Some (Ok %d)" % string) n) "find_opt" % string
                    else
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ := IntErrorTable.remove t 0 in
                      match IntErrorTable.find_opt t 0 with
                      | Some _ =>
                        op_startypeminuserrorstar "None" % string
                          "Some _" % string "remove;find_opt" % string
                      | None => Lwt.return_unit
                      end
                  end)
            end
        end).

Definition test_add_add {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    let t := IntErrorTable.create 2 in
    op_gtgteq
      (IntErrorTable.find_or_make t 0
        (fun function_parameter =>
          let 'tt := function_parameter in
          Error_monad._return 0))
      (fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteq
          (IntErrorTable.find_or_make t 0
            (fun function_parameter =>
              let 'tt := function_parameter in
              Error_monad._return 1))
          (fun function_parameter =>
            let '_ := function_parameter in
            match IntErrorTable.find_opt t 0 with
            | None =>
              op_startypeminuserrorstar "Some (Ok 0)" % string "None" % string
                "find_opt" % string
            | Some p =>
              op_gtgteq p
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Error _ =>
                    op_startypeminuserrorstar "Some (Ok 0)" % string
                      "Some (Error _)" % string "find_opt" % string
                  | Stdlib.Ok n =>
                    if negb (equiv_decb n 0) then
                      op_startypeminuserrorstar "Some (Ok 0)" % string
                        (Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Some (Ok " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.Char_literal
                                  ")" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "Some (Ok %d)" % string) n) "find_opt" % string
                    else
                      Lwt.return_unit
                  end)
            end)).

Definition test_length {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    let t := IntErrorTable.create 2 in
    op_gtgteq
      (IntErrorTable.find_or_make t 0
        (fun function_parameter =>
          let 'tt := function_parameter in
          Error_monad._return 0))
      (fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteq
          (IntErrorTable.find_or_make t 1
            (fun function_parameter =>
              let 'tt := function_parameter in
              Error_monad._return 1))
          (fun function_parameter =>
            let '_ := function_parameter in
            op_gtgteq
              (IntErrorTable.find_or_make t 2
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Error_monad._return 2))
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq
                  (IntErrorTable.find_or_make t 3
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Error_monad._return 3))
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    let l := IntErrorTable.length t in
                    if negb (equiv_decb l 4) then
                      op_startypeminuserrorstar "4" % string
                        (Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Int
                              CamlinternalFormatBasics.Int_d
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.No_precision
                              CamlinternalFormatBasics.End_of_format)
                            "%d" % string) l) "length" % string
                    else
                      Lwt.return_unit)))).

Definition test_self_clean {A B : Type} (function_parameter : A)
  : B -> Lwt.t unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    let t := IntErrorTable.create 2 in
    op_gtgteq
      (IntErrorTable.find_or_make t 0
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt._return (Stdlib.Ok 0)))
      (fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteq
          (IntErrorTable.find_or_make t 1
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt._return (Stdlib.Error [])))
          (fun function_parameter =>
            let '_ := function_parameter in
            op_gtgteq
              (IntErrorTable.find_or_make t 2
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt._return (Stdlib.Error [])))
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq
                  (IntErrorTable.find_or_make t 3
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Lwt._return (Stdlib.Ok 3)))
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    op_gtgteq
                      (IntErrorTable.find_or_make t 4
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Lwt._return (Stdlib.Ok 4)))
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        op_gtgteq
                          (IntErrorTable.find_or_make t 5
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              Lwt._return (Stdlib.Error [])))
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            let l := IntErrorTable.length t in
                            if negb (equiv_decb l 3) then
                              op_startypeminuserrorstar "3" % string
                                (Format.asprintf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Int
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      CamlinternalFormatBasics.End_of_format)
                                    "%d" % string) l) "length" % string
                            else
                              Lwt.return_unit)))))).

Definition test_order {A B : Type} (function_parameter : A) : B -> Lwt.t unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    let t := IntErrorTable.create 2 in
    let '(wter, wker) := Lwt.task tt in
    let world := Stdlib.ref [] in
    let p_a :=
      op_gtgteq
        (IntErrorTable.find_or_make t 0
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq wter
              (fun r =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Stdlib.op_coloneq world
                    (cons "a_inner" % string (Stdlib.op_exclamation world)) in
                Lwt._return r)))
        (fun r_a =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.op_coloneq world
              (cons "a_outer" % string (Stdlib.op_exclamation world)) in
          Lwt._return r_a) in
    op_gtgteq (op_startypeminuserrorstar tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let p_b :=
          op_gtgteq
            (IntErrorTable.find_or_make t 0
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Stdlib.op_coloneq world
                    (cons "b_inner" % string (Stdlib.op_exclamation world)) in
                Lwt._return (Stdlib.Ok 1024)))
            (fun r_b =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Stdlib.op_coloneq world
                  (cons "b_outer" % string (Stdlib.op_exclamation world)) in
              Lwt._return r_b) in
        op_gtgteq (op_startypeminuserrorstar tt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Lwt.wakeup wker (Stdlib.Ok 0) in
            op_gtgteq
              (op_gtgteq p_a
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Error _ =>
                    op_startypeminuserrorstar "Ok 0" % string "Error _" % string
                      "find_or_make(a)" % string
                  | Stdlib.Ok n =>
                    if negb (equiv_decb n 0) then
                      op_startypeminuserrorstar "Ok 0" % string
                        (Format.asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Ok " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                CamlinternalFormatBasics.End_of_format))
                            "Ok %d" % string) n) "find_or_make(a)" % string
                    else
                      Lwt.return_unit
                  end))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (op_gtgteq p_b
                    (fun function_parameter =>
                      match function_parameter with
                      | Stdlib.Error _ =>
                        op_startypeminuserrorstar "Ok 0" % string
                          "Error _" % string "find_or_make(b)" % string
                      | Stdlib.Ok n =>
                        if negb (equiv_decb n 0) then
                          op_startypeminuserrorstar "Ok 0" % string
                            (Format.asprintf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Ok " % string
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    CamlinternalFormatBasics.End_of_format))
                                "Ok %d" % string) n) "find_or_make(b)" % string
                        else
                          Lwt.return_unit
                      end))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    match Stdlib.op_exclamation world with
                    |
                      cons "b_outer" % string
                        (cons "a_outer" % string (cons "a_inner" % string [])) |
                        cons "a_outer" % string
                          (cons "b_outer" % string (cons "a_inner" % string []))
                      => Lwt._return tt
                    | world =>
                      op_startypeminuserrorstar "[outers;a_inner]" % string
                        (asprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Char_literal "[" % char
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  "]" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "[%a]" % string)
                          (pp_print_list None pp_print_string) world)
                        "world" % string
                    end)))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "add_remove" % string
      (* ❌ Variants not supported *)
      variant test_add_remove)
    (cons
      (op_startypeminuserrorstar "add_add" % string
        (* ❌ Variants not supported *)
        variant test_add_add)
      (cons
        (op_startypeminuserrorstar "length" % string
          (* ❌ Variants not supported *)
          variant test_length)
        (cons
          (op_startypeminuserrorstar "self_clean" % string
            (* ❌ Variants not supported *)
            variant test_length)
          (cons
            (op_startypeminuserrorstar "order" % string
              (* ❌ Variants not supported *)
              variant test_order) [])))).



src/lib_micheline/micheline.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type annot = string list

type ('l, 'p) node =
  | Int of 'l * Z.t
  | String of 'l * string
  | Bytes of 'l * Bytes.t
  | Prim of 'l * 'p * ('l, 'p) node list * annot
  | Seq of 'l * ('l, 'p) node list

type canonical_location = int

type 'p canonical = Canonical of (canonical_location, 'p) node

let canonical_location_encoding =
  let open Data_encoding in
  def
    "micheline.location"
    ~title:"Canonical location in a Micheline expression"
    ~description:
      "The location of a node in a Micheline expression tree in prefix order, \
       with zero being the root and adding one for every basic node, sequence \
       and primitive application."
  @@ int31

let location = function
  | Int (loc, _) ->
      loc
  | String (loc, _) ->
      loc
  | Bytes (loc, _) ->
      loc
  | Seq (loc, _) ->
      loc
  | Prim (loc, _, _, _) ->
      loc

let annotations = function
  | Int (_, _) ->
      []
  | String (_, _) ->
      []
  | Bytes (_, _) ->
      []
  | Seq (_, _) ->
      []
  | Prim (_, _, _, annots) ->
      annots

let root (Canonical expr) = expr

let strip_locations root =
  let id =
    let id = ref (-1) in
    fun () -> incr id ; !id
  in
  let rec strip_locations l =
    let id = id () in
    match l with
    | Int (_, v) ->
        Int (id, v)
    | String (_, v) ->
        String (id, v)
    | Bytes (_, v) ->
        Bytes (id, v)
    | Seq (_, seq) ->
        Seq (id, List.map strip_locations seq)
    | Prim (_, name, seq, annots) ->
        Prim (id, name, List.map strip_locations seq, annots)
  in
  Canonical (strip_locations root)

let extract_locations root =
  let id =
    let id = ref (-1) in
    fun () -> incr id ; !id
  in
  let loc_table = ref [] in
  let rec strip_locations l =
    let id = id () in
    match l with
    | Int (loc, v) ->
        loc_table := (id, loc) :: !loc_table ;
        Int (id, v)
    | String (loc, v) ->
        loc_table := (id, loc) :: !loc_table ;
        String (id, v)
    | Bytes (loc, v) ->
        loc_table := (id, loc) :: !loc_table ;
        Bytes (id, v)
    | Seq (loc, seq) ->
        loc_table := (id, loc) :: !loc_table ;
        Seq (id, List.map strip_locations seq)
    | Prim (loc, name, seq, annots) ->
        loc_table := (id, loc) :: !loc_table ;
        Prim (id, name, List.map strip_locations seq, annots)
  in
  let stripped = strip_locations root in
  (Canonical stripped, List.rev !loc_table)

let inject_locations lookup (Canonical root) =
  let rec inject_locations l =
    match l with
    | Int (loc, v) ->
        Int (lookup loc, v)
    | String (loc, v) ->
        String (lookup loc, v)
    | Bytes (loc, v) ->
        Bytes (lookup loc, v)
    | Seq (loc, seq) ->
        Seq (lookup loc, List.map inject_locations seq)
    | Prim (loc, name, seq, annots) ->
        Prim (lookup loc, name, List.map inject_locations seq, annots)
  in
  inject_locations root

let map f (Canonical expr) =
  let rec map_node f = function
    | (Int _ | String _ | Bytes _) as node ->
        node
    | Seq (loc, seq) ->
        Seq (loc, List.map (map_node f) seq)
    | Prim (loc, name, seq, annots) ->
        Prim (loc, f name, List.map (map_node f) seq, annots)
  in
  Canonical (map_node f expr)

let rec map_node fl fp = function
  | Int (loc, v) ->
      Int (fl loc, v)
  | String (loc, v) ->
      String (fl loc, v)
  | Bytes (loc, v) ->
      Bytes (fl loc, v)
  | Seq (loc, seq) ->
      Seq (fl loc, List.map (map_node fl fp) seq)
  | Prim (loc, name, seq, annots) ->
      Prim (fl loc, fp name, List.map (map_node fl fp) seq, annots)

type semantics = V0 | V1

let internal_canonical_encoding ~semantics ~variant prim_encoding =
  let open Data_encoding in
  let int_encoding = obj1 (req "int" z) in
  let string_encoding = obj1 (req "string" string) in
  let bytes_encoding = obj1 (req "bytes" bytes) in
  let int_encoding tag =
    case
      tag
      int_encoding
      ~title:"Int"
      (function Int (_, v) -> Some v | _ -> None)
      (fun v -> Int (0, v))
  in
  let string_encoding tag =
    case
      tag
      string_encoding
      ~title:"String"
      (function String (_, v) -> Some v | _ -> None)
      (fun v -> String (0, v))
  in
  let bytes_encoding tag =
    case
      tag
      bytes_encoding
      ~title:"Bytes"
      (function Bytes (_, v) -> Some v | _ -> None)
      (fun v -> Bytes (0, v))
  in
  let seq_encoding tag expr_encoding =
    case
      tag
      (list expr_encoding)
      ~title:"Sequence"
      (function Seq (_, v) -> Some v | _ -> None)
      (fun args -> Seq (0, args))
  in
  let annots_encoding =
    let split s =
      if s = "" && semantics <> V0 then []
      else
        let annots = String.split_on_char ' ' s in
        List.iter
          (fun a ->
            if String.length a > 255 then failwith "Oversized annotation")
          annots ;
        if String.concat " " annots <> s then
          failwith
            "Invalid annotation string, must be a sequence of valid \
             annotations with spaces" ;
        annots
    in
    splitted
      ~json:(list (Bounded.string 255))
      ~binary:(conv (String.concat " ") split string)
  in
  let application_encoding tag expr_encoding =
    case
      tag
      ~title:"Generic prim (any number of args with or without annot)"
      (obj3
         (req "prim" prim_encoding)
         (dft "args" (list expr_encoding) [])
         (dft "annots" annots_encoding []))
      (function
        | Prim (_, prim, args, annots) -> Some (prim, args, annots) | _ -> None)
      (fun (prim, args, annots) -> Prim (0, prim, args, annots))
  in
  let node_encoding =
    mu
      ("micheline." ^ variant ^ ".expression")
      (fun expr_encoding ->
        splitted
          ~json:
            (union
               ~tag_size:`Uint8
               [ int_encoding Json_only;
                 string_encoding Json_only;
                 bytes_encoding Json_only;
                 seq_encoding Json_only expr_encoding;
                 application_encoding Json_only expr_encoding ])
          ~binary:
            (union
               ~tag_size:`Uint8
               [ int_encoding (Tag 0);
                 string_encoding (Tag 1);
                 seq_encoding (Tag 2) expr_encoding;
                 (* No args, no annot *)
                 case
                   (Tag 3)
                   ~title:"Prim (no args, annot)"
                   (obj1 (req "prim" prim_encoding))
                   (function Prim (_, v, [], []) -> Some v | _ -> None)
                   (fun v -> Prim (0, v, [], []));
                 (* No args, with annots *)
                 case
                   (Tag 4)
                   ~title:"Prim (no args + annot)"
                   (obj2
                      (req "prim" prim_encoding)
                      (req "annots" annots_encoding))
                   (function
                     | Prim (_, v, [], annots) -> Some (v, annots) | _ -> None)
                   (function (prim, annots) -> Prim (0, prim, [], annots));
                 (* Single arg, no annot *)
                 case
                   (Tag 5)
                   ~title:"Prim (1 arg, no annot)"
                   (obj2 (req "prim" prim_encoding) (req "arg" expr_encoding))
                   (function
                     | Prim (_, v, [arg], []) -> Some (v, arg) | _ -> None)
                   (function (prim, arg) -> Prim (0, prim, [arg], []));
                 (* Single arg, with annot *)
                 case
                   (Tag 6)
                   ~title:"Prim (1 arg + annot)"
                   (obj3
                      (req "prim" prim_encoding)
                      (req "arg" expr_encoding)
                      (req "annots" annots_encoding))
                   (function
                     | Prim (_, prim, [arg], annots) ->
                         Some (prim, arg, annots)
                     | _ ->
                         None)
                   (fun (prim, arg, annots) -> Prim (0, prim, [arg], annots));
                 (* Two args, no annot *)
                 case
                   (Tag 7)
                   ~title:"Prim (2 args, no annot)"
                   (obj3
                      (req "prim" prim_encoding)
                      (req "arg1" expr_encoding)
                      (req "arg2" expr_encoding))
                   (function
                     | Prim (_, prim, [arg1; arg2], []) ->
                         Some (prim, arg1, arg2)
                     | _ ->
                         None)
                   (fun (prim, arg1, arg2) -> Prim (0, prim, [arg1; arg2], []));
                 (* Two args, with annots *)
                 case
                   (Tag 8)
                   ~title:"Prim (2 args + annot)"
                   (obj4
                      (req "prim" prim_encoding)
                      (req "arg1" expr_encoding)
                      (req "arg2" expr_encoding)
                      (req "annots" annots_encoding))
                   (function
                     | Prim (_, prim, [arg1; arg2], annots) ->
                         Some (prim, arg1, arg2, annots)
                     | _ ->
                         None)
                   (fun (prim, arg1, arg2, annots) ->
                     Prim (0, prim, [arg1; arg2], annots));
                 (* General case *)
                 application_encoding (Tag 9) expr_encoding;
                 bytes_encoding (Tag 10) ]))
  in
  conv
    (function Canonical node -> node)
    (fun node -> strip_locations node)
    node_encoding

let canonical_encoding ~variant prim_encoding =
  internal_canonical_encoding ~semantics:V1 ~variant prim_encoding

let canonical_encoding_v1 ~variant prim_encoding =
  internal_canonical_encoding ~semantics:V1 ~variant prim_encoding

let canonical_encoding_v0 ~variant prim_encoding =
  internal_canonical_encoding ~semantics:V0 ~variant prim_encoding

let table_encoding ~variant location_encoding prim_encoding =
  let open Data_encoding in
  conv
    (fun node ->
      let (canon, assoc) = extract_locations node in
      let (_, table) = List.split assoc in
      (canon, table))
    (fun (canon, table) ->
      let table = Array.of_list table in
      inject_locations (fun i -> table.(i)) canon)
    (obj2
       (req "expression" (canonical_encoding ~variant prim_encoding))
       (req "locations" (list location_encoding)))

let erased_encoding ~variant default_location prim_encoding =
  let open Data_encoding in
  conv
    (fun node -> strip_locations node)
    (fun canon -> inject_locations (fun _ -> default_location) canon)
    (canonical_encoding ~variant prim_encoding)
src/lib_micheline/micheline.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition annot := list string.

Inductive node (l p : Type) : Type :=
| Int : l -> Z.t -> node l p
| String : l -> string -> node l p
| Bytes : l -> Stdlib.Bytes.t -> node l p
| Prim : l -> p -> (list (node l p)) -> annot -> node l p
| Seq : l -> (list (node l p)) -> node l p.

Arguments Int {_ _}.
Arguments String {_ _}.
Arguments Bytes {_ _}.
Arguments Prim {_ _}.
Arguments Seq {_ _}.

Definition canonical_location := Z.

Inductive canonical (p : Type) : Type :=
| Canonical : (node canonical_location p) -> canonical p.

Arguments Canonical {_}.

Definition canonical_location_encoding
  : Tezos_data_encoding.Data_encoding.encoding Z :=
  apply
    (def "micheline.location" % string
      (Some "Canonical location in a Micheline expression" % string)
      (Some
        "The location of a node in a Micheline expression tree in prefix order, with zero being the root and adding one for every basic node, sequence and primitive application."
          % string)) int31.

Definition location {A B : Type} (function_parameter : node A B) : A :=
  match function_parameter with
  | Int loc _ => loc
  | String loc _ => loc
  | Bytes loc _ => loc
  | Seq loc _ => loc
  | Prim loc _ _ _ => loc
  end.

Definition annotations {A B : Type} (function_parameter : node A B) : annot :=
  match function_parameter with
  | Int _ _ => []
  | String _ _ => []
  | Bytes _ _ => []
  | Seq _ _ => []
  | Prim _ _ _ annots => annots
  end.

Definition root {A : Type} (function_parameter : canonical A)
  : node canonical_location A :=
  let 'Canonical expr := function_parameter in
  expr.

Definition strip_locations {A B : Type} (root : node A B) : canonical B :=
  let id :=
    let id := Stdlib.ref (-1) in
    fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.incr id in
      Stdlib.op_exclamation id in
  let fix strip_locations {C D : Type} (l : node C D) : node Z D :=
    let id := id tt in
    match l with
    | Int _ v => Int id v
    | String _ v => String id v
    | Bytes _ v => Bytes id v
    | Seq _ seq => Seq id (List.map strip_locations seq)
    | Prim _ name seq annots =>
      Prim id name (List.map strip_locations seq) annots
    end in
  Canonical (strip_locations root).

Definition extract_locations {A B : Type} (root : node A B)
  : (canonical B) * (list (Z * A)) :=
  let id :=
    let id := Stdlib.ref (-1) in
    fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.incr id in
      Stdlib.op_exclamation id in
  let loc_table := Stdlib.ref [] in
  let fix strip_locations {C : Type} (l : node A C) : node Z C :=
    let id := id tt in
    match l with
    | Int loc v =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq loc_table
          (cons (id, loc) (Stdlib.op_exclamation loc_table)) in
      Int id v
    | String loc v =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq loc_table
          (cons (id, loc) (Stdlib.op_exclamation loc_table)) in
      String id v
    | Bytes loc v =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq loc_table
          (cons (id, loc) (Stdlib.op_exclamation loc_table)) in
      Bytes id v
    | Seq loc seq =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq loc_table
          (cons (id, loc) (Stdlib.op_exclamation loc_table)) in
      Seq id (List.map strip_locations seq)
    | Prim loc name seq annots =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq loc_table
          (cons (id, loc) (Stdlib.op_exclamation loc_table)) in
      Prim id name (List.map strip_locations seq) annots
    end in
  let stripped := strip_locations root in
  ((Canonical stripped), (List.rev (Stdlib.op_exclamation loc_table))).

Definition inject_locations {A B : Type}
  (lookup : canonical_location -> A) (function_parameter : canonical B)
  : node A B :=
  let 'Canonical root := function_parameter in
  let fix inject_locations {C : Type} (l : node canonical_location C)
    : node A C :=
    match l with
    | Int loc v => Int (lookup loc) v
    | String loc v => String (lookup loc) v
    | Bytes loc v => Bytes (lookup loc) v
    | Seq loc seq => Seq (lookup loc) (List.map inject_locations seq)
    | Prim loc name seq annots =>
      Prim (lookup loc) name (List.map inject_locations seq) annots
    end in
  inject_locations root.

Definition map {A B : Type} (f : A -> B) (function_parameter : canonical A)
  : canonical B :=
  let 'Canonical expr := function_parameter in
  let fix map_node {C D E : Type} (f : C -> D) (function_parameter : node E C)
    : node E D :=
    match function_parameter with
    | (Int _ _ | String _ _ | Bytes _ _) as node => node
    | Seq loc seq => Seq loc (List.map (map_node f) seq)
    | Prim loc name seq annots =>
      Prim loc (f name) (List.map (map_node f) seq) annots
    end in
  Canonical (map_node f expr).

Fixpoint map_node {A B C D : Type}
  (fl : A -> B) (fp : C -> D) (function_parameter : node A C) : node B D :=
  match function_parameter with
  | Int loc v => Int (fl loc) v
  | String loc v => String (fl loc) v
  | Bytes loc v => Bytes (fl loc) v
  | Seq loc seq => Seq (fl loc) (List.map (map_node fl fp) seq)
  | Prim loc name seq annots =>
    Prim (fl loc) (fp name) (List.map (map_node fl fp) seq) annots
  end.

Inductive semantics : Type :=
| V0 : semantics
| V1 : semantics.

Definition internal_canonical_encoding {A : Type}
  (semantics : semantics) (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  let int_encoding := obj1 (req None None "int" % string z) in
  let string_encoding := obj1 (req None None "string" % string string) in
  let bytes_encoding := obj1 (req None None "bytes" % string bytes) in
  let int_encoding {B : Type} (tag : Tezos_data_encoding.Data_encoding.case_tag)
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    case "Int" % string None tag int_encoding
      (fun function_parameter =>
        match function_parameter with
        | Int _ v => Some v
        | _ => None
        end) (fun v => Int 0 v) in
  let string_encoding {B : Type}
    (tag : Tezos_data_encoding.Data_encoding.case_tag)
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    case "String" % string None tag string_encoding
      (fun function_parameter =>
        match function_parameter with
        | String _ v => Some v
        | _ => None
        end) (fun v => String 0 v) in
  let bytes_encoding {B : Type}
    (tag : Tezos_data_encoding.Data_encoding.case_tag)
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    case "Bytes" % string None tag bytes_encoding
      (fun function_parameter =>
        match function_parameter with
        | Bytes _ v => Some v
        | _ => None
        end) (fun v => Bytes 0 v) in
  let seq_encoding {B : Type}
    (tag : Tezos_data_encoding.Data_encoding.case_tag) (expr_encoding :
    Tezos_data_encoding.Data_encoding.encoding (node Z B))
    : Tezos_data_encoding.Data_encoding.case (node Z B) :=
    case "Sequence" % string None tag (list None expr_encoding)
      (fun function_parameter =>
        match function_parameter with
        | Seq _ v => Some v
        | _ => None
        end) (fun args => Seq 0 args) in
  let annots_encoding :=
    let split (s : string) : list string :=
      if andb (equiv_decb s "" % string) (nequiv_decb semantics V0) then
        []
      else
        let annots := Stdlib.String.split_on_char " " % char s in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.List.iter
            (fun a =>
              if OCaml.Stdlib.gt (OCaml.String.length a) 255 then
                OCaml.Stdlib.failwith "Oversized annotation" % string
              else
                tt) annots in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if nequiv_decb (Stdlib.String.concat " " % string annots) s then
            OCaml.Stdlib.failwith
              "Invalid annotation string, must be a sequence of valid annotations with spaces"
                % string
          else
            tt in
        annots in
    splitted (list None (Bounded.string 255))
      (conv (Stdlib.String.concat " " % string) split None string) in
  let application_encoding
    (tag : Tezos_data_encoding.Data_encoding.case_tag) (expr_encoding :
    Tezos_data_encoding.Data_encoding.encoding (node Z A))
    : Tezos_data_encoding.Data_encoding.case (node Z A) :=
    case "Generic prim (any number of args with or without annot)" % string None
      tag
      (obj3 (req None None "prim" % string prim_encoding)
        (dft None None "args" % string (list None expr_encoding) [])
        (dft None None "annots" % string annots_encoding []))
      (fun function_parameter =>
        match function_parameter with
        | Prim _ prim args annots => Some (prim, args, annots)
        | _ => None
        end)
      (fun function_parameter =>
        let '(prim, args, annots) := function_parameter in
        Prim 0 prim args annots) in
  let node_encoding :=
    mu
      (String.append "micheline." % string
        (String.append variant ".expression" % string)) None None
      (fun expr_encoding =>
        splitted
          (union
            (Some
              (* ❌ Variants not supported *)
              variant)
            (cons (int_encoding Tezos_data_encoding.Data_encoding.Json_only)
              (cons
                (string_encoding Tezos_data_encoding.Data_encoding.Json_only)
                (cons
                  (bytes_encoding Tezos_data_encoding.Data_encoding.Json_only)
                  (cons
                    (seq_encoding Tezos_data_encoding.Data_encoding.Json_only
                      expr_encoding)
                    (cons
                      (application_encoding
                        Tezos_data_encoding.Data_encoding.Json_only
                        expr_encoding) []))))))
          (union
            (Some
              (* ❌ Variants not supported *)
              variant)
            (cons (int_encoding (Tezos_data_encoding.Data_encoding.Tag 0))
              (cons (string_encoding (Tezos_data_encoding.Data_encoding.Tag 1))
                (cons
                  (seq_encoding (Tezos_data_encoding.Data_encoding.Tag 2)
                    expr_encoding)
                  (cons
                    (case "Prim (no args, annot)" % string None
                      (Tezos_data_encoding.Data_encoding.Tag 3)
                      (obj1 (req None None "prim" % string prim_encoding))
                      (fun function_parameter =>
                        match function_parameter with
                        | Prim _ v [] [] => Some v
                        | _ => None
                        end) (fun v => Prim 0 v [] []))
                    (cons
                      (case "Prim (no args + annot)" % string None
                        (Tezos_data_encoding.Data_encoding.Tag 4)
                        (obj2 (req None None "prim" % string prim_encoding)
                          (req None None "annots" % string annots_encoding))
                        (fun function_parameter =>
                          match function_parameter with
                          | Prim _ v [] annots => Some (v, annots)
                          | _ => None
                          end)
                        (fun function_parameter =>
                          let '(prim, annots) := function_parameter in
                          Prim 0 prim [] annots))
                      (cons
                        (case "Prim (1 arg, no annot)" % string None
                          (Tezos_data_encoding.Data_encoding.Tag 5)
                          (obj2 (req None None "prim" % string prim_encoding)
                            (req None None "arg" % string expr_encoding))
                          (fun function_parameter =>
                            match function_parameter with
                            | Prim _ v (cons arg []) [] => Some (v, arg)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            let '(prim, arg) := function_parameter in
                            Prim 0 prim (cons arg []) []))
                        (cons
                          (case "Prim (1 arg + annot)" % string None
                            (Tezos_data_encoding.Data_encoding.Tag 6)
                            (obj3 (req None None "prim" % string prim_encoding)
                              (req None None "arg" % string expr_encoding)
                              (req None None "annots" % string annots_encoding))
                            (fun function_parameter =>
                              match function_parameter with
                              | Prim _ prim (cons arg []) annots =>
                                Some (prim, arg, annots)
                              | _ => None
                              end)
                            (fun function_parameter =>
                              let '(prim, arg, annots) := function_parameter in
                              Prim 0 prim (cons arg []) annots))
                          (cons
                            (case "Prim (2 args, no annot)" % string None
                              (Tezos_data_encoding.Data_encoding.Tag 7)
                              (obj3
                                (req None None "prim" % string prim_encoding)
                                (req None None "arg1" % string expr_encoding)
                                (req None None "arg2" % string expr_encoding))
                              (fun function_parameter =>
                                match function_parameter with
                                | Prim _ prim (cons arg1 (cons arg2 [])) [] =>
                                  Some (prim, arg1, arg2)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                let '(prim, arg1, arg2) := function_parameter in
                                Prim 0 prim (cons arg1 (cons arg2 [])) []))
                            (cons
                              (case "Prim (2 args + annot)" % string None
                                (Tezos_data_encoding.Data_encoding.Tag 8)
                                (obj4
                                  (req None None "prim" % string prim_encoding)
                                  (req None None "arg1" % string expr_encoding)
                                  (req None None "arg2" % string expr_encoding)
                                  (req None None "annots" % string
                                    annots_encoding))
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    Prim _ prim (cons arg1 (cons arg2 []))
                                      annots => Some (prim, arg1, arg2, annots)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  let '(prim, arg1, arg2, annots) :=
                                    function_parameter in
                                  Prim 0 prim (cons arg1 (cons arg2 [])) annots))
                              (cons
                                (application_encoding
                                  (Tezos_data_encoding.Data_encoding.Tag 9)
                                  expr_encoding)
                                (cons
                                  (bytes_encoding
                                    (Tezos_data_encoding.Data_encoding.Tag 10))
                                  []))))))))))))) in
  conv
    (fun function_parameter =>
      let 'Canonical node := function_parameter in
      node) (fun node => strip_locations node) None node_encoding.

Definition canonical_encoding {A : Type}
  (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  internal_canonical_encoding V1 variant prim_encoding.

Definition canonical_encoding_v1 {A : Type}
  (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  internal_canonical_encoding V1 variant prim_encoding.

Definition canonical_encoding_v0 {A : Type}
  (variant : string)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding.Data_encoding.encoding (canonical A) :=
  internal_canonical_encoding V0 variant prim_encoding.

Definition table_encoding {A B : Type}
  (variant : string)
  (location_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding B)
  : Tezos_data_encoding.Data_encoding.encoding (node A B) :=
  conv
    (fun node =>
      let '(canon, assoc) := extract_locations node in
      let '(_, table) := Stdlib.List.split assoc in
      (canon, table))
    (fun function_parameter =>
      let '(canon, table) := function_parameter in
      let table := Array.of_list table in
      inject_locations (fun i => Array.get table i) canon) None
    (obj2
      (req None None "expression" % string
        (canonical_encoding variant prim_encoding))
      (req None None "locations" % string (list None location_encoding))).

Definition erased_encoding {A B : Type}
  (variant : string) (default_location : A)
  (prim_encoding : Tezos_data_encoding.Data_encoding.encoding B)
  : Tezos_data_encoding.Data_encoding.encoding (node A B) :=
  conv (fun node => strip_locations node)
    (fun canon =>
      inject_locations
        (fun function_parameter =>
          let '_ := function_parameter in
          default_location) canon) None
    (canonical_encoding variant prim_encoding).

src/lib_micheline/micheline_parser.ml 90 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad
open Micheline

type 'a parsing_result = 'a * error list

type point = {point : int; byte : int; line : int; column : int}

let point_zero = {point = 0; byte = 0; line = 0; column = 0}

let point_encoding =
  let open Data_encoding in
  conv
    (fun {line; column; point; byte} -> (line, column, point, byte))
    (fun (line, column, point, byte) -> {line; column; point; byte})
    (obj4
       (req "line" uint16)
       (req "column" uint16)
       (req "point" uint16)
       (req "byte" uint16))

type location = {start : point; stop : point}

let location_zero = {start = point_zero; stop = point_zero}

let location_encoding =
  let open Data_encoding in
  conv
    (fun {start; stop} -> (start, stop))
    (fun (start, stop) -> {start; stop})
    (obj2 (req "start" point_encoding) (req "stop" point_encoding))

type token_value =
  | String of string
  | Bytes of string
  | Int of string
  | Ident of string
  | Annot of string
  | Comment of string
  | Eol_comment of string
  | Semi
  | Open_paren
  | Close_paren
  | Open_brace
  | Close_brace

let token_value_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"String"
        (obj1 (req "string" string))
        (function String s -> Some s | _ -> None)
        (fun s -> String s);
      case
        (Tag 1)
        ~title:"Int"
        (obj1 (req "int" string))
        (function Int s -> Some s | _ -> None)
        (fun s -> Int s);
      case
        (Tag 2)
        ~title:"Annot"
        (obj1 (req "annot" string))
        (function Annot s -> Some s | _ -> None)
        (fun s -> Annot s);
      case
        (Tag 3)
        ~title:"Comment"
        (obj2 (req "comment" string) (dft "end_of_line" bool false))
        (function
          | Comment s ->
              Some (s, false)
          | Eol_comment s ->
              Some (s, true)
          | _ ->
              None)
        (function (s, false) -> Comment s | (s, true) -> Eol_comment s);
      case
        (Tag 4)
        ~title:"Punctuation"
        (obj1
           (req
              "punctuation"
              (string_enum
                 [ ("(", Open_paren);
                   (")", Close_paren);
                   ("{", Open_brace);
                   ("}", Close_brace);
                   (";", Semi) ])))
        (fun t -> Some t)
        (fun t -> t);
      case
        (Tag 5)
        ~title:"Bytes"
        (obj1 (req "bytes" string))
        (function Bytes s -> Some s | _ -> None)
        (fun s -> Bytes s) ]

type token = {token : token_value; loc : location}

let max_annot_length = 255

type error += Invalid_utf8_sequence of point * string

type error += Unexpected_character of point * string

type error += Undefined_escape_sequence of point * string

type error += Missing_break_after_number of point

type error += Unterminated_string of location

type error += Unterminated_integer of location

type error += Odd_lengthed_bytes of location

type error += Unterminated_comment of location

type error += Annotation_length of location

let tokenize source =
  let decoder = Uutf.decoder ~encoding:`UTF_8 (`String source) in
  let here () =
    {
      point = Uutf.decoder_count decoder;
      byte = Uutf.decoder_byte_count decoder;
      line = Uutf.decoder_line decoder;
      column = Uutf.decoder_col decoder;
    }
  in
  let tok start stop token = {loc = {start; stop}; token} in
  let stack = ref [] in
  let errors = ref [] in
  let rec next () =
    match !stack with
    | charloc :: charlocs ->
        stack := charlocs ;
        charloc
    | [] -> (
        let loc = here () in
        match Uutf.decode decoder with
        | `Await ->
            assert false
        | `Malformed s ->
            errors := Invalid_utf8_sequence (loc, s) :: !errors ;
            next ()
        | (`Uchar _ | `End) as other ->
            (other, loc) )
  in
  let back charloc = stack := charloc :: !stack in
  let uchar_to_char c =
    if Uchar.is_char c then Some (Uchar.to_char c) else None
  in
  let allowed_ident_char c =
    match uchar_to_char c with
    | Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9') ->
        true
    | Some _ | None ->
        false
  in
  let allowed_annot_char c =
    match uchar_to_char c with
    | Some ('a' .. 'z' | 'A' .. 'Z' | '_' | '.' | '%' | '@' | '0' .. '9') ->
        true
    | Some _ | None ->
        false
  in
  let rec skip acc =
    match next () with
    | (`End, _) ->
        List.rev acc
    | (`Uchar c, start) -> (
      match uchar_to_char c with
      | Some ('a' .. 'z' | 'A' .. 'Z') ->
          ident acc start (fun s _ -> Ident s)
      | Some ('@' | ':' | '$' | '&' | '%' | '!' | '?') ->
          annot acc start (fun str stop ->
              if String.length str > max_annot_length then
                errors := Annotation_length {start; stop} :: !errors ;
              Annot str)
      | Some '-' -> (
        match next () with
        | (`End, stop) ->
            errors := Unterminated_integer {start; stop} :: !errors ;
            List.rev acc
        | (`Uchar c, stop) as first -> (
          match uchar_to_char c with
          | Some '0' ->
              base acc start
          | Some '1' .. '9' ->
              integer acc start
          | Some _ | None ->
              errors := Unterminated_integer {start; stop} :: !errors ;
              back first ;
              skip acc ) )
      | Some '0' ->
          base acc start
      | Some '1' .. '9' ->
          integer acc start
      | Some (' ' | '\n') ->
          skip acc
      | Some ';' ->
          skip (tok start (here ()) Semi :: acc)
      | Some '{' ->
          skip (tok start (here ()) Open_brace :: acc)
      | Some '}' ->
          skip (tok start (here ()) Close_brace :: acc)
      | Some '(' ->
          skip (tok start (here ()) Open_paren :: acc)
      | Some ')' ->
          skip (tok start (here ()) Close_paren :: acc)
      | Some '"' ->
          string acc [] start
      | Some '#' ->
          eol_comment acc start
      | Some '/' -> (
        match next () with
        | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') ->
            comment acc start 0
        | ((`Uchar _ | `End), _) as charloc ->
            errors := Unexpected_character (start, "/") :: !errors ;
            back charloc ;
            skip acc )
      | Some _ | None ->
          let byte = Uutf.decoder_byte_count decoder in
          let s = String.sub source start.byte (byte - start.byte) in
          errors := Unexpected_character (start, s) :: !errors ;
          skip acc )
  and base acc start =
    match next () with
    | (`Uchar c, stop) as charloc -> (
      match uchar_to_char c with
      | Some '0' .. '9' ->
          integer acc start
      | Some 'x' ->
          bytes acc start
      | Some ('a' .. 'w' | 'y' | 'z' | 'A' .. 'Z') ->
          errors := Missing_break_after_number stop :: !errors ;
          back charloc ;
          skip (tok start stop (Int "0") :: acc)
      | Some _ | None ->
          back charloc ;
          skip (tok start stop (Int "0") :: acc) )
    | (_, stop) as other ->
        back other ;
        skip (tok start stop (Int "0") :: acc)
  and integer acc start =
    let tok stop =
      let value = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (Int value)
    in
    match next () with
    | (`Uchar c, stop) as charloc -> (
        let missing_break () =
          errors := Missing_break_after_number stop :: !errors ;
          back charloc ;
          skip (tok stop :: acc)
        in
        match Uchar.to_char c with
        | '0' .. '9' ->
            integer acc start
        | 'a' .. 'z' | 'A' .. 'Z' ->
            missing_break ()
        | _ ->
            back charloc ;
            skip (tok stop :: acc) )
    | (`End, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  and bytes acc start =
    let tok stop =
      let value = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (Bytes value)
    in
    match next () with
    | (`Uchar c, stop) as charloc -> (
        let missing_break () =
          errors := Missing_break_after_number stop :: !errors ;
          back charloc ;
          skip (tok stop :: acc)
        in
        match Uchar.to_char c with
        | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
            bytes acc start
        | 'g' .. 'z' | 'G' .. 'Z' ->
            missing_break ()
        | _ ->
            back charloc ;
            skip (tok stop :: acc) )
    | (`End, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  and string acc sacc start =
    let tok () =
      tok start (here ()) (String (String.concat "" (List.rev sacc)))
    in
    match next () with
    | (`End, stop) ->
        errors := Unterminated_string {start; stop} :: !errors ;
        skip (tok () :: acc)
    | (`Uchar c, stop) -> (
      match uchar_to_char c with
      | Some '"' ->
          skip (tok () :: acc)
      | Some ('\n' | '\r') ->
          errors := Unterminated_string {start; stop} :: !errors ;
          skip (tok () :: acc)
      | Some '\\' -> (
        match next () with
        | (`End, stop) ->
            errors := Unterminated_string {start; stop} :: !errors ;
            skip (tok () :: acc)
        | (`Uchar c, loc) -> (
          match uchar_to_char c with
          | Some '"' ->
              string acc ("\"" :: sacc) start
          | Some 'r' ->
              string acc ("\r" :: sacc) start
          | Some 'n' ->
              string acc ("\n" :: sacc) start
          | Some 't' ->
              string acc ("\t" :: sacc) start
          | Some 'b' ->
              string acc ("\b" :: sacc) start
          | Some '\\' ->
              string acc ("\\" :: sacc) start
          | Some _ | None ->
              let byte = Uutf.decoder_byte_count decoder in
              let s = String.sub source loc.byte (byte - loc.byte) in
              errors := Undefined_escape_sequence (loc, s) :: !errors ;
              string acc sacc start ) )
      | Some _ | None ->
          let byte = Uutf.decoder_byte_count decoder in
          let s = String.sub source stop.byte (byte - stop.byte) in
          string acc (s :: sacc) start )
  and generic_ident allow_char acc start (ret : string -> point -> token_value)
      =
    let tok stop =
      let name = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (ret name stop)
    in
    match next () with
    | (`Uchar c, stop) as charloc ->
        if allow_char c then generic_ident allow_char acc start ret
        else (
          back charloc ;
          skip (tok stop :: acc) )
    | (_, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  and ident acc start ret = generic_ident allowed_ident_char acc start ret
  and annot acc start ret = generic_ident allowed_annot_char acc start ret
  and comment acc start lvl =
    match next () with
    | (`End, stop) ->
        errors := Unterminated_comment {start; stop} :: !errors ;
        let text = String.sub source start.byte (stop.byte - start.byte) in
        skip (tok start stop (Comment text) :: acc)
    | (`Uchar c, _) -> (
      match uchar_to_char c with
      | Some '*' -> (
        match next () with
        | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '/') ->
            if lvl = 0 then
              let stop = here () in
              let text =
                String.sub source start.byte (stop.byte - start.byte)
              in
              skip (tok start stop (Comment text) :: acc)
            else comment acc start (lvl - 1)
        | other ->
            back other ; comment acc start lvl )
      | Some '/' -> (
        match next () with
        | (`Uchar c, _) when Uchar.equal c (Uchar.of_char '*') ->
            comment acc start (lvl + 1)
        | other ->
            back other ; comment acc start lvl )
      | Some _ | None ->
          comment acc start lvl )
  and eol_comment acc start =
    let tok stop =
      let text = String.sub source start.byte (stop.byte - start.byte) in
      tok start stop (Eol_comment text)
    in
    match next () with
    | (`Uchar c, stop) -> (
      match uchar_to_char c with
      | Some '\n' ->
          skip (tok stop :: acc)
      | Some _ | None ->
          eol_comment acc start )
    | (_, stop) as other ->
        back other ;
        skip (tok stop :: acc)
  in
  let tokens = skip [] in
  (tokens, List.rev !errors)

type node = (location, string) Micheline.node

let node_encoding =
  Micheline.table_encoding
    ~variant:"generic"
    location_encoding
    Data_encoding.string

(* Beginning of a sequence of consecutive primitives *)
let min_point : node list -> point = function
  | [] ->
      point_zero
  | Int ({start; _}, _) :: _
  | String ({start; _}, _) :: _
  | Bytes ({start; _}, _) :: _
  | Prim ({start; _}, _, _, _) :: _
  | Seq ({start; _}, _) :: _ ->
      start

(* End of a sequence of consecutive primitives *)
let rec max_point : node list -> point = function
  | [] ->
      point_zero
  | _ :: (_ :: _ as rest) ->
      max_point rest
  | [Int ({stop; _}, _)]
  | [String ({stop; _}, _)]
  | [Bytes ({stop; _}, _)]
  | [Prim ({stop; _}, _, _, _)]
  | [Seq ({stop; _}, _)] ->
      stop

(* An item in the parser's state stack.
   Not every value of type [mode list] is a valid parsing context.
   It must respect the following additional invariants.
   - a state stack always ends in [Toplevel _],
   - [Toplevel _] does not appear anywhere else,
   - [Unwrapped _] cannot appear directly on top of [Wrapped _],
   - [Wrapped _] cannot appear directly on top of [Sequence _],
   - [Wrapped _] cannot appear directly on top of [Sequence _]. *)
type mode =
  | Toplevel of node list
  | Expression of node option
  | Sequence of token * node list
  | Unwrapped of location * string * node list * string list
  | Wrapped of token * string * node list * string list

(* Enter a new parsing state. *)
let push_mode mode stack = mode :: stack

(* Leave a parsing state. *)
let pop_mode = function [] -> assert false | _ :: rest -> rest

(* Usually after a [pop_mode], jump back into the previous parsing
   state, injecting the current reduction (insert the just parsed item
   of a sequence or argument of a primitive application). *)
let fill_mode result = function
  | [] ->
      assert false
  | Expression _ :: _ :: _ ->
      assert false
  | [Expression (Some _)] ->
      assert false
  | Toplevel _ :: _ :: _ ->
      assert false
  | [Expression None] ->
      [Expression (Some result)]
  | [Toplevel exprs] ->
      [Toplevel (result :: exprs)]
  | Sequence (token, exprs) :: rest ->
      Sequence (token, result :: exprs) :: rest
  | Wrapped (token, name, exprs, annot) :: rest ->
      Wrapped (token, name, result :: exprs, annot) :: rest
  | Unwrapped (start, name, exprs, annot) :: rest ->
      Unwrapped (start, name, result :: exprs, annot) :: rest

type error += Unclosed of token

type error += Unexpected of token

type error += Extra of token

type error += Misaligned of node

type error += Empty

let rec annots = function
  | {token = Annot annot; _} :: rest ->
      let (annots, rest) = annots rest in
      (annot :: annots, rest)
  | rest ->
      ([], rest)

let rec parse ?(check = true) errors tokens stack =
  (* Two steps:
     - 1. parse without checking indentation [parse]
     - 2. check indentation [check] (inlined in 1) *)
  match (stack, tokens) with
  (* Start by preventing all absurd cases, so now the pattern
     matching exhaustivity can tell us that we treater all
     possible tokens for all possible valid states. *)
  | ([], _)
  | ([Wrapped _], _)
  | ([Unwrapped _], _)
  | (Unwrapped _ :: Unwrapped _ :: _, _)
  | (Unwrapped _ :: Wrapped _ :: _, _)
  | (Toplevel _ :: _ :: _, _)
  | (Expression _ :: _ :: _, _) ->
      assert false
  (* Return *)
  | (Expression (Some result) :: _, []) ->
      ([result], List.rev errors)
  | (Expression (Some _) :: _, token :: rem) ->
      let errors = Unexpected token :: errors in
      parse ~check errors rem (* skip *) stack
  | (Expression None :: _, []) ->
      let errors = Empty :: errors in
      let ghost = {start = point_zero; stop = point_zero} in
      ([Seq (ghost, [])], List.rev errors)
  | ([Toplevel [(Seq (_, exprs) as expr)]], []) ->
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      (exprs, List.rev errors)
  | ([Toplevel exprs], []) ->
      let exprs = List.rev exprs in
      let loc = {start = min_point exprs; stop = max_point exprs} in
      let expr = Seq (loc, exprs) in
      let errors =
        if check then do_check ~toplevel:true errors expr else errors
      in
      (exprs, List.rev errors)
  (* Ignore comments *)
  | (_, {token = Eol_comment _ | Comment _; _} :: rest) ->
      parse ~check errors rest stack
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      ({token = Int _ | String _ | Bytes _; _} as token)
      :: {token = Eol_comment _ | Comment _; _} :: rest )
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: {token = Eol_comment _ | Comment _; _} :: rest ) ->
      parse ~check errors (token :: rest) stack
  (* Erroneous states *)
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: {token = Open_paren | Open_brace; _} :: rem )
  | ( Unwrapped _ :: Expression _ :: _,
      ({token = Semi | Close_brace | Close_paren; _} as token) :: rem )
  | ( Expression None :: _,
      ({token = Semi | Close_brace | Close_paren | Open_paren; _} as token)
      :: rem ) ->
      let errors = Unexpected token :: errors in
      parse ~check errors rem (* skip *) stack
  | ( (Sequence _ | Toplevel _) :: _,
      ({token = Semi; _} as valid) :: ({token = Semi; _} as token) :: rem ) ->
      let errors = Extra token :: errors in
      parse ~check errors ((* skip *) valid :: rem) stack
  | ( (Wrapped _ | Unwrapped _) :: _,
      {token = Open_paren; _}
      :: ( {token = Int _ | String _ | Bytes _ | Annot _ | Close_paren; _} as
         token )
         :: rem )
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = Int _ | String _ | Bytes _; _}
      :: ( { token =
               ( Ident _
               | Int _
               | String _
               | Bytes _
               | Annot _
               | Close_paren
               | Open_paren
               | Open_brace );
             _ } as token )
         :: rem )
  | ( Unwrapped (_, _, _, _) :: Toplevel _ :: _,
      ({token = Close_brace; _} as token) :: rem )
  | (Unwrapped (_, _, _, _) :: _, ({token = Close_paren; _} as token) :: rem)
  | ([Toplevel _], ({token = Close_paren; _} as token) :: rem)
  | ([Toplevel _], ({token = Open_paren; _} as token) :: rem)
  | ([Toplevel _], ({token = Close_brace; _} as token) :: rem)
  | (Sequence _ :: _, ({token = Open_paren; _} as token) :: rem)
  | (Sequence _ :: _, ({token = Close_paren; _} as token) :: rem)
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: (({token = Close_brace | Semi; _} :: _ | []) as rem) )
  | (_, ({token = Annot _; _} as token) :: rem) ->
      let errors = Unexpected token :: errors in
      parse ~check errors rem (* skip *) stack
  | (Wrapped (token, _, _, _) :: _, ([] | {token = Close_brace | Semi; _} :: _))
    ->
      let errors = Unclosed token :: errors in
      let fake = {token with token = Close_paren} in
      let tokens = (* insert *) fake :: tokens in
      parse ~check errors tokens stack
  | ((Sequence (token, _) :: _ | Unwrapped _ :: Sequence (token, _) :: _), [])
    ->
      let errors = Unclosed token :: errors in
      let fake = {token with token = Close_brace} in
      let tokens = (* insert *) fake :: tokens in
      parse ~check errors tokens stack
  (* Valid states *)
  | ( (Toplevel _ | Sequence (_, _)) :: _,
      {token = Ident name; loc} :: ({token = Annot _; _} :: _ as rest) ) ->
      let (annots, rest) = annots rest in
      let mode = Unwrapped (loc, name, [], annots) in
      parse ~check errors rest (push_mode mode stack)
  | ( (Expression None | Toplevel _ | Sequence (_, _)) :: _,
      {token = Ident name; loc} :: rest ) ->
      let mode = Unwrapped (loc, name, [], []) in
      parse ~check errors rest (push_mode mode stack)
  | ((Unwrapped _ | Wrapped _) :: _, {token = Int value; loc} :: rest)
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = Int value; loc}
      :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
      let expr : node = Int (loc, Z.of_string value) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ((Unwrapped _ | Wrapped _) :: _, {token = String contents; loc} :: rest)
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = String contents; loc}
      :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
      let expr : node = String (loc, contents) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ((Unwrapped _ | Wrapped _) :: _, {token = Bytes contents; loc} :: rest)
  | ( (Expression None | Sequence _ | Toplevel _) :: _,
      {token = Bytes contents; loc}
      :: (([] | {token = Semi | Close_brace; _} :: _) as rest) ) ->
      let (errors, contents) =
        if String.length contents mod 2 <> 0 then
          (Odd_lengthed_bytes loc :: errors, contents ^ "0")
        else (errors, contents)
      in
      let bytes =
        Hex.to_bytes
          (`Hex (String.sub contents 2 (String.length contents - 2)))
      in
      let expr : node = Bytes (loc, bytes) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ( Sequence ({loc = {start; _}; _}, exprs) :: _,
      {token = Close_brace; loc = {stop; _}} :: rest ) ->
      let exprs = List.rev exprs in
      let expr = Micheline.Seq ({start; stop}, exprs) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr (pop_mode stack))
  | ((Sequence _ | Toplevel _) :: _, {token = Semi; _} :: rest) ->
      parse ~check errors rest stack
  | ( Unwrapped ({start; stop}, name, exprs, annot) :: Expression _ :: _,
      ([] as rest) )
  | ( Unwrapped ({start; stop}, name, exprs, annot) :: Toplevel _ :: _,
      (({token = Semi; _} :: _ | []) as rest) )
  | ( Unwrapped ({start; stop}, name, exprs, annot) :: Sequence _ :: _,
      ({token = Close_brace | Semi; _} :: _ as rest) )
  | ( Wrapped ({loc = {start; stop}; _}, name, exprs, annot) :: _,
      {token = Close_paren; _} :: rest ) ->
      let exprs = List.rev exprs in
      let stop = if exprs = [] then stop else max_point exprs in
      let expr = Micheline.Prim ({start; stop}, name, exprs, annot) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr (pop_mode stack))
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token)
      :: {token = Ident name; _} :: ({token = Annot _; _} :: _ as rest) ) ->
      let (annots, rest) = annots rest in
      let mode = Wrapped (token, name, [], annots) in
      parse ~check errors rest (push_mode mode stack)
  | ( (Wrapped _ | Unwrapped _) :: _,
      ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest )
    ->
      let mode = Wrapped (token, name, [], []) in
      parse ~check errors rest (push_mode mode stack)
  | ((Wrapped _ | Unwrapped _) :: _, {token = Ident name; loc} :: rest) ->
      let expr = Micheline.Prim (loc, name, [], []) in
      let errors =
        if check then do_check ~toplevel:false errors expr else errors
      in
      parse ~check errors rest (fill_mode expr stack)
  | ( (Wrapped _ | Unwrapped _ | Toplevel _ | Sequence _ | Expression None) :: _,
      ({token = Open_brace; _} as token) :: rest ) ->
      let mode = Sequence (token, []) in
      parse ~check errors rest (push_mode mode stack)

(* indentation checker *)
and do_check ?(toplevel = false) errors = function
  | Seq ({start; stop}, []) as expr ->
      if start.column >= stop.column then Misaligned expr :: errors else errors
  | ( Prim ({start; stop}, _, first :: rest, _)
    | Seq ({start; stop}, first :: rest) ) as expr ->
      let {column = first_column; line = first_line; _} = min_point [first] in
      if start.column >= stop.column then Misaligned expr :: errors
      else if (not toplevel) && start.column >= first_column then
        Misaligned expr :: errors
      else
        (* In a sequence or in the arguments of a primitive, we
           require all items to be aligned, but we relax the rule to
           allow consecutive items to be writtem on the same line. *)
        let rec in_line_or_aligned prev_start_line errors = function
          | [] ->
              errors
          | expr :: rest ->
              let {column; line = start_line; _} = min_point [expr] in
              let {line = stop_line; _} = max_point [expr] in
              let errors =
                if stop_line <> prev_start_line && column <> first_column then
                  Misaligned expr :: errors
                else errors
              in
              in_line_or_aligned start_line errors rest
        in
        in_line_or_aligned first_line errors rest
  | Prim (_, _, [], _) | String _ | Int _ | Bytes _ ->
      errors

let parse_expression ?check tokens =
  let result =
    match tokens with
    | ({token = Open_paren; _} as token)
      :: {token = Ident name; _} :: {token = Annot annot; _} :: rest ->
        let (annots, rest) = annots rest in
        let mode = Wrapped (token, name, [], annot :: annots) in
        parse ?check [] rest [mode; Expression None]
    | ({token = Open_paren; _} as token) :: {token = Ident name; _} :: rest ->
        let mode = Wrapped (token, name, [], []) in
        parse ?check [] rest [mode; Expression None]
    | _ ->
        parse ?check [] tokens [Expression None]
  in
  match result with
  | ([single], errors) ->
      (single, errors)
  | _ ->
      assert false

let parse_toplevel ?check tokens = parse ?check [] tokens [Toplevel []]

let print_point ppf {line; column; _} =
  Format.fprintf ppf "At line %d character %d" line column

let print_token_kind ppf = function
  | Open_paren | Close_paren ->
      Format.fprintf ppf "parenthesis"
  | Open_brace | Close_brace ->
      Format.fprintf ppf "curly brace"
  | String _ ->
      Format.fprintf ppf "string constant"
  | Bytes _ ->
      Format.fprintf ppf "bytes constant"
  | Int _ ->
      Format.fprintf ppf "integer constant"
  | Ident _ ->
      Format.fprintf ppf "identifier"
  | Annot _ ->
      Format.fprintf ppf "annotation"
  | Comment _ | Eol_comment _ ->
      Format.fprintf ppf "comment"
  | Semi ->
      Format.fprintf ppf "semi colon"

let print_location ppf loc =
  if loc.start.line = loc.stop.line then
    if loc.start.column = loc.stop.column then
      Format.fprintf
        ppf
        "At line %d character %d"
        loc.start.line
        loc.start.column
    else
      Format.fprintf
        ppf
        "At line %d characters %d to %d"
        loc.start.line
        loc.start.column
        loc.stop.column
  else
    Format.fprintf
      ppf
      "From line %d character %d to line %d character %d"
      loc.start.line
      loc.start.column
      loc.stop.line
      loc.stop.column

let no_parsing_error (ast, errors) =
  match errors with [] -> ok ast | errors -> Error errors

let () =
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.invalid_utf8_sequence"
    ~title:"Micheline parser error: invalid UTF-8 sequence"
    ~description:
      "While parsing a piece of Micheline source, a sequence of bytes that is \
       not valid UTF-8 was encountered."
    ~pp:(fun ppf (point, str) ->
      Format.fprintf ppf "%a, invalid UTF-8 sequence %S" print_point point str)
    Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
    (function
      | Invalid_utf8_sequence (point, str) -> Some (point, str) | _ -> None)
    (fun (point, str) -> Invalid_utf8_sequence (point, str)) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unexpected_character"
    ~title:"Micheline parser error: unexpected character"
    ~description:
      "While parsing a piece of Micheline source, an unexpected character was \
       encountered."
    ~pp:(fun ppf (point, str) ->
      Format.fprintf ppf "%a, unexpected character %s" print_point point str)
    Data_encoding.(obj2 (req "point" point_encoding) (req "character" string))
    (function
      | Unexpected_character (point, str) -> Some (point, str) | _ -> None)
    (fun (point, str) -> Unexpected_character (point, str)) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.undefined_escape_sequence"
    ~title:"Micheline parser error: undefined escape sequence"
    ~description:
      "While parsing a piece of Micheline source, an unexpected escape \
       sequence was encountered in a string."
    ~pp:(fun ppf (point, str) ->
      Format.fprintf
        ppf
        "%a, undefined escape sequence \"%s\""
        print_point
        point
        str)
    Data_encoding.(obj2 (req "point" point_encoding) (req "sequence" string))
    (function
      | Undefined_escape_sequence (point, str) -> Some (point, str) | _ -> None)
    (fun (point, str) -> Undefined_escape_sequence (point, str)) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.missing_break_after_number"
    ~title:"Micheline parser error: missing break after number"
    ~description:
      "While parsing a piece of Micheline source, a number was not visually \
       separated from its follower token, leading to misreadability."
    ~pp:(fun ppf point ->
      Format.fprintf ppf "%a, missing break after number" print_point point)
    Data_encoding.(obj1 (req "point" point_encoding))
    (function Missing_break_after_number point -> Some point | _ -> None)
    (fun point -> Missing_break_after_number point) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unterminated_string"
    ~title:"Micheline parser error: unterminated string"
    ~description:
      "While parsing a piece of Micheline source, a string was not terminated."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, unterminated string" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Unterminated_string loc -> Some loc | _ -> None)
    (fun loc -> Unterminated_string loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unterminated_integer"
    ~title:"Micheline parser error: unterminated integer"
    ~description:
      "While parsing a piece of Micheline source, an integer was not \
       terminated."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, unterminated integer" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Unterminated_integer loc -> Some loc | _ -> None)
    (fun loc -> Unterminated_integer loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.odd_lengthed_bytes"
    ~title:"Micheline parser error: odd lengthed bytes"
    ~description:
      "While parsing a piece of Micheline source, the length of a byte \
       sequence (0x...) was not a multiple of two, leaving a trailing half \
       byte."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, odd_lengthed bytes" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Odd_lengthed_bytes loc -> Some loc | _ -> None)
    (fun loc -> Odd_lengthed_bytes loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unterminated_comment"
    ~title:"Micheline parser error: unterminated comment"
    ~description:
      "While parsing a piece of Micheline source, a commentX was not \
       terminated."
    ~pp:(fun ppf loc ->
      Format.fprintf ppf "%a, unterminated comment" print_location loc)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Unterminated_comment loc -> Some loc | _ -> None)
    (fun loc -> Unterminated_comment loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.annotation_exceeds_max_length"
    ~title:"Micheline parser error: annotation exceeds max length"
    ~description:
      (Format.sprintf
         "While parsing a piece of Micheline source, an annotation exceeded \
          the maximum length (%d)."
         max_annot_length)
    ~pp:(fun ppf loc ->
      Format.fprintf
        ppf
        "%a, annotation exceeded maximum length (%d chars)"
        print_location
        loc
        max_annot_length)
    Data_encoding.(obj1 (req "location" location_encoding))
    (function Annotation_length loc -> Some loc | _ -> None)
    (fun loc -> Annotation_length loc) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unclosed_token"
    ~title:"Micheline parser error: unclosed token"
    ~description:
      "While parsing a piece of Micheline source, a parenthesis or a brace \
       was unclosed."
    ~pp:(fun ppf (loc, token) ->
      Format.fprintf
        ppf
        "%a, unclosed %a"
        print_location
        loc
        print_token_kind
        token)
    Data_encoding.(
      obj2
        (req "location" location_encoding)
        (req "token" token_value_encoding))
    (function Unclosed {loc; token} -> Some (loc, token) | _ -> None)
    (fun (loc, token) -> Unclosed {loc; token}) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.unexpected_token"
    ~title:"Micheline parser error: unexpected token"
    ~description:
      "While parsing a piece of Micheline source, an unexpected token was \
       encountered."
    ~pp:(fun ppf (loc, token) ->
      Format.fprintf
        ppf
        "%a, unexpected %a"
        print_location
        loc
        print_token_kind
        token)
    Data_encoding.(
      obj2
        (req "location" location_encoding)
        (req "token" token_value_encoding))
    (function Unexpected {loc; token} -> Some (loc, token) | _ -> None)
    (fun (loc, token) -> Unexpected {loc; token}) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.extra_token"
    ~title:"Micheline parser error: extra token"
    ~description:
      "While parsing a piece of Micheline source, an extra semi colon or \
       parenthesis was encountered."
    ~pp:(fun ppf (loc, token) ->
      Format.fprintf
        ppf
        "%a, extra %a"
        print_location
        loc
        print_token_kind
        token)
    Data_encoding.(
      obj2
        (req "location" location_encoding)
        (req "token" token_value_encoding))
    (function Extra {loc; token} -> Some (loc, token) | _ -> None)
    (fun (loc, token) -> Extra {loc; token}) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.misaligned_node"
    ~title:"Micheline parser error: misaligned node"
    ~description:
      "While parsing a piece of Micheline source, an expression was not \
       aligned with its siblings of the same mother application or sequence."
    ~pp:(fun ppf node ->
      Format.fprintf
        ppf
        "%a, misaligned expression"
        print_location
        (location node))
    Data_encoding.(obj1 (req "expression" node_encoding))
    (function Misaligned node -> Some node | _ -> None)
    (fun node -> Misaligned node) ;
  register_error_kind
    `Permanent
    ~id:"micheline.parse_error.empty_expression"
    ~title:"Micheline parser error: empty_expression"
    ~description:
      "Tried to interpret an empty piece or Micheline source as a single \
       expression."
    ~pp:(fun ppf () -> Format.fprintf ppf "empty expression")
    Data_encoding.empty
    (function Empty -> Some () | _ -> None)
    (fun () -> Empty)
src/lib_micheline/micheline_parser.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Import Micheline.

Definition parsing_result (a : Type) :=
  a * (list Tezos_error_monad.Error_monad.error).

Record point := {
  point : Z;
  byte : Z;
  line : Z;
  column : Z }.

Definition point_zero : point :=
  {| point := 0; byte := 0; line := 0; column := 0 |}.

Definition point_encoding : Tezos_data_encoding.Data_encoding.encoding point :=
  conv
    (fun function_parameter =>
      let '{| point := point; byte := byte; line := line; column := column |} :=
        function_parameter in
      (line, column, point, byte))
    (fun function_parameter =>
      let '(line, column, point, byte) := function_parameter in
      {| point := point; byte := byte; line := line; column := column |}) None
    (obj4 (req None None "line" % string uint16)
      (req None None "column" % string uint16)
      (req None None "point" % string uint16)
      (req None None "byte" % string uint16)).

Record location := {
  start : point;
  stop : point }.

Definition location_zero : location :=
  {| start := point_zero; stop := point_zero |}.

Definition location_encoding
  : Tezos_data_encoding.Data_encoding.encoding location :=
  conv
    (fun function_parameter =>
      let '{| start := start; stop := stop |} := function_parameter in
      (start, stop))
    (fun function_parameter =>
      let '(start, stop) := function_parameter in
      {| start := start; stop := stop |}) None
    (obj2 (req None None "start" % string point_encoding)
      (req None None "stop" % string point_encoding)).

Inductive token_value : Type :=
| String : string -> token_value
| Bytes : string -> token_value
| Int : string -> token_value
| Ident : string -> token_value
| Annot : string -> token_value
| Comment : string -> token_value
| Eol_comment : string -> token_value
| Semi : token_value
| Open_paren : token_value
| Close_paren : token_value
| Open_brace : token_value
| Close_brace : token_value.

Definition token_value_encoding
  : Tezos_data_encoding.Data_encoding.encoding token_value :=
  union None
    (cons
      (case "String" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
        (obj1 (req None None "string" % string string))
        (fun function_parameter =>
          match function_parameter with
          | String s => Some s
          | _ => None
          end) (fun s => String s))
      (cons
        (case "Int" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
          (obj1 (req None None "int" % string string))
          (fun function_parameter =>
            match function_parameter with
            | Int s => Some s
            | _ => None
            end) (fun s => Int s))
        (cons
          (case "Annot" % string None (Tezos_data_encoding.Data_encoding.Tag 2)
            (obj1 (req None None "annot" % string string))
            (fun function_parameter =>
              match function_parameter with
              | Annot s => Some s
              | _ => None
              end) (fun s => Annot s))
          (cons
            (case "Comment" % string None
              (Tezos_data_encoding.Data_encoding.Tag 3)
              (obj2 (req None None "comment" % string string)
                (dft None None "end_of_line" % string bool false))
              (fun function_parameter =>
                match function_parameter with
                | Comment s => Some (s, false)
                | Eol_comment s => Some (s, true)
                | _ => None
                end)
              (fun function_parameter =>
                match function_parameter with
                | (s, false) => Comment s
                | (s, true) => Eol_comment s
                end))
            (cons
              (case "Punctuation" % string None
                (Tezos_data_encoding.Data_encoding.Tag 4)
                (obj1
                  (req None None "punctuation" % string
                    (string_enum
                      (cons ("(" % string, Open_paren)
                        (cons (")" % string, Close_paren)
                          (cons ("{" % string, Open_brace)
                            (cons ("}" % string, Close_brace)
                              (cons (";" % string, Semi) []))))))))
                (fun t => Some t) (fun t => t))
              (cons
                (case "Bytes" % string None
                  (Tezos_data_encoding.Data_encoding.Tag 5)
                  (obj1 (req None None "bytes" % string string))
                  (fun function_parameter =>
                    match function_parameter with
                    | Bytes s => Some s
                    | _ => None
                    end) (fun s => Bytes s)) [])))))).

Record token := {
  token : token_value;
  loc : location }.

Definition max_annot_length : Z := 255.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition tokenize (source : string)
  : (list token) * (list Tezos_error_monad.Error_monad.error) :=
  let decoder :=
    Uutf.decoder None
      (Some
        (* ❌ Variants not supported *)
        variant)
      (* ❌ Variants not supported *)
      variant in
  let here (function_parameter : unit) : point :=
    let 'tt := function_parameter in
    {| point := Uutf.decoder_count decoder;
      byte := Uutf.decoder_byte_count decoder;
      line := Uutf.decoder_line decoder; column := Uutf.decoder_col decoder |}
    in
  let tok (start : point) (stop : point) (token : token_value) : token :=
    {| token := token; loc := {| start := start; stop := stop |} |} in
  let stack := Stdlib.ref [] in
  let errors := Stdlib.ref [] in
  let fix next (function_parameter : unit) : variant * point :=
    let 'tt := function_parameter in
    match Stdlib.op_exclamation stack with
    | cons charloc charlocs =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq stack charlocs in
      charloc
    | [] =>
      let loc := here tt in
      match Uutf.decode decoder with
      | Await =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      | Malformed s =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq errors
            (cons (Tezos_error_monad.Error_monad.Invalid_utf8_sequence loc s)
              (Stdlib.op_exclamation errors)) in
        next tt
      | (Uchar _ | End) as other => (other, loc)
      end
    end in
  let back (charloc : variant * point) : unit :=
    Stdlib.op_coloneq stack (cons charloc (Stdlib.op_exclamation stack)) in
  let uchar_to_char (c : Stdlib.Uchar.t) : option ascii :=
    if Uchar.is_char c then
      Some (Uchar.to_char c)
    else
      None in
  let allowed_ident_char (c : Stdlib.Uchar.t) : bool :=
    match uchar_to_char c with
    |
      Some
        ("a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
          |
          "A" % char |
            "B" % char |
              "C" % char |
                "D" % char |
                  "E" % char |
                    "F" % char |
                      "G" % char |
                        "H" % char |
                          "I" % char |
                            "J" % char |
                              "K" % char |
                                "L" % char |
                                  "M" % char |
                                    "N" % char |
                                      "O" % char |
                                        "P" % char |
                                          "Q" % char |
                                            "R" % char |
                                              "S" % char |
                                                "T" % char |
                                                  "U" % char |
                                                    "V" % char |
                                                      "W" % char |
                                                        "X" % char |
                                                          "Y" % char |
                                                            "Z" % char |
          "_" % char |
          "0" % char |
            "1" % char |
              "2" % char |
                "3" % char |
                  "4" % char |
                    "5" % char |
                      "6" % char | "7" % char | "8" % char | "9" % char) => true
    | Some _ | None => false
    end in
  let allowed_annot_char (c : Stdlib.Uchar.t) : bool :=
    match uchar_to_char c with
    |
      Some
        ("a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
          |
          "A" % char |
            "B" % char |
              "C" % char |
                "D" % char |
                  "E" % char |
                    "F" % char |
                      "G" % char |
                        "H" % char |
                          "I" % char |
                            "J" % char |
                              "K" % char |
                                "L" % char |
                                  "M" % char |
                                    "N" % char |
                                      "O" % char |
                                        "P" % char |
                                          "Q" % char |
                                            "R" % char |
                                              "S" % char |
                                                "T" % char |
                                                  "U" % char |
                                                    "V" % char |
                                                      "W" % char |
                                                        "X" % char |
                                                          "Y" % char |
                                                            "Z" % char |
          "_" % char | "." % char | "%" % char | "@" % char |
          "0" % char |
            "1" % char |
              "2" % char |
                "3" % char |
                  "4" % char |
                    "5" % char |
                      "6" % char | "7" % char | "8" % char | "9" % char) => true
    | Some _ | None => false
    end in
  let fix skip (acc : list token) : list token :=
    match next tt with
    | (End, _) => List.rev acc
    | (Uchar c, start) =>
      match uchar_to_char c with
      |
        Some
          ("a" % char |
            "b" % char |
              "c" % char |
                "d" % char |
                  "e" % char |
                    "f" % char |
                      "g" % char |
                        "h" % char |
                          "i" % char |
                            "j" % char |
                              "k" % char |
                                "l" % char |
                                  "m" % char |
                                    "n" % char |
                                      "o" % char |
                                        "p" % char |
                                          "q" % char |
                                            "r" % char |
                                              "s" % char |
                                                "t" % char |
                                                  "u" % char |
                                                    "v" % char |
                                                      "w" % char |
                                                        "x" % char |
                                                          "y" % char |
                                                            "z" % char |
            "A" % char |
              "B" % char |
                "C" % char |
                  "D" % char |
                    "E" % char |
                      "F" % char |
                        "G" % char |
                          "H" % char |
                            "I" % char |
                              "J" % char |
                                "K" % char |
                                  "L" % char |
                                    "M" % char |
                                      "N" % char |
                                        "O" % char |
                                          "P" % char |
                                            "Q" % char |
                                              "R" % char |
                                                "S" % char |
                                                  "T" % char |
                                                    "U" % char |
                                                      "V" % char |
                                                        "W" % char |
                                                          "X" % char |
                                                            "Y" % char |
                                                              "Z" % char) =>
        ident acc start
          (fun s =>
            fun function_parameter =>
              let '_ := function_parameter in
              Ident s)
      |
        Some
          ("@" % char | ":" % char | "$" % char | "&" % char | "%" % char |
            "!" % char | "?" % char) =>
        annot acc start
          (fun str =>
            fun stop =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                if OCaml.Stdlib.gt (OCaml.String.length str) max_annot_length
                  then
                  Stdlib.op_coloneq errors
                    (cons
                      (Tezos_error_monad.Error_monad.Annotation_length
                        {| start := start; stop := stop |})
                      (Stdlib.op_exclamation errors))
                else
                  tt in
              Annot str)
      | Some "-" % char =>
        match next tt with
        | (End, stop) =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.op_coloneq errors
              (cons
                (Tezos_error_monad.Error_monad.Unterminated_integer
                  {| start := start; stop := stop |})
                (Stdlib.op_exclamation errors)) in
          List.rev acc
        | (Uchar c, stop) as first =>
          match uchar_to_char c with
          | Some "0" % char => base acc start
          |
            Some
              ("1" % char |
                "2" % char |
                  "3" % char |
                    "4" % char |
                      "5" % char |
                        "6" % char | "7" % char | "8" % char | "9" % char) =>
            integer acc start
          | Some _ | None =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Stdlib.op_coloneq errors
                (cons
                  (Tezos_error_monad.Error_monad.Unterminated_integer
                    {| start := start; stop := stop |})
                  (Stdlib.op_exclamation errors)) in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := back first in
            skip acc
          end
        end
      | Some "0" % char => base acc start
      |
        Some
          ("1" % char |
            "2" % char |
              "3" % char |
                "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char)
        => integer acc start
      | Some (" " % char | "010" % char) => skip acc
      | Some ";" % char => skip (cons (tok start (here tt) Semi) acc)
      | Some "{" % char => skip (cons (tok start (here tt) Open_brace) acc)
      | Some "}" % char => skip (cons (tok start (here tt) Close_brace) acc)
      | Some "(" % char => skip (cons (tok start (here tt) Open_paren) acc)
      | Some ")" % char => skip (cons (tok start (here tt) Close_paren) acc)
      | Some """" % char => string acc [] start
      | Some "#" % char => eol_comment acc start
      | Some "/" % char =>
        match next tt with
        | (Uchar c, _) => comment acc start 0
        | (Uchar _ | End, _) as charloc =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.op_coloneq errors
              (cons
                (Tezos_error_monad.Error_monad.Unexpected_character start
                  "/" % string) (Stdlib.op_exclamation errors)) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := back charloc in
          skip acc
        end
      | Some _ | None =>
        let byte := Uutf.decoder_byte_count decoder in
        let s := Stdlib.String.sub source (byte start) (Z.sub byte (byte start))
          in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq errors
            (cons (Tezos_error_monad.Error_monad.Unexpected_character start s)
              (Stdlib.op_exclamation errors)) in
        skip acc
      end
    end
  with base (acc : list token) (start : point) : list token :=
    match next tt with
    | (Uchar c, stop) as charloc =>
      match uchar_to_char c with
      |
        Some
          ("0" % char |
            "1" % char |
              "2" % char |
                "3" % char |
                  "4" % char |
                    "5" % char |
                      "6" % char | "7" % char | "8" % char | "9" % char) =>
        integer acc start
      | Some "x" % char => string acc start
      |
        Some
          ("a" % char |
            "b" % char |
              "c" % char |
                "d" % char |
                  "e" % char |
                    "f" % char |
                      "g" % char |
                        "h" % char |
                          "i" % char |
                            "j" % char |
                              "k" % char |
                                "l" % char |
                                  "m" % char |
                                    "n" % char |
                                      "o" % char |
                                        "p" % char |
                                          "q" % char |
                                            "r" % char |
                                              "s" % char |
                                                "t" % char |
                                                  "u" % char |
                                                    "v" % char | "w" % char |
            "y" % char | "z" % char |
            "A" % char |
              "B" % char |
                "C" % char |
                  "D" % char |
                    "E" % char |
                      "F" % char |
                        "G" % char |
                          "H" % char |
                            "I" % char |
                              "J" % char |
                                "K" % char |
                                  "L" % char |
                                    "M" % char |
                                      "N" % char |
                                        "O" % char |
                                          "P" % char |
                                            "Q" % char |
                                              "R" % char |
                                                "S" % char |
                                                  "T" % char |
                                                    "U" % char |
                                                      "V" % char |
                                                        "W" % char |
                                                          "X" % char |
                                                            "Y" % char |
                                                              "Z" % char) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq errors
            (cons
              (Tezos_error_monad.Error_monad.Missing_break_after_number stop)
              (Stdlib.op_exclamation errors)) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok start stop (Int "0" % string)) acc)
      | Some _ | None =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok start stop (Int "0" % string)) acc)
      end
    | (_, stop) as other =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := back other in
      skip (cons (tok start stop (Int "0" % string)) acc)
    end
  with integer (acc : list token) (start : point) : list token :=
    let tok (stop : point) : token :=
      let value :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (Int value) in
    match next tt with
    | (Uchar c, stop) as charloc =>
      let missing_break (function_parameter : unit) : list token :=
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq errors
            (cons
              (Tezos_error_monad.Error_monad.Missing_break_after_number stop)
              (Stdlib.op_exclamation errors)) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok stop) acc) in
      match Uchar.to_char c with
      |
        "0" % char |
          "1" % char |
            "2" % char |
              "3" % char |
                "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char
        => integer acc start
      |
        "a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
          |
          "A" % char |
            "B" % char |
              "C" % char |
                "D" % char |
                  "E" % char |
                    "F" % char |
                      "G" % char |
                        "H" % char |
                          "I" % char |
                            "J" % char |
                              "K" % char |
                                "L" % char |
                                  "M" % char |
                                    "N" % char |
                                      "O" % char |
                                        "P" % char |
                                          "Q" % char |
                                            "R" % char |
                                              "S" % char |
                                                "T" % char |
                                                  "U" % char |
                                                    "V" % char |
                                                      "W" % char |
                                                        "X" % char |
                                                          "Y" % char |
                                                            "Z" % char =>
        missing_break tt
      | _ =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok stop) acc)
      end
    | (End, stop) as other =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := back other in
      skip (cons (tok stop) acc)
    end
  with bytes (acc : list token) (start : point) : list token :=
    let tok (stop : point) : token :=
      let value :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (Bytes value) in
    match next tt with
    | (Uchar c, stop) as charloc =>
      let missing_break (function_parameter : unit) : list token :=
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq errors
            (cons
              (Tezos_error_monad.Error_monad.Missing_break_after_number stop)
              (Stdlib.op_exclamation errors)) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok stop) acc) in
      match Uchar.to_char c with
      |
        "0" % char |
          "1" % char |
            "2" % char |
              "3" % char |
                "4" % char |
                  "5" % char | "6" % char | "7" % char | "8" % char | "9" % char
          |
          "a" % char |
            "b" % char | "c" % char | "d" % char | "e" % char | "f" % char |
          "A" % char |
            "B" % char | "C" % char | "D" % char | "E" % char | "F" % char =>
        string acc start
      |
        "g" % char |
          "h" % char |
            "i" % char |
              "j" % char |
                "k" % char |
                  "l" % char |
                    "m" % char |
                      "n" % char |
                        "o" % char |
                          "p" % char |
                            "q" % char |
                              "r" % char |
                                "s" % char |
                                  "t" % char |
                                    "u" % char |
                                      "v" % char |
                                        "w" % char |
                                          "x" % char | "y" % char | "z" % char |
          "G" % char |
            "H" % char |
              "I" % char |
                "J" % char |
                  "K" % char |
                    "L" % char |
                      "M" % char |
                        "N" % char |
                          "O" % char |
                            "P" % char |
                              "Q" % char |
                                "R" % char |
                                  "S" % char |
                                    "T" % char |
                                      "U" % char |
                                        "V" % char |
                                          "W" % char |
                                            "X" % char | "Y" % char | "Z" % char
        => missing_break tt
      | _ =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok stop) acc)
      end
    | (End, stop) as other =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := back other in
      skip (cons (tok stop) acc)
    end
  with string (acc : list token) (sacc : list string) (start : point)
    : list token :=
    let tok (function_parameter : unit) : token :=
      let 'tt := function_parameter in
      tok start (here tt)
        (String (Stdlib.String.concat "" % string (List.rev sacc))) in
    match next tt with
    | (End, stop) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq errors
          (cons
            (Tezos_error_monad.Error_monad.Unterminated_string
              {| start := start; stop := stop |}) (Stdlib.op_exclamation errors))
        in
      skip (cons (tok tt) acc)
    | (Uchar c, stop) =>
      match uchar_to_char c with
      | Some """" % char => skip (cons (tok tt) acc)
      | Some ("010" % char | "013" % char) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq errors
            (cons
              (Tezos_error_monad.Error_monad.Unterminated_string
                {| start := start; stop := stop |})
              (Stdlib.op_exclamation errors)) in
        skip (cons (tok tt) acc)
      | Some "\" % char =>
        match next tt with
        | (End, stop) =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.op_coloneq errors
              (cons
                (Tezos_error_monad.Error_monad.Unterminated_string
                  {| start := start; stop := stop |})
                (Stdlib.op_exclamation errors)) in
          skip (cons (tok tt) acc)
        | (Uchar c, loc) =>
          match uchar_to_char c with
          | Some """" % char => string acc (cons """" % string sacc) start
          | Some "r" % char => string acc (cons "
" % string sacc) start
          | Some "n" % char => string acc (cons "
" % string sacc) start
          | Some "t" % char => string acc (cons "	" % string sacc) start
          | Some "b" % char => string acc (cons "" % string sacc) start
          | Some "\" % char => string acc (cons "\" % string sacc) start
          | Some _ | None =>
            let byte := Uutf.decoder_byte_count decoder in
            let s := Stdlib.String.sub source (byte loc) (Z.sub byte (byte loc))
              in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Stdlib.op_coloneq errors
                (cons
                  (Tezos_error_monad.Error_monad.Undefined_escape_sequence loc s)
                  (Stdlib.op_exclamation errors)) in
            string acc sacc start
          end
        end
      | Some _ | None =>
        let byte := Uutf.decoder_byte_count decoder in
        let s := Stdlib.String.sub source (byte stop) (Z.sub byte (byte stop))
          in
        string acc (cons s sacc) start
      end
    end
  with generic_ident
    (allow_char : Stdlib.Uchar.t -> bool) (acc : list token) (start : point)
    (ret : string -> point -> token_value) : list token :=
    let tok (stop : point) : token :=
      let name :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (ret name stop) in
    match next tt with
    | (Uchar c, stop) as charloc =>
      if allow_char c then
        generic_ident allow_char acc start ret
      else
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := back charloc in
        skip (cons (tok stop) acc)
    | (_, stop) as other =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := back other in
      skip (cons (tok stop) acc)
    end
  with ident
    (acc : list token) (start : point) (ret : string -> point -> token_value)
    : list token :=
    generic_ident allowed_ident_char acc start ret
  with annot
    (acc : list token) (start : point) (ret : string -> point -> token_value)
    : list token :=
    generic_ident allowed_annot_char acc start ret
  with comment (acc : list token) (start : point) (lvl : Z) : list token :=
    match next tt with
    | (End, stop) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.op_coloneq errors
          (cons
            (Tezos_error_monad.Error_monad.Unterminated_comment
              {| start := start; stop := stop |}) (Stdlib.op_exclamation errors))
        in
      let text :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      skip (cons (tok start stop (Comment text)) acc)
    | (Uchar c, _) =>
      match uchar_to_char c with
      | Some "*" % char =>
        match next tt with
        | (Uchar c, _) =>
          if equiv_decb lvl 0 then
            let stop := here tt in
            let text :=
              Stdlib.String.sub source (byte start)
                (Z.sub (byte stop) (byte start)) in
            skip (cons (tok start stop (Comment text)) acc)
          else
            comment acc start (Z.sub lvl 1)
        | other =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := back other in
          comment acc start lvl
        end
      | Some "/" % char =>
        match next tt with
        | (Uchar c, _) => comment acc start (Z.add lvl 1)
        | other =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := back other in
          comment acc start lvl
        end
      | Some _ | None => comment acc start lvl
      end
    end
  with eol_comment (acc : list token) (start : point) : list token :=
    let tok (stop : point) : token :=
      let text :=
        Stdlib.String.sub source (byte start) (Z.sub (byte stop) (byte start))
        in
      tok start stop (Eol_comment text) in
    match next tt with
    | (Uchar c, stop) =>
      match uchar_to_char c with
      | Some "010" % char => skip (cons (tok stop) acc)
      | Some _ | None => eol_comment acc start
      end
    | (_, stop) as other =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := back other in
      skip (cons (tok stop) acc)
    end in
  let tokens := skip [] in
  (tokens, (List.rev (Stdlib.op_exclamation errors))).

Definition node := Tezos_micheline.Micheline.node location string.

Definition node_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_micheline.Micheline.node location string) :=
  Micheline.table_encoding "generic" % string location_encoding
    Data_encoding.string.

Definition min_point (function_parameter : list node) : point :=
  match function_parameter with
  | [] => point_zero
  |
    cons (Tezos_micheline.Micheline.Int {| start := start |} _) _ |
      cons (Tezos_micheline.Micheline.String {| start := start |} _) _ |
      cons (Tezos_micheline.Micheline.Bytes {| start := start |} _) _ |
      cons (Tezos_micheline.Micheline.Prim {| start := start |} _ _ _) _ |
      cons (Tezos_micheline.Micheline.Seq {| start := start |} _) _ => start
  end.

Fixpoint max_point (function_parameter : list node) : point :=
  match function_parameter with
  | [] => point_zero
  | cons _ ((cons _ _) as rest) => max_point rest
  |
    cons (Tezos_micheline.Micheline.Int {| stop := stop |} _) [] |
      cons (Tezos_micheline.Micheline.String {| stop := stop |} _) [] |
      cons (Tezos_micheline.Micheline.Bytes {| stop := stop |} _) [] |
      cons (Tezos_micheline.Micheline.Prim {| stop := stop |} _ _ _) [] |
      cons (Tezos_micheline.Micheline.Seq {| stop := stop |} _) [] => stop
  end.

Inductive mode : Type :=
| Toplevel : (list node) -> mode
| Expression : (option node) -> mode
| Sequence : token -> (list node) -> mode
| Unwrapped : location -> string -> (list node) -> (list string) -> mode
| Wrapped : token -> string -> (list node) -> (list string) -> mode.

Definition push_mode {A : Type} (mode : A) (stack : list A) : list A :=
  cons mode stack.

Definition pop_mode {A : Type} (function_parameter : list A) : list A :=
  match function_parameter with
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons _ rest => rest
  end.

Definition fill_mode (result : node) (function_parameter : list mode)
  : list mode :=
  match function_parameter with
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Expression _) (cons _ _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Expression (Some _)) [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Toplevel _) (cons _ _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Expression None) [] => cons (Expression (Some result)) []
  | cons (Toplevel exprs) [] => cons (Toplevel (cons result exprs)) []
  | cons (Sequence token exprs) rest =>
    cons (Sequence token (cons result exprs)) rest
  | cons (Wrapped token name exprs annot) rest =>
    cons (Wrapped token name (cons result exprs) annot) rest
  | cons (Unwrapped start name exprs annot) rest =>
    cons (Unwrapped start name (cons result exprs) annot) rest
  end.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Fixpoint annots (function_parameter : list token)
  : (list string) * (list token) :=
  match function_parameter with
  | cons {| token := Annot annot |} rest =>
    let '(annots, rest) := annots rest in
    ((cons annot annots), rest)
  | rest => ([], rest)
  end.

Fixpoint parse (op_staroptstar : option bool)
  : (list Tezos_error_monad.Error_monad.error) ->
    (list token) ->
      (list mode) -> (list node) * (list Tezos_error_monad.Error_monad.error) :=
  let check :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun errors =>
    fun tokens =>
      fun stack =>
        match (stack, tokens) with
        |
          ([], _) | (cons (Wrapped _ _ _ _) [], _) |
            (cons (Unwrapped _ _ _ _) [], _) |
            (cons (Unwrapped _ _ _ _) (cons (Unwrapped _ _ _ _) _), _) |
            (cons (Unwrapped _ _ _ _) (cons (Wrapped _ _ _ _) _), _) |
            (cons (Toplevel _) (cons _ _), _) |
            (cons (Expression _) (cons _ _), _) =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | (cons (Expression (Some result)) _, []) =>
          ((cons result []), (List.rev errors))
        | (cons (Expression (Some _)) _, cons token rem) =>
          let errors :=
            cons (Tezos_error_monad.Error_monad.Unexpected token) errors in
          parse (Some check) errors rem stack
        | (cons (Expression None) _, []) =>
          let errors := cons Tezos_error_monad.Error_monad.Empty errors in
          let ghost := {| start := point_zero; stop := point_zero |} in
          ((cons (Tezos_micheline.Micheline.Seq ghost []) []), (List.rev errors))
        |
          (cons
            (Toplevel
              (cons ((Tezos_micheline.Micheline.Seq _ exprs) as expr) [])) [],
            []) =>
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          (exprs, (List.rev errors))
        | (cons (Toplevel exprs) [], []) =>
          let exprs := List.rev exprs in
          let loc := {| start := min_point exprs; stop := max_point exprs |} in
          let expr := Tezos_micheline.Micheline.Seq loc exprs in
          let errors :=
            if check then
              do_check (Some true) errors expr
            else
              errors in
          (exprs, (List.rev errors))
        | (_, cons {| token := Eol_comment _ | Comment _ |} rest) =>
          parse (Some check) errors rest stack
        |
          (cons (Expression None | Sequence _ _ | Toplevel _) _,
            cons ({| token := Int _ | String _ | Bytes _ |} as token)
              (cons {| token := Eol_comment _ | Comment _ |} rest)) |
            (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
              cons ({| token := Open_paren |} as token)
                (cons {| token := Eol_comment _ | Comment _ |} rest)) =>
          parse (Some check) errors (cons token rest) stack
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons ({| token := Open_paren |} as token)
              (cons {| token := Open_paren | Open_brace |} rem)) |
            (cons (Unwrapped _ _ _ _) (cons (Expression _) _),
              cons ({| token := Semi | Close_brace | Close_paren |} as token)
                rem) |
            (cons (Expression None) _,
              cons
                ({| token := Semi | Close_brace | Close_paren | Open_paren |} as
                  token) rem) =>
          let errors :=
            cons (Tezos_error_monad.Error_monad.Unexpected token) errors in
          parse (Some check) errors rem stack
        |
          (cons (Sequence _ _ | Toplevel _) _,
            cons ({| token := Semi |} as valid)
              (cons ({| token := Semi |} as token) rem)) =>
          let errors := cons (Tezos_error_monad.Error_monad.Extra token) errors
            in
          parse (Some check) errors (cons valid rem) stack
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons {| token := Open_paren |}
              (cons
                ({|
                  token := Int _ | String _ | Bytes _ | Annot _ | Close_paren
                    |} as token) rem)) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := Int _ | String _ | Bytes _ |}
                (cons
                  ({|
                    token :=
                      Ident _ | Int _ | String _ | Bytes _ | Annot _ |
                        Close_paren | Open_paren | Open_brace
                      |} as token) rem)) |
            (cons (Unwrapped _ _ _ _) (cons (Toplevel _) _),
              cons ({| token := Close_brace |} as token) rem) |
            (cons (Unwrapped _ _ _ _) _,
              cons ({| token := Close_paren |} as token) rem) |
            (cons (Toplevel _) [],
              cons ({| token := Close_paren |} as token) rem) |
            (cons (Toplevel _) [], cons ({| token := Open_paren |} as token) rem)
            |
            (cons (Toplevel _) [],
              cons ({| token := Close_brace |} as token) rem) |
            (cons (Sequence _ _) _,
              cons ({| token := Open_paren |} as token) rem) |
            (cons (Sequence _ _) _,
              cons ({| token := Close_paren |} as token) rem) |
            (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
              cons ({| token := Open_paren |} as token)
                ((cons {| token := Close_brace | Semi |} _ | []) as rem)) |
            (_, cons ({| token := Annot _ |} as token) rem) =>
          let errors :=
            cons (Tezos_error_monad.Error_monad.Unexpected token) errors in
          parse (Some check) errors rem stack
        |
          (cons (Wrapped token _ _ _) _,
            [] | cons {| token := Close_brace | Semi |} _) =>
          let errors :=
            cons (Tezos_error_monad.Error_monad.Unclosed token) errors in
          let fake :=
            (* ❌ Record substitution not handled *)
            record_substitution in
          let tokens := cons fake tokens in
          parse (Some check) errors tokens stack
        |
          (cons (Sequence token _) _ |
            cons (Unwrapped _ _ _ _) (cons (Sequence token _) _), []) =>
          let errors :=
            cons (Tezos_error_monad.Error_monad.Unclosed token) errors in
          let fake :=
            (* ❌ Record substitution not handled *)
            record_substitution in
          let tokens := cons fake tokens in
          parse (Some check) errors tokens stack
        |
          (cons (Toplevel _ | Sequence _ _) _,
            cons {| token := Ident name; loc := loc |}
              ((cons {| token := Annot _ |} _) as rest)) =>
          let '(annots, rest) := annots rest in
          let mode := Unwrapped loc name [] annots in
          parse (Some check) errors rest (push_mode mode stack)
        |
          (cons (Expression None | Toplevel _ | Sequence _ _) _,
            cons {| token := Ident name; loc := loc |} rest) =>
          let mode := Unwrapped loc name [] [] in
          parse (Some check) errors rest (push_mode mode stack)
        |
          (cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
            cons {| token := Int value; loc := loc |} rest) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := Int value; loc := loc |}
                (([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
          let expr := Tezos_micheline.Micheline.Int loc (Z.of_string value) in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
            cons {| token := String contents; loc := loc |} rest) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := String contents; loc := loc |}
                (([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
          let expr := Tezos_micheline.Micheline.String loc contents in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons (Unwrapped _ _ _ _ | Wrapped _ _ _ _) _,
            cons {| token := Bytes contents; loc := loc |} rest) |
            (cons (Expression None | Sequence _ _ | Toplevel _) _,
              cons {| token := Bytes contents; loc := loc |}
                (([] | cons {| token := Semi | Close_brace |} _) as rest)) =>
          let '(errors, contents) :=
            if nequiv_decb (Z.modulo (OCaml.String.length contents) 2) 0 then
              ((cons (Tezos_error_monad.Error_monad.Odd_lengthed_bytes loc)
                errors), (String.append contents "0" % string))
            else
              (errors, contents) in
          let bytes :=
            Hex.to_bytes
              (* ❌ Variants not supported *)
              variant in
          let expr := Tezos_micheline.Micheline.Bytes loc string in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons (Sequence {| loc := {| start := start |} |} exprs) _,
            cons {| token := Close_brace; loc := {| stop := stop |} |} rest) =>
          let exprs := List.rev exprs in
          let expr :=
            Tezos_micheline.Micheline.Seq {| start := start; stop := stop |}
              exprs in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr (pop_mode stack))
        | (cons (Sequence _ _ | Toplevel _) _, cons {| token := Semi |} rest) =>
          parse (Some check) errors rest stack
        |
          (cons (Unwrapped {| start := start; stop := stop |} name exprs annot)
            (cons (Expression _) _), [] as rest) |
            (cons
              (Unwrapped {| start := start; stop := stop |} name exprs annot)
              (cons (Toplevel _) _), (cons {| token := Semi |} _ | []) as rest)
            |
            (cons
              (Unwrapped {| start := start; stop := stop |} name exprs annot)
              (cons (Sequence _ _) _),
              (cons {| token := Close_brace | Semi |} _) as rest) |
            (cons
              (Wrapped {| loc := {| start := start; stop := stop |} |} name
                exprs annot) _, cons {| token := Close_paren |} rest) =>
          let exprs := List.rev exprs in
          let stop :=
            if equiv_decb exprs [] then
              stop
            else
              max_point exprs in
          let expr :=
            Tezos_micheline.Micheline.Prim {| start := start; stop := stop |}
              name exprs annot in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr (pop_mode stack))
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons ({| token := Open_paren |} as token)
              (cons {| token := Ident name |}
                ((cons {| token := Annot _ |} _) as rest))) =>
          let '(annots, rest) := annots rest in
          let mode := Wrapped token name [] annots in
          parse (Some check) errors rest (push_mode mode stack)
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons ({| token := Open_paren |} as token)
              (cons {| token := Ident name |} rest)) =>
          let mode := Wrapped token name [] [] in
          parse (Some check) errors rest (push_mode mode stack)
        |
          (cons (Wrapped _ _ _ _ | Unwrapped _ _ _ _) _,
            cons {| token := Ident name; loc := loc |} rest) =>
          let expr := Tezos_micheline.Micheline.Prim loc name [] [] in
          let errors :=
            if check then
              do_check (Some false) errors expr
            else
              errors in
          parse (Some check) errors rest (fill_mode expr stack)
        |
          (cons
            (Wrapped _ _ _ _ | Unwrapped _ _ _ _ | Toplevel _ | Sequence _ _ |
              Expression None) _, cons ({| token := Open_brace |} as token) rest)
          =>
          let mode := Sequence token [] in
          parse (Some check) errors rest (push_mode mode stack)
        end

with do_check (op_staroptstar : option bool)
  : (list Tezos_error_monad.Error_monad.error) ->
    (Tezos_micheline.Micheline.node location string) ->
      list Tezos_error_monad.Error_monad.error :=
  let toplevel :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun errors =>
    fun function_parameter =>
      match function_parameter with
      |
        (Tezos_micheline.Micheline.Seq {| start := start; stop := stop |} []) as
          expr =>
        if OCaml.Stdlib.ge (column start) (column stop) then
          cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
        else
          errors
      |
        (Tezos_micheline.Micheline.Prim {| start := start; stop := stop |} _
          (cons first rest) _ |
          Tezos_micheline.Micheline.Seq {| start := start; stop := stop |}
            (cons first rest)) as expr =>
        let '{| line := first_line; column := first_column |} :=
          min_point (cons first []) in
        if OCaml.Stdlib.ge (column start) (column stop) then
          cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
        else
          if andb (negb toplevel) (OCaml.Stdlib.ge (column start) first_column)
            then
            cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
          else
            let fix in_line_or_aligned
              (prev_start_line : Z) (errors :
              list Tezos_error_monad.Error_monad.error) (function_parameter :
              list node) : list Tezos_error_monad.Error_monad.error :=
              match function_parameter with
              | [] => errors
              | cons expr rest =>
                let '{| line := start_line; column := column |} :=
                  min_point (cons expr []) in
                let '{| line := stop_line |} := max_point (cons expr []) in
                let errors :=
                  if
                    andb (nequiv_decb stop_line prev_start_line)
                      (nequiv_decb column first_column) then
                    cons (Tezos_error_monad.Error_monad.Misaligned expr) errors
                  else
                    errors in
                in_line_or_aligned start_line errors rest
              end in
            in_line_or_aligned first_line errors rest
      |
        Tezos_micheline.Micheline.Prim _ _ [] _ |
          Tezos_micheline.Micheline.String _ _ |
          Tezos_micheline.Micheline.Int _ _ |
          Tezos_micheline.Micheline.Bytes _ _ => errors
      end.

Definition parse_expression (check : option bool) (tokens : list token)
  : node * (list Tezos_error_monad.Error_monad.error) :=
  let result :=
    match tokens with
    |
      cons ({| token := Open_paren |} as token)
        (cons {| token := Ident name |} (cons {| token := Annot annot |} rest))
      =>
      let '(annots, rest) := annots rest in
      let mode := Wrapped token name [] (cons annot annots) in
      parse check [] rest (cons mode (cons (Expression None) []))
    |
      cons ({| token := Open_paren |} as token)
        (cons {| token := Ident name |} rest) =>
      let mode := Wrapped token name [] [] in
      parse check [] rest (cons mode (cons (Expression None) []))
    | _ => parse check [] tokens (cons (Expression None) [])
    end in
  match result with
  | (cons single [], errors) => (single, errors)
  | _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition parse_toplevel (check : option bool) (tokens : list token)
  : (list node) * (list Tezos_error_monad.Error_monad.error) :=
  parse check [] tokens (cons (Toplevel []) []).

Definition print_point
  (ppf : Stdlib.Format.formatter) (function_parameter : point) : unit :=
  let '{| line := line; column := column |} := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "At line " % string
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.String_literal " character " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))))
      "At line %d character %d" % string) line column.

Definition print_token_kind
  (ppf : Stdlib.Format.formatter) (function_parameter : token_value) : unit :=
  match function_parameter with
  | Open_paren | Close_paren =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "parenthesis" % string
          CamlinternalFormatBasics.End_of_format) "parenthesis" % string)
  | Open_brace | Close_brace =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "curly brace" % string
          CamlinternalFormatBasics.End_of_format) "curly brace" % string)
  | String _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "string constant" % string
          CamlinternalFormatBasics.End_of_format) "string constant" % string)
  | Bytes _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "bytes constant" % string
          CamlinternalFormatBasics.End_of_format) "bytes constant" % string)
  | Int _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "integer constant" % string
          CamlinternalFormatBasics.End_of_format) "integer constant" % string)
  | Ident _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "identifier" % string
          CamlinternalFormatBasics.End_of_format) "identifier" % string)
  | Annot _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "annotation" % string
          CamlinternalFormatBasics.End_of_format) "annotation" % string)
  | Comment _ | Eol_comment _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "comment" % string
          CamlinternalFormatBasics.End_of_format) "comment" % string)
  | Semi =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "semi colon" % string
          CamlinternalFormatBasics.End_of_format) "semi colon" % string)
  end.

Definition print_location (ppf : Stdlib.Format.formatter) (loc : location)
  : unit :=
  if equiv_decb (line (start loc)) (line (stop loc)) then
    if equiv_decb (column (start loc)) (column (stop loc)) then
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "At line " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " character " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))
          "At line %d character %d" % string) (line (start loc))
        (column (start loc))
    else
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "At line " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " characters " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal " to " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format))))))
          "At line %d characters %d to %d" % string) (line (start loc))
        (column (start loc)) (column (stop loc))
  else
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "From line " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " character " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " to line " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      " character " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        CamlinternalFormatBasics.End_of_format))))))))
        "From line %d character %d to line %d character %d" % string)
      (line (start loc)) (column (start loc)) (line (stop loc))
      (column (stop loc)).

Definition no_parsing_error {A : Type}
  (function_parameter : A * Tezos_error_monad.Error_monad.trace)
  : Tezos_error_monad.Error_monad.tzresult A :=
  let '(ast, errors) := function_parameter in
  match errors with
  | [] => ok ast
  | errors => Stdlib.Error errors
  end.



src/lib_micheline/micheline_printer.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Micheline

type location = {comment : string option}

type node = (location, string) Micheline.node

let printable ?(comment = fun _ -> None) map_prim expr =
  let map_loc loc = {comment = comment loc} in
  map_node map_loc map_prim (root expr)

let print_comment ppf text =
  Format.fprintf ppf "/* @[<h>%a@] */" Format.pp_print_text text

let print_string ppf text =
  Format.fprintf ppf "\"" ;
  String.iter
    (function
      | '"' ->
          Format.fprintf ppf "\\\""
      | '\n' ->
          Format.fprintf ppf "\\n"
      | '\r' ->
          Format.fprintf ppf "\\r"
      | '\b' ->
          Format.fprintf ppf "\\b"
      | '\t' ->
          Format.fprintf ppf "\\t"
      | '\\' ->
          Format.fprintf ppf "\\\\"
      | c ->
          Format.fprintf ppf "%c" c)
    text ;
  Format.fprintf ppf "\""

let print_annotations =
  Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string

let preformat root =
  let preformat_loc = function
    | {comment = None} ->
        (false, 0)
    | {comment = Some text} ->
        (String.contains text '\n', String.length text + 1)
  in
  let preformat_annots = function
    | [] ->
        0
    | annots ->
        String.length (String.concat " " annots) + 2
  in
  let rec preformat_expr = function
    | Int (loc, value) ->
        let (cml, csz) = preformat_loc loc in
        Int ((cml, String.length (Z.to_string value) + csz, loc), value)
    | String (loc, value) ->
        let (cml, csz) = preformat_loc loc in
        String ((cml, String.length value + csz, loc), value)
    | Bytes (loc, value) ->
        let (cml, csz) = preformat_loc loc in
        Bytes ((cml, (Bytes.length value * 2) + 2 + csz, loc), value)
    | Prim (loc, name, items, annots) ->
        let (cml, csz) = preformat_loc loc in
        let asz = preformat_annots annots in
        let items = List.map preformat_expr items in
        let (ml, sz) =
          List.fold_left
            (fun (tml, tsz) e ->
              let (ml, sz, _) = location e in
              (tml || ml, tsz + 1 + sz))
            (cml, String.length name + csz + asz)
            items
        in
        Prim ((ml, sz, loc), name, items, annots)
    | Seq (loc, items) ->
        let (cml, csz) = preformat_loc loc in
        let items = List.map preformat_expr items in
        let (ml, sz) =
          List.fold_left
            (fun (tml, tsz) e ->
              let (ml, sz, _) = location e in
              (tml || ml, tsz + 3 + sz))
            (cml, 4 + csz)
            items
        in
        Seq ((ml, sz, loc), items)
  in
  preformat_expr root

let rec print_expr_unwrapped ppf = function
  | Prim ((ml, s, {comment}), name, args, annot) ->
      let name =
        match annot with
        | [] ->
            name
        | annots ->
            Format.asprintf "%s @[<h>%a@]" name print_annotations annots
      in
      if (not ml) && s < 80 then (
        if args = [] then Format.fprintf ppf "%s" name
        else
          Format.fprintf
            ppf
            "@[<h>%s %a@]"
            name
            (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
            args ;
        match comment with
        | None ->
            ()
        | Some text ->
            Format.fprintf ppf "@ /* %s */" text )
      else (
        if args = [] then Format.fprintf ppf "%s" name
        else if String.length name <= 4 then
          Format.fprintf
            ppf
            "%s @[<v 0>%a@]"
            name
            (Format.pp_print_list print_expr)
            args
        else
          Format.fprintf
            ppf
            "@[<v 2>%s@,%a@]"
            name
            (Format.pp_print_list print_expr)
            args ;
        match comment with
        | None ->
            ()
        | Some comment ->
            Format.fprintf ppf "@ %a" print_comment comment )
  | Int ((_, _, {comment}), value) -> (
    match comment with
    | None ->
        Format.fprintf ppf "%s" (Z.to_string value)
    | Some comment ->
        Format.fprintf ppf "%s@ %a" (Z.to_string value) print_comment comment )
  | String ((_, _, {comment}), value) -> (
    match comment with
    | None ->
        print_string ppf value
    | Some comment ->
        Format.fprintf ppf "%a@ %a" print_string value print_comment comment )
  | Bytes ((_, _, {comment}), value) -> (
    match comment with
    | None ->
        Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
    | Some comment ->
        Format.fprintf
          ppf
          "0x%a@ %a"
          Hex.pp
          (Hex.of_bytes value)
          print_comment
          comment )
  | Seq ((_, _, {comment = None}), []) ->
      Format.fprintf ppf "{}"
  | Seq ((ml, s, {comment}), items) ->
      if (not ml) && s < 80 then Format.fprintf ppf "{ @[<h 0>"
      else Format.fprintf ppf "{ @[<v 0>" ;
      ( match (comment, items) with
      | (None, _) ->
          ()
      | (Some comment, []) ->
          Format.fprintf ppf "%a" print_comment comment
      | (Some comment, _) ->
          Format.fprintf ppf "%a@ " print_comment comment ) ;
      Format.pp_print_list
        ~pp_sep:(fun ppf () -> Format.fprintf ppf " ;@ ")
        print_expr_unwrapped
        ppf
        items ;
      Format.fprintf ppf "@] }"

and print_expr ppf = function
  | (Prim (_, _, _ :: _, _) | Prim (_, _, [], _ :: _)) as expr ->
      Format.fprintf ppf "(%a)" print_expr_unwrapped expr
  | expr ->
      print_expr_unwrapped ppf expr

let with_unbounded_formatter ppf f x =
  let buf = Buffer.create 10000 in
  let sppf = Format.formatter_of_buffer buf in
  Format.pp_set_margin sppf 199999 ;
  Format.pp_set_max_indent sppf 99999 ;
  Format.pp_set_max_boxes sppf 99999 ;
  f sppf x ;
  Format.fprintf sppf "%!" ;
  let lines = String.split_on_char '\n' (Buffer.contents buf) in
  Format.pp_print_list
    ~pp_sep:Format.pp_force_newline
    Format.pp_print_string
    ppf
    lines

let print_expr_unwrapped ppf expr =
  with_unbounded_formatter ppf print_expr_unwrapped (preformat expr)

let print_expr ppf expr =
  with_unbounded_formatter ppf print_expr (preformat expr)
src/lib_micheline/micheline_printer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Micheline.

Record location := {
  comment : option string }.

Definition node := Tezos_micheline.Micheline.node location string.

Definition printable {A B : Type}
  (op_staroptstar :
    option (Tezos_micheline.Micheline.canonical_location -> option string))
  : (A -> B) ->
    (Tezos_micheline.Micheline.canonical A) ->
      Tezos_micheline.Micheline.node location B :=
  let comment :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        None
    end in
  fun map_prim =>
    fun expr =>
      let map_loc (loc : Tezos_micheline.Micheline.canonical_location)
        : location :=
        {| comment := comment loc |} in
      map_node map_loc map_prim (root expr).

Definition print_comment (ppf : Stdlib.Format.formatter) (text : string)
  : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "/* " % string
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<h>" % string
                CamlinternalFormatBasics.End_of_format) "<h>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              (CamlinternalFormatBasics.String_literal " */" % string
                CamlinternalFormatBasics.End_of_format)))))
      "/* @[<h>%a@] */" % string) Format.pp_print_text text.

Definition print_string (ppf : Stdlib.Format.formatter) (text : string)
  : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal """" % char
          CamlinternalFormatBasics.End_of_format) """" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Stdlib.String.iter
      (fun function_parameter =>
        match function_parameter with
        | """" % char =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "\""" % string
                CamlinternalFormatBasics.End_of_format) "\""" % string)
        | "010" % char =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "\n" % string
                CamlinternalFormatBasics.End_of_format) "\n" % string)
        | "013" % char =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "\r" % string
                CamlinternalFormatBasics.End_of_format) "\r" % string)
        | "008" % char =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "\b" % string
                CamlinternalFormatBasics.End_of_format) "\b" % string)
        | "009" % char =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "\t" % string
                CamlinternalFormatBasics.End_of_format) "\t" % string)
        | "\" % char =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "\\" % string
                CamlinternalFormatBasics.End_of_format) "\\" % string)
        | c =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Char
                CamlinternalFormatBasics.End_of_format) "%c" % string) c
        end) text in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal """" % char
        CamlinternalFormatBasics.End_of_format) """" % string).

Definition print_annotations
  : Stdlib.Format.formatter -> (list string) -> unit :=
  Format.pp_print_list (Some Format.pp_print_space) Format.pp_print_string.

Definition preformat (root : Tezos_micheline.Micheline.node location string)
  : Tezos_micheline.Micheline.node (bool * Z * location) string :=
  let preformat_loc (function_parameter : location) : bool * Z :=
    match function_parameter with
    | {| comment := None |} => (false, 0)
    | {| comment := Some text |} =>
      ((Stdlib.String.contains text "010" % char),
        (Z.add (OCaml.String.length text) 1))
    end in
  let preformat_annots (function_parameter : list string) : Z :=
    match function_parameter with
    | [] => 0
    | annots =>
      Z.add (OCaml.String.length (Stdlib.String.concat " " % string annots)) 2
    end in
  let fix preformat_expr
    (function_parameter : Tezos_micheline.Micheline.node location string)
    : Tezos_micheline.Micheline.node (bool * Z * location) string :=
    match function_parameter with
    | Tezos_micheline.Micheline.Int loc value =>
      let '(cml, csz) := preformat_loc loc in
      Tezos_micheline.Micheline.Int
        (cml, (Z.add (OCaml.String.length (Z.to_string value)) csz), loc) value
    | Tezos_micheline.Micheline.String loc value =>
      let '(cml, csz) := preformat_loc loc in
      Tezos_micheline.Micheline.String
        (cml, (Z.add (OCaml.String.length value) csz), loc) value
    | Tezos_micheline.Micheline.Bytes loc value =>
      let '(cml, csz) := preformat_loc loc in
      Tezos_micheline.Micheline.Bytes
        (cml, (Z.add (Z.add (Z.mul (String.length value) 2) 2) csz), loc) value
    | Tezos_micheline.Micheline.Prim loc name items annots =>
      let '(cml, csz) := preformat_loc loc in
      let asz := preformat_annots annots in
      let items := List.map preformat_expr items in
      let '(ml, sz) :=
        Stdlib.List.fold_left
          (fun function_parameter =>
            let '(tml, tsz) := function_parameter in
            fun e =>
              let '(ml, sz, _) := location e in
              ((orb tml ml), (Z.add (Z.add tsz 1) sz)))
          (cml, (Z.add (Z.add (OCaml.String.length name) csz) asz)) items in
      Tezos_micheline.Micheline.Prim (ml, sz, loc) name items annots
    | Tezos_micheline.Micheline.Seq loc items =>
      let '(cml, csz) := preformat_loc loc in
      let items := List.map preformat_expr items in
      let '(ml, sz) :=
        Stdlib.List.fold_left
          (fun function_parameter =>
            let '(tml, tsz) := function_parameter in
            fun e =>
              let '(ml, sz, _) := location e in
              ((orb tml ml), (Z.add (Z.add tsz 3) sz))) (cml, (Z.add 4 csz))
          items in
      Tezos_micheline.Micheline.Seq (ml, sz, loc) items
    end in
  preformat_expr root.

Fixpoint print_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_micheline.Micheline.node (bool * Z * location) string) : unit :=
  match function_parameter with
  |
    Tezos_micheline.Micheline.Prim (ml, s, {| comment := comment |}) name args
      annot =>
    let name :=
      match annot with
      | [] => name
      | annots =>
        Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal " " % char
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<h>" % string
                        CamlinternalFormatBasics.End_of_format) "<h>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "%s @[<h>%a@]" % string) name print_annotations annots
      end in
    if andb (negb ml) (OCaml.Stdlib.lt s 80) then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if equiv_decb args [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) name
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<h>" % string
                      CamlinternalFormatBasics.End_of_format) "<h>" % string))
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "@[<h>%s %a@]" % string) name
            (Format.pp_print_list (Some Format.pp_print_space) print_expr) args
        in
      match comment with
      | None => tt
      | Some text =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal "/* " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " */" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@ /* %s */" % string) text
      end
    else
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if equiv_decb args [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) name
        else
          if OCaml.Stdlib.le (OCaml.String.length name) 4 then
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "%s @[<v 0>%a@]" % string) name
              (Format.pp_print_list None print_expr) args
          else
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "@[<v 2>%s@,%a@]" % string) name
              (Format.pp_print_list None print_expr) args in
      match comment with
      | None => tt
      | Some comment =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "@ %a" % string)
          print_comment comment
      end
  | Tezos_micheline.Micheline.Int (_, _, {| comment := comment |}) value =>
    match comment with
    | None =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string)
        (Z.to_string value)
    | Some comment =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%s@ %a" % string)
        (Z.to_string value) print_comment comment
    end
  | Tezos_micheline.Micheline.String (_, _, {| comment := comment |}) value =>
    match comment with
    | None => print_string ppf value
    | Some comment =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))) "%a@ %a" % string)
        print_string value print_comment comment
    end
  | Tezos_micheline.Micheline.Bytes (_, _, {| comment := comment |}) value =>
    match comment with
    | None =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "0x" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "0x%a" % string) Hex.pp
        (Hex.of_bytes None value)
    | Some comment =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "0x" % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))) "0x%a@ %a" % string)
        Hex.pp (Hex.of_bytes None value) print_comment comment
    end
  | Tezos_micheline.Micheline.Seq (_, _, {| comment := None |}) [] =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "{}" % string
          CamlinternalFormatBasics.End_of_format) "{}" % string)
  | Tezos_micheline.Micheline.Seq (ml, s, {| comment := comment |}) items =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if andb (negb ml) (OCaml.Stdlib.lt s 80) then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "{ " % string
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<h 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<h 0>" % string))
                CamlinternalFormatBasics.End_of_format)) "{ @[<h 0>" % string)
      else
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "{ " % string
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                CamlinternalFormatBasics.End_of_format)) "{ @[<v 0>" % string)
      in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match (comment, items) with
      | (None, _) => tt
      | (Some comment, []) =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          print_comment comment
      | (Some comment, _) =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                CamlinternalFormatBasics.End_of_format)) "%a@ " % string)
          print_comment comment
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal " ;" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      CamlinternalFormatBasics.End_of_format)) " ;@ " % string)))
        print_expr_unwrapped ppf items in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          (CamlinternalFormatBasics.String_literal " }" % string
            CamlinternalFormatBasics.End_of_format)) "@] }" % string)
  end

with print_expr
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_micheline.Micheline.node (bool * Z * location) string) : unit :=
  match function_parameter with
  |
    (Tezos_micheline.Micheline.Prim _ _ (cons _ _) _ |
      Tezos_micheline.Micheline.Prim _ _ [] (cons _ _)) as expr =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format))) "(%a)" % string)
      print_expr_unwrapped expr
  | expr => print_expr_unwrapped ppf expr
  end.

Definition with_unbounded_formatter {A : Type}
  (ppf : Stdlib.Format.formatter) (f : Stdlib.Format.formatter -> A -> unit)
  (x : A) : unit :=
  let buf := Buffer.create 10000 in
  let sppf := Format.formatter_of_buffer buf in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Format.pp_set_margin sppf 199999 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Format.pp_set_max_indent sppf 99999 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Format.pp_set_max_boxes sppf 99999 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := f sppf x in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf sppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)
        "%!" % string) in
  let lines := Stdlib.String.split_on_char "010" % char (Buffer.contents buf) in
  Format.pp_print_list (Some Format.pp_force_newline) Format.pp_print_string ppf
    lines.

Definition print_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (expr : Tezos_micheline.Micheline.node location string) : unit :=
  with_unbounded_formatter ppf print_expr_unwrapped (preformat expr).

Definition print_expr
  (ppf : Stdlib.Format.formatter)
  (expr : Tezos_micheline.Micheline.node location string) : unit :=
  with_unbounded_formatter ppf print_expr (preformat expr).

src/lib_micheline/test/assert.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Mini compatibility layer to avoid circular dependency *)
module Compat = struct
  let failwith fmt = Format.kasprintf (fun s -> Lwt.return_error s) fmt

  let return_unit = Lwt.return_ok ()

  let ( >>= ) = Lwt.bind

  let ( >>=? ) v f =
    v >>= function Error _ as err -> Lwt.return err | Ok v -> f v

  let rec iter2_p f l1 l2 =
    match (l1, l2) with
    | ([], []) ->
        return_unit
    | ([], _) | (_, []) ->
        invalid_arg "Error_monad.iter2_p"
    | (x1 :: l1, x2 :: l2) -> (
        let tx = f x1 x2 and tl = iter2_p f l1 l2 in
        tx
        >>= fun tx_res ->
        tl
        >>= fun tl_res ->
        match (tx_res, tl_res) with
        | (Ok (), Ok ()) ->
            Lwt.return_ok ()
        | (Error exn1, Error exn2) ->
            failwith "%s -- %s" exn1 exn2
        | (Ok (), Error exn) | (Error exn, Ok ()) ->
            Lwt.return_error exn )
end

open Compat

let fail loc printer given expected msg =
  failwith
    "@[<v 2> On %s : %s@ @[Given:\t%a@]@ @[Expected:\t%a@]@]"
    loc
    msg
    printer
    given
    printer
    expected

let default_printer fmt _ = Format.fprintf fmt ""

let equal ~loc ?(eq = ( = )) ?(printer = default_printer) ?(msg = "") given
    expected =
  if not (eq given expected) then fail loc printer given expected msg
  else return_unit

let not_equal ~loc ?(eq = ( = )) ?(printer = default_printer) ?(msg = "") given
    expected =
  if eq given expected then fail loc printer given expected msg
  else return_unit

let pp_tokens fmt tokens =
  let token_value_printer fmt token_value =
    Format.fprintf
      fmt
      "@[%s@]"
      (let open Micheline_parser in
      match token_value with
      | String s ->
          Format.sprintf "String %S" s
      | Bytes s ->
          Format.sprintf "Bytes %S" s
      | Int s ->
          Format.sprintf "Int %S" s
      | Ident s ->
          Format.sprintf "Ident %S" s
      | Annot s ->
          Format.sprintf "Annot %S" s
      | Comment s ->
          Format.sprintf "Comment %S" s
      | Eol_comment s ->
          Format.sprintf "Eol_comment %S" s
      | Semi ->
          Format.sprintf "Semi"
      | Open_paren ->
          Format.sprintf "Open_paren"
      | Close_paren ->
          Format.sprintf "Close_paren"
      | Open_brace ->
          Format.sprintf "Open_brace"
      | Close_brace ->
          Format.sprintf "Close_brace")
  in
  Format.fprintf fmt "%a" (Format.pp_print_list token_value_printer) tokens

let equal_tokens ~loc given expected =
  equal
    ~loc
    ~eq:( = )
    ~printer:pp_tokens
    ~msg:"Tokens are not equal"
    given
    expected

let not_equal_tokens ~loc given expected =
  not_equal
    ~loc
    ~eq:( = )
    ~printer:pp_tokens
    ~msg:"Tokens are equal"
    given
    expected
src/lib_micheline/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Compat.
  Definition failwith {A B : Type}
    (fmt :
      Stdlib.format4 A Stdlib.Format.formatter unit
        (Lwt.t (Result.result B string))) : A :=
    Format.kasprintf (fun s => Lwt.return_error s) fmt.
  
  Definition return_unit {A : Type} : Lwt.t (Result.result unit A) :=
    Lwt.return_ok tt.
  
  Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
    Lwt.bind.
  
  Definition op_gtgteqquestion {A B C : Type}
    (v : Lwt.t (sum A B)) (f : A -> Lwt.t (sum C B)) : Lwt.t (sum C B) :=
    op_gtgteq v
      (fun function_parameter =>
        match function_parameter with
        | (Stdlib.Error _) as err => Lwt._return err
        | Stdlib.Ok v => f v
        end).
  
  Fixpoint iter2_p {A B : Type}
    (f : A -> B -> Lwt.t (sum unit string)) (l1 : list A) (l2 : list B)
    : Lwt.t (Result.result unit string) :=
    match (l1, l2) with
    | ([], []) => return_unit
    | ([], _) | (_, []) =>
      OCaml.Stdlib.invalid_arg "Error_monad.iter2_p" % string
    | (cons x1 l1, cons x2 l2) =>
      let tx : Lwt.t (sum unit string) :=
        f x1 x2
      with tl : Lwt.t (Result.result unit string) :=
        iter2_p f l1 l2 in
      op_gtgteq tx
        (fun tx_res =>
          op_gtgteq tl
            (fun tl_res =>
              match (tx_res, tl_res) with
              | (Stdlib.Ok tt, Stdlib.Ok tt) => Lwt.return_ok tt
              | (Stdlib.Error exn1, Stdlib.Error exn2) =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal " -- " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.End_of_format)))
                    "%s -- %s" % string) exn1 exn2
              |
                (Stdlib.Ok tt, Stdlib.Error exn) |
                  (Stdlib.Error exn, Stdlib.Ok tt) => Lwt.return_error exn
              end))
    end.
End Compat.

Import Compat.

Definition fail {A B : Type}
  (loc : string) (printer : Stdlib.Format.formatter -> A -> unit) (given : A)
  (expected : A) (msg : string) : Lwt.t (Result.result B string) :=
  failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 2>" % string
              CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
        (CamlinternalFormatBasics.String_literal " On " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal " : " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal "Given:	" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  CamlinternalFormatBasics.End_of_format
                                  "" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Expected:	" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format))))))))))))))))
      "@[<v 2> On %s : %s@ @[Given:	%a@]@ @[Expected:	%a@]@]" % string) loc msg
    printer given printer expected.

Definition default_printer {A : Type}
  (fmt : Stdlib.Format.formatter) (function_parameter : A) : unit :=
  let '_ := function_parameter in
  Format.fprintf fmt
    (CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
      "" % string).

Definition equal {A : Type}
  (loc : string) (op_staroptstar : option (A -> A -> bool))
  : (option (Stdlib.Format.formatter -> A -> unit)) ->
    (option string) -> A -> A -> Lwt.t (Result.result unit string) :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let printer :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun given =>
        fun expected =>
          if negb (eq given expected) then
            fail loc printer given expected msg
          else
            return_unit.

Definition not_equal {A : Type}
  (loc : string) (op_staroptstar : option (A -> A -> bool))
  : (option (Stdlib.Format.formatter -> A -> unit)) ->
    (option string) -> A -> A -> Lwt.t (Result.result unit string) :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let printer :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun given =>
        fun expected =>
          if eq given expected then
            fail loc printer given expected msg
          else
            return_unit.

Definition pp_tokens
  (fmt : Stdlib.Format.formatter)
  (tokens : list Tezos_micheline.Micheline_parser.token_value) : unit :=
  let token_value_printer
    (fmt : Stdlib.Format.formatter) (token_value :
    Tezos_micheline.Micheline_parser.token_value) : unit :=
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[%s@]" % string)
      match token_value with
      | Tezos_micheline.Micheline_parser.String s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "String " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "String %S" % string) s
      | Tezos_micheline.Micheline_parser.Bytes s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Bytes " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Bytes %S" % string) s
      | Tezos_micheline.Micheline_parser.Int s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Int " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Int %S" % string) s
      | Tezos_micheline.Micheline_parser.Ident s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Ident " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Ident %S" % string) s
      | Tezos_micheline.Micheline_parser.Annot s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Annot " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Annot %S" % string) s
      | Tezos_micheline.Micheline_parser.Comment s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Comment " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "Comment %S" % string)
          s
      | Tezos_micheline.Micheline_parser.Eol_comment s =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Eol_comment " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Eol_comment %S" % string) s
      | Tezos_micheline.Micheline_parser.Semi =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Semi" % string
              CamlinternalFormatBasics.End_of_format) "Semi" % string)
      | Tezos_micheline.Micheline_parser.Open_paren =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Open_paren" % string
              CamlinternalFormatBasics.End_of_format) "Open_paren" % string)
      | Tezos_micheline.Micheline_parser.Close_paren =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Close_paren" % string
              CamlinternalFormatBasics.End_of_format) "Close_paren" % string)
      | Tezos_micheline.Micheline_parser.Open_brace =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Open_brace" % string
              CamlinternalFormatBasics.End_of_format) "Open_brace" % string)
      | Tezos_micheline.Micheline_parser.Close_brace =>
        Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Close_brace" % string
              CamlinternalFormatBasics.End_of_format) "Close_brace" % string)
      end in
  Format.fprintf fmt
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
      "%a" % string) (Format.pp_print_list None token_value_printer) tokens.

Definition equal_tokens
  (loc : string) (given : list Tezos_micheline.Micheline_parser.token_value)
  (expected : list Tezos_micheline.Micheline_parser.token_value)
  : Lwt.t (Result.result unit string) :=
  equal loc (Some equiv_decb) (Some pp_tokens)
    (Some "Tokens are not equal" % string) given expected.

Definition not_equal_tokens
  (loc : string) (given : list Tezos_micheline.Micheline_parser.token_value)
  (expected : list Tezos_micheline.Micheline_parser.token_value)
  : Lwt.t (Result.result unit string) :=
  not_equal loc (Some equiv_decb) (Some pp_tokens)
    (Some "Tokens are equal" % string) given expected.

src/lib_micheline/test/test_parser.ml 343 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(****************************************************************************)
(* Token value   *)
(****************************************************************************)

open Assert.Compat

let assert_tokenize ~loc given expected =
  match Micheline_parser.tokenize given with
  | (tokens, []) ->
      let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in
      Assert.equal_tokens ~loc tokens_got expected
  | (_, _) ->
      failwith "%s - Cannot tokenize %s" loc given

let assert_tokenize_error ~loc given expected =
  match Micheline_parser.tokenize given with
  | (tokens, []) ->
      let tokens_got = List.map (fun x -> x.Micheline_parser.token) tokens in
      Assert.not_equal_tokens ~loc tokens_got expected
  | (_, _) ->
      return_unit

let test_tokenize_basic () =
  (* String *)
  assert_tokenize ~loc:__LOC__ "\"abc\"" [String "abc"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\t\"" [String "abc\t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\b\"" [String "abc\b"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\\n\"" [String "abc\n"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "\"abc\\r\"" [String "abc\r"]
  >>=? fun () ->
  (*fail*)
  assert_tokenize_error ~loc:__LOC__ "\"abc\n\"" [String "abc\n"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\\\"" [String "abc\\"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\"" [String "abc\n"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\r\"" [String "abc\r"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "abc\r" [String "abc\r"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc\"\r" [String "abc\r"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"abc" [String "abc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "abc\"" [String "abc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "\"\"\"" [String ""]
  >>=? fun () ->
  (* Bytes *)
  assert_tokenize ~loc:__LOC__ "0xabc" [Bytes "0xabc"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "0x" [Bytes "0x"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "0x1" [Bytes "0x1"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "xabc" [Bytes "xabc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1xabc" [Bytes "1xabc"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1c" [Bytes "1c"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0c" [Bytes "0c"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0xx" [Bytes "0xx"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0b" [Bytes "0b"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0xg" [Bytes "0xg"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0X" [Bytes "0X"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1x" [Bytes "1x"]
  >>=? fun () ->
  (* Int *)
  assert_tokenize ~loc:__LOC__ "10" [Int "10"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "0" [Int "0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "00" [Int "00"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "001" [Int "001"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "-0" [Int "0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "-1" [Int "-1"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "1" [Int "1"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "-10" [Int "-10"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ ".1000" [Int ".1000"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "10_00" [Int "10_00"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1,000" [Int "1,000"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "1000.000" [Int "1000.000"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "-0" [Int "-0"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "--0" [Int "0"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "+0" [Int "0"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "a" [Int "a"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "0a" [Int "0a"]
  >>=? fun () ->
  (* Ident *)
  assert_tokenize ~loc:__LOC__ "string" [Ident "string"]
  >>=? fun () ->
  (* Annotation *)
  assert_tokenize ~loc:__LOC__ "@my_pair" [Annot "@my_pair"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "@@my_pair" [Annot "@@my_pair"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "$t" [Annot "$t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "&t" [Annot "&t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":t" [Annot ":t"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":_" [Annot ":_"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":0" [Annot ":0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%" [Annot ":%"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%%" [Annot ":%%"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%@" [Annot ":%@"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%@_" [Annot ":%@_"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ":%@_0" [Annot ":%@_0"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%from" [Annot "%from"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%@from" [Annot "%@from"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%from_a" [Annot "%from_a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%from.a" [Annot "%from.a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%From.a" [Annot "%From.a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "%0From.a" [Annot "%0From.a"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "?t" [Annot "?t"]
  >>=? fun () ->
  (*fail*)
  assert_tokenize_error ~loc:__LOC__ "??t" [Annot "??t"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "&&t" [Annot "&&t"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "$$t" [Annot "$$t"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "_from" [Annot "_from"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ ".from" [Annot ".from"]
  >>=? fun () ->
  (*NOTE: the cases below fail because ':' is used in the middle of the
    annotation. *)
  assert_tokenize_error ~loc:__LOC__ "%:from" [Annot "%:from"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "%:@from" [Annot "%:@from"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "::t" [Annot "::t"]
  >>=? fun () ->
  (* Comment *)
  assert_tokenize ~loc:__LOC__ "/*\"/**/\"*/" [Comment "/*\"/**/\"*/"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "/* /* /* */ */ */" [Comment "/* /* /* */ */ */"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "/*parse 1" [Comment "/*parse 1"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "parse 1*/" [Comment "parse 1*/"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "/* */*/" [Comment "/* */*/"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "/*/* */" [Comment "/*/* */"]
  >>=? fun () ->
  (* EOL *)
  assert_tokenize ~loc:__LOC__ "#Access" [Eol_comment "#Access"]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "##Access" [Eol_comment "##Access"]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "?Access" [Eol_comment "?Access"]
  >>=? fun () ->
  (* SKIP *)
  assert_tokenize ~loc:__LOC__ ";" [Semi]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "{" [Open_brace]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "}" [Close_brace]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "(" [Open_paren]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ ")" [Close_paren]
  >>=? fun () ->
  (*fail*)
  assert_tokenize_error ~loc:__LOC__ "{" [Semi]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ ";" [Open_brace]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "}" [Open_brace]
  >>=? fun () ->
  assert_tokenize_error ~loc:__LOC__ "(" [Close_paren]
  >>=? fun () -> assert_tokenize_error ~loc:__LOC__ ")" [Open_paren]

(*********************)
(* One line contracts *)

let test_one_line_contract () =
  assert_tokenize
    ~loc:__LOC__
    "(option int)"
    [Open_paren; Ident "option"; Ident "int"; Close_paren]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "DIP {ADD}"
    [Ident "DIP"; Open_brace; Ident "ADD"; Close_brace]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "parameter int;"
    [Ident "parameter"; Ident "int"; Semi]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "PUSH string \"abc\";"
    [Ident "PUSH"; Ident "string"; String "abc"; Semi]
  >>=? fun () ->
  assert_tokenize ~loc:__LOC__ "DROP; SWAP" [Ident "DROP"; Semi; Ident "SWAP"]
  >>=? fun () ->
  (* NOTE: the cases below do not fail because we only do tokenization. *)
  assert_tokenize ~loc:__LOC__ "DIP {ADD" [Ident "DIP"; Open_brace; Ident "ADD"]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "(option int"
    [Open_paren; Ident "option"; Ident "int"]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "parameter int}"
    [Ident "parameter"; Ident "int"; Close_brace]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "}{}{}{"
    [Close_brace; Open_brace; Close_brace; Open_brace; Close_brace; Open_brace]

(*********************************)
(* Conditional contracts *)

let test_condition_contract () =
  assert_tokenize
    ~loc:__LOC__
    "parameter (or string (option int));storage unit;return string;code \
     {CAR;IF_LEFT{}{IF_NONE {FAIL}{PUSH int 0; CMPGT; IF {FAIL}{PUSH string \
     \"\"}}};UNIT; SWAP; PAIR}"
    [ Ident "parameter";
      Open_paren;
      Ident "or";
      Ident "string";
      Open_paren;
      Ident "option";
      Ident "int";
      Close_paren;
      Close_paren;
      Semi;
      Ident "storage";
      Ident "unit";
      Semi;
      Ident "return";
      Ident "string";
      Semi;
      Ident "code";
      Open_brace;
      Ident "CAR";
      Semi;
      Ident "IF_LEFT";
      Open_brace;
      Close_brace;
      Open_brace;
      Ident "IF_NONE";
      Open_brace;
      Ident "FAIL";
      Close_brace;
      Open_brace;
      Ident "PUSH";
      Ident "int";
      Int "0";
      Semi;
      Ident "CMPGT";
      Semi;
      Ident "IF";
      Open_brace;
      Ident "FAIL";
      Close_brace;
      Open_brace;
      Ident "PUSH";
      Ident "string";
      String "";
      Close_brace;
      Close_brace;
      Close_brace;
      Semi;
      Ident "UNIT";
      Semi;
      Ident "SWAP";
      Semi;
      Ident "PAIR";
      Close_brace ]
  >>=? fun () ->
  (* NOTE: the cases below do not fail because we only do tokenization. *)
  assert_tokenize
    ~loc:__LOC__
    "parameter (or string (option int);"
    [ Ident "parameter";
      Open_paren;
      Ident "or";
      Ident "string";
      Open_paren;
      Ident "option";
      Ident "int";
      Close_paren;
      Semi ]
  >>=? fun () ->
  assert_tokenize
    ~loc:__LOC__
    "parameter (or)"
    [Ident "parameter"; Open_paren; Ident "or"; Close_paren]
  >>=? fun () ->
  assert_tokenize_error
    ~loc:__LOC__
    "parameter (or"
    [Ident "parameter"; Open_paren; Ident "or"; Close_paren]

(****************************************************************************)
(* Top-level parsing tests *)
(****************************************************************************)

let assert_toplevel_parsing ~loc source expected =
  match Micheline_parser.tokenize source with
  | (_, _ :: _) ->
      failwith "%s - Cannot tokenize %s" loc source
  | (tokens, []) -> (
    match Micheline_parser.parse_toplevel tokens with
    | (_, _ :: _) ->
        failwith "%s - Cannot parse_toplevel %s" loc source
    | (ast, []) ->
        let ast = List.map Micheline.strip_locations ast in
        let expected = List.map Micheline.strip_locations expected in
        Assert.equal ~loc (List.length ast) (List.length expected)
        >>=? fun () ->
        iter2_p (Assert.equal ~loc) ast expected >>=? fun () -> return_unit )

let assert_toplevel_parsing_error ~loc source expected =
  match Micheline_parser.tokenize source with
  | (_, _ :: _) ->
      return_unit
  | (tokens, []) -> (
    match Micheline_parser.parse_toplevel tokens with
    | (_, _ :: _) ->
        return_unit
    | (ast, []) ->
        let ast = List.map Micheline.strip_locations ast in
        let expected = List.map Micheline.strip_locations expected in
        Assert.equal ~loc (List.length ast) (List.length expected)
        >>=? fun () -> iter2_p (Assert.not_equal ~loc) ast expected )

let test_basic_parsing () =
  assert_toplevel_parsing
    ~loc:__LOC__
    "parameter unit;"
    [Prim ((), "parameter", [Prim ((), "unit", [], [])], [])]
  >>=? fun () ->
  (* Sequence *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "code {}"
    [Prim ((), "code", [Seq ((), [])], [])]
  >>=? fun () ->
  (* Int *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "PUSH int 100"
    [Prim ((), "PUSH", [Prim ((), "int", [], []); Int ((), Z.of_int 100)], [])]
  >>=? fun () ->
  (*NOTE: this case doesn't fail because we don't type check *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "PUSH string 100"
    [ Prim
        ((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
    ]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int 100_000"
    [ Prim
        ( (),
          "PUSH",
          [Prim ((), "string", [], []); Int ((), Z.of_int 100_000)],
          [] ) ]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int 100"
    [Prim ((), "PUSH", [Prim ((), "int", [], []); Int ((), Z.of_int 1000)], [])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int 100"
    [ Prim
        ((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
    ]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "PUSH int \"100\""
    [ Prim
        ((), "PUSH", [Prim ((), "string", [], []); Int ((), Z.of_int 100)], [])
    ]
  >>=? fun () ->
  (* String *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "Pair False \"abc\""
    [Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "Pair False \"ab\""
    [Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "Pair False abc\""
    [Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], [])]
  >>=? fun () ->
  (* annotations *)
  assert_toplevel_parsing
    ~loc:__LOC__
    "NIL @annot string; #comment\n"
    [Prim ((), "NIL", [Prim ((), "string", [], [])], ["@annot"])]
  >>=? fun () ->
  assert_toplevel_parsing_error
    ~loc:__LOC__
    "NIL @annot string; #comment\n"
    [Prim ((), "NIL", [Prim ((), "string", [], [])], [])]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "IF_NONE {FAIL} {}"
    [ Prim
        ( (),
          "IF_NONE",
          [Seq ((), [Prim ((), "FAIL", [], [])]); Seq ((), [])],
          [] ) ]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "PUSH (map int bool) (Map (Item 100 False))"
    [ Prim
        ( (),
          "PUSH",
          [ Prim
              ( (),
                "map",
                [Prim ((), "int", [], []); Prim ((), "bool", [], [])],
                [] );
            Prim
              ( (),
                "Map",
                [ Prim
                    ( (),
                      "Item",
                      [Int ((), Z.of_int 100); Prim ((), "False", [], [])],
                      [] ) ],
                [] ) ],
          [] ) ]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "LAMDA @name int int {}"
    [ Prim
        ( (),
          "LAMDA",
          [Prim ((), "int", [], []); Prim ((), "int", [], []); Seq ((), [])],
          ["@name"] ) ]
  >>=? fun () ->
  assert_toplevel_parsing
    ~loc:__LOC__
    "code {DUP @test; DROP}"
    [ Prim
        ( (),
          "code",
          [ Seq
              ((), [Prim ((), "DUP", [], ["@test"]); Prim ((), "DROP", [], [])])
          ],
          [] ) ]

let test_condition_contract_parsing () =
  assert_toplevel_parsing
    ~loc:__LOC__
    "parameter unit;return unit;storage tez; #How much you have to send me \n\
     code {CDR; DUP;AMOUNT; CMPLT;IF {FAIL}}"
    [ Prim ((), "parameter", [Prim ((), "unit", [], [])], []);
      Prim ((), "return", [Prim ((), "unit", [], [])], []);
      Prim ((), "storage", [Prim ((), "tez", [], [])], []);
      Prim
        ( (),
          "code",
          [ Seq
              ( (),
                [ Prim ((), "CDR", [], []);
                  Prim ((), "DUP", [], []);
                  Prim ((), "AMOUNT", [], []);
                  Prim ((), "CMPLT", [], []);
                  Prim ((), "IF", [Seq ((), [Prim ((), "FAIL", [], [])])], [])
                ] ) ],
          [] ) ]

let test_list_append_parsing () =
  assert_toplevel_parsing
    ~loc:__LOC__
    "parameter (pair (list int)(list int));return (list int);storage \
     unit;code { CAR; DUP; DIP{CDR}; CAR;NIL int; SWAP;LAMDA (pair int (list \
     int))(list int){DUP; CAR; DIP {CDR}; CONS};REDUCE;LAMDA (pair int (list \
     int))(list int){DUP; CAR; DIP{CDR}; CONS};UNIT; SWAP; PAIR}"
    [ Prim
        ( (),
          "parameter",
          [ Prim
              ( (),
                "pair",
                [ Prim ((), "list", [Prim ((), "int", [], [])], []);
                  Prim ((), "list", [Prim ((), "int", [], [])], []) ],
                [] ) ],
          [] );
      Prim
        ((), "return", [Prim ((), "list", [Prim ((), "int", [], [])], [])], []);
      Prim ((), "storage", [Prim ((), "unit", [], [])], []);
      Prim
        ( (),
          "code",
          [ Seq
              ( (),
                [ Prim ((), "CAR", [], []);
                  Prim ((), "DUP", [], []);
                  Prim ((), "DIP", [Seq ((), [Prim ((), "CDR", [], [])])], []);
                  Prim ((), "CAR", [], []);
                  Prim ((), "NIL", [Prim ((), "int", [], [])], []);
                  Prim ((), "SWAP", [], []);
                  Prim
                    ( (),
                      "LAMDA",
                      [ Prim
                          ( (),
                            "pair",
                            [ Prim ((), "int", [], []);
                              Prim ((), "list", [Prim ((), "int", [], [])], [])
                            ],
                            [] );
                        Prim ((), "list", [Prim ((), "int", [], [])], []);
                        Seq
                          ( (),
                            [ Prim ((), "DUP", [], []);
                              Prim ((), "CAR", [], []);
                              Prim
                                ( (),
                                  "DIP",
                                  [Seq ((), [Prim ((), "CDR", [], [])])],
                                  [] );
                              Prim ((), "CONS", [], []) ] ) ],
                      [] );
                  Prim ((), "REDUCE", [], []);
                  Prim
                    ( (),
                      "LAMDA",
                      [ Prim
                          ( (),
                            "pair",
                            [ Prim ((), "int", [], []);
                              Prim ((), "list", [Prim ((), "int", [], [])], [])
                            ],
                            [] );
                        Prim ((), "list", [Prim ((), "int", [], [])], []);
                        Seq
                          ( (),
                            [ Prim ((), "DUP", [], []);
                              Prim ((), "CAR", [], []);
                              Prim
                                ( (),
                                  "DIP",
                                  [Seq ((), [Prim ((), "CDR", [], [])])],
                                  [] );
                              Prim ((), "CONS", [], []) ] ) ],
                      [] );
                  Prim ((), "UNIT", [], []);
                  Prim ((), "SWAP", [], []);
                  Prim ((), "PAIR", [], []) ] ) ],
          [] ) ]

(****************************************************************************)
(* Expression parsing tests *)
(****************************************************************************)

let assert_expression_parsing ~loc source expected =
  match Micheline_parser.tokenize source with
  | (_, _ :: _) ->
      failwith "%s - Cannot tokenize %s" loc source
  | (tokens, []) -> (
    match Micheline_parser.parse_expression tokens with
    | (_, _ :: _) ->
        failwith "%s - Cannot parse_expression %s" loc source
    | (ast, []) ->
        let ast = Micheline.strip_locations ast in
        let expected = Micheline.strip_locations expected in
        Assert.equal ~loc ast expected )

let test_parses_expression () =
  (* String *)
  assert_expression_parsing
    ~loc:__LOC__
    "Pair False \"abc\""
    (Prim ((), "Pair", [Prim ((), "False", [], []); String ((), "abc")], []))
  >>=? fun () ->
  (* Int *)
  assert_expression_parsing
    ~loc:__LOC__
    "Item 100"
    (Prim ((), "Item", [Int ((), Z.of_int 100)], []))
  >>=? fun () ->
  (* Sequence *)
  assert_expression_parsing ~loc:__LOC__ "{}" (Seq ((), []))

(****************************************************************************)

let tests =
  [ ("tokenize", fun _ -> test_tokenize_basic ());
    ("test one line contract", fun _ -> test_one_line_contract ());
    ("test_condition_contract", fun _ -> test_condition_contract ());
    ("test_basic_parsing", fun _ -> test_basic_parsing ());
    ( "test_condition_contract_parsing",
      fun _ -> test_condition_contract_parsing () );
    ("test_list_append_parsing", fun _ -> test_list_append_parsing ());
    ("test_parses_expression", fun _ -> test_parses_expression ()) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      f ()
      >>= function Ok () -> Lwt.return_unit | Error err -> Lwt.fail_with err)

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-lib-micheline"
    [("micheline", List.map wrap tests)]
src/lib_micheline/test/test_parser.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition assert_tokenize {A B C : Type}
  (loc : A) (given : string) (expected : B) : C :=
  match Micheline_parser.tokenize given with
  | (tokens, []) =>
    let tokens_got := List.map (fun x => Micheline_parser.token x) tokens in
    op_startypeminuserrorstar loc tokens_got expected
  | (_, _) => OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc given
  end.

Definition assert_tokenize_error {A B C : Type}
  (loc : A) (given : string) (expected : B) : C :=
  match Micheline_parser.tokenize given with
  | (tokens, []) =>
    let tokens_got := List.map (fun x => Micheline_parser.token x) tokens in
    op_startypeminuserrorstar loc tokens_got expected
  | (_, _) => op_startypeminuserrorstar
  end.

Definition test_tokenize_basic {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (assert_tokenize Stdlib.__LOC__ """abc""" % string
      (cons op_startypeminuserrorstar []))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (assert_tokenize Stdlib.__LOC__ """abc	""" % string
          (cons op_startypeminuserrorstar []))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (assert_tokenize Stdlib.__LOC__ """abc""" % string
              (cons op_startypeminuserrorstar []))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (assert_tokenize Stdlib.__LOC__ """abc\n""" % string
                  (cons op_startypeminuserrorstar []))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    (assert_tokenize Stdlib.__LOC__ """abc\r""" % string
                      (cons op_startypeminuserrorstar []))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar
                        (assert_tokenize_error Stdlib.__LOC__
                          """abc
""" % string
                          (cons op_startypeminuserrorstar []))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar
                            (assert_tokenize_error Stdlib.__LOC__
                              """abc\""" % string
                              (cons op_startypeminuserrorstar []))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar
                                (assert_tokenize_error Stdlib.__LOC__
                                  """abc""" % string
                                  (cons op_startypeminuserrorstar []))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar
                                    (assert_tokenize_error Stdlib.__LOC__
                                      """abc
""" % string
                                      (cons op_startypeminuserrorstar []))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar
                                        (assert_tokenize_error Stdlib.__LOC__
                                          "abc
" % string
                                          (cons op_startypeminuserrorstar []))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (assert_tokenize_error
                                              Stdlib.__LOC__ """abc""
" % string
                                              (cons op_startypeminuserrorstar []))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar
                                                (assert_tokenize_error
                                                  Stdlib.__LOC__
                                                  """abc" % string
                                                  (cons
                                                    op_startypeminuserrorstar []))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_startypeminuserrorstar
                                                    (assert_tokenize_error
                                                      Stdlib.__LOC__
                                                      "abc""" % string
                                                      (cons
                                                        op_startypeminuserrorstar
                                                        []))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (assert_tokenize_error
                                                          Stdlib.__LOC__
                                                          """""""" % string
                                                          (cons
                                                            op_startypeminuserrorstar
                                                            []))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_startypeminuserrorstar
                                                            (assert_tokenize
                                                              Stdlib.__LOC__
                                                              "0xabc" % string
                                                              (cons
                                                                op_startypeminuserrorstar
                                                                []))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (assert_tokenize
                                                                  Stdlib.__LOC__
                                                                  "0x" % string
                                                                  (cons
                                                                    op_startypeminuserrorstar
                                                                    []))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_startypeminuserrorstar
                                                                    (assert_tokenize
                                                                      Stdlib.__LOC__
                                                                      "0x1" %
                                                                        string
                                                                      (cons
                                                                        op_startypeminuserrorstar
                                                                        []))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_startypeminuserrorstar
                                                                        (assert_tokenize_error
                                                                          Stdlib.__LOC__
                                                                          "xabc"
                                                                            %
                                                                            string
                                                                          (cons
                                                                            op_startypeminuserrorstar
                                                                            []))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_startypeminuserrorstar
                                                                            (assert_tokenize_error
                                                                              Stdlib.__LOC__
                                                                              "1xabc"
                                                                                %
                                                                                string
                                                                              (cons
                                                                                op_startypeminuserrorstar
                                                                                []))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_startypeminuserrorstar
                                                                                (assert_tokenize_error
                                                                                  Stdlib.__LOC__
                                                                                  "1c"
                                                                                    %
                                                                                    string
                                                                                  (cons
                                                                                    op_startypeminuserrorstar
                                                                                    []))
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  op_startypeminuserrorstar
                                                                                    (assert_tokenize_error
                                                                                      Stdlib.__LOC__
                                                                                      "0c"
                                                                                        %
                                                                                        string
                                                                                      (cons
                                                                                        op_startypeminuserrorstar
                                                                                        []))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_startypeminuserrorstar
                                                                                        (assert_tokenize_error
                                                                                          Stdlib.__LOC__
                                                                                          "0xx"
                                                                                            %
                                                                                            string
                                                                                          (cons
                                                                                            op_startypeminuserrorstar
                                                                                            []))
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            'tt :=
                                                                                            function_parameter
                                                                                            in
                                                                                          op_startypeminuserrorstar
                                                                                            (assert_tokenize_error
                                                                                              Stdlib.__LOC__
                                                                                              "0b"
                                                                                                %
                                                                                                string
                                                                                              (cons
                                                                                                op_startypeminuserrorstar
                                                                                                []))
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                'tt :=
                                                                                                function_parameter
                                                                                                in
                                                                                              op_startypeminuserrorstar
                                                                                                (assert_tokenize_error
                                                                                                  Stdlib.__LOC__
                                                                                                  "0xg"
                                                                                                    %
                                                                                                    string
                                                                                                  (cons
                                                                                                    op_startypeminuserrorstar
                                                                                                    []))
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  op_startypeminuserrorstar
                                                                                                    (assert_tokenize_error
                                                                                                      Stdlib.__LOC__
                                                                                                      "0X"
                                                                                                        %
                                                                                                        string
                                                                                                      (cons
                                                                                                        op_startypeminuserrorstar
                                                                                                        []))
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        'tt :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      op_startypeminuserrorstar
                                                                                                        (assert_tokenize_error
                                                                                                          Stdlib.__LOC__
                                                                                                          "1x"
                                                                                                            %
                                                                                                            string
                                                                                                          (cons
                                                                                                            op_startypeminuserrorstar
                                                                                                            []))
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_startypeminuserrorstar
                                                                                                            (assert_tokenize
                                                                                                              Stdlib.__LOC__
                                                                                                              "10"
                                                                                                                %
                                                                                                                string
                                                                                                              (cons
                                                                                                                op_startypeminuserrorstar
                                                                                                                []))
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                'tt :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_startypeminuserrorstar
                                                                                                                (assert_tokenize
                                                                                                                  Stdlib.__LOC__
                                                                                                                  "0"
                                                                                                                    %
                                                                                                                    string
                                                                                                                  (cons
                                                                                                                    op_startypeminuserrorstar
                                                                                                                    []))
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    (assert_tokenize
                                                                                                                      Stdlib.__LOC__
                                                                                                                      "00"
                                                                                                                        %
                                                                                                                        string
                                                                                                                      (cons
                                                                                                                        op_startypeminuserrorstar
                                                                                                                        []))
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        'tt :=
                                                                                                                        function_parameter
                                                                                                                        in
                                                                                                                      op_startypeminuserrorstar
                                                                                                                        (assert_tokenize
                                                                                                                          Stdlib.__LOC__
                                                                                                                          "001"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          (cons
                                                                                                                            op_startypeminuserrorstar
                                                                                                                            []))
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          let
                                                                                                                            'tt :=
                                                                                                                            function_parameter
                                                                                                                            in
                                                                                                                          op_startypeminuserrorstar
                                                                                                                            (assert_tokenize
                                                                                                                              Stdlib.__LOC__
                                                                                                                              "-0"
                                                                                                                                %
                                                                                                                                string
                                                                                                                              (cons
                                                                                                                                op_startypeminuserrorstar
                                                                                                                                []))
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              let
                                                                                                                                'tt :=
                                                                                                                                function_parameter
                                                                                                                                in
                                                                                                                              op_startypeminuserrorstar
                                                                                                                                (assert_tokenize
                                                                                                                                  Stdlib.__LOC__
                                                                                                                                  "-1"
                                                                                                                                    %
                                                                                                                                    string
                                                                                                                                  (cons
                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                    []))
                                                                                                                                (fun
                                                                                                                                  function_parameter
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    'tt :=
                                                                                                                                    function_parameter
                                                                                                                                    in
                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                    (assert_tokenize
                                                                                                                                      Stdlib.__LOC__
                                                                                                                                      "1"
                                                                                                                                        %
                                                                                                                                        string
                                                                                                                                      (cons
                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                        []))
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      let
                                                                                                                                        'tt :=
                                                                                                                                        function_parameter
                                                                                                                                        in
                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                        (assert_tokenize
                                                                                                                                          Stdlib.__LOC__
                                                                                                                                          "-10"
                                                                                                                                            %
                                                                                                                                            string
                                                                                                                                          (cons
                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                            []))
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          let
                                                                                                                                            'tt :=
                                                                                                                                            function_parameter
                                                                                                                                            in
                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                            (assert_tokenize_error
                                                                                                                                              Stdlib.__LOC__
                                                                                                                                              ".1000"
                                                                                                                                                %
                                                                                                                                                string
                                                                                                                                              (cons
                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                []))
                                                                                                                                            (fun
                                                                                                                                              function_parameter
                                                                                                                                              =>
                                                                                                                                              let
                                                                                                                                                'tt :=
                                                                                                                                                function_parameter
                                                                                                                                                in
                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                (assert_tokenize_error
                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                  "10_00"
                                                                                                                                                    %
                                                                                                                                                    string
                                                                                                                                                  (cons
                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                    []))
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  let
                                                                                                                                                    'tt :=
                                                                                                                                                    function_parameter
                                                                                                                                                    in
                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                      "1,000"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      (cons
                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                        []))
                                                                                                                                                    (fun
                                                                                                                                                      function_parameter
                                                                                                                                                      =>
                                                                                                                                                      let
                                                                                                                                                        'tt :=
                                                                                                                                                        function_parameter
                                                                                                                                                        in
                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                          "1000.000"
                                                                                                                                                            %
                                                                                                                                                            string
                                                                                                                                                          (cons
                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                            []))
                                                                                                                                                        (fun
                                                                                                                                                          function_parameter
                                                                                                                                                          =>
                                                                                                                                                          let
                                                                                                                                                            'tt :=
                                                                                                                                                            function_parameter
                                                                                                                                                            in
                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                              "-0"
                                                                                                                                                                %
                                                                                                                                                                string
                                                                                                                                                              (cons
                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                []))
                                                                                                                                                            (fun
                                                                                                                                                              function_parameter
                                                                                                                                                              =>
                                                                                                                                                              let
                                                                                                                                                                'tt :=
                                                                                                                                                                function_parameter
                                                                                                                                                                in
                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                  "--0"
                                                                                                                                                                    %
                                                                                                                                                                    string
                                                                                                                                                                  (cons
                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                    []))
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  let
                                                                                                                                                                    'tt :=
                                                                                                                                                                    function_parameter
                                                                                                                                                                    in
                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                      "+0"
                                                                                                                                                                        %
                                                                                                                                                                        string
                                                                                                                                                                      (cons
                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                        []))
                                                                                                                                                                    (fun
                                                                                                                                                                      function_parameter
                                                                                                                                                                      =>
                                                                                                                                                                      let
                                                                                                                                                                        'tt :=
                                                                                                                                                                        function_parameter
                                                                                                                                                                        in
                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                          "a"
                                                                                                                                                                            %
                                                                                                                                                                            string
                                                                                                                                                                          (cons
                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                            []))
                                                                                                                                                                        (fun
                                                                                                                                                                          function_parameter
                                                                                                                                                                          =>
                                                                                                                                                                          let
                                                                                                                                                                            'tt :=
                                                                                                                                                                            function_parameter
                                                                                                                                                                            in
                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                              "0a"
                                                                                                                                                                                %
                                                                                                                                                                                string
                                                                                                                                                                              (cons
                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                []))
                                                                                                                                                                            (fun
                                                                                                                                                                              function_parameter
                                                                                                                                                                              =>
                                                                                                                                                                              let
                                                                                                                                                                                'tt :=
                                                                                                                                                                                function_parameter
                                                                                                                                                                                in
                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                  "string"
                                                                                                                                                                                    %
                                                                                                                                                                                    string
                                                                                                                                                                                  (cons
                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                    []))
                                                                                                                                                                                (fun
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  =>
                                                                                                                                                                                  let
                                                                                                                                                                                    'tt :=
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    in
                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                      "@my_pair"
                                                                                                                                                                                        %
                                                                                                                                                                                        string
                                                                                                                                                                                      (cons
                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                        []))
                                                                                                                                                                                    (fun
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      =>
                                                                                                                                                                                      let
                                                                                                                                                                                        'tt :=
                                                                                                                                                                                        function_parameter
                                                                                                                                                                                        in
                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                          "@@my_pair"
                                                                                                                                                                                            %
                                                                                                                                                                                            string
                                                                                                                                                                                          (cons
                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                            []))
                                                                                                                                                                                        (fun
                                                                                                                                                                                          function_parameter
                                                                                                                                                                                          =>
                                                                                                                                                                                          let
                                                                                                                                                                                            'tt :=
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            in
                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                              "$t"
                                                                                                                                                                                                %
                                                                                                                                                                                                string
                                                                                                                                                                                              (cons
                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                []))
                                                                                                                                                                                            (fun
                                                                                                                                                                                              function_parameter
                                                                                                                                                                                              =>
                                                                                                                                                                                              let
                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                in
                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                  "&t"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string
                                                                                                                                                                                                  (cons
                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                    []))
                                                                                                                                                                                                (fun
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  let
                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    in
                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                      ":t"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        string
                                                                                                                                                                                                      (cons
                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                        []))
                                                                                                                                                                                                    (fun
                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                      =>
                                                                                                                                                                                                      let
                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                        in
                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                          ":_"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            string
                                                                                                                                                                                                          (cons
                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                            []))
                                                                                                                                                                                                        (fun
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          let
                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            in
                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                              ":0"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                string
                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                []))
                                                                                                                                                                                                            (fun
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              let
                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                in
                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                  ":%"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string
                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  let
                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                    in
                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                      ":%%"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string
                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      let
                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        in
                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                          ":%@"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string
                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          let
                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                            in
                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                              ":%@_"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string
                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                in
                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                  ":%@_0"
                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                      "%from"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                          "%@from"
                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                              "%from_a"
                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                  "%from.a"
                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                      "%From.a"
                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                          "%0From.a"
                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                              "?t"
                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                  "??t"
                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                      "&&t"
                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                          "$$t"
                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                              "_from"
                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                  ".from"
                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                      "%:from"
                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                          "%:@from"
                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                              "::t"
                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                  "/*""/**/""*/"
                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                      "/* /* /* */ */ */"
                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                          "/*parse 1"
                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                              "parse 1*/"
                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                  "/* */*/"
                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                      "/*/* */"
                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                          "#Access"
                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                              "##Access"
                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                  "?Access"
                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                      ";"
                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                        (assert_tokenize
                                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                          "{"
                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                            (assert_tokenize
                                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                              "}"
                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                  "("
                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                    (assert_tokenize
                                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                      ")"
                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                        (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                          Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                          "{"
                                                                                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                            []))
                                                                                                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                            (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                              Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                              ";"
                                                                                                                                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                                                                                                                                string
                                                                                                                                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                                                                                                                                op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                                []))
                                                                                                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                                                                                                                                              op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                                (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                  Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                  "}"
                                                                                                                                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                                                                                                                                    string
                                                                                                                                                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                                    []))
                                                                                                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                                    (assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                      Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                      "("
                                                                                                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                                        []))
                                                                                                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                                                                                                      assert_tokenize_error
                                                                                                                                                                                                                                                                                                                                                                        Stdlib.__LOC__
                                                                                                                                                                                                                                                                                                                                                                        ")"
                                                                                                                                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                                                                                                          [])))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).

Definition test_one_line_contract {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (assert_tokenize Stdlib.__LOC__ "(option int)" % string
      (cons op_startypeminuserrorstar
        (cons op_startypeminuserrorstar
          (cons op_startypeminuserrorstar (cons op_startypeminuserrorstar [])))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (assert_tokenize Stdlib.__LOC__ "DIP {ADD}" % string
          (cons op_startypeminuserrorstar
            (cons op_startypeminuserrorstar
              (cons op_startypeminuserrorstar
                (cons op_startypeminuserrorstar [])))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (assert_tokenize Stdlib.__LOC__ "parameter int;" % string
              (cons op_startypeminuserrorstar
                (cons op_startypeminuserrorstar
                  (cons op_startypeminuserrorstar []))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (assert_tokenize Stdlib.__LOC__ "PUSH string ""abc"";" % string
                  (cons op_startypeminuserrorstar
                    (cons op_startypeminuserrorstar
                      (cons op_startypeminuserrorstar
                        (cons op_startypeminuserrorstar [])))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    (assert_tokenize Stdlib.__LOC__ "DROP; SWAP" % string
                      (cons op_startypeminuserrorstar
                        (cons op_startypeminuserrorstar
                          (cons op_startypeminuserrorstar []))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar
                        (assert_tokenize Stdlib.__LOC__ "DIP {ADD" % string
                          (cons op_startypeminuserrorstar
                            (cons op_startypeminuserrorstar
                              (cons op_startypeminuserrorstar []))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar
                            (assert_tokenize Stdlib.__LOC__
                              "(option int" % string
                              (cons op_startypeminuserrorstar
                                (cons op_startypeminuserrorstar
                                  (cons op_startypeminuserrorstar []))))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar
                                (assert_tokenize Stdlib.__LOC__
                                  "parameter int}" % string
                                  (cons op_startypeminuserrorstar
                                    (cons op_startypeminuserrorstar
                                      (cons op_startypeminuserrorstar []))))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  assert_tokenize Stdlib.__LOC__
                                    "}{}{}{" % string
                                    (cons op_startypeminuserrorstar
                                      (cons op_startypeminuserrorstar
                                        (cons op_startypeminuserrorstar
                                          (cons op_startypeminuserrorstar
                                            (cons op_startypeminuserrorstar
                                              (cons op_startypeminuserrorstar [])))))))))))))).

Definition test_condition_contract {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (assert_tokenize Stdlib.__LOC__
      "parameter (or string (option int));storage unit;return string;code {CAR;IF_LEFT{}{IF_NONE {FAIL}{PUSH int 0; CMPGT; IF {FAIL}{PUSH string """"}}};UNIT; SWAP; PAIR}"
        % string
      (cons op_startypeminuserrorstar
        (cons op_startypeminuserrorstar
          (cons op_startypeminuserrorstar
            (cons op_startypeminuserrorstar
              (cons op_startypeminuserrorstar
                (cons op_startypeminuserrorstar
                  (cons op_startypeminuserrorstar
                    (cons op_startypeminuserrorstar
                      (cons op_startypeminuserrorstar
                        (cons op_startypeminuserrorstar
                          (cons op_startypeminuserrorstar
                            (cons op_startypeminuserrorstar
                              (cons op_startypeminuserrorstar
                                (cons op_startypeminuserrorstar
                                  (cons op_startypeminuserrorstar
                                    (cons op_startypeminuserrorstar
                                      (cons op_startypeminuserrorstar
                                        (cons op_startypeminuserrorstar
                                          (cons op_startypeminuserrorstar
                                            (cons op_startypeminuserrorstar
                                              (cons op_startypeminuserrorstar
                                                (cons op_startypeminuserrorstar
                                                  (cons
                                                    op_startypeminuserrorstar
                                                    (cons
                                                      op_startypeminuserrorstar
                                                      (cons
                                                        op_startypeminuserrorstar
                                                        (cons
                                                          op_startypeminuserrorstar
                                                          (cons
                                                            op_startypeminuserrorstar
                                                            (cons
                                                              op_startypeminuserrorstar
                                                              (cons
                                                                op_startypeminuserrorstar
                                                                (cons
                                                                  op_startypeminuserrorstar
                                                                  (cons
                                                                    op_startypeminuserrorstar
                                                                    (cons
                                                                      op_startypeminuserrorstar
                                                                      (cons
                                                                        op_startypeminuserrorstar
                                                                        (cons
                                                                          op_startypeminuserrorstar
                                                                          (cons
                                                                            op_startypeminuserrorstar
                                                                            (cons
                                                                              op_startypeminuserrorstar
                                                                              (cons
                                                                                op_startypeminuserrorstar
                                                                                (cons
                                                                                  op_startypeminuserrorstar
                                                                                  (cons
                                                                                    op_startypeminuserrorstar
                                                                                    (cons
                                                                                      op_startypeminuserrorstar
                                                                                      (cons
                                                                                        op_startypeminuserrorstar
                                                                                        (cons
                                                                                          op_startypeminuserrorstar
                                                                                          (cons
                                                                                            op_startypeminuserrorstar
                                                                                            (cons
                                                                                              op_startypeminuserrorstar
                                                                                              (cons
                                                                                                op_startypeminuserrorstar
                                                                                                (cons
                                                                                                  op_startypeminuserrorstar
                                                                                                  (cons
                                                                                                    op_startypeminuserrorstar
                                                                                                    (cons
                                                                                                      op_startypeminuserrorstar
                                                                                                      (cons
                                                                                                        op_startypeminuserrorstar
                                                                                                        (cons
                                                                                                          op_startypeminuserrorstar
                                                                                                          (cons
                                                                                                            op_startypeminuserrorstar
                                                                                                            (cons
                                                                                                              op_startypeminuserrorstar
                                                                                                              (cons
                                                                                                                op_startypeminuserrorstar
                                                                                                                []))))))))))))))))))))))))))))))))))))))))))))))))))))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (assert_tokenize Stdlib.__LOC__
          "parameter (or string (option int);" % string
          (cons op_startypeminuserrorstar
            (cons op_startypeminuserrorstar
              (cons op_startypeminuserrorstar
                (cons op_startypeminuserrorstar
                  (cons op_startypeminuserrorstar
                    (cons op_startypeminuserrorstar
                      (cons op_startypeminuserrorstar
                        (cons op_startypeminuserrorstar
                          (cons op_startypeminuserrorstar []))))))))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (assert_tokenize Stdlib.__LOC__ "parameter (or)" % string
              (cons op_startypeminuserrorstar
                (cons op_startypeminuserrorstar
                  (cons op_startypeminuserrorstar
                    (cons op_startypeminuserrorstar [])))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              assert_tokenize_error Stdlib.__LOC__ "parameter (or" % string
                (cons op_startypeminuserrorstar
                  (cons op_startypeminuserrorstar
                    (cons op_startypeminuserrorstar
                      (cons op_startypeminuserrorstar []))))))).

Definition assert_toplevel_parsing {A B C D : Type}
  (loc : A) (source : string)
  (expected : list (Tezos_micheline.Micheline.node B C)) : D :=
  match Micheline_parser.tokenize source with
  | (_, cons _ _) =>
    OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc source
  | (tokens, []) =>
    match Micheline_parser.parse_toplevel None tokens with
    | (_, cons _ _) =>
      OCaml.Stdlib.failwith "%s - Cannot parse_toplevel %s" % string loc source
    | (ast, []) =>
      let ast := List.map Micheline.strip_locations ast in
      let expected := List.map Micheline.strip_locations expected in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar loc (OCaml.List.length ast)
          (OCaml.List.length expected))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (op_startypeminuserrorstar (op_startypeminuserrorstar loc) ast
              expected)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar))
    end
  end.

Definition assert_toplevel_parsing_error {A B C D : Type}
  (loc : A) (source : string)
  (expected : list (Tezos_micheline.Micheline.node B C)) : D :=
  match Micheline_parser.tokenize source with
  | (_, cons _ _) => op_startypeminuserrorstar
  | (tokens, []) =>
    match Micheline_parser.parse_toplevel None tokens with
    | (_, cons _ _) => op_startypeminuserrorstar
    | (ast, []) =>
      let ast := List.map Micheline.strip_locations ast in
      let expected := List.map Micheline.strip_locations expected in
      op_startypeminuserrorstar
        (op_startypeminuserrorstar loc (OCaml.List.length ast)
          (OCaml.List.length expected))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar (op_startypeminuserrorstar loc) ast expected)
    end
  end.

Definition test_basic_parsing {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (assert_toplevel_parsing Stdlib.__LOC__ "parameter unit;" % string
      (cons
        (Tezos_micheline.Micheline.Prim tt "parameter" % string
          (cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) []) [])
        []))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (assert_toplevel_parsing Stdlib.__LOC__ "code {}" % string
          (cons
            (Tezos_micheline.Micheline.Prim tt "code" % string
              (cons (Tezos_micheline.Micheline.Seq tt []) []) []) []))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_startypeminuserrorstar
            (assert_toplevel_parsing Stdlib.__LOC__ "PUSH int 100" % string
              (cons
                (Tezos_micheline.Micheline.Prim tt "PUSH" % string
                  (cons (Tezos_micheline.Micheline.Prim tt "int" % string [] [])
                    (cons (Tezos_micheline.Micheline.Int tt (Z.of_int 100)) []))
                  []) []))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_startypeminuserrorstar
                (assert_toplevel_parsing Stdlib.__LOC__
                  "PUSH string 100" % string
                  (cons
                    (Tezos_micheline.Micheline.Prim tt "PUSH" % string
                      (cons
                        (Tezos_micheline.Micheline.Prim tt "string" % string []
                          [])
                        (cons (Tezos_micheline.Micheline.Int tt (Z.of_int 100))
                          [])) []) []))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_startypeminuserrorstar
                    (assert_toplevel_parsing_error Stdlib.__LOC__
                      "PUSH int 100_000" % string
                      (cons
                        (Tezos_micheline.Micheline.Prim tt "PUSH" % string
                          (cons
                            (Tezos_micheline.Micheline.Prim tt "string" % string
                              [] [])
                            (cons
                              (Tezos_micheline.Micheline.Int tt
                                (Z.of_int 100000)) [])) []) []))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar
                        (assert_toplevel_parsing_error Stdlib.__LOC__
                          "PUSH int 100" % string
                          (cons
                            (Tezos_micheline.Micheline.Prim tt "PUSH" % string
                              (cons
                                (Tezos_micheline.Micheline.Prim tt
                                  "int" % string [] [])
                                (cons
                                  (Tezos_micheline.Micheline.Int tt
                                    (Z.of_int 1000)) [])) []) []))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_startypeminuserrorstar
                            (assert_toplevel_parsing_error Stdlib.__LOC__
                              "PUSH int 100" % string
                              (cons
                                (Tezos_micheline.Micheline.Prim tt
                                  "PUSH" % string
                                  (cons
                                    (Tezos_micheline.Micheline.Prim tt
                                      "string" % string [] [])
                                    (cons
                                      (Tezos_micheline.Micheline.Int tt
                                        (Z.of_int 100)) [])) []) []))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_startypeminuserrorstar
                                (assert_toplevel_parsing_error Stdlib.__LOC__
                                  "PUSH int ""100""" % string
                                  (cons
                                    (Tezos_micheline.Micheline.Prim tt
                                      "PUSH" % string
                                      (cons
                                        (Tezos_micheline.Micheline.Prim tt
                                          "string" % string [] [])
                                        (cons
                                          (Tezos_micheline.Micheline.Int tt
                                            (Z.of_int 100)) [])) []) []))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_startypeminuserrorstar
                                    (assert_toplevel_parsing Stdlib.__LOC__
                                      "Pair False ""abc""" % string
                                      (cons
                                        (Tezos_micheline.Micheline.Prim tt
                                          "Pair" % string
                                          (cons
                                            (Tezos_micheline.Micheline.Prim tt
                                              "False" % string [] [])
                                            (cons
                                              (Tezos_micheline.Micheline.String
                                                tt "abc" % string) [])) []) []))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_startypeminuserrorstar
                                        (assert_toplevel_parsing_error
                                          Stdlib.__LOC__
                                          "Pair False ""ab""" % string
                                          (cons
                                            (Tezos_micheline.Micheline.Prim tt
                                              "Pair" % string
                                              (cons
                                                (Tezos_micheline.Micheline.Prim
                                                  tt "False" % string [] [])
                                                (cons
                                                  (Tezos_micheline.Micheline.String
                                                    tt "abc" % string) [])) [])
                                            []))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_startypeminuserrorstar
                                            (assert_toplevel_parsing_error
                                              Stdlib.__LOC__
                                              "Pair False abc""" % string
                                              (cons
                                                (Tezos_micheline.Micheline.Prim
                                                  tt "Pair" % string
                                                  (cons
                                                    (Tezos_micheline.Micheline.Prim
                                                      tt "False" % string [] [])
                                                    (cons
                                                      (Tezos_micheline.Micheline.String
                                                        tt "abc" % string) []))
                                                  []) []))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar
                                                (assert_toplevel_parsing
                                                  Stdlib.__LOC__
                                                  "NIL @annot string; #comment
"
                                                    % string
                                                  (cons
                                                    (Tezos_micheline.Micheline.Prim
                                                      tt "NIL" % string
                                                      (cons
                                                        (Tezos_micheline.Micheline.Prim
                                                          tt "string" % string
                                                          [] []) [])
                                                      (cons "@annot" % string []))
                                                    []))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_startypeminuserrorstar
                                                    (assert_toplevel_parsing_error
                                                      Stdlib.__LOC__
                                                      "NIL @annot string; #comment
"
                                                        % string
                                                      (cons
                                                        (Tezos_micheline.Micheline.Prim
                                                          tt "NIL" % string
                                                          (cons
                                                            (Tezos_micheline.Micheline.Prim
                                                              tt
                                                              "string" % string
                                                              [] []) []) []) []))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_startypeminuserrorstar
                                                        (assert_toplevel_parsing
                                                          Stdlib.__LOC__
                                                          "IF_NONE {FAIL} {}" %
                                                            string
                                                          (cons
                                                            (Tezos_micheline.Micheline.Prim
                                                              tt
                                                              "IF_NONE" % string
                                                              (cons
                                                                (Tezos_micheline.Micheline.Seq
                                                                  tt
                                                                  (cons
                                                                    (Tezos_micheline.Micheline.Prim
                                                                      tt
                                                                      "FAIL" %
                                                                        string
                                                                      [] []) []))
                                                                (cons
                                                                  (Tezos_micheline.Micheline.Seq
                                                                    tt []) []))
                                                              []) []))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_startypeminuserrorstar
                                                            (assert_toplevel_parsing
                                                              Stdlib.__LOC__
                                                              "PUSH (map int bool) (Map (Item 100 False))"
                                                                % string
                                                              (cons
                                                                (Tezos_micheline.Micheline.Prim
                                                                  tt
                                                                  "PUSH" %
                                                                    string
                                                                  (cons
                                                                    (Tezos_micheline.Micheline.Prim
                                                                      tt
                                                                      "map" %
                                                                        string
                                                                      (cons
                                                                        (Tezos_micheline.Micheline.Prim
                                                                          tt
                                                                          "int"
                                                                            %
                                                                            string
                                                                          [] [])
                                                                        (cons
                                                                          (Tezos_micheline.Micheline.Prim
                                                                            tt
                                                                            "bool"
                                                                              %
                                                                              string
                                                                            []
                                                                            [])
                                                                          []))
                                                                      [])
                                                                    (cons
                                                                      (Tezos_micheline.Micheline.Prim
                                                                        tt
                                                                        "Map" %
                                                                          string
                                                                        (cons
                                                                          (Tezos_micheline.Micheline.Prim
                                                                            tt
                                                                            "Item"
                                                                              %
                                                                              string
                                                                            (cons
                                                                              (Tezos_micheline.Micheline.Int
                                                                                tt
                                                                                (Z.of_int
                                                                                  100))
                                                                              (cons
                                                                                (Tezos_micheline.Micheline.Prim
                                                                                  tt
                                                                                  "False"
                                                                                    %
                                                                                    string
                                                                                  []
                                                                                  [])
                                                                                []))
                                                                            [])
                                                                          []) [])
                                                                      [])) [])
                                                                []))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_startypeminuserrorstar
                                                                (assert_toplevel_parsing
                                                                  Stdlib.__LOC__
                                                                  "LAMDA @name int int {}"
                                                                    % string
                                                                  (cons
                                                                    (Tezos_micheline.Micheline.Prim
                                                                      tt
                                                                      "LAMDA" %
                                                                        string
                                                                      (cons
                                                                        (Tezos_micheline.Micheline.Prim
                                                                          tt
                                                                          "int"
                                                                            %
                                                                            string
                                                                          [] [])
                                                                        (cons
                                                                          (Tezos_micheline.Micheline.Prim
                                                                            tt
                                                                            "int"
                                                                              %
                                                                              string
                                                                            []
                                                                            [])
                                                                          (cons
                                                                            (Tezos_micheline.Micheline.Seq
                                                                              tt
                                                                              [])
                                                                            [])))
                                                                      (cons
                                                                        "@name"
                                                                          %
                                                                          string
                                                                        [])) []))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  assert_toplevel_parsing
                                                                    Stdlib.__LOC__
                                                                    "code {DUP @test; DROP}"
                                                                      % string
                                                                    (cons
                                                                      (Tezos_micheline.Micheline.Prim
                                                                        tt
                                                                        "code" %
                                                                          string
                                                                        (cons
                                                                          (Tezos_micheline.Micheline.Seq
                                                                            tt
                                                                            (cons
                                                                              (Tezos_micheline.Micheline.Prim
                                                                                tt
                                                                                "DUP"
                                                                                  %
                                                                                  string
                                                                                []
                                                                                (cons
                                                                                  "@test"
                                                                                    %
                                                                                    string
                                                                                  []))
                                                                              (cons
                                                                                (Tezos_micheline.Micheline.Prim
                                                                                  tt
                                                                                  "DROP"
                                                                                    %
                                                                                    string
                                                                                  []
                                                                                  [])
                                                                                [])))
                                                                          []) [])
                                                                      []))))))))))))))))).

Definition test_condition_contract_parsing {A : Type}
  (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  assert_toplevel_parsing Stdlib.__LOC__
    "parameter unit;return unit;storage tez; #How much you have to send me 
code {CDR; DUP;AMOUNT; CMPLT;IF {FAIL}}"
      % string
    (cons
      (Tezos_micheline.Micheline.Prim tt "parameter" % string
        (cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) []) [])
      (cons
        (Tezos_micheline.Micheline.Prim tt "return" % string
          (cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) []) [])
        (cons
          (Tezos_micheline.Micheline.Prim tt "storage" % string
            (cons (Tezos_micheline.Micheline.Prim tt "tez" % string [] []) [])
            [])
          (cons
            (Tezos_micheline.Micheline.Prim tt "code" % string
              (cons
                (Tezos_micheline.Micheline.Seq tt
                  (cons (Tezos_micheline.Micheline.Prim tt "CDR" % string [] [])
                    (cons
                      (Tezos_micheline.Micheline.Prim tt "DUP" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim tt "AMOUNT" % string []
                          [])
                        (cons
                          (Tezos_micheline.Micheline.Prim tt "CMPLT" % string []
                            [])
                          (cons
                            (Tezos_micheline.Micheline.Prim tt "IF" % string
                              (cons
                                (Tezos_micheline.Micheline.Seq tt
                                  (cons
                                    (Tezos_micheline.Micheline.Prim tt
                                      "FAIL" % string [] []) [])) []) []) []))))))
                []) []) [])))).

Definition test_list_append_parsing {A : Type} (function_parameter : unit)
  : A :=
  let 'tt := function_parameter in
  assert_toplevel_parsing Stdlib.__LOC__
    "parameter (pair (list int)(list int));return (list int);storage unit;code { CAR; DUP; DIP{CDR}; CAR;NIL int; SWAP;LAMDA (pair int (list int))(list int){DUP; CAR; DIP {CDR}; CONS};REDUCE;LAMDA (pair int (list int))(list int){DUP; CAR; DIP{CDR}; CONS};UNIT; SWAP; PAIR}"
      % string
    (cons
      (Tezos_micheline.Micheline.Prim tt "parameter" % string
        (cons
          (Tezos_micheline.Micheline.Prim tt "pair" % string
            (cons
              (Tezos_micheline.Micheline.Prim tt "list" % string
                (cons (Tezos_micheline.Micheline.Prim tt "int" % string [] [])
                  []) [])
              (cons
                (Tezos_micheline.Micheline.Prim tt "list" % string
                  (cons (Tezos_micheline.Micheline.Prim tt "int" % string [] [])
                    []) []) [])) []) []) [])
      (cons
        (Tezos_micheline.Micheline.Prim tt "return" % string
          (cons
            (Tezos_micheline.Micheline.Prim tt "list" % string
              (cons (Tezos_micheline.Micheline.Prim tt "int" % string [] []) [])
              []) []) [])
        (cons
          (Tezos_micheline.Micheline.Prim tt "storage" % string
            (cons (Tezos_micheline.Micheline.Prim tt "unit" % string [] []) [])
            [])
          (cons
            (Tezos_micheline.Micheline.Prim tt "code" % string
              (cons
                (Tezos_micheline.Micheline.Seq tt
                  (cons (Tezos_micheline.Micheline.Prim tt "CAR" % string [] [])
                    (cons
                      (Tezos_micheline.Micheline.Prim tt "DUP" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim tt "DIP" % string
                          (cons
                            (Tezos_micheline.Micheline.Seq tt
                              (cons
                                (Tezos_micheline.Micheline.Prim tt
                                  "CDR" % string [] []) [])) []) [])
                        (cons
                          (Tezos_micheline.Micheline.Prim tt "CAR" % string []
                            [])
                          (cons
                            (Tezos_micheline.Micheline.Prim tt "NIL" % string
                              (cons
                                (Tezos_micheline.Micheline.Prim tt
                                  "int" % string [] []) []) [])
                            (cons
                              (Tezos_micheline.Micheline.Prim tt "SWAP" % string
                                [] [])
                              (cons
                                (Tezos_micheline.Micheline.Prim tt
                                  "LAMDA" % string
                                  (cons
                                    (Tezos_micheline.Micheline.Prim tt
                                      "pair" % string
                                      (cons
                                        (Tezos_micheline.Micheline.Prim tt
                                          "int" % string [] [])
                                        (cons
                                          (Tezos_micheline.Micheline.Prim tt
                                            "list" % string
                                            (cons
                                              (Tezos_micheline.Micheline.Prim tt
                                                "int" % string [] []) []) []) []))
                                      [])
                                    (cons
                                      (Tezos_micheline.Micheline.Prim tt
                                        "list" % string
                                        (cons
                                          (Tezos_micheline.Micheline.Prim tt
                                            "int" % string [] []) []) [])
                                      (cons
                                        (Tezos_micheline.Micheline.Seq tt
                                          (cons
                                            (Tezos_micheline.Micheline.Prim tt
                                              "DUP" % string [] [])
                                            (cons
                                              (Tezos_micheline.Micheline.Prim tt
                                                "CAR" % string [] [])
                                              (cons
                                                (Tezos_micheline.Micheline.Prim
                                                  tt "DIP" % string
                                                  (cons
                                                    (Tezos_micheline.Micheline.Seq
                                                      tt
                                                      (cons
                                                        (Tezos_micheline.Micheline.Prim
                                                          tt "CDR" % string []
                                                          []) [])) []) [])
                                                (cons
                                                  (Tezos_micheline.Micheline.Prim
                                                    tt "CONS" % string [] []) [])))))
                                        []))) [])
                                (cons
                                  (Tezos_micheline.Micheline.Prim tt
                                    "REDUCE" % string [] [])
                                  (cons
                                    (Tezos_micheline.Micheline.Prim tt
                                      "LAMDA" % string
                                      (cons
                                        (Tezos_micheline.Micheline.Prim tt
                                          "pair" % string
                                          (cons
                                            (Tezos_micheline.Micheline.Prim tt
                                              "int" % string [] [])
                                            (cons
                                              (Tezos_micheline.Micheline.Prim tt
                                                "list" % string
                                                (cons
                                                  (Tezos_micheline.Micheline.Prim
                                                    tt "int" % string [] []) [])
                                                []) [])) [])
                                        (cons
                                          (Tezos_micheline.Micheline.Prim tt
                                            "list" % string
                                            (cons
                                              (Tezos_micheline.Micheline.Prim tt
                                                "int" % string [] []) []) [])
                                          (cons
                                            (Tezos_micheline.Micheline.Seq tt
                                              (cons
                                                (Tezos_micheline.Micheline.Prim
                                                  tt "DUP" % string [] [])
                                                (cons
                                                  (Tezos_micheline.Micheline.Prim
                                                    tt "CAR" % string [] [])
                                                  (cons
                                                    (Tezos_micheline.Micheline.Prim
                                                      tt "DIP" % string
                                                      (cons
                                                        (Tezos_micheline.Micheline.Seq
                                                          tt
                                                          (cons
                                                            (Tezos_micheline.Micheline.Prim
                                                              tt "CDR" % string
                                                              [] []) [])) []) [])
                                                    (cons
                                                      (Tezos_micheline.Micheline.Prim
                                                        tt "CONS" % string [] [])
                                                      []))))) []))) [])
                                    (cons
                                      (Tezos_micheline.Micheline.Prim tt
                                        "UNIT" % string [] [])
                                      (cons
                                        (Tezos_micheline.Micheline.Prim tt
                                          "SWAP" % string [] [])
                                        (cons
                                          (Tezos_micheline.Micheline.Prim tt
                                            "PAIR" % string [] []) [])))))))))))))
                []) []) [])))).

Definition assert_expression_parsing {A B C D : Type}
  (loc : A) (source : string) (expected : Tezos_micheline.Micheline.node B C)
  : D :=
  match Micheline_parser.tokenize source with
  | (_, cons _ _) =>
    OCaml.Stdlib.failwith "%s - Cannot tokenize %s" % string loc source
  | (tokens, []) =>
    match Micheline_parser.parse_expression None tokens with
    | (_, cons _ _) =>
      OCaml.Stdlib.failwith "%s - Cannot parse_expression %s" % string loc
        source
    | (ast, []) =>
      let ast := Micheline.strip_locations ast in
      let expected := Micheline.strip_locations expected in
      op_startypeminuserrorstar loc ast expected
    end
  end.

Definition test_parses_expression {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar
    (assert_expression_parsing Stdlib.__LOC__ "Pair False ""abc""" % string
      (Tezos_micheline.Micheline.Prim tt "Pair" % string
        (cons (Tezos_micheline.Micheline.Prim tt "False" % string [] [])
          (cons (Tezos_micheline.Micheline.String tt "abc" % string) [])) []))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_startypeminuserrorstar
        (assert_expression_parsing Stdlib.__LOC__ "Item 100" % string
          (Tezos_micheline.Micheline.Prim tt "Item" % string
            (cons (Tezos_micheline.Micheline.Int tt (Z.of_int 100)) []) []))
        (fun function_parameter =>
          let 'tt := function_parameter in
          assert_expression_parsing Stdlib.__LOC__ "{}" % string
            (Tezos_micheline.Micheline.Seq tt []))).

Definition tests {A B : Type} : list (string * (A -> B)) :=
  cons
    ("tokenize" % string,
      (fun function_parameter =>
        let '_ := function_parameter in
        test_tokenize_basic tt))
    (cons
      ("test one line contract" % string,
        (fun function_parameter =>
          let '_ := function_parameter in
          test_one_line_contract tt))
      (cons
        ("test_condition_contract" % string,
          (fun function_parameter =>
            let '_ := function_parameter in
            test_condition_contract tt))
        (cons
          ("test_basic_parsing" % string,
            (fun function_parameter =>
              let '_ := function_parameter in
              test_basic_parsing tt))
          (cons
            ("test_condition_contract_parsing" % string,
              (fun function_parameter =>
                let '_ := function_parameter in
                test_condition_contract_parsing tt))
            (cons
              ("test_list_append_parsing" % string,
                (fun function_parameter =>
                  let '_ := function_parameter in
                  test_list_append_parsing tt))
              (cons
                ("test_parses_expression" % string,
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    test_parses_expression tt)) [])))))).

Definition wrap {A B C : Type} (function_parameter : A * (unit -> B)) : C :=
  let '(n, f) := function_parameter in
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_startypeminuserrorstar (f tt)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok tt => Lwt.return_unit
            | Stdlib.Error err => Lwt.fail_with err
            end)).



src/lib_p2p/p2p.ml 42 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p"
end)

type 'peer_meta peer_meta_config = 'peer_meta P2p_pool.peer_meta_config = {
  peer_meta_encoding : 'peer_meta Data_encoding.t;
  peer_meta_initial : unit -> 'peer_meta;
  score : 'peer_meta -> float;
}

type 'conn_meta conn_meta_config = 'conn_meta P2p_socket.metadata_config = {
  conn_meta_encoding : 'conn_meta Data_encoding.t;
  conn_meta_value : P2p_peer.Id.t -> 'conn_meta;
  private_node : 'conn_meta -> bool;
}

type 'msg app_message_encoding = 'msg P2p_message.encoding =
  | Encoding : {
      tag : int;
      title : string;
      encoding : 'a Data_encoding.t;
      wrap : 'a -> 'msg;
      unwrap : 'msg -> 'a option;
      max_length : int option;
    }
      -> 'msg app_message_encoding

type 'msg message_config = 'msg P2p_connect_handler.message_config = {
  encoding : 'msg app_message_encoding list;
  chain_name : Distributed_db_version.name;
  distributed_db_versions : Distributed_db_version.t list;
}

type config = {
  listening_port : P2p_addr.port option;
  listening_addr : P2p_addr.t option;
  discovery_port : P2p_addr.port option;
  discovery_addr : Ipaddr.V4.t option;
  trusted_points : P2p_point.Id.t list;
  peers_file : string;
  private_mode : bool;
  identity : P2p_identity.t;
  proof_of_work_target : Crypto_box.target;
  disable_mempool : bool;
  trust_discovered_peers : bool;
  disable_testchain : bool;
  greylisting_config : P2p_point_state.Info.greylisting_config;
}

type limits = {
  connection_timeout : Time.System.Span.t;
  authentication_timeout : Time.System.Span.t;
  greylist_timeout : Time.System.Span.t;
  maintenance_idle_time : Time.System.Span.t;
  min_connections : int;
  expected_connections : int;
  max_connections : int;
  backlog : int;
  max_incoming_connections : int;
  max_download_speed : int option;
  max_upload_speed : int option;
  read_buffer_size : int;
  read_queue_size : int option;
  write_queue_size : int option;
  incoming_app_message_queue_size : int option;
  incoming_message_queue_size : int option;
  outgoing_message_queue_size : int option;
  known_peer_ids_history_size : int;
  (* TODO: remove these two fields *)
  known_points_history_size : int;
  max_known_peer_ids : (int * int) option;
  max_known_points : (int * int) option;
  swap_linger : Time.System.Span.t;
  binary_chunks_size : int option;
}

let create_scheduler limits =
  let max_upload_speed = Option.map limits.max_upload_speed ~f:(( * ) 1024) in
  let max_download_speed =
    Option.map limits.max_upload_speed ~f:(( * ) 1024)
  in
  P2p_io_scheduler.create
    ~read_buffer_size:limits.read_buffer_size
    ?max_upload_speed
    ?max_download_speed
    ?read_queue_size:limits.read_queue_size
    ?write_queue_size:limits.write_queue_size
    ()

let create_connection_pool config limits meta_cfg log triggers =
  let pool_cfg =
    {
      P2p_pool.identity = config.identity;
      trusted_points = config.trusted_points;
      peers_file = config.peers_file;
      private_mode = config.private_mode;
      max_known_points = limits.max_known_points;
      max_known_peer_ids = limits.max_known_peer_ids;
    }
  in
  P2p_pool.create pool_cfg meta_cfg ~log triggers

let create_connect_handler config limits pool msg_cfg conn_meta_cfg io_sched
    triggers log answerer =
  let connect_handler_cfg =
    {
      P2p_connect_handler.identity = config.identity;
      proof_of_work_target = config.proof_of_work_target;
      listening_port = config.listening_port;
      private_mode = config.private_mode;
      greylisting_config = config.greylisting_config;
      min_connections = limits.min_connections;
      max_connections = limits.max_connections;
      max_incoming_connections = limits.max_incoming_connections;
      connection_timeout = limits.connection_timeout;
      authentication_timeout = limits.authentication_timeout;
      incoming_app_message_queue_size = limits.incoming_app_message_queue_size;
      incoming_message_queue_size = limits.incoming_message_queue_size;
      outgoing_message_queue_size = limits.outgoing_message_queue_size;
      binary_chunks_size = limits.binary_chunks_size;
    }
  in
  P2p_connect_handler.create
    connect_handler_cfg
    pool
    msg_cfg
    conn_meta_cfg
    io_sched
    triggers
    ~log
    ~answerer

let may_create_discovery_worker _limits config pool =
  match
    (config.listening_port, config.discovery_port, config.discovery_addr)
  with
  | (Some listening_port, Some discovery_port, Some discovery_addr) ->
      Some
        (P2p_discovery.create
           pool
           config.identity.peer_id
           ~listening_port
           ~discovery_port
           ~discovery_addr
           ~trust_discovered_peers:config.trust_discovered_peers)
  | (_, _, _) ->
      None

let create_maintenance_worker limits pool connect_handler config triggers log =
  let maintenance_config =
    {
      P2p_maintenance.maintenance_idle_time = limits.maintenance_idle_time;
      greylist_timeout = limits.greylist_timeout;
      private_mode = config.private_mode;
      min_connections = limits.min_connections;
      max_connections = limits.max_connections;
      expected_connections = limits.max_connections;
    }
  in
  let discovery = may_create_discovery_worker limits config pool in
  P2p_maintenance.create
    ?discovery
    maintenance_config
    pool
    connect_handler
    triggers
    ~log

let may_create_welcome_worker config limits connect_handler =
  match config.listening_port with
  | None ->
      Lwt.return_none
  | Some port ->
      P2p_welcome.create
        ~backlog:limits.backlog
        connect_handler
        ?addr:config.listening_addr
        port
      >>= fun w -> Lwt.return_some w

type ('msg, 'peer_meta, 'conn_meta) connection =
  ('msg, 'peer_meta, 'conn_meta) P2p_conn.t

module Real = struct
  type ('msg, 'peer_meta, 'conn_meta) net = {
    config : config;
    limits : limits;
    io_sched : P2p_io_scheduler.t;
    pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t;
    connect_handler : ('msg, 'peer_meta, 'conn_meta) P2p_connect_handler.t;
    maintenance : ('msg, 'peer_meta, 'conn_meta) P2p_maintenance.t;
    welcome : P2p_welcome.t option;
    watcher : P2p_connection.P2p_event.t Lwt_watcher.input;
    triggers : P2p_trigger.t;
  }

  let create ~config ~limits meta_cfg msg_cfg conn_meta_cfg =
    let io_sched = create_scheduler limits in
    let watcher = Lwt_watcher.create_input () in
    let log event = Lwt_watcher.notify watcher event in
    let triggers = P2p_trigger.create () in
    create_connection_pool config limits meta_cfg log triggers
    >>= fun pool ->
    (* There is a mutual recursion between an answerer and connect_handler,
       for the default answerer. Because of the swap request mechanism, the
       default answerer needs to initiate new connections using the
       [P2p_connect_hander.connect] callback. *)
    let rec answerer =
      lazy
        ( if config.private_mode then P2p_protocol.create_private ()
        else
          let connect =
            P2p_connect_handler.connect (Lazy.force connect_handler)
          in
          let proto_conf =
            {
              P2p_protocol.swap_linger = limits.swap_linger;
              pool;
              log;
              connect;
              latest_accepted_swap = Ptime.epoch;
              latest_successful_swap = Ptime.epoch;
            }
          in
          P2p_protocol.create_default proto_conf )
    and connect_handler =
      lazy
        (create_connect_handler
           config
           limits
           pool
           msg_cfg
           conn_meta_cfg
           io_sched
           triggers
           log
           answerer)
    in
    let connect_handler = Lazy.force connect_handler in
    let maintenance =
      create_maintenance_worker limits pool connect_handler config triggers log
    in
    may_create_welcome_worker config limits connect_handler
    >>= fun welcome ->
    return
      {
        config;
        limits;
        io_sched;
        pool;
        connect_handler;
        maintenance;
        welcome;
        watcher;
        triggers;
      }

  let peer_id {config; _} = config.identity.peer_id

  let maintain {maintenance; _} () = P2p_maintenance.maintain maintenance

  let activate t () =
    log_info "activate" ;
    (match t.welcome with None -> () | Some w -> P2p_welcome.activate w) ;
    P2p_maintenance.activate t.maintenance ;
    ()

  let roll _net () = Lwt.return_unit (* TODO implement *)

  (* returns when all workers have shutted down in the opposite
     creation order. *)
  let shutdown net () =
    lwt_log_notice "Shutting down the p2p's welcome worker..."
    >>= fun () ->
    Lwt_utils.may ~f:P2p_welcome.shutdown net.welcome
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p's network maintenance worker..."
    >>= fun () ->
    P2p_maintenance.shutdown net.maintenance
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p connection pool..."
    >>= fun () ->
    P2p_pool.destroy net.pool
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p connection handler..."
    >>= fun () ->
    P2p_connect_handler.destroy net.connect_handler
    >>= fun () ->
    lwt_log_notice "Shutting down the p2p scheduler..."
    >>= fun () -> P2p_io_scheduler.shutdown ~timeout:3.0 net.io_sched

  let connections {pool; _} () =
    P2p_pool.Connection.fold pool ~init:[] ~f:(fun _peer_id c acc -> c :: acc)

  let find_connection {pool; _} peer_id =
    P2p_pool.Connection.find_by_peer_id pool peer_id

  let disconnect ?wait conn = P2p_conn.disconnect ?wait conn

  let connection_info _net conn = P2p_conn.info conn

  let connection_local_metadata _net conn = P2p_conn.local_metadata conn

  let connection_remote_metadata _net conn = P2p_conn.remote_metadata conn

  let connection_stat _net conn = P2p_conn.stat conn

  let global_stat {connect_handler; _} () =
    P2p_connect_handler.stat connect_handler

  let set_peer_metadata {pool; _} conn meta =
    P2p_pool.Peers.set_peer_metadata pool conn meta

  let get_peer_metadata {pool; _} conn =
    P2p_pool.Peers.get_peer_metadata pool conn

  let recv _net conn =
    P2p_conn.read conn
    >>=? fun msg ->
    lwt_debug
      "message read from %a"
      P2p_peer.Id.pp
      (P2p_conn.info conn).peer_id
    >>= fun () -> return msg

  let rec recv_any net () =
    let pipes =
      P2p_pool.Connection.fold net.pool ~init:[] ~f:(fun _peer_id conn acc ->
          ( P2p_conn.is_readable conn
          >>= function
          | Ok () ->
              Lwt.return_some conn
          | Error _ ->
              Lwt_utils.never_ending () )
          :: acc)
    in
    Lwt.pick
      ( ( P2p_trigger.wait_new_connection net.triggers
        >>= fun () -> Lwt.return_none )
      :: pipes )
    >>= function
    | None ->
        recv_any net ()
    | Some conn -> (
        P2p_conn.read conn
        >>= function
        | Ok msg ->
            lwt_debug
              "message read from %a"
              P2p_peer.Id.pp
              (P2p_conn.info conn).peer_id
            >>= fun () -> Lwt.return (conn, msg)
        | Error _ ->
            lwt_debug
              "error reading message from %a"
              P2p_peer.Id.pp
              (P2p_conn.info conn).peer_id
            >>= fun () -> Lwt_unix.yield () >>= fun () -> recv_any net () )

  let send _net conn m =
    P2p_conn.write conn m
    >>= function
    | Ok () ->
        lwt_debug
          "message sent to %a"
          P2p_peer.Id.pp
          (P2p_conn.info conn).peer_id
        >>= fun () -> return_unit
    | Error err ->
        lwt_debug
          "error sending message from %a: %a"
          P2p_peer.Id.pp
          (P2p_conn.info conn).peer_id
          pp_print_error
          err
        >>= fun () -> Lwt.return_error err

  let try_send _net conn v =
    match P2p_conn.write_now conn v with
    | Ok v ->
        debug
          "message trysent to %a"
          P2p_peer.Id.pp
          (P2p_conn.info conn).peer_id ;
        v
    | Error err ->
        debug
          "error trysending message to %a@ %a"
          P2p_peer.Id.pp
          (P2p_conn.info conn).peer_id
          pp_print_error
          err ;
        false

  let broadcast {pool; _} msg =
    P2p_peer.Table.iter
      (fun _peer_id peer_info ->
        match P2p_peer_state.get peer_info with
        | Running {data = conn; _} ->
            (* Silently discards Error P2p_errors.Connection_closed in case
                the pipe is closed. Shouldn't happen because
                - no race conditions (no Lwt)
                - the peer state is Running. *)
            ignore (P2p_conn.write_now conn msg : bool tzresult)
        | _ ->
            ())
      (P2p_pool.connected_peer_ids pool) ;
    debug "message broadcasted"

  let fold_connections {pool; _} ~init ~f =
    P2p_pool.Connection.fold pool ~init ~f

  let iter_connections {pool; _} f =
    P2p_pool.Connection.fold pool ~init:() ~f:(fun gid conn () -> f gid conn)

  let on_new_connection {connect_handler; _} f =
    P2p_connect_handler.on_new_connection connect_handler f
end

module Fake = struct
  let id = P2p_identity.generate (Crypto_box.make_target 0.)

  let empty_stat =
    {
      P2p_stat.total_sent = 0L;
      total_recv = 0L;
      current_inflow = 0;
      current_outflow = 0;
    }

  let connection_info announced_version faked_metadata =
    {
      P2p_connection.Info.incoming = false;
      peer_id = id.peer_id;
      id_point = (Ipaddr.V6.unspecified, None);
      remote_socket_port = 0;
      announced_version;
      local_metadata = faked_metadata;
      remote_metadata = faked_metadata;
      private_node = false;
    }
end

type ('msg, 'peer_meta, 'conn_meta) t = {
  announced_version : Network_version.t;
  peer_id : P2p_peer.Id.t;
  maintain : unit -> unit Lwt.t;
  roll : unit -> unit Lwt.t;
  shutdown : unit -> unit Lwt.t;
  connections : unit -> ('msg, 'peer_meta, 'conn_meta) connection list;
  find_connection :
    P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection option;
  disconnect :
    ?wait:bool -> ('msg, 'peer_meta, 'conn_meta) connection -> unit Lwt.t;
  connection_info :
    ('msg, 'peer_meta, 'conn_meta) connection ->
    'conn_meta P2p_connection.Info.t;
  connection_local_metadata :
    ('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta;
  connection_remote_metadata :
    ('msg, 'peer_meta, 'conn_meta) connection -> 'conn_meta;
  connection_stat : ('msg, 'peer_meta, 'conn_meta) connection -> P2p_stat.t;
  global_stat : unit -> P2p_stat.t;
  get_peer_metadata : P2p_peer.Id.t -> 'peer_meta;
  set_peer_metadata : P2p_peer.Id.t -> 'peer_meta -> unit;
  recv : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg tzresult Lwt.t;
  recv_any : unit -> (('msg, 'peer_meta, 'conn_meta) connection * 'msg) Lwt.t;
  send :
    ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> unit tzresult Lwt.t;
  try_send : ('msg, 'peer_meta, 'conn_meta) connection -> 'msg -> bool;
  broadcast : 'msg -> unit;
  pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t option;
  connect_handler :
    ('msg, 'peer_meta, 'conn_meta) P2p_connect_handler.t option;
  fold_connections :
    'a. init:'a ->
    f:(P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> 'a -> 'a) ->
    'a;
  iter_connections :
    (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
    unit;
  on_new_connection :
    (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) connection -> unit) ->
    unit;
  activate : unit -> unit;
  watcher : P2p_connection.P2p_event.t Lwt_watcher.input;
}

type ('msg, 'peer_meta, 'conn_meta) net = ('msg, 'peer_meta, 'conn_meta) t

let announced_version net = net.announced_version

let pool net = net.pool

let connect_handler net = net.connect_handler

let check_limits =
  let fail_1 v orig =
    if not (Ptime.Span.compare v Ptime.Span.zero <= 0) then return_unit
    else
      Error_monad.failwith
        "value of option %S cannot be negative or null@."
        orig
  in
  let fail_2 v orig =
    if not (v < 0) then return_unit
    else Error_monad.failwith "value of option %S cannot be negative@." orig
  in
  fun c ->
    fail_1 c.authentication_timeout "authentication-timeout"
    >>=? fun () ->
    fail_2 c.min_connections "min-connections"
    >>=? fun () ->
    fail_2 c.expected_connections "expected-connections"
    >>=? fun () ->
    fail_2 c.max_connections "max-connections"
    >>=? fun () ->
    fail_2 c.max_incoming_connections "max-incoming-connections"
    >>=? fun () ->
    fail_2 c.read_buffer_size "read-buffer-size"
    >>=? fun () ->
    fail_2 c.known_peer_ids_history_size "known-peer-ids-history-size"
    >>=? fun () ->
    fail_2 c.known_points_history_size "known-points-history-size"
    >>=? fun () ->
    fail_1 c.swap_linger "swap-linger"
    >>=? fun () ->
    ( match c.binary_chunks_size with
    | None ->
        return_unit
    | Some size ->
        P2p_socket.check_binary_chunks_size size )
    >>=? fun () -> return_unit

let create ~config ~limits peer_cfg conn_cfg msg_cfg =
  check_limits limits
  >>=? fun () ->
  Real.create ~config ~limits peer_cfg msg_cfg conn_cfg
  >>=? fun net ->
  return
    {
      announced_version =
        Network_version.announced
          ~chain_name:msg_cfg.chain_name
          ~distributed_db_versions:msg_cfg.distributed_db_versions
          ~p2p_versions:P2p_version.supported;
      peer_id = Real.peer_id net;
      maintain = Real.maintain net;
      roll = Real.roll net;
      shutdown = Real.shutdown net;
      connections = Real.connections net;
      find_connection = Real.find_connection net;
      disconnect = Real.disconnect;
      connection_info = Real.connection_info net;
      connection_local_metadata = Real.connection_local_metadata net;
      connection_remote_metadata = Real.connection_remote_metadata net;
      connection_stat = Real.connection_stat net;
      global_stat = Real.global_stat net;
      get_peer_metadata = Real.get_peer_metadata net;
      set_peer_metadata = Real.set_peer_metadata net;
      recv = Real.recv net;
      recv_any = Real.recv_any net;
      send = Real.send net;
      try_send = Real.try_send net;
      broadcast = Real.broadcast net;
      pool = Some net.pool;
      connect_handler = Some net.connect_handler;
      fold_connections = (fun ~init ~f -> Real.fold_connections net ~init ~f);
      iter_connections = Real.iter_connections net;
      on_new_connection = Real.on_new_connection net;
      activate = Real.activate net;
      watcher = net.Real.watcher;
    }

let activate t =
  log_info "activate P2P layer !" ;
  t.activate ()

let faked_network (msg_cfg : 'msg message_config) peer_cfg faked_metadata =
  let announced_version =
    Network_version.announced
      ~chain_name:msg_cfg.chain_name
      ~distributed_db_versions:msg_cfg.distributed_db_versions
      ~p2p_versions:P2p_version.supported
  in
  {
    announced_version;
    peer_id = Fake.id.peer_id;
    maintain = Lwt.return;
    roll = Lwt.return;
    shutdown = Lwt.return;
    connections = (fun () -> []);
    find_connection = (fun _ -> None);
    disconnect = (fun ?wait:_ _ -> Lwt.return_unit);
    connection_info =
      (fun _ -> Fake.connection_info announced_version faked_metadata);
    connection_local_metadata = (fun _ -> faked_metadata);
    connection_remote_metadata = (fun _ -> faked_metadata);
    connection_stat = (fun _ -> Fake.empty_stat);
    global_stat = (fun () -> Fake.empty_stat);
    get_peer_metadata = (fun _ -> peer_cfg.peer_meta_initial ());
    set_peer_metadata = (fun _ _ -> ());
    recv = (fun _ -> Lwt_utils.never_ending ());
    recv_any = (fun () -> Lwt_utils.never_ending ());
    send = (fun _ _ -> fail P2p_errors.Connection_closed);
    try_send = (fun _ _ -> false);
    fold_connections = (fun ~init ~f:_ -> init);
    iter_connections = (fun _f -> ());
    on_new_connection = (fun _f -> ());
    broadcast = ignore;
    pool = None;
    connect_handler = None;
    activate = (fun _ -> ());
    watcher = Lwt_watcher.create_input ();
  }

let peer_id net = net.peer_id

let maintain net = net.maintain ()

let roll net = net.roll ()

let shutdown net = net.shutdown ()

let connections net = net.connections ()

let disconnect net = net.disconnect

let find_connection net = net.find_connection

let connection_info net = net.connection_info

let connection_local_metadata net = net.connection_local_metadata

let connection_remote_metadata net = net.connection_remote_metadata

let connection_stat net = net.connection_stat

let global_stat net = net.global_stat ()

let get_peer_metadata net = net.get_peer_metadata

let set_peer_metadata net = net.set_peer_metadata

let recv net = net.recv

let recv_any net = net.recv_any ()

let send net = net.send

let try_send net = net.try_send

let broadcast net = net.broadcast

let fold_connections net = net.fold_connections

let iter_connections net = net.iter_connections

let on_new_connection net = net.on_new_connection

let greylist_addr net addr =
  Option.iter net.pool ~f:(fun pool -> P2p_pool.greylist_addr pool addr)

let greylist_peer net peer_id =
  Option.iter net.pool ~f:(fun pool -> P2p_pool.greylist_peer pool peer_id)

let watcher net = Lwt_watcher.create_stream net.watcher
src/lib_p2p/p2p.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Record peer_meta_config {peer_meta : Type} := {
  peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer_meta;
  peer_meta_initial : unit -> peer_meta;
  score : peer_meta -> Z }.
Arguments peer_meta_config : clear implicits.

Record conn_meta_config {conn_meta : Type} := {
  conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t conn_meta;
  conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> conn_meta;
  private_node : conn_meta -> bool }.
Arguments conn_meta_config : clear implicits.

Inductive app_message_encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
  (Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
  (msg -> option a) -> (option Z) -> app_message_encoding msg.

Arguments Encoding {_}.

Record message_config {msg : Type} := {
  encoding : list (app_message_encoding msg);
  chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
  distributed_db_versions :
    list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.

Record config := {
  listening_port : option Tezos_base__TzPervasives.P2p_addr.port;
  listening_addr : option Tezos_base__TzPervasives.P2p_addr.t;
  discovery_port : option Tezos_base__TzPervasives.P2p_addr.port;
  discovery_addr : option Ipaddr.V4.t;
  trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
  peers_file : string;
  private_mode : bool;
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
  disable_mempool : bool;
  trust_discovered_peers : bool;
  disable_testchain : bool;
  greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config }.

Record limits := {
  connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
  min_connections : Z;
  expected_connections : Z;
  max_connections : Z;
  backlog : Z;
  max_incoming_connections : Z;
  max_download_speed : option Z;
  max_upload_speed : option Z;
  read_buffer_size : Z;
  read_queue_size : option Z;
  write_queue_size : option Z;
  incoming_app_message_queue_size : option Z;
  incoming_message_queue_size : option Z;
  outgoing_message_queue_size : option Z;
  known_peer_ids_history_size : Z;
  known_points_history_size : Z;
  max_known_peer_ids : option (Z * Z);
  max_known_points : option (Z * Z);
  swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
  binary_chunks_size : option Z }.

Definition create_scheduler (limits : limits) : Tezos_p2p.P2p_io_scheduler.t :=
  let max_upload_speed := Option.map (Z.mul 1024) (max_upload_speed limits) in
  let max_download_speed := Option.map (Z.mul 1024) (max_upload_speed limits) in
  P2p_io_scheduler.create max_upload_speed max_download_speed
    (read_queue_size limits) (write_queue_size limits) (read_buffer_size limits)
    tt.

Definition create_connection_pool {A B C : Type}
  (config : config) (limits : limits)
  (meta_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
  (log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
  (triggers : Tezos_p2p.P2p_trigger.t) : Lwt.t (Tezos_p2p.P2p_pool.t B A C) :=
  let pool_cfg :=
    {| P2p_pool.identity := identity config;
      P2p_pool.trusted_points := trusted_points config;
      P2p_pool.peers_file := peers_file config;
      P2p_pool.private_mode := private_mode config;
      P2p_pool.max_known_points := max_known_points limits;
      P2p_pool.max_known_peer_ids := max_known_peer_ids limits |} in
  P2p_pool.create pool_cfg meta_cfg triggers log.

Definition create_connect_handler {A B C : Type}
  (config : config) (limits : limits) (pool : Tezos_p2p.P2p_pool.t A B C)
  (msg_cfg : Tezos_p2p.P2p_connect_handler.message_config A)
  (conn_meta_cfg : Tezos_p2p.P2p_socket.metadata_config C)
  (io_sched : Tezos_p2p.P2p_io_scheduler.t) (triggers : Tezos_p2p.P2p_trigger.t)
  (log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
  (answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t A))
  : Tezos_p2p.P2p_connect_handler.t A B C :=
  let connect_handler_cfg :=
    {|
      P2p_connect_handler.incoming_app_message_queue_size :=
        incoming_app_message_queue_size limits;
      P2p_connect_handler.private_mode := private_mode config;
      P2p_connect_handler.min_connections := min_connections limits;
      P2p_connect_handler.max_connections := max_connections limits;
      P2p_connect_handler.max_incoming_connections :=
        max_incoming_connections limits;
      P2p_connect_handler.incoming_message_queue_size :=
        incoming_message_queue_size limits;
      P2p_connect_handler.outgoing_message_queue_size :=
        outgoing_message_queue_size limits;
      P2p_connect_handler.binary_chunks_size := binary_chunks_size limits;
      P2p_connect_handler.identity := identity config;
      P2p_connect_handler.connection_timeout := connection_timeout limits;
      P2p_connect_handler.authentication_timeout :=
        authentication_timeout limits;
      P2p_connect_handler.greylisting_config := greylisting_config config;
      P2p_connect_handler.proof_of_work_target := proof_of_work_target config;
      P2p_connect_handler.listening_port := listening_port config |} in
  P2p_connect_handler.create None connect_handler_cfg pool msg_cfg conn_meta_cfg
    io_sched triggers log answerer.

Definition may_create_discovery_worker {A B C D : Type}
  (_limits : A) (config : config) (pool : Tezos_p2p.P2p_pool.t B C D)
  : option Tezos_p2p.P2p_discovery.t :=
  match
    ((listening_port config), (discovery_port config), (discovery_addr config))
    with
  | (Some listening_port, Some discovery_port, Some discovery_addr) =>
    Some
      (P2p_discovery.create listening_port discovery_port discovery_addr
        (trust_discovered_peers config) pool (peer_id (identity config)))
  | (_, _, _) => None
  end.

Definition create_maintenance_worker {A B C : Type}
  (limits : limits) (pool : Tezos_p2p.P2p_pool.t A B C)
  (connect_handler : Tezos_p2p.P2p_connect_handler.t A B C) (config : config)
  (triggers : Tezos_p2p.P2p_trigger.t)
  (log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
  : Tezos_p2p.P2p_maintenance.t A B C :=
  let maintenance_config :=
    {| P2p_maintenance.maintenance_idle_time := maintenance_idle_time limits;
      P2p_maintenance.greylist_timeout := greylist_timeout limits;
      P2p_maintenance.private_mode := private_mode config;
      P2p_maintenance.min_connections := min_connections limits;
      P2p_maintenance.max_connections := max_connections limits;
      P2p_maintenance.expected_connections := max_connections limits |} in
  let discovery := may_create_discovery_worker limits config pool in
  P2p_maintenance.create discovery maintenance_config pool connect_handler
    triggers log.

Definition may_create_welcome_worker {A B C : Type}
  (config : config) (limits : limits)
  (connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
  : Lwt.t (option Tezos_p2p.P2p_welcome.t) :=
  match listening_port config with
  | None => Lwt.return_none
  | Some port =>
    op_gtgteq
      (P2p_welcome.create (listening_addr config) (backlog limits)
        connect_handler port) (fun w => Lwt.return_some w)
  end.

Definition connection (msg peer_meta conn_meta : Type) :=
  Tezos_p2p.P2p_conn.t msg peer_meta conn_meta.

Module Real.
  Record net {msg peer_meta conn_meta : Type} := {
    config : config;
    limits : limits;
    io_sched : Tezos_p2p.P2p_io_scheduler.t;
    pool : Tezos_p2p.P2p_pool.t msg peer_meta conn_meta;
    connect_handler : Tezos_p2p.P2p_connect_handler.t msg peer_meta conn_meta;
    maintenance : Tezos_p2p.P2p_maintenance.t msg peer_meta conn_meta;
    welcome : option Tezos_p2p.P2p_welcome.t;
    watcher :
      Tezos_stdlib.Lwt_watcher.input
        Tezos_base__TzPervasives.P2p_connection.P2p_event.t;
    triggers : Tezos_p2p.P2p_trigger.t }.
  Arguments net : clear implicits.
  
  Definition create {A B C : Type}
    (config : config) (limits : limits)
    (meta_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
    (msg_cfg : Tezos_p2p.P2p_connect_handler.message_config B)
    (conn_meta_cfg : Tezos_p2p.P2p_socket.metadata_config C)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (net B A C)) :=
    let io_sched := create_scheduler limits in
    let watcher := Lwt_watcher.create_input tt in
    let log (event : Tezos_base__TzPervasives.P2p_connection.P2p_event.t)
      : unit :=
      Lwt_watcher.notify watcher event in
    let triggers := P2p_trigger.create tt in
    op_gtgteq (create_connection_pool config limits meta_cfg log triggers)
      (fun pool =>
        let fix answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t B) :=
          (* ❌ Lazy expressions are not handled *)
          lazy
            (if private_mode config then
              P2p_protocol.create_private tt
            else
              let connect :=
                P2p_connect_handler.connect None (Lazy.force connect_handler) in
              let proto_conf :=
                {| P2p_protocol.swap_linger := swap_linger limits;
                  P2p_protocol.pool := pool; P2p_protocol.log := log;
                  P2p_protocol.connect := connect;
                  P2p_protocol.latest_accepted_swap := Ptime.epoch;
                  P2p_protocol.latest_successful_swap := Ptime.epoch |} in
              P2p_protocol.create_default proto_conf)
        with connect_handler
          : Stdlib.Lazy.t (Tezos_p2p.P2p_connect_handler.t B A C) :=
          (* ❌ Lazy expressions are not handled *)
          lazy
            (create_connect_handler config limits pool msg_cfg conn_meta_cfg
              io_sched triggers log answerer) in
        let connect_handler := Lazy.force connect_handler in
        let maintenance :=
          create_maintenance_worker limits pool connect_handler config triggers
            log in
        op_gtgteq (may_create_welcome_worker config limits connect_handler)
          (fun welcome =>
            _return
              {| config := config; limits := limits; io_sched := io_sched;
                pool := pool; connect_handler := connect_handler;
                maintenance := maintenance; welcome := welcome;
                watcher := watcher; triggers := triggers |})).
  
  Definition peer_id {A B C : Type} (function_parameter : net A B C)
    : Tezos_base.P2p_peer.Id.t :=
    let '{| config := config |} := function_parameter in
    peer_id (identity config).
  
  Definition maintain {A B C : Type} (function_parameter : net A B C)
    : unit -> Lwt.t unit :=
    let '{| maintenance := maintenance |} := function_parameter in
    fun function_parameter =>
      let 'tt := function_parameter in
      P2p_maintenance.maintain maintenance.
  
  Definition activate {A B C : Type} (t : net A B C) (function_parameter : unit)
    : unit :=
    let 'tt := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "activate" % string
            CamlinternalFormatBasics.End_of_format) "activate" % string) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match welcome t with
      | None => tt
      | Some w => P2p_welcome.activate w
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_maintenance.activate (maintenance t) in
    tt.
  
  Definition roll {A : Type} (_net : A) (function_parameter : unit)
    : Lwt.t unit :=
    let 'tt := function_parameter in
    Lwt.return_unit.
  
  Definition shutdown {A B C : Type}
    (net : net A B C) (function_parameter : unit) : Lwt.t unit :=
    let 'tt := function_parameter in
    op_gtgteq
      (lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Shutting down the p2p's welcome worker..." % string
            CamlinternalFormatBasics.End_of_format)
          "Shutting down the p2p's welcome worker..." % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Lwt_utils.may P2p_welcome.shutdown (welcome net))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (lwt_log_notice
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Shutting down the p2p's network maintenance worker..." %
                      string CamlinternalFormatBasics.End_of_format)
                  "Shutting down the p2p's network maintenance worker..." %
                    string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_maintenance.shutdown (maintenance net))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      (lwt_log_notice
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Shutting down the p2p connection pool..." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Shutting down the p2p connection pool..." % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (P2p_pool.destroy (pool net))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              (lwt_log_notice
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Shutting down the p2p connection handler..."
                                      % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "Shutting down the p2p connection handler..."
                                    % string))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  (P2p_connect_handler.destroy
                                    (connect_handler net))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      (lwt_log_notice
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Shutting down the p2p scheduler..."
                                              % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "Shutting down the p2p scheduler..." %
                                            string))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        P2p_io_scheduler.shutdown
                                          (Some
                                            (* ❌ Float constant 3.0 is approximated by the integer 3 *)
                                            3) (io_sched net)))))))))).
  
  Definition connections {A B C : Type} (function_parameter : net A B C)
    : unit -> list (Tezos_p2p.P2p_conn.t A B C) :=
    let '{| pool := pool |} := function_parameter in
    fun function_parameter =>
      let 'tt := function_parameter in
      P2p_pool.Connection.fold pool []
        (fun _peer_id => fun c => fun acc => cons c acc).
  
  Definition find_connection {A B C : Type} (function_parameter : net A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t ->
      option (Tezos_p2p.P2p_conn.t A B C) :=
    let '{| pool := pool |} := function_parameter in
    fun peer_id => P2p_pool.Connection.find_by_peer_id pool peer_id.
  
  Definition disconnect {A B C : Type}
    (wait : option bool) (conn : Tezos_p2p.P2p_conn.t A B C) : Lwt.t unit :=
    P2p_conn.disconnect wait conn.
  
  Definition connection_info {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D)
    : Tezos_base__TzPervasives.P2p_connection.Info.t D := P2p_conn.info conn.
  
  Definition connection_local_metadata {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) : D :=
    P2p_conn.local_metadata conn.
  
  Definition connection_remote_metadata {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) : D :=
    P2p_conn.remote_metadata conn.
  
  Definition connection_stat {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D)
    : Tezos_base__TzPervasives.P2p_stat.t := P2p_conn.stat conn.
  
  Definition global_stat {A B C : Type} (function_parameter : net A B C)
    : unit -> Tezos_base__TzPervasives.P2p_stat.t :=
    let '{| connect_handler := connect_handler |} := function_parameter in
    fun function_parameter =>
      let 'tt := function_parameter in
      P2p_connect_handler.stat connect_handler.
  
  Definition set_peer_metadata {A B C : Type} (function_parameter : net A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t -> B -> unit :=
    let '{| pool := pool |} := function_parameter in
    fun conn => fun meta => P2p_pool.Peers.set_peer_metadata pool conn meta.
  
  Definition get_peer_metadata {A B C : Type} (function_parameter : net A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t -> B :=
    let '{| pool := pool |} := function_parameter in
    fun conn => P2p_pool.Peers.get_peer_metadata pool conn.
  
  Definition recv {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D)
    : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
    op_gtgteqquestion (P2p_conn.read conn)
      (fun msg =>
        op_gtgteq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "message read from " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "message read from %a" % string) P2p_peer.Id.pp
            (peer_id (P2p_conn.info conn)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            _return msg)).
  
  Fixpoint recv_any {A B C : Type} (net : net A B C) (function_parameter : unit)
    : Lwt.t ((Tezos_p2p.P2p_conn.t A B C) * A) :=
    let 'tt := function_parameter in
    let pipes :=
      P2p_pool.Connection.fold (pool net) []
        (fun _peer_id =>
          fun conn =>
            fun acc =>
              cons
                (op_gtgteq (P2p_conn.is_readable conn)
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Ok tt => Lwt.return_some conn
                    | Stdlib.Error _ => Lwt_utils.never_ending tt
                    end)) acc) in
    op_gtgteq
      (Lwt.pick
        (cons
          (op_gtgteq (P2p_trigger.wait_new_connection (triggers net))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.return_none)) pipes))
      (fun function_parameter =>
        match function_parameter with
        | None => recv_any net tt
        | Some conn =>
          op_gtgteq (P2p_conn.read conn)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok msg =>
                op_gtgteq
                  (lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "message read from " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "message read from %a" % string) P2p_peer.Id.pp
                    (peer_id (P2p_conn.info conn)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt._return (conn, msg))
              | Stdlib.Error _ =>
                op_gtgteq
                  (lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "error reading message from " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "error reading message from %a" % string) P2p_peer.Id.pp
                    (peer_id (P2p_conn.info conn)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (Lwt_unix.yield tt)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        recv_any net tt))
              end)
        end).
  
  Definition send {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) (m : B)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq (P2p_conn.write conn m)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok tt =>
          op_gtgteq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "message sent to " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "message sent to %a" % string) P2p_peer.Id.pp
              (peer_id (P2p_conn.info conn)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        | Stdlib.Error err =>
          op_gtgteq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "error sending message from " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ": " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "error sending message from %a: %a" % string) P2p_peer.Id.pp
              (peer_id (P2p_conn.info conn)) pp_print_error err)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.return_error err)
        end).
  
  Definition try_send {A B C D : Type}
    (_net : A) (conn : Tezos_p2p.P2p_conn.t B C D) (v : B) : bool :=
    match P2p_conn.write_now conn v with
    | Stdlib.Ok v =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "message trysent to " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "message trysent to %a" % string) P2p_peer.Id.pp
          (peer_id (P2p_conn.info conn)) in
      v
    | Stdlib.Error err =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "error trysending message to " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))))
            "error trysending message to %a@ %a" % string) P2p_peer.Id.pp
          (peer_id (P2p_conn.info conn)) pp_print_error err in
      false
    end.
  
  Definition broadcast {A B C : Type} (function_parameter : net A B C)
    : A -> unit :=
    let '{| pool := pool |} := function_parameter in
    fun msg =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        P2p_peer.Table.iter
          (fun _peer_id =>
            fun peer_info =>
              match P2p_peer_state.get peer_info with
              | Tezos_p2p.P2p_peer_state.Running {| data := conn |} =>
                OCaml.Stdlib.ignore (P2p_conn.write_now conn msg)
              | _ => tt
              end) (P2p_pool.connected_peer_ids pool) in
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "message broadcasted" % string
            CamlinternalFormatBasics.End_of_format)
          "message broadcasted" % string).
  
  Definition fold_connections {A B C D : Type} (function_parameter : net A B C)
    : D ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (Tezos_p2p.P2p_conn.t A B C) -> D -> D) -> D :=
    let '{| pool := pool |} := function_parameter in
    fun init => fun f => P2p_pool.Connection.fold pool init f.
  
  Definition iter_connections {A B C : Type} (function_parameter : net A B C)
    : (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (Tezos_p2p.P2p_conn.t A B C) -> unit) -> unit :=
    let '{| pool := pool |} := function_parameter in
    fun f =>
      P2p_pool.Connection.fold pool tt
        (fun gid =>
          fun conn =>
            fun function_parameter =>
              let 'tt := function_parameter in
              f gid conn).
  
  Definition on_new_connection {A B C : Type} (function_parameter : net A B C)
    : (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (Tezos_p2p.P2p_conn.t A B C) -> unit) -> unit :=
    let '{| connect_handler := connect_handler |} := function_parameter in
    fun f => P2p_connect_handler.on_new_connection connect_handler f.
End Real.

Module Fake.
  Definition id : Tezos_base__TzPervasives.P2p_identity.t :=
    P2p_identity.generate
      (Crypto_box.make_target
        (* ❌ Float constant 0. is approximated by the integer 0 *)
        0).
  
  Definition empty_stat : Tezos_base__TzPervasives.P2p_stat.t :=
    {|
      P2p_stat.total_sent :=
        (* ❌ Constant of type int64 is converted to int *)
        0;
      P2p_stat.total_recv :=
        (* ❌ Constant of type int64 is converted to int *)
        0; P2p_stat.current_inflow := 0; P2p_stat.current_outflow := 0 |}.
  
  Definition connection_info {A : Type}
    (announced_version : Tezos_base.Network_version.t) (faked_metadata : A)
    : Tezos_base__TzPervasives.P2p_connection.Info.t A :=
    {| P2p_connection.Info.incoming := false;
      P2p_connection.Info.peer_id := peer_id id;
      P2p_connection.Info.id_point := (Ipaddr.V6.unspecified, None);
      P2p_connection.Info.remote_socket_port := 0;
      P2p_connection.Info.announced_version := announced_version;
      P2p_connection.Info.private_node := false;
      P2p_connection.Info.local_metadata := faked_metadata;
      P2p_connection.Info.remote_metadata := faked_metadata |}.
End Fake.

Record t {msg peer_meta conn_meta : Type} := {
  announced_version : Tezos_base__TzPervasives.Network_version.t;
  peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
  maintain : unit -> Lwt.t unit;
  roll : unit -> Lwt.t unit;
  shutdown : unit -> Lwt.t unit;
  connections : unit -> list (connection msg peer_meta conn_meta);
  find_connection :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      option (connection msg peer_meta conn_meta);
  disconnect :
    (option bool) -> (connection msg peer_meta conn_meta) -> Lwt.t unit;
  connection_info :
    (connection msg peer_meta conn_meta) ->
      Tezos_base__TzPervasives.P2p_connection.Info.t conn_meta;
  connection_local_metadata : (connection msg peer_meta conn_meta) -> conn_meta;
  connection_remote_metadata : (connection msg peer_meta conn_meta) -> conn_meta;
  connection_stat :
    (connection msg peer_meta conn_meta) -> Tezos_base__TzPervasives.P2p_stat.t;
  global_stat : unit -> Tezos_base__TzPervasives.P2p_stat.t;
  get_peer_metadata : Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta;
  set_peer_metadata :
    Tezos_base__TzPervasives.P2p_peer.Id.t -> peer_meta -> unit;
  recv :
    (connection msg peer_meta conn_meta) ->
      Lwt.t (Tezos_base__TzPervasives.tzresult msg);
  recv_any : unit -> Lwt.t ((connection msg peer_meta conn_meta) * msg);
  send :
    (connection msg peer_meta conn_meta) ->
      msg -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
  try_send : (connection msg peer_meta conn_meta) -> msg -> bool;
  broadcast : msg -> unit;
  pool : option (Tezos_p2p.P2p_pool.t msg peer_meta conn_meta);
  connect_handler :
    option (Tezos_p2p.P2p_connect_handler.t msg peer_meta conn_meta);
  fold_connections :
    (a ->
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (connection msg peer_meta conn_meta) -> a -> a) -> a) * (a);
  iter_connections :
    (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (connection msg peer_meta conn_meta) -> unit) -> unit;
  on_new_connection :
    (Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (connection msg peer_meta conn_meta) -> unit) -> unit;
  activate : unit -> unit;
  watcher :
    Tezos_stdlib.Lwt_watcher.input
      Tezos_base__TzPervasives.P2p_connection.P2p_event.t }.
Arguments t : clear implicits.

Definition net (msg peer_meta conn_meta : Type) := t msg peer_meta conn_meta.

Definition announced_version {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.Network_version.t := announced_version net.

Definition pool {A B C : Type} (net : t A B C)
  : option (Tezos_p2p.P2p_pool.t A B C) := pool net.

Definition connect_handler {A B C : Type} (net : t A B C)
  : option (Tezos_p2p.P2p_connect_handler.t A B C) := connect_handler net.

Definition check_limits
  : limits -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let fail_1 (v : Ptime.span) (orig : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    if negb (OCaml.Stdlib.le (Ptime.Span.compare v Ptime.Span.zero) 0) then
      return_unit
    else
      Error_monad.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "value of option " % string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " cannot be negative or null" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "value of option %S cannot be negative or null@." % string) orig in
  let fail_2 (v : Z) (orig : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    if negb (OCaml.Stdlib.lt v 0) then
      return_unit
    else
      Error_monad.failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "value of option " % string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " cannot be negative" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Flush_newline
                  CamlinternalFormatBasics.End_of_format))))
          "value of option %S cannot be negative@." % string) orig in
  fun c =>
    op_gtgteqquestion
      (fail_1 (authentication_timeout c) "authentication-timeout" % string)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (fail_2 (min_connections c) "min-connections" % string)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (fail_2 (expected_connections c) "expected-connections" % string)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (fail_2 (max_connections c) "max-connections" % string)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion
                      (fail_2 (max_incoming_connections c)
                        "max-incoming-connections" % string)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (fail_2 (read_buffer_size c)
                            "read-buffer-size" % string)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (fail_2 (known_peer_ids_history_size c)
                                "known-peer-ids-history-size" % string)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion
                                  (fail_2 (known_points_history_size c)
                                    "known-points-history-size" % string)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (fail_1 (swap_linger c)
                                        "swap-linger" % string)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteqquestion
                                          match binary_chunks_size c with
                                          | None => return_unit
                                          | Some size =>
                                            P2p_socket.check_binary_chunks_size
                                              size
                                          end
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            return_unit)))))))))).

Definition create {A B C : Type}
  (config : config) (limits : limits)
  (peer_cfg : Tezos_p2p.P2p_pool.peer_meta_config A)
  (conn_cfg : Tezos_p2p.P2p_socket.metadata_config B)
  (msg_cfg : Tezos_p2p.P2p_connect_handler.message_config C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (t C A B)) :=
  op_gtgteqquestion (check_limits limits)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (Real.create config limits peer_cfg msg_cfg conn_cfg)
        (fun net =>
          _return
            {|
              announced_version :=
                Network_version.announced (chain_name msg_cfg)
                  (distributed_db_versions msg_cfg) P2p_version.supported;
              peer_id := Real.peer_id net; maintain := Real.maintain net;
              roll := Real.roll net; shutdown := Real.shutdown net;
              connections := Real.connections net;
              find_connection := Real.find_connection net;
              disconnect := Real.disconnect;
              connection_info := Real.connection_info net;
              connection_local_metadata := Real.connection_local_metadata net;
              connection_remote_metadata := Real.connection_remote_metadata net;
              connection_stat := Real.connection_stat net;
              global_stat := Real.global_stat net;
              get_peer_metadata := Real.get_peer_metadata net;
              set_peer_metadata := Real.set_peer_metadata net;
              recv := Real.recv net; recv_any := Real.recv_any net;
              send := Real.send net; try_send := Real.try_send net;
              broadcast := Real.broadcast net; pool := Some (pool net);
              connect_handler := Some (connect_handler net);
              fold_connections :=
                fun init => fun f => Real.fold_connections net init f;
              iter_connections := Real.iter_connections net;
              on_new_connection := Real.on_new_connection net;
              activate := Real.activate net; watcher := Real.watcher net |})).

Definition activate {A B C : Type} (t : t A B C) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "activate P2P layer !" % string
          CamlinternalFormatBasics.End_of_format)
        "activate P2P layer !" % string) in
  (activate t) tt.

Definition faked_network {B C D msg : Type}
  (msg_cfg : message_config msg) (peer_cfg : peer_meta_config B)
  (faked_metadata : C) : t D B C :=
  let announced_version :=
    Network_version.announced (chain_name msg_cfg)
      (distributed_db_versions msg_cfg) P2p_version.supported in
  {| announced_version := announced_version; peer_id := peer_id Fake.id;
    maintain := Lwt._return; roll := Lwt._return; shutdown := Lwt._return;
    connections :=
      fun function_parameter =>
        let 'tt := function_parameter in
        [];
    find_connection :=
      fun function_parameter =>
        let '_ := function_parameter in
        None;
    disconnect :=
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          Lwt.return_unit;
    connection_info :=
      fun function_parameter =>
        let '_ := function_parameter in
        Fake.connection_info announced_version faked_metadata;
    connection_local_metadata :=
      fun function_parameter =>
        let '_ := function_parameter in
        faked_metadata;
    connection_remote_metadata :=
      fun function_parameter =>
        let '_ := function_parameter in
        faked_metadata;
    connection_stat :=
      fun function_parameter =>
        let '_ := function_parameter in
        Fake.empty_stat;
    global_stat :=
      fun function_parameter =>
        let 'tt := function_parameter in
        Fake.empty_stat;
    get_peer_metadata :=
      fun function_parameter =>
        let '_ := function_parameter in
        (peer_meta_initial peer_cfg) tt;
    set_peer_metadata :=
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          tt;
    recv :=
      fun function_parameter =>
        let '_ := function_parameter in
        Lwt_utils.never_ending tt;
    recv_any :=
      fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_utils.never_ending tt;
    send :=
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          fail Tezos_base__TzPervasives.Connection_closed;
    try_send :=
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          false; broadcast := OCaml.Stdlib.ignore; pool := None;
    connect_handler := None;
    fold_connections :=
      fun init =>
        fun function_parameter =>
          let '_ := function_parameter in
          init; iter_connections := fun _f => tt;
    on_new_connection := fun _f => tt;
    activate :=
      fun function_parameter =>
        let '_ := function_parameter in
        tt; watcher := Lwt_watcher.create_input tt |}.

Definition peer_id {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t := peer_id net.

Definition maintain {A B C : Type} (net : t A B C) : Lwt.t unit :=
  (maintain net) tt.

Definition roll {A B C : Type} (net : t A B C) : Lwt.t unit := (roll net) tt.

Definition shutdown {A B C : Type} (net : t A B C) : Lwt.t unit :=
  (shutdown net) tt.

Definition connections {A B C : Type} (net : t A B C)
  : list (connection A B C) := (connections net) tt.

Definition disconnect {A B C : Type} (net : t A B C)
  : (option bool) -> (connection A B C) -> Lwt.t unit := disconnect net.

Definition find_connection {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> option (connection A B C) :=
  find_connection net.

Definition connection_info {A B C : Type} (net : t A B C)
  : (connection A B C) -> Tezos_base__TzPervasives.P2p_connection.Info.t C :=
  connection_info net.

Definition connection_local_metadata {A B C : Type} (net : t A B C)
  : (connection A B C) -> C := connection_local_metadata net.

Definition connection_remote_metadata {A B C : Type} (net : t A B C)
  : (connection A B C) -> C := connection_remote_metadata net.

Definition connection_stat {A B C : Type} (net : t A B C)
  : (connection A B C) -> Tezos_base__TzPervasives.P2p_stat.t :=
  connection_stat net.

Definition global_stat {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_stat.t := (global_stat net) tt.

Definition get_peer_metadata {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> B := get_peer_metadata net.

Definition set_peer_metadata {A B C : Type} (net : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> B -> unit := set_peer_metadata net.

Definition recv {A B C : Type} (net : t A B C)
  : (connection A B C) -> Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  recv net.

Definition recv_any {A B C : Type} (net : t A B C)
  : Lwt.t ((connection A B C) * A) := (recv_any net) tt.

Definition send {A B C : Type} (net : t A B C)
  : (connection A B C) -> A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  send net.

Definition try_send {A B C : Type} (net : t A B C)
  : (connection A B C) -> A -> bool := try_send net.

Definition broadcast {A B C : Type} (net : t A B C) : A -> unit := broadcast net.

Definition fold_connections {A B C D : Type} (net : t A B C)
  : D ->
    (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> D -> D) ->
      D := fold_connections net.

Definition iter_connections {A B C : Type} (net : t A B C)
  : (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit) ->
    unit := iter_connections net.

Definition on_new_connection {A B C : Type} (net : t A B C)
  : (Tezos_base__TzPervasives.P2p_peer.Id.t -> (connection A B C) -> unit) ->
    unit := on_new_connection net.

Definition greylist_addr {A B C : Type}
  (net : t A B C) (addr : Tezos_base__TzPervasives.P2p_addr.t) : unit :=
  Option.iter (fun pool => P2p_pool.greylist_addr pool addr) (pool net).

Definition greylist_peer {A B C : Type}
  (net : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
  Option.iter (fun pool => P2p_pool.greylist_peer pool peer_id) (pool net).

Definition watcher {A B C : Type} (net : t A B C)
  : (Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.P2p_event.t) *
    Tezos_stdlib.Lwt_watcher.stopper := Lwt_watcher.create_stream (watcher net).

src/lib_p2p/p2p_acl.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module PeerRing = Ring.MakeTable (struct
  include P2p_peer.Id
end)

module PatriciaTree (V : HashPtree.Value) = struct
  module Size = struct
    let size = 128
  end

  module Bits = HashPtree.Bits (Size)
  module M = HashPtree.Make_BE_sized (V) (Size)

  type t = M.t

  let empty = M.empty

  (* take into consideration the fact that the int64
   * returned by Ipaddr.V6.to_int64 is signed *)
  let z_of_bytes i =
    let i = Z.of_int64 i in
    Z.(if i < zero then i + (of_int 2 ** 64) else i)

  let z_of_ipv6 ip =
    let (hi_x, lo_x) = Ipaddr.V6.to_int64 ip in
    let hi = z_of_bytes hi_x in
    let lo = z_of_bytes lo_x in
    Z.((hi lsl 64) + lo)

  let key_of_ipv6 ip = Bits.of_z (z_of_ipv6 ip)

  let z_mask_of_ipv6_prefix p =
    let ip = Ipaddr.V6.Prefix.network p in
    let len = Ipaddr.V6.Prefix.bits p in
    (z_of_ipv6 ip, Z.( lsl ) Z.one (128 - len))

  let key_mask_of_ipv6_prefix p =
    let (z, m) = z_mask_of_ipv6_prefix p in
    (Bits.of_z z, Bits.of_z m)

  let z_to_ipv6 z =
    (* assumes z is a 128 bit value *)
    let hi_z = Z.(z asr 64) in
    let hi =
      if Z.(hi_z >= of_int 2 ** 63) then
        (* If overflows int64, then returns the bit equivalent
           representation (which is negative) *)
        Int64.add 0x8000000000000000L Z.(to_int64 (hi_z - (of_int 2 ** 63)))
      else Z.(to_int64 hi_z)
    in
    let lo = Z.(to_int64 (z mod pow ~$2 64)) in
    Ipaddr.V6.of_int64 (hi, lo)

  let remove key t = M.remove (key_of_ipv6 key) t

  let remove_prefix prefix t =
    let (key, mask) = key_mask_of_ipv6_prefix prefix in
    M.remove_prefix key mask t

  let add_prefix prefix value t =
    let (key, mask) = key_mask_of_ipv6_prefix prefix in
    M.add (fun _ v -> v) ~key ~value ~mask t

  let add key value t =
    let key = key_of_ipv6 key in
    M.add (fun _ v -> v) ~key ~value t

  let mem key t = M.mem (key_of_ipv6 key) t

  let key_mask_to_prefix key mask =
    let len =
      if Bits.(equal mask zero) then 0
      else 128 - Z.trailing_zeros (Bits.to_z mask)
    in
    Ipaddr.V6.Prefix.make len (z_to_ipv6 (Bits.to_z key))

  let fold f t acc =
    let f key mask value acc =
      let prefix = key_mask_to_prefix key mask in
      f prefix value acc
    in
    M.fold f t acc

  let pp ppf t =
    let lst = fold (fun p _ l -> p :: l) t [] in
    Format.fprintf
      ppf
      "@[<2>[%a]@]"
      Format.(
        pp_print_list
          ~pp_sep:(fun ppf () -> fprintf ppf ";@ ")
          Ipaddr.V6.Prefix.pp)
      lst
end

(* patricia trees using IpV6 addresses as keys *)
module IpSet = struct
  include PatriciaTree (Time.System)

  let remove_old t ~older_than =
    let module MI = struct
      type result = Time.System.t

      let default = Ptime.max

      let map _t _key value = value

      let reduce _t left right = Time.System.(min left right)
    end in
    let module MR = M.Map_Reduce (MI) in
    MR.filter (fun addtime -> Time.System.(older_than <= addtime)) t
end

module IpTable = Hashtbl.Make (struct
  type t = Ipaddr.V6.t

  let hash = Hashtbl.hash

  let equal x y = Ipaddr.V6.compare x y = 0
end)

type t = {
  mutable greylist_ips : IpSet.t;
  greylist_peers : PeerRing.t;
  banned_ips : unit IpTable.t;
  banned_peers : unit P2p_peer.Table.t;
}

let create size =
  {
    greylist_ips = IpSet.empty;
    greylist_peers = PeerRing.create size;
    banned_ips = IpTable.create 53;
    banned_peers = P2p_peer.Table.create 53;
  }

(* check if an ip is banned. priority is for static blacklist, then
   in the greylist *)
let banned_addr acl addr =
  IpTable.mem acl.banned_ips addr || IpSet.mem addr acl.greylist_ips

let unban_addr acl addr =
  IpTable.remove acl.banned_ips addr ;
  acl.greylist_ips <- IpSet.remove addr acl.greylist_ips

(* Check is the peer_id is in the banned ring. It might be possible that
   a peer ID that is not banned, but its ip address is. *)
let banned_peer acl peer_id =
  P2p_peer.Table.mem acl.banned_peers peer_id
  || PeerRing.mem acl.greylist_peers peer_id

let unban_peer acl peer_id =
  P2p_peer.Table.remove acl.banned_peers peer_id ;
  PeerRing.remove acl.greylist_peers peer_id

let clear acl =
  acl.greylist_ips <- IpSet.empty ;
  P2p_peer.Table.clear acl.banned_peers ;
  IpTable.clear acl.banned_ips ;
  PeerRing.clear acl.greylist_peers

module IPGreylist = struct
  let add acl addr time =
    acl.greylist_ips <- IpSet.add addr time acl.greylist_ips

  let mem acl addr = IpSet.mem addr acl.greylist_ips

  (* The GC operation works only on the address set. Peers are removed
     from the ring in a round-robin fashion. If a address is removed
     by the GC from the acl.greylist set, it could potentially
     persist in the acl.peers set until more peers are banned. *)
  let remove_old acl ~older_than =
    acl.greylist_ips <- IpSet.remove_old acl.greylist_ips ~older_than

  let encoding = Data_encoding.(list P2p_addr.encoding)
end

module IPBlacklist = struct
  let add acl addr = IpTable.add acl.banned_ips addr ()

  let mem acl addr = IpTable.mem acl.banned_ips addr
end

module PeerBlacklist = struct
  let add acl addr = P2p_peer.Table.add acl.banned_peers addr ()

  let mem acl addr = P2p_peer.Table.mem acl.banned_peers addr
end

module PeerGreylist = struct
  let add acl peer_id = PeerRing.add acl.greylist_peers peer_id

  let mem acl peer_id = PeerRing.mem acl.greylist_peers peer_id
end
src/lib_p2p/p2p_acl.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Functors are not handled. *)
functor

Module IpSet.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition remove_old
    (t : M.t) (older_than : Tezos_base__TzPervasives.Time.System.t) : M.t :=
    let MI :=
      existT _ unit
        {|
          M.Map_Reduce.default := Ptime.max;
          (* ❌ This kind of definition of value for first-class modules is not handled *)
          M.Map_Reduce.map := unhandled;
          (* ❌ This kind of definition of value for first-class modules is not handled *)
          M.Map_Reduce.reduce := unhandled
          |} in
    let MR :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    MR.filter (fun addtime => op_lteq older_than addtime) t.
End IpSet.

(* ❌ Applications of functors are not handled. *)
functor_application

Record t := {
  greylist_ips : IpSet.t;
  greylist_peers : PeerRing.t;
  banned_ips : IpTable.t unit;
  banned_peers : Tezos_base__TzPervasives.P2p_peer.Table.t unit }.

Definition create (size : Z) : t :=
  {| greylist_ips := IpSet.empty; greylist_peers := PeerRing.create size;
    banned_ips := IpTable.create 53; banned_peers := P2p_peer.Table.create 53 |}.

Definition banned_addr (acl : t) (addr : IpTable.key) : bool :=
  orb (IpTable.mem (banned_ips acl) addr) (IpSet.mem addr (greylist_ips acl)).

Definition unban_addr (acl : t) (addr : IpTable.key) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := IpTable.remove (banned_ips acl) addr in
  (* ❌ Set record field not handled. *)
  set_record_field acl "greylist_ips" % string
    (IpSet.remove addr (greylist_ips acl)).

Definition banned_peer
  (acl : t) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key) : bool :=
  orb (P2p_peer.Table.mem (banned_peers acl) peer_id)
    (PeerRing.mem (greylist_peers acl) peer_id).

Definition unban_peer
  (acl : t) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_peer.Table.remove (banned_peers acl) peer_id in
  PeerRing.remove (greylist_peers acl) peer_id.

Definition clear (acl : t) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field acl "greylist_ips" % string IpSet.empty in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_peer.Table.clear (banned_peers acl) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := IpTable.clear (banned_ips acl) in
  PeerRing.clear (greylist_peers acl).

Module IPGreylist.
  Definition add (acl : t) (addr : Ipaddr.V6.t) (time : IpSet.M.value) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field acl "greylist_ips" % string
      (IpSet.add addr time (greylist_ips acl)).
  
  Definition mem (acl : t) (addr : Ipaddr.V6.t) : bool :=
    IpSet.mem addr (greylist_ips acl).
  
  Definition remove_old
    (acl : t) (older_than : Tezos_base__TzPervasives.Time.System.t) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field acl "greylist_ips" % string
      (IpSet.remove_old (greylist_ips acl) older_than).
  
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.P2p_addr.t) := list None P2p_addr.encoding.
End IPGreylist.

Module IPBlacklist.
  Definition add (acl : t) (addr : IpTable.key) : unit :=
    IpTable.add (banned_ips acl) addr tt.
  
  Definition mem (acl : t) (addr : IpTable.key) : bool :=
    IpTable.mem (banned_ips acl) addr.
End IPBlacklist.

Module PeerBlacklist.
  Definition add (acl : t) (addr : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit := P2p_peer.Table.add (banned_peers acl) addr tt.
  
  Definition mem (acl : t) (addr : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : bool := P2p_peer.Table.mem (banned_peers acl) addr.
End PeerBlacklist.

Module PeerGreylist.
  Definition add (acl : t) (peer_id : PeerRing.v) : unit :=
    PeerRing.add (greylist_peers acl) peer_id.
  
  Definition mem (acl : t) (peer_id : PeerRing.v) : bool :=
    PeerRing.mem (greylist_peers acl) peer_id.
End PeerGreylist.

src/lib_p2p/p2p_answerer.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** An [Answerer.t] is a set of callback functions, parameterized by
    [conn_info] record. The [conn_info] records contains values useful
    for the callback functions to perfom their task, and known after
    the connection is set up.

    The callback functions are called when the node receives `P2p_messages.t`
    messages. The parameters are the values carried by the message, and
    a [request_info] record that contains values pertaining to the connection
    that may change during the life of the connection. *)

type 'msg conn_info = {
  peer_id : P2p_peer.Id.t;
  is_private : bool;
  write_swap_ack : P2p_point.Id.t -> P2p_peer.Id.t -> bool tzresult;
  messages : (int * 'msg) Lwt_pipe.t;
}

type request_info = {
  last_sent_swap_request : (Time.System.t * P2p_peer.Id.t) option;
}

type 'msg callback = {
  bootstrap : request_info -> P2p_point.Id.t list Lwt.t;
  advertise : request_info -> P2p_point.Id.t list -> unit Lwt.t;
  message : request_info -> int -> 'msg -> unit Lwt.t;
  swap_request : request_info -> P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
  swap_ack : request_info -> P2p_point.Id.t -> P2p_peer.Id.t -> unit Lwt.t;
}

type 'msg t = 'msg conn_info -> 'msg callback
src/lib_p2p/p2p_answerer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record conn_info {msg : Type} := {
  peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
  is_private : bool;
  write_swap_ack :
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t ->
        Tezos_base__TzPervasives.tzresult bool;
  messages : Tezos_stdlib.Lwt_pipe.t (Z * msg) }.
Arguments conn_info : clear implicits.

Record request_info := {
  last_sent_swap_request :
    option
      (Tezos_base__TzPervasives.Time.System.t *
        Tezos_base__TzPervasives.P2p_peer.Id.t) }.

Record callback {msg : Type} := {
  bootstrap :
    request_info -> Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t);
  advertise :
    request_info -> (list Tezos_base__TzPervasives.P2p_point.Id.t) -> Lwt.t unit;
  message : request_info -> Z -> msg -> Lwt.t unit;
  swap_request :
    request_info ->
      Tezos_base__TzPervasives.P2p_point.Id.t ->
        Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit;
  swap_ack :
    request_info ->
      Tezos_base__TzPervasives.P2p_point.Id.t ->
        Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit }.
Arguments callback : clear implicits.

Definition t (msg : Type) := (conn_info msg) -> callback msg.

src/lib_p2p/p2p_conn.ml 21 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.conn"
end)

type ('msg, 'peer, 'conn) t = {
  canceler : Lwt_canceler.t;
  messages : (int * 'msg) Lwt_pipe.t;
  conn : ('msg P2p_message.t, 'conn) P2p_socket.t;
  peer_info : (('msg, 'peer, 'conn) t, 'peer, 'conn) P2p_peer_state.Info.t;
  point_info : ('msg, 'peer, 'conn) t P2p_point_state.Info.t option;
  negotiated_version : Network_version.t;
  mutable last_sent_swap_request : (Time.System.t * P2p_peer.Id.t) option;
  mutable wait_close : bool;
  mutable worker : unit Lwt.t option;
  peer_id : P2p_peer.Id.t;
  trusted_node : bool;
  private_node : bool;
}

let rec worker_loop (t : ('msg, 'peer, 'conn) t) callback =
  let open P2p_answerer in
  let request_info =
    P2p_answerer.{last_sent_swap_request = t.last_sent_swap_request}
  in
  Lwt_unix.yield ()
  >>= fun () ->
  protect ~canceler:t.canceler (fun () -> P2p_socket.read t.conn)
  >>= function
  | Ok (_, Bootstrap) -> (
      (* callback.bootstrap will return an empty list if the node
         is in private mode *)
      callback.bootstrap request_info
      >>= function
      | [] ->
          worker_loop t callback
      | points -> (
        match P2p_socket.write_now t.conn (Advertise points) with
        | Ok _sent ->
            (* if not sent then ?? TODO count dropped message ?? *)
            worker_loop t callback
        | Error _ ->
            Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit ) )
  | Ok (_, Advertise points) ->
      (* callback.advertise will ignore the points if the node is
         in private mode *)
      callback.advertise request_info points
      >>= fun () -> worker_loop t callback
  | Ok (_, Swap_request (point, peer)) ->
      callback.swap_request request_info point peer
      >>= fun () -> worker_loop t callback
  | Ok (_, Swap_ack (point, peer)) ->
      callback.swap_ack request_info point peer
      >>= fun () -> worker_loop t callback
  | Ok (size, Message msg) ->
      callback.message request_info size msg
      >>= fun () -> worker_loop t callback
  | Ok (_, Disconnect) | Error (P2p_errors.Connection_closed :: _) ->
      Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit
  | Error (P2p_errors.Decoding_error :: _) ->
      (* TODO: Penalize peer... *)
      Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit
  | Error (Canceled :: _) ->
      Lwt.return_unit
  | Error err ->
      lwt_log_error
        "@[Answerer unexpected error:@ %a@]"
        Error_monad.pp_print_error
        err
      >>= fun () ->
      Lwt_canceler.cancel t.canceler >>= fun () -> Lwt.return_unit

let shutdown t =
  match t.worker with
  | None ->
      Lwt.return_unit
  | Some w ->
      Lwt_canceler.cancel t.canceler >>= fun () -> w

let write_swap_ack t point peer_id =
  P2p_socket.write_now t.conn (Swap_request (point, peer_id))

let create conn point_info peer_info messages canceler callback
    negotiated_version =
  let private_node = P2p_socket.private_node conn in
  let trusted_node =
    P2p_peer_state.Info.trusted peer_info
    || Option.unopt_map
         ~default:false
         ~f:P2p_point_state.Info.trusted
         point_info
  in
  let peer_id = peer_info |> P2p_peer_state.Info.peer_id in
  let t =
    {
      conn;
      point_info;
      peer_info;
      messages;
      canceler;
      wait_close = false;
      last_sent_swap_request = None;
      negotiated_version;
      worker = None;
      peer_id;
      private_node;
      trusted_node;
    }
  in
  let conn_info =
    P2p_answerer.
      {
        peer_id = t.peer_info |> P2p_peer_state.Info.peer_id;
        is_private = P2p_socket.private_node t.conn;
        write_swap_ack = write_swap_ack t;
        messages;
      }
  in
  t.worker <-
    Some
      (Lwt_utils.worker
         "answerer"
         ~on_event:Internal_event.Lwt_worker_event.on_event
         ~run:(fun () -> worker_loop t (callback conn_info))
         ~cancel:(fun () -> Lwt_canceler.cancel t.canceler)) ;
  t

let pipe_exn_handler = function
  | Lwt_pipe.Closed ->
      fail P2p_errors.Connection_closed
  | _ ->
      assert false

(* see [Lwt_pipe.pop] *)

let read t =
  Lwt.catch
    (fun () ->
      Lwt_pipe.pop t.messages
      >>= fun (s, msg) ->
      lwt_debug
        "%d bytes message popped from queue %a\027[0m"
        s
        P2p_peer.Id.pp
        (P2p_socket.info t.conn).peer_id
      >>= fun () -> return msg)
    pipe_exn_handler

let is_readable t =
  Lwt.catch
    (fun () -> Lwt_pipe.values_available t.messages >>= return)
    pipe_exn_handler

let write t msg = P2p_socket.write t.conn (Message msg)

let write_sync t msg = P2p_socket.write_sync t.conn (Message msg)

let raw_write_sync t buf = P2p_socket.raw_write_sync t.conn buf

let write_now t msg = P2p_socket.write_now t.conn (Message msg)

let write_swap_request t point peer_id =
  t.last_sent_swap_request <- Some (Systime_os.now (), peer_id) ;
  P2p_socket.write_now t.conn (Swap_request (point, peer_id))

let write_bootstrap t = P2p_socket.write_now t.conn Bootstrap

let stat t = P2p_socket.stat t.conn

let info t = P2p_socket.info t.conn

let local_metadata t = P2p_socket.local_metadata t.conn

let remote_metadata t = P2p_socket.remote_metadata t.conn

let disconnect ?(wait = false) t =
  t.wait_close <- wait ;
  shutdown t

let close t = P2p_socket.close ~wait:t.wait_close t.conn

let equal_sock t t' = P2p_socket.equal t.conn t'.conn

let private_node t = t.private_node

let peer_id t = t.peer_id

let trusted_node t = t.trusted_node
src/lib_p2p/p2p_conn.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Record t {msg peer conn : Type} := {
  canceler : Tezos_stdlib.Lwt_canceler.t;
  messages : Tezos_stdlib.Lwt_pipe.t (Z * msg);
  conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t msg) conn;
  peer_info : Tezos_p2p.P2p_peer_state.Info.t (t msg peer conn) peer conn;
  point_info : option (Tezos_p2p.P2p_point_state.Info.t (t msg peer conn));
  negotiated_version : Tezos_base__TzPervasives.Network_version.t;
  last_sent_swap_request :
    option
      (Tezos_base__TzPervasives.Time.System.t *
        Tezos_base__TzPervasives.P2p_peer.Id.t);
  wait_close : bool;
  worker : option (Lwt.t unit);
  peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
  trusted_node : bool;
  private_node : bool }.
Arguments t : clear implicits.

Fixpoint worker_loop {conn msg peer : Type}
  (t : t msg peer conn) (callback : Tezos_p2p.P2p_answerer.callback msg)
  : Lwt.t unit :=
  let request_info := {| last_sent_swap_request := last_sent_swap_request t |}
    in
  op_gtgteq (Lwt_unix.yield tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (protect None (Some (canceler t))
          (fun function_parameter =>
            let 'tt := function_parameter in
            P2p_socket.read (conn t)))
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok (_, Tezos_p2p.P2p_message.Bootstrap) =>
            op_gtgteq ((bootstrap callback) request_info)
              (fun function_parameter =>
                match function_parameter with
                | [] => worker_loop t callback
                | points =>
                  match
                    P2p_socket.write_now (conn t)
                      (Tezos_p2p.P2p_message.Advertise points) with
                  | Stdlib.Ok _sent => worker_loop t callback
                  | Stdlib.Error _ =>
                    op_gtgteq (Lwt_canceler.cancel (canceler t))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Lwt.return_unit)
                  end
                end)
          | Stdlib.Ok (_, Tezos_p2p.P2p_message.Advertise points) =>
            op_gtgteq ((advertise callback) request_info points)
              (fun function_parameter =>
                let 'tt := function_parameter in
                worker_loop t callback)
          | Stdlib.Ok (_, Tezos_p2p.P2p_message.Swap_request point peer) =>
            op_gtgteq ((swap_request callback) request_info point peer)
              (fun function_parameter =>
                let 'tt := function_parameter in
                worker_loop t callback)
          | Stdlib.Ok (_, Tezos_p2p.P2p_message.Swap_ack point peer) =>
            op_gtgteq ((swap_ack callback) request_info point peer)
              (fun function_parameter =>
                let 'tt := function_parameter in
                worker_loop t callback)
          | Stdlib.Ok (size, Tezos_p2p.P2p_message.Message msg) =>
            op_gtgteq ((message callback) request_info size msg)
              (fun function_parameter =>
                let 'tt := function_parameter in
                worker_loop t callback)
          |
            Stdlib.Ok (_, Tezos_p2p.P2p_message.Disconnect) |
              Stdlib.Error (cons Tezos_base__TzPervasives.Connection_closed _)
            =>
            op_gtgteq (Lwt_canceler.cancel (canceler t))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.return_unit)
          | Stdlib.Error (cons Tezos_base__TzPervasives.Decoding_error _) =>
            op_gtgteq (Lwt_canceler.cancel (canceler t))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.return_unit)
          | Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
            Lwt.return_unit
          | Stdlib.Error err =>
            op_gtgteq
              (lwt_log_error
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Answerer unexpected error:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))
                  "@[Answerer unexpected error:@ %a@]" % string)
                Error_monad.pp_print_error err)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Lwt_canceler.cancel (canceler t))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt.return_unit))
          end)).

Definition shutdown {A B C : Type} (t : t A B C) : Lwt.t unit :=
  match worker t with
  | None => Lwt.return_unit
  | Some w =>
    op_gtgteq (Lwt_canceler.cancel (canceler t))
      (fun function_parameter =>
        let 'tt := function_parameter in
        w)
  end.

Definition write_swap_ack {A B C : Type}
  (t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
  : Tezos_base__TzPervasives.tzresult bool :=
  P2p_socket.write_now (conn t)
    (Tezos_p2p.P2p_message.Swap_request point peer_id).

Definition create {A B C : Type}
  (conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t A) B)
  (point_info : option (Tezos_p2p.P2p_point_state.Info.t (t A C B)))
  (peer_info : Tezos_p2p.P2p_peer_state.Info.peer_info (t A C B) C B)
  (messages : Tezos_stdlib.Lwt_pipe.t (Z * A))
  (canceler : Tezos_stdlib.Lwt_canceler.t)
  (callback :
    (Tezos_p2p.P2p_answerer.conn_info A) -> Tezos_p2p.P2p_answerer.callback A)
  (negotiated_version : Tezos_base__TzPervasives.Network_version.t) : t A C B :=
  let private_node := P2p_socket.private_node conn in
  let trusted_node :=
    orb (P2p_peer_state.Info.trusted peer_info)
      (Option.unopt_map P2p_point_state.Info.trusted false point_info) in
  let peer_id :=
    OCaml.Stdlib.reverse_apply peer_info P2p_peer_state.Info.peer_id in
  let t :=
    {| canceler := canceler; messages := messages; conn := conn;
      peer_info := peer_info; point_info := point_info;
      negotiated_version := negotiated_version; last_sent_swap_request := None;
      wait_close := false; worker := None; peer_id := peer_id;
      trusted_node := trusted_node; private_node := private_node |} in
  let conn_info :=
    {|
      peer_id :=
        OCaml.Stdlib.reverse_apply (peer_info t) P2p_peer_state.Info.peer_id;
      is_private := P2p_socket.private_node (conn t);
      write_swap_ack := write_swap_ack t; messages := messages |} in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field t "worker" % string
      (Some
        (Lwt_utils.worker "answerer" % string
          Internal_event.Lwt_worker_event.on_event
          (fun function_parameter =>
            let 'tt := function_parameter in
            worker_loop t (callback conn_info))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler t)))) in
  t.

Definition pipe_exn_handler {A : Type} (function_parameter : exn)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  match function_parameter with
  | Closed => fail Tezos_base__TzPervasives.Connection_closed
  | _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition read {A B C : Type} (t : t A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_pipe.pop (messages t))
        (fun function_parameter =>
          let '(s, msg) := function_parameter in
          op_gtgteq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.String_literal
                    " bytes message popped from queue " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal "" % string
                        CamlinternalFormatBasics.End_of_format))))
                "%d bytes message popped from queue %a" % string) s
              P2p_peer.Id.pp (peer_id (P2p_socket.info (conn t))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              _return msg))) pipe_exn_handler.

Definition is_readable {A B C : Type} (t : t A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_pipe.values_available (messages t)) _return)
    pipe_exn_handler.

Definition write {A B C : Type} (t : t A B C) (msg : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  P2p_socket.write (conn t) (Tezos_p2p.P2p_message.Message msg).

Definition write_sync {A B C : Type} (t : t A B C) (msg : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  P2p_socket.write_sync (conn t) (Tezos_p2p.P2p_message.Message msg).

Definition raw_write_sync {A B C : Type} (t : t A B C) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  P2p_socket.raw_write_sync (conn t) buf.

Definition write_now {A B C : Type} (t : t A B C) (msg : A)
  : Tezos_base__TzPervasives.tzresult bool :=
  P2p_socket.write_now (conn t) (Tezos_p2p.P2p_message.Message msg).

Definition write_swap_request {A B C : Type}
  (t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
  : Tezos_base__TzPervasives.tzresult bool :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field t "last_sent_swap_request" % string
      (Some ((Systime_os.now tt), peer_id)) in
  P2p_socket.write_now (conn t)
    (Tezos_p2p.P2p_message.Swap_request point peer_id).

Definition write_bootstrap {A B C : Type} (t : t A B C)
  : Tezos_base__TzPervasives.tzresult bool :=
  P2p_socket.write_now (conn t) Tezos_p2p.P2p_message.Bootstrap.

Definition stat {A B C : Type} (t : t A B C)
  : Tezos_base__TzPervasives.P2p_stat.t := P2p_socket.stat (conn t).

Definition info {A B C : Type} (t : t A B C)
  : Tezos_base__TzPervasives.P2p_connection.Info.t C := P2p_socket.info (conn t).

Definition local_metadata {A B C : Type} (t : t A B C) : C :=
  P2p_socket.local_metadata (conn t).

Definition remote_metadata {A B C : Type} (t : t A B C) : C :=
  P2p_socket.remote_metadata (conn t).

Definition disconnect {A B C : Type} (op_staroptstar : option bool)
  : (t A B C) -> Lwt.t unit :=
  let wait :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun t =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field t "wait_close" % string wait in
    shutdown t.

Definition close {A B C : Type} (t : t A B C) : Lwt.t unit :=
  P2p_socket.close (Some (wait_close t)) (conn t).

Definition equal_sock {A B C D E : Type} (t : t A B C) (t' : t D E C) : bool :=
  P2p_socket.equal (conn t) (conn t').

Definition private_node {A B C : Type} (t : t A B C) : bool := private_node t.

Definition peer_id {A B C : Type} (t : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Id.t := peer_id t.

Definition trusted_node {A B C : Type} (t : t A B C) : bool := trusted_node t.

src/lib_p2p/p2p_connect_handler.ml 91 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.connect_handler"
end)

type 'msg message_config = {
  encoding : 'msg P2p_message.encoding list;
  chain_name : Distributed_db_version.name;
  distributed_db_versions : Distributed_db_version.t list;
}

type config = {
  incoming_app_message_queue_size : int option;
  private_mode : bool;
  min_connections : int;
  max_connections : int;
  max_incoming_connections : int;
  incoming_message_queue_size : int option;
  outgoing_message_queue_size : int option;
  binary_chunks_size : int option;
  identity : P2p_identity.t;
  connection_timeout : Time.System.Span.t;
  authentication_timeout : Time.System.Span.t;
  greylisting_config : P2p_point_state.Info.greylisting_config;
  proof_of_work_target : Crypto_box.target;
  listening_port : P2p_addr.port option;
}

type ('msg, 'peer_meta, 'conn_meta) t = {
  config : config;
  pool : ('msg, 'peer_meta, 'conn_meta) P2p_pool.t;
  log : P2p_connection.P2p_event.t -> unit;
  triggers : P2p_trigger.t;
  io_sched : P2p_io_scheduler.t;
  announced_version : Network_version.t;
  conn_meta_config : 'conn_meta P2p_socket.metadata_config;
  message_config : 'msg message_config;
  custom_p2p_versions : P2p_version.t list;
  encoding : 'msg P2p_message.t Data_encoding.t;
  incoming : Lwt_canceler.t P2p_point.Table.t;
  mutable new_connection_hook :
    (P2p_peer.Id.t -> ('msg, 'peer_meta, 'conn_meta) P2p_conn.t -> unit) list;
  answerer : 'msg P2p_answerer.t Lazy.t;
}

let create ?(p2p_versions = P2p_version.supported) config pool message_config
    conn_meta_config io_sched triggers ~log ~answerer =
  {
    config;
    conn_meta_config;
    message_config;
    announced_version =
      Network_version.announced
        ~chain_name:message_config.chain_name
        ~distributed_db_versions:message_config.distributed_db_versions
        ~p2p_versions;
    custom_p2p_versions = p2p_versions;
    incoming = P2p_point.Table.create 53;
    io_sched;
    encoding = P2p_message.encoding message_config.encoding;
    triggers;
    new_connection_hook = [];
    log;
    pool;
    answerer;
  }

let create_connection t p2p_conn id_point point_info peer_info
    negotiated_version =
  let peer_id = P2p_peer_state.Info.peer_id peer_info in
  let canceler = Lwt_canceler.create () in
  let size =
    Option.map t.config.incoming_app_message_queue_size ~f:(fun qs ->
        ( qs,
          fun (size, _) ->
            (Sys.word_size / 8 * 11) + size + Lwt_pipe.push_overhead ))
  in
  let messages = Lwt_pipe.create ?size () in
  let conn =
    P2p_conn.create
      p2p_conn
      point_info
      peer_info
      messages
      canceler
      (Lazy.force t.answerer)
      negotiated_version
  in
  let conn_meta = P2p_socket.remote_metadata p2p_conn in
  Option.iter point_info ~f:(fun point_info ->
      let point = P2p_point_state.Info.point point_info in
      P2p_point_state.set_running point_info peer_id conn ;
      P2p_pool.Points.add_connected t.pool point point_info) ;
  t.log (Connection_established (id_point, peer_id)) ;
  P2p_peer_state.set_running peer_info id_point conn conn_meta ;
  P2p_pool.Peers.add_connected t.pool peer_id peer_info ;
  P2p_trigger.broadcast_new_connection t.triggers ;
  Lwt_canceler.on_cancel canceler (fun () ->
      lwt_debug
        "Disconnect: %a (%a)"
        P2p_peer.Id.pp
        peer_id
        P2p_connection.Id.pp
        id_point
      >>= fun () ->
      Option.iter
        ~f:(P2p_point_state.set_disconnected t.config.greylisting_config)
        point_info ;
      t.log (Disconnection peer_id) ;
      P2p_peer_state.set_disconnected peer_info ;
      Option.iter point_info ~f:(fun point_info ->
          P2p_pool.Points.remove_connected t.pool point_info) ;
      P2p_pool.Peers.remove_connected t.pool peer_id ;
      if t.config.max_connections <= P2p_pool.active_connections t.pool then (
        P2p_trigger.broadcast_too_many_connections t.triggers ;
        t.log Too_many_connections ) ;
      Lwt_pipe.close messages ;
      P2p_conn.close conn) ;
  List.iter (fun f -> f peer_id conn) t.new_connection_hook ;
  if P2p_pool.active_connections t.pool < t.config.min_connections then (
    P2p_trigger.broadcast_too_few_connections t.triggers ;
    t.log Too_few_connections ) ;
  conn

let may_register_my_id_point pool = function
  | [P2p_errors.Myself (addr, Some port)] ->
      P2p_pool.add_to_id_points pool (addr, port)
  | _ ->
      ()

let raw_authenticate t ?point_info canceler fd point =
  let incoming = point_info = None in
  lwt_debug
    "authenticate: %a%s"
    P2p_point.Id.pp
    point
    (if incoming then " incoming" else "")
  >>= fun () ->
  protect
    ~canceler
    (fun () ->
      P2p_socket.authenticate
        ~canceler
        ~proof_of_work_target:t.config.proof_of_work_target
        ~incoming
        fd
        point
        ?listening_port:t.config.listening_port
        t.config.identity
        t.announced_version
        t.conn_meta_config)
    ~on_error:(fun err ->
      ( match err with
      | [Canceled] ->
          (* Currently only on time out *)
          lwt_debug
            "authenticate: %a%s -> canceled"
            P2p_point.Id.pp
            point
            (if incoming then " incoming" else "")
      | err ->
          (* Authentication incorrect! Temp ban the offending points/peers *)
          List.iter
            (function
              | P2p_errors.Not_enough_proof_of_work _
              | P2p_errors.Invalid_auth
              | P2p_errors.Decipher_error
              | P2p_errors.Invalid_message_size
              | P2p_errors.Encoding_error
              | P2p_errors.Decoding_error
              | P2p_errors.Invalid_chunks_size _ ->
                  P2p_pool.greylist_addr t.pool (fst point)
              | _ ->
                  ())
            err ;
          lwt_debug
            "@[authenticate: %a%s -> failed@ %a@]"
            P2p_point.Id.pp
            point
            (if incoming then " incoming" else "")
            pp_print_error
            err )
      >>= fun () ->
      may_register_my_id_point t.pool err ;
      t.log (Authentication_failed point) ;
      if incoming then P2p_point.Table.remove t.incoming point
      else
        Option.iter
          ~f:(P2p_point_state.set_disconnected t.config.greylisting_config)
          point_info ;
      Lwt.return_error err)
  >>=? fun (info, auth_fd) ->
  (* Authentication correct! *)
  lwt_debug
    "authenticate: %a -> auth %a"
    P2p_point.Id.pp
    point
    P2p_peer.Id.pp
    info.peer_id
  >>= fun () ->
  fail_when
    (P2p_pool.Peers.banned t.pool info.peer_id)
    (P2p_errors.Peer_banned info.peer_id)
  >>=? fun () ->
  let remote_point_info =
    match info.id_point with
    | (addr, Some port) ->
        P2p_pool.register_new_point t.pool (addr, port)
    | _ ->
        None
  in
  let connection_point_info =
    match (point_info, remote_point_info) with
    | (None, None) ->
        None
    | ((Some _ as point_info), _) | (_, (Some _ as point_info)) ->
        point_info
  in
  let peer_info = P2p_pool.register_peer t.pool info.peer_id in
  let acceptable_version =
    Network_version.select
      ~chain_name:t.message_config.chain_name
      ~distributed_db_versions:t.message_config.distributed_db_versions
      ~p2p_versions:t.custom_p2p_versions
      info.announced_version
  in
  let acceptable_point =
    Option.unopt_map
      connection_point_info
      ~default:(not t.config.private_mode)
      ~f:(fun connection_point_info ->
        match P2p_point_state.get connection_point_info with
        | Requested _ ->
            not incoming
        | Disconnected ->
            let unexpected =
              t.config.private_mode
              && not (P2p_point_state.Info.trusted connection_point_info)
            in
            if unexpected then
              warn
                "[private node] incoming connection from untrused peer \
                 rejected!" ;
            not unexpected
        | Accepted _ | Running _ ->
            false)
  in
  let acceptable_peer_id =
    match P2p_peer_state.get peer_info with
    | Accepted _ ->
        (* TODO: in some circumstances cancel and accept... *)
        false
    | Running _ ->
        false
    | Disconnected ->
        true
  in
  (* To Verify : the thread must ? not be interrupted between
     point removal from incoming and point registration into
     active connection to prevent flooding attack.
     incoming_connections + active_connection must reflect/dominate
     the actual number of ongoing connections.
     On the other hand, if we wait too long for Ack, we will reject
     incoming connections, thus giving an entry point for dos attack
     by giving late Nack.
  *)
  if incoming then P2p_point.Table.remove t.incoming point ;
  Option.iter connection_point_info ~f:(fun point_info ->
      (* set the point to private or not, depending on the [info] gethered
           during authentication *)
      P2p_point_state.set_private point_info info.private_node) ;
  match acceptable_version with
  | Some version when acceptable_peer_id && acceptable_point ->
      t.log (Accepting_request (point, info.id_point, info.peer_id)) ;
      Option.iter connection_point_info ~f:(fun point_info ->
          P2p_point_state.set_accepted point_info info.peer_id canceler) ;
      P2p_peer_state.set_accepted peer_info info.id_point canceler ;
      lwt_debug
        "authenticate: %a -> accept %a"
        P2p_point.Id.pp
        point
        P2p_peer.Id.pp
        info.peer_id
      >>= fun () ->
      protect
        ~canceler
        (fun () ->
          P2p_socket.accept
            ?incoming_message_queue_size:t.config.incoming_message_queue_size
            ?outgoing_message_queue_size:t.config.outgoing_message_queue_size
            ?binary_chunks_size:t.config.binary_chunks_size
            ~canceler
            auth_fd
            t.encoding
          >>=? fun conn ->
          lwt_debug
            "authenticate: %a -> Connected %a"
            P2p_point.Id.pp
            point
            P2p_peer.Id.pp
            info.peer_id
          >>= fun () -> return conn)
        ~on_error:(fun err ->
          if incoming then
            t.log
              (Request_rejected (point, Some (info.id_point, info.peer_id))) ;
          lwt_debug
            "authenticate: %a -> rejected %a"
            P2p_point.Id.pp
            point
            P2p_peer.Id.pp
            info.peer_id
          >>= fun () ->
          Option.iter
            connection_point_info
            ~f:(P2p_point_state.set_disconnected t.config.greylisting_config) ;
          P2p_peer_state.set_disconnected peer_info ;
          Lwt.return_error err)
      >>=? fun conn ->
      let id_point =
        match
          (info.id_point, Option.map ~f:P2p_point_state.Info.point point_info)
        with
        | ((addr, _), Some (_, port)) ->
            (addr, Some port)
        | (id_point, None) ->
            id_point
      in
      return
        (create_connection
           t
           conn
           id_point
           connection_point_info
           peer_info
           version)
  | _ -> (
      t.log (Rejecting_request (point, info.id_point, info.peer_id)) ;
      lwt_debug
        "authenticate: %a -> kick %a point: %B peer_id: %B"
        P2p_point.Id.pp
        point
        P2p_peer.Id.pp
        info.peer_id
        acceptable_point
        acceptable_peer_id
      >>= fun () ->
      P2p_socket.kick auth_fd
      >>= fun () ->
      if not incoming then
        Option.iter
          ~f:(P2p_point_state.set_disconnected t.config.greylisting_config)
          point_info
        (* FIXME P2p_peer_state.set_disconnected ~requested:true peer_info ; *) ;
      match acceptable_version with
      | None ->
          lwt_debug
            "No common protocol@.(chains: local %a - remote \
             %a)@.(db_versions: local [%a] - remote %a)@.(p2p_versions: local \
             [%a] - remote %a)"
            Distributed_db_version.pp_name
            t.message_config.chain_name
            Distributed_db_version.pp_name
            info.announced_version.chain_name
            (Format.pp_print_list Distributed_db_version.pp)
            t.message_config.distributed_db_versions
            Distributed_db_version.pp
            info.announced_version.distributed_db_version
            (Format.pp_print_list P2p_version.pp)
            t.custom_p2p_versions
            P2p_version.pp
            info.announced_version.p2p_version
          >>= fun () ->
          fail
            (P2p_errors.Rejected_no_common_protocol
               {announced = info.announced_version})
      | Some _ ->
          fail (P2p_errors.Rejected info.peer_id) )

let authenticate t ?point_info canceler fd point =
  let fd = P2p_io_scheduler.register t.io_sched fd in
  raw_authenticate t ?point_info canceler fd point
  >>= function
  | Ok connection ->
      return connection
  | Error _ as err ->
      P2p_io_scheduler.close fd >>=? fun () -> Lwt.return err

let accept t fd point =
  t.log (Incoming_connection point) ;
  let max_active_conns = t.config.max_connections + Random.int 2 in
  if
    t.config.max_incoming_connections <= P2p_point.Table.length t.incoming
    || max_active_conns <= P2p_pool.active_connections t.pool
    (* silently ignore banned points *)
    || P2p_pool.Points.banned t.pool point
  then Lwt.async (fun () -> P2p_fd.close fd)
  else
    let canceler = Lwt_canceler.create () in
    P2p_point.Table.add t.incoming point canceler ;
    Lwt.async (fun () ->
        with_timeout
          ~canceler
          (Systime_os.sleep t.config.authentication_timeout)
          (fun canceler -> authenticate t canceler fd point))

let fail_unless_disconnected_point point_info =
  match P2p_point_state.get point_info with
  | Disconnected ->
      return_unit
  | Requested _ | Accepted _ ->
      fail P2p_errors.Pending_connection
  | Running _ ->
      fail P2p_errors.Connected

let connect ?timeout t point =
  fail_when
    (P2p_pool.Points.banned t.pool point)
    (P2p_errors.Point_banned point)
  >>=? fun () ->
  let timeout = Option.unopt ~default:t.config.connection_timeout timeout in
  fail_unless
    (P2p_pool.active_connections t.pool <= t.config.max_connections)
    P2p_errors.Too_many_connections
  >>=? fun () ->
  let canceler = Lwt_canceler.create () in
  with_timeout ~canceler (Systime_os.sleep timeout) (fun canceler ->
      let point_info = P2p_pool.register_point t.pool point in
      let ((addr, port) as point) = P2p_point_state.Info.point point_info in
      fail_unless
        ((not t.config.private_mode) || P2p_point_state.Info.trusted point_info)
        P2p_errors.Private_mode
      >>=? fun () ->
      fail_unless_disconnected_point point_info
      >>=? fun () ->
      P2p_point_state.set_requested point_info canceler ;
      let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
      let uaddr =
        Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port)
      in
      lwt_debug "connect: %a" P2p_point.Id.pp point
      >>= fun () ->
      protect
        ~canceler
        (fun () ->
          t.log (Outgoing_connection point) ;
          P2p_fd.connect fd uaddr >>= fun () -> return_unit)
        ~on_error:(fun err ->
          lwt_debug "connect: %a -> disconnect" P2p_point.Id.pp point
          >>= fun () ->
          P2p_point_state.set_disconnected
            t.config.greylisting_config
            point_info ;
          P2p_fd.close fd
          >>= fun () ->
          match err with
          | [Exn (Unix.Unix_error (Unix.ECONNREFUSED, _, _))] ->
              fail P2p_errors.Connection_refused
          | err ->
              Lwt.return_error err)
      >>=? fun () ->
      lwt_debug "connect: %a -> authenticate" P2p_point.Id.pp point
      >>= fun () -> authenticate t ~point_info canceler fd point)

let stat t = P2p_io_scheduler.global_stat t.io_sched

let on_new_connection t f = t.new_connection_hook <- f :: t.new_connection_hook

let destroy t =
  P2p_point.Table.fold
    (fun _point canceler acc -> Lwt_canceler.cancel canceler >>= fun () -> acc)
    t.incoming
    Lwt.return_unit
src/lib_p2p/p2p_connect_handler.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Record message_config {msg : Type} := {
  encoding : list (Tezos_p2p.P2p_message.encoding msg);
  chain_name : Tezos_base__TzPervasives.Distributed_db_version.name;
  distributed_db_versions :
    list Tezos_base__TzPervasives.Distributed_db_version.t }.
Arguments message_config : clear implicits.

Record config := {
  incoming_app_message_queue_size : option Z;
  private_mode : bool;
  min_connections : Z;
  max_connections : Z;
  max_incoming_connections : Z;
  incoming_message_queue_size : option Z;
  outgoing_message_queue_size : option Z;
  binary_chunks_size : option Z;
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  connection_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  authentication_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  greylisting_config : Tezos_p2p.P2p_point_state.Info.greylisting_config;
  proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target;
  listening_port : option Tezos_base__TzPervasives.P2p_addr.port }.

Record t {msg peer_meta conn_meta : Type} := {
  config : config;
  pool : Tezos_p2p.P2p_pool.t msg peer_meta conn_meta;
  log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit;
  triggers : Tezos_p2p.P2p_trigger.t;
  io_sched : Tezos_p2p.P2p_io_scheduler.t;
  announced_version : Tezos_base__TzPervasives.Network_version.t;
  conn_meta_config : Tezos_p2p.P2p_socket.metadata_config conn_meta;
  message_config : message_config msg;
  custom_p2p_versions : list Tezos_base__TzPervasives.P2p_version.t;
  encoding :
    Tezos_base__TzPervasives.Data_encoding.t (Tezos_p2p.P2p_message.t msg);
  incoming :
    Tezos_base__TzPervasives.P2p_point.Table.t Tezos_stdlib.Lwt_canceler.t;
  new_connection_hook :
    list
      (Tezos_base__TzPervasives.P2p_peer.Id.t ->
        (Tezos_p2p.P2p_conn.t msg peer_meta conn_meta) -> unit);
  answerer : Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t msg) }.
Arguments t : clear implicits.

Definition create {A B C : Type}
  (op_staroptstar : option (list Tezos_base__TzPervasives.P2p_version.t))
  : config ->
    (Tezos_p2p.P2p_pool.t A B C) ->
      (message_config A) ->
        (Tezos_p2p.P2p_socket.metadata_config C) ->
          Tezos_p2p.P2p_io_scheduler.t ->
            Tezos_p2p.P2p_trigger.t ->
              (Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit) ->
                (Stdlib.Lazy.t (Tezos_p2p.P2p_answerer.t A)) -> t A B C :=
  let p2p_versions :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => P2p_version.supported
    end in
  fun config =>
    fun pool =>
      fun message_config =>
        fun conn_meta_config =>
          fun io_sched =>
            fun triggers =>
              fun log =>
                fun answerer =>
                  {| config := config; pool := pool; log := log;
                    triggers := triggers; io_sched := io_sched;
                    announced_version :=
                      Network_version.announced (chain_name message_config)
                        (distributed_db_versions message_config) p2p_versions;
                    conn_meta_config := conn_meta_config;
                    message_config := message_config;
                    custom_p2p_versions := p2p_versions;
                    encoding := P2p_message.encoding (encoding message_config);
                    incoming := P2p_point.Table.create 53;
                    new_connection_hook := []; answerer := answerer |}.

Definition create_connection {A B C : Type}
  (t : t A B C)
  (p2p_conn : Tezos_p2p.P2p_socket.t (Tezos_p2p.P2p_message.t A) C)
  (id_point : Tezos_base__P2p_connection.Id.t)
  (point_info :
    option
      (Tezos_p2p.P2p_point_state.Info.point_info (Tezos_p2p.P2p_conn.t A B C)))
  (peer_info :
    Tezos_p2p.P2p_peer_state.Info.peer_info (Tezos_p2p.P2p_conn.t A B C) B C)
  (negotiated_version : Tezos_base__TzPervasives.Network_version.t)
  : Tezos_p2p.P2p_conn.t A B C :=
  let peer_id := P2p_peer_state.Info.peer_id peer_info in
  let canceler := Lwt_canceler.create tt in
  let size :=
    Option.map
      (fun qs =>
        (qs,
          (fun function_parameter =>
            let '(size, _) := function_parameter in
            Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 11) size)
              Lwt_pipe.push_overhead)))
      (incoming_app_message_queue_size (config t)) in
  let messages := Lwt_pipe.create size tt in
  let conn :=
    P2p_conn.create p2p_conn point_info peer_info messages canceler
      (Lazy.force (answerer t)) negotiated_version in
  let conn_meta := P2p_socket.remote_metadata p2p_conn in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Option.iter
      (fun point_info =>
        let point := P2p_point_state.Info.point point_info in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := P2p_point_state.set_running None point_info peer_id conn in
        P2p_pool.Points.add_connected (pool t) point point_info) point_info in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (log t)
      (Tezos_base__TzPervasives.P2p_connection.P2p_event.Connection_established
        id_point peer_id) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_peer_state.set_running None peer_info id_point conn conn_meta in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_pool.Peers.add_connected (pool t) peer_id peer_info in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_trigger.broadcast_new_connection (triggers t) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Lwt_canceler.on_cancel canceler
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Disconnect: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Disconnect: %a (%a)" % string) P2p_peer.Id.pp peer_id
            P2p_connection.Id.pp id_point)
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Option.iter
                (P2p_point_state.set_disconnected None None
                  (greylisting_config (config t))) point_info in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (log t)
                (Tezos_base__TzPervasives.P2p_connection.P2p_event.Disconnection
                  peer_id) in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := P2p_peer_state.set_disconnected None None peer_info in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Option.iter
                (fun point_info =>
                  P2p_pool.Points.remove_connected (pool t) point_info)
                point_info in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := P2p_pool.Peers.remove_connected (pool t) peer_id in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              if
                OCaml.Stdlib.le (max_connections (config t))
                  (P2p_pool.active_connections (pool t)) then
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := P2p_trigger.broadcast_too_many_connections (triggers t)
                  in
                (log t)
                  Tezos_base__TzPervasives.P2p_connection.P2p_event.Too_many_connections
              else
                tt in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Lwt_pipe.close messages in
            P2p_conn.close conn)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := List.iter (fun f => f peer_id conn) (new_connection_hook t) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      OCaml.Stdlib.lt (P2p_pool.active_connections (pool t))
        (min_connections (config t)) then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := P2p_trigger.broadcast_too_few_connections (triggers t) in
      (log t)
        Tezos_base__TzPervasives.P2p_connection.P2p_event.Too_few_connections
    else
      tt in
  conn.

Definition may_register_my_id_point {A B C : Type}
  (pool : Tezos_p2p.P2p_pool.t A B C)
  (function_parameter : list Tezos_base__TzPervasives.error) : unit :=
  match function_parameter with
  | cons (Tezos_base__TzPervasives.Myself (addr, Some port)) [] =>
    P2p_pool.add_to_id_points pool (addr, port)
  | _ => tt
  end.

Definition raw_authenticate {A B C : Type}
  (t : t A B C)
  (point_info :
    option (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)))
  (canceler : Tezos_stdlib.Lwt_canceler.t)
  (fd : Tezos_p2p.P2p_io_scheduler.connection)
  (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
  let incoming := equiv_decb point_info None in
  op_gtgteq
    (lwt_debug
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "authenticate: " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)))
        "authenticate: %a%s" % string) P2p_point.Id.pp point
      (if incoming then
        " incoming" % string
      else
        "" % string))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (protect
          (Some
            (fun err =>
              op_gtgteq
                match err with
                | cons Tezos_base__TzPervasives.Canceled [] =>
                  lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "authenticate: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " -> canceled" % string
                              CamlinternalFormatBasics.End_of_format))))
                      "authenticate: %a%s -> canceled" % string) P2p_point.Id.pp
                    point
                    (if incoming then
                      " incoming" % string
                    else
                      "" % string)
                | err =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    List.iter
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          Tezos_base__TzPervasives.Not_enough_proof_of_work _ |
                            Tezos_base__TzPervasives.Invalid_auth |
                            Tezos_base__TzPervasives.Decipher_error |
                            Tezos_base__TzPervasives.Invalid_message_size |
                            Tezos_base__TzPervasives.Encoding_error |
                            Tezos_base__TzPervasives.Decoding_error |
                            Tezos_base__TzPervasives.Invalid_chunks_size _ =>
                          P2p_pool.greylist_addr (pool t) (fst point)
                        | _ => tt
                        end) err in
                  lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "authenticate: " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                " -> failed" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format))))))))
                      "@[authenticate: %a%s -> failed@ %a@]" % string)
                    P2p_point.Id.pp point
                    (if incoming then
                      " incoming" % string
                    else
                      "" % string) pp_print_error err
                end
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := may_register_my_id_point (pool t) err in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    (log t)
                      (Tezos_base__TzPervasives.P2p_connection.P2p_event.Authentication_failed
                        point) in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    if incoming then
                      P2p_point.Table.remove (incoming t) point
                    else
                      Option.iter
                        (P2p_point_state.set_disconnected None None
                          (greylisting_config (config t))) point_info in
                  Lwt.return_error err))) (Some canceler)
          (fun function_parameter =>
            let 'tt := function_parameter in
            P2p_socket.authenticate canceler (proof_of_work_target (config t))
              incoming fd point (listening_port (config t))
              (identity (config t)) (announced_version t) (conn_meta_config t)))
        (fun function_parameter =>
          let '(info, auth_fd) := function_parameter in
          op_gtgteq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "authenticate: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " -> auth " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "authenticate: %a -> auth %a" % string) P2p_point.Id.pp point
              P2p_peer.Id.pp (peer_id info))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (fail_when (P2p_pool.Peers.banned (pool t) (peer_id info))
                  (Tezos_base__TzPervasives.Peer_banned (peer_id info)))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let remote_point_info :=
                    match id_point info with
                    | (addr, Some port) =>
                      P2p_pool.register_new_point None (pool t) (addr, port)
                    | _ => None
                    end in
                  let connection_point_info :=
                    match (point_info, remote_point_info) with
                    | (None, None) => None
                    | ((Some _) as point_info, _) | (_, (Some _) as point_info)
                      => point_info
                    end in
                  let peer_info :=
                    P2p_pool.register_peer (pool t) (peer_id info) in
                  let acceptable_version :=
                    Network_version.select (chain_name (message_config t))
                      (distributed_db_versions (message_config t))
                      (custom_p2p_versions t) (announced_version info) in
                  let acceptable_point :=
                    Option.unopt_map
                      (fun connection_point_info =>
                        match P2p_point_state.get connection_point_info with
                        | Tezos_p2p.P2p_point_state.Requested _ => negb incoming
                        | Tezos_p2p.P2p_point_state.Disconnected =>
                          let unexpected :=
                            andb (private_mode (config t))
                              (negb
                                (P2p_point_state.Info.trusted
                                  connection_point_info)) in
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            if unexpected then
                              warn
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "[private node] incoming connection from untrused peer rejected!"
                                      % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "[private node] incoming connection from untrused peer rejected!"
                                    % string)
                            else
                              tt in
                          negb unexpected
                        |
                          Tezos_p2p.P2p_point_state.Accepted _ |
                            Tezos_p2p.P2p_point_state.Running _ => false
                        end) (negb (private_mode (config t)))
                      connection_point_info in
                  let acceptable_peer_id :=
                    match P2p_peer_state.get peer_info with
                    | Tezos_p2p.P2p_peer_state.Accepted _ => false
                    | Tezos_p2p.P2p_peer_state.Running _ => false
                    | Tezos_p2p.P2p_peer_state.Disconnected => true
                    end in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    if incoming then
                      P2p_point.Table.remove (incoming t) point
                    else
                      tt in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Option.iter
                      (fun point_info =>
                        P2p_point_state.set_private point_info
                          (private_node info)) connection_point_info in
                  match acceptable_version with
                  | Some version =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      (log t)
                        (Tezos_base__TzPervasives.P2p_connection.P2p_event.Accepting_request
                          point (id_point info) (peer_id info)) in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Option.iter
                        (fun point_info =>
                          P2p_point_state.set_accepted None point_info
                            (peer_id info) canceler) connection_point_info in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      P2p_peer_state.set_accepted None peer_info (id_point info)
                        canceler in
                    op_gtgteq
                      (lwt_debug
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "authenticate: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " -> accept " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))))
                          "authenticate: %a -> accept %a" % string)
                        P2p_point.Id.pp point P2p_peer.Id.pp (peer_id info))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (protect
                            (Some
                              (fun err =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  if incoming then
                                    (log t)
                                      (Tezos_base__TzPervasives.P2p_connection.P2p_event.Request_rejected
                                        point
                                        (Some ((id_point info), (peer_id info))))
                                  else
                                    tt in
                                op_gtgteq
                                  (lwt_debug
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "authenticate: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " -> rejected " % string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))))
                                      "authenticate: %a -> rejected %a" % string)
                                    P2p_point.Id.pp point P2p_peer.Id.pp
                                    (peer_id info))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      Option.iter
                                        (P2p_point_state.set_disconnected None
                                          None (greylisting_config (config t)))
                                        connection_point_info in
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      P2p_peer_state.set_disconnected None None
                                        peer_info in
                                    Lwt.return_error err))) (Some canceler)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (P2p_socket.accept
                                  (incoming_message_queue_size (config t))
                                  (outgoing_message_queue_size (config t))
                                  (binary_chunks_size (config t)) canceler
                                  auth_fd (encoding t))
                                (fun conn =>
                                  op_gtgteq
                                    (lwt_debug
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "authenticate: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " -> Connected " % string
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format))))
                                        "authenticate: %a -> Connected %a" %
                                          string) P2p_point.Id.pp point
                                      P2p_peer.Id.pp (peer_id info))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      _return conn))))
                          (fun conn =>
                            let id_point :=
                              match
                                ((id_point info),
                                  (Option.map P2p_point_state.Info.point
                                    point_info)) with
                              | ((addr, _), Some (_, port)) =>
                                (addr, (Some port))
                              | (id_point, None) => id_point
                              end in
                            _return
                              (create_connection t conn id_point
                                connection_point_info peer_info version)))
                  | _ =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      (log t)
                        (Tezos_base__TzPervasives.P2p_connection.P2p_event.Rejecting_request
                          point (id_point info) (peer_id info)) in
                    op_gtgteq
                      (lwt_debug
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "authenticate: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " -> kick " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " point: " % string
                                    (CamlinternalFormatBasics.Bool
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.String_literal
                                        " peer_id: " % string
                                        (CamlinternalFormatBasics.Bool
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))))))))
                          "authenticate: %a -> kick %a point: %B peer_id: %B" %
                            string) P2p_point.Id.pp point P2p_peer.Id.pp
                        (peer_id info) acceptable_point acceptable_peer_id)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (P2p_socket.kick auth_fd)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              if negb incoming then
                                Option.iter
                                  (P2p_point_state.set_disconnected None None
                                    (greylisting_config (config t))) point_info
                              else
                                tt in
                            match acceptable_version with
                            | None =>
                              op_gtgteq
                                (lwt_debug
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "No common protocol" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        (CamlinternalFormatBasics.String_literal
                                          "(chains: local " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " - remote " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  ")" % char
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    (CamlinternalFormatBasics.String_literal
                                                      "(db_versions: local [" %
                                                        string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          "] - remote " % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Char_literal
                                                              ")" % char
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                CamlinternalFormatBasics.Flush_newline
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "(p2p_versions: local ["
                                                                    % string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "] - remote "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          ")" %
                                                                            char
                                                                          CamlinternalFormatBasics.End_of_format)))))))))))))))))))
                                    "No common protocol@.(chains: local %a - remote %a)@.(db_versions: local [%a] - remote %a)@.(p2p_versions: local [%a] - remote %a)"
                                      % string) Distributed_db_version.pp_name
                                  (chain_name (message_config t))
                                  Distributed_db_version.pp_name
                                  (chain_name (announced_version info))
                                  (Format.pp_print_list None
                                    Distributed_db_version.pp)
                                  (distributed_db_versions (message_config t))
                                  Distributed_db_version.pp
                                  (distributed_db_version
                                    (announced_version info))
                                  (Format.pp_print_list None P2p_version.pp)
                                  (custom_p2p_versions t) P2p_version.pp
                                  (p2p_version (announced_version info)))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  fail
                                    (Tezos_base__TzPervasives.Rejected_no_common_protocol
                                      {| announced := announced_version info |}))
                            | Some _ =>
                              fail
                                (Tezos_base__TzPervasives.Rejected
                                  (peer_id info))
                            end))
                  end)))).

Definition authenticate {A B C : Type}
  (t : t A B C)
  (point_info :
    option (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)))
  (canceler : Tezos_stdlib.Lwt_canceler.t) (fd : Tezos_p2p.P2p_fd.t)
  (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
  let fd := P2p_io_scheduler.register (io_sched t) fd in
  op_gtgteq (raw_authenticate t point_info canceler fd point)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok connection => _return connection
      | (Stdlib.Error _) as err =>
        op_gtgteqquestion (P2p_io_scheduler.close None fd)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt._return err)
      end).

Definition accept {A B C : Type}
  (t : t A B C) (fd : Tezos_p2p.P2p_fd.t) (point : Tezos_base.P2p_point.Id.t)
  : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (log t)
      (Tezos_base__TzPervasives.P2p_connection.P2p_event.Incoming_connection
        point) in
  let max_active_conns := Z.add (max_connections (config t)) (Random.int 2) in
  if
    orb
      (OCaml.Stdlib.le (max_incoming_connections (config t))
        (P2p_point.Table.length (incoming t)))
      (orb
        (OCaml.Stdlib.le max_active_conns (P2p_pool.active_connections (pool t)))
        (P2p_pool.Points.banned (pool t) point)) then
    Lwt.async
      (fun function_parameter =>
        let 'tt := function_parameter in
        P2p_fd.close fd)
  else
    let canceler := Lwt_canceler.create tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_point.Table.add (incoming t) point canceler in
    Lwt.async
      (fun function_parameter =>
        let 'tt := function_parameter in
        with_timeout (Some canceler)
          (Systime_os.sleep (authentication_timeout (config t)))
          (fun canceler => authenticate t None canceler fd point)).

Definition fail_unless_disconnected_point {A : Type}
  (point_info : Tezos_p2p.P2p_point_state.Info.t A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match P2p_point_state.get point_info with
  | Tezos_p2p.P2p_point_state.Disconnected => return_unit
  | Tezos_p2p.P2p_point_state.Requested _ | Tezos_p2p.P2p_point_state.Accepted _
    => fail Tezos_base__TzPervasives.Pending_connection
  | Tezos_p2p.P2p_point_state.Running _ =>
    fail Tezos_base__TzPervasives.Connected
  end.

Definition connect {A B C : Type}
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t) (t : t A B C)
  (point : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
  op_gtgteqquestion
    (fail_when (P2p_pool.Points.banned (pool t) point)
      (Tezos_base__TzPervasives.Point_banned point))
    (fun function_parameter =>
      let 'tt := function_parameter in
      let timeout := Option.unopt (connection_timeout (config t)) timeout in
      op_gtgteqquestion
        (fail_unless
          (OCaml.Stdlib.le (P2p_pool.active_connections (pool t))
            (max_connections (config t)))
          Tezos_base__TzPervasives.Too_many_connections)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let canceler := Lwt_canceler.create tt in
          with_timeout (Some canceler) (Systime_os.sleep timeout)
            (fun canceler =>
              let point_info := P2p_pool.register_point None (pool t) point in
              let '(addr, port) as point :=
                P2p_point_state.Info.point point_info in
              op_gtgteqquestion
                (fail_unless
                  (orb (negb (private_mode (config t)))
                    (P2p_point_state.Info.trusted point_info))
                  Tezos_base__TzPervasives.Private_mode)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion (fail_unless_disconnected_point point_info)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        P2p_point_state.set_requested None point_info canceler
                        in
                      let fd :=
                        P2p_fd.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0
                        in
                      let uaddr :=
                        Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr)
                          port in
                      op_gtgteq
                        (lwt_debug
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "connect: " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            "connect: %a" % string) P2p_point.Id.pp point)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (protect
                              (Some
                                (fun err =>
                                  op_gtgteq
                                    (lwt_debug
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "connect: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " -> disconnect" % string
                                              CamlinternalFormatBasics.End_of_format)))
                                        "connect: %a -> disconnect" % string)
                                      P2p_point.Id.pp point)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        P2p_point_state.set_disconnected None
                                          None (greylisting_config (config t))
                                          point_info in
                                      op_gtgteq (P2p_fd.close fd)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          match err with
                                          |
                                            cons
                                              (Tezos_base__TzPervasives.Exn
                                                (Unix_error Unix.ECONNREFUSED _
                                                  _)) [] =>
                                            fail
                                              Tezos_base__TzPervasives.Connection_refused
                                          | err => Lwt.return_error err
                                          end)))) (Some canceler)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  (log t)
                                    (Tezos_base__TzPervasives.P2p_connection.P2p_event.Outgoing_connection
                                      point) in
                                op_gtgteq (P2p_fd.connect fd uaddr)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (lwt_debug
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "connect: " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " -> authenticate" % string
                                          CamlinternalFormatBasics.End_of_format)))
                                    "connect: %a -> authenticate" % string)
                                  P2p_point.Id.pp point)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  authenticate t (Some point_info) canceler fd
                                    point)))))))).

Definition stat {A B C : Type} (t : t A B C)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  P2p_io_scheduler.global_stat (io_sched t).

Definition on_new_connection {A B C : Type}
  (t : t A B C)
  (f :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      (Tezos_p2p.P2p_conn.t A B C) -> unit) : unit :=
  (* ❌ Set record field not handled. *)
  set_record_field t "new_connection_hook" % string
    (cons f (new_connection_hook t)).

Definition destroy {A B C : Type} (t : t A B C) : Lwt.t unit :=
  P2p_point.Table.fold
    (fun _point =>
      fun canceler =>
        fun acc =>
          op_gtgteq (Lwt_canceler.cancel canceler)
            (fun function_parameter =>
              let 'tt := function_parameter in
              acc)) (incoming t) Lwt.return_unit.

src/lib_p2p/p2p_discovery.ml 20 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.discovery"
end)

type pool = Pool : ('msg, 'meta, 'meta_conn) P2p_pool.t -> pool

module Message = struct
  let encoding =
    Data_encoding.(tup3 (Fixed.string 10) P2p_peer.Id.encoding int16)

  let length = Data_encoding.Binary.fixed_length_exn encoding

  let key = "DISCOMAGIC"

  let make peer_id port =
    Data_encoding.Binary.to_bytes_exn encoding (key, peer_id, port)
end

module Answer = struct
  type t = {
    my_peer_id : P2p_peer.Id.t;
    pool : pool;
    discovery_port : int;
    canceler : Lwt_canceler.t;
    trust_discovered_peers : bool;
    mutable worker : unit Lwt.t;
  }

  let create_socket st =
    Lwt.catch
      (fun () ->
        let socket = Lwt_unix.socket PF_INET SOCK_DGRAM 0 in
        Lwt_canceler.on_cancel st.canceler (fun () ->
            Lwt_utils_unix.safe_close socket) ;
        Lwt_unix.setsockopt socket SO_BROADCAST true ;
        Lwt_unix.setsockopt socket SO_REUSEADDR true ;
        let addr =
          Lwt_unix.ADDR_INET (Unix.inet_addr_any, st.discovery_port)
        in
        Lwt_unix.bind socket addr >>= fun () -> Lwt.return socket)
      (fun exn ->
        lwt_debug "Error creating a socket" >>= fun () -> Lwt.fail exn)

  let loop st =
    protect ~canceler:st.canceler (fun () ->
        create_socket st >>= fun socket -> return socket)
    >>=? fun socket ->
    (* Infinite loop, should never exit. *)
    let rec aux () =
      let buf = Bytes.create Message.length in
      protect ~canceler:st.canceler (fun () ->
          Lwt_unix.recvfrom socket buf 0 Message.length []
          >>= fun content ->
          lwt_debug "Received discovery message..."
          >>= fun () -> return content)
      >>=? function
      | (len, Lwt_unix.ADDR_INET (remote_addr, _))
        when Compare.Int.equal len Message.length -> (
        match Data_encoding.Binary.of_bytes Message.encoding buf with
        | Some (key, remote_peer_id, remote_port)
          when Compare.String.equal key Message.key
               && not (P2p_peer.Id.equal remote_peer_id st.my_peer_id) -> (
            let s_addr = Unix.string_of_inet_addr remote_addr in
            match P2p_addr.of_string_opt s_addr with
            | None ->
                lwt_debug "Failed to parse %S\n@." s_addr >>= fun () -> aux ()
            | Some addr ->
                let (Pool pool) = st.pool in
                lwt_log_info
                  "Registering new point %a:%d"
                  P2p_addr.pp
                  addr
                  remote_port
                >>= fun () ->
                P2p_pool.register_new_point
                  ~trusted:st.trust_discovered_peers
                  pool
                  (addr, remote_port)
                |> ignore ;
                aux () )
        | _ ->
            aux () )
      | _ ->
          aux ()
    in
    aux ()

  let worker_loop st =
    loop st
    >>= function
    | Error (Canceled :: _) ->
        Lwt.return_unit
    | Error err ->
        lwt_log_error
          "@[<v 2>Unexpected error in answer worker@ %a@]"
          pp_print_error
          err
        >>= fun () -> Lwt_canceler.cancel st.canceler
    | Ok () ->
        lwt_log_error "@[<v 2>Unexpected exit in answer worker@]"
        >>= fun () -> Lwt_canceler.cancel st.canceler

  let create my_peer_id pool ~trust_discovered_peers ~discovery_port =
    {
      canceler = Lwt_canceler.create ();
      my_peer_id;
      discovery_port;
      trust_discovered_peers;
      pool = Pool pool;
      worker = Lwt.return_unit;
    }

  let activate st =
    st.worker <-
      Lwt_utils.worker
        "discovery_answer"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
end

(* ************************************************************ *)
(* Sender  *)

module Sender = struct
  type t = {
    canceler : Lwt_canceler.t;
    my_peer_id : P2p_peer.Id.t;
    listening_port : int;
    discovery_port : int;
    discovery_addr : Ipaddr.V4.t;
    pool : pool;
    restart_discovery : unit Lwt_condition.t;
    mutable worker : unit Lwt.t;
  }

  module Config = struct
    type t = {delay : float; loop : int}

    let initial = {delay = 0.1; loop = 0}

    let increase_delay config = {config with delay = 2.0 *. config.delay}

    let max_loop = 10
  end

  let broadcast_message st =
    let msg = Message.make st.my_peer_id st.listening_port in
    Lwt.catch
      (fun () ->
        let socket = Lwt_unix.(socket PF_INET SOCK_DGRAM 0) in
        Lwt_canceler.on_cancel st.canceler (fun () ->
            Lwt_utils_unix.safe_close socket) ;
        Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true ;
        let broadcast_ipv4 = Ipaddr_unix.V4.to_inet_addr st.discovery_addr in
        let addr = Lwt_unix.ADDR_INET (broadcast_ipv4, st.discovery_port) in
        Lwt_unix.connect socket addr
        >>= fun () ->
        lwt_debug "Broadcasting discovery message..."
        >>= fun () ->
        Lwt_unix.sendto socket msg 0 Message.length [] addr
        >>= fun _len -> Lwt_utils_unix.safe_close socket)
      (fun _exn -> lwt_debug "Error broadcasting a discovery request")

  let rec worker_loop sender_config st =
    protect ~canceler:st.canceler (fun () ->
        broadcast_message st >>= fun () -> return_unit)
    >>=? (fun () ->
           protect ~canceler:st.canceler (fun () ->
               Lwt.pick
                 [ ( Lwt_condition.wait st.restart_discovery
                   >>= fun () -> return Config.initial );
                   ( Lwt_unix.sleep sender_config.Config.delay
                   >>= fun () ->
                   return
                     {sender_config with Config.loop = succ sender_config.loop}
                   ) ]))
    >>= function
    | Ok config when config.Config.loop = Config.max_loop ->
        let new_sender_config = {config with Config.loop = pred config.loop} in
        worker_loop new_sender_config st
    | Ok config ->
        let new_sender_config = Config.increase_delay config in
        worker_loop new_sender_config st
    | Error (Canceled :: _) ->
        Lwt.return_unit
    | Error err ->
        lwt_log_error
          "@[<v 2>Unexpected error in sender worker@ %a@]"
          pp_print_error
          err
        >>= fun () -> Lwt_canceler.cancel st.canceler

  let create my_peer_id pool ~listening_port ~discovery_port ~discovery_addr =
    {
      canceler = Lwt_canceler.create ();
      my_peer_id;
      listening_port;
      discovery_port;
      discovery_addr;
      restart_discovery = Lwt_condition.create ();
      pool = Pool pool;
      worker = Lwt.return_unit;
    }

  let activate st =
    st.worker <-
      Lwt_utils.worker
        "discovery_sender"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop Config.initial st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler)
end

(* ********************************************************************** *)

type t = {answer : Answer.t; sender : Sender.t}

let create ~listening_port ~discovery_port ~discovery_addr
    ~trust_discovered_peers pool my_peer_id =
  let answer =
    Answer.create my_peer_id pool ~discovery_port ~trust_discovered_peers
  in
  let sender =
    Sender.create
      my_peer_id
      pool
      ~listening_port
      ~discovery_port
      ~discovery_addr
  in
  {answer; sender}

let activate {answer; sender} = Answer.activate answer ; Sender.activate sender

let wakeup t = Lwt_condition.signal t.sender.restart_discovery ()

let shutdown t =
  Lwt.join
    [ Lwt_canceler.cancel t.answer.canceler;
      Lwt_canceler.cancel t.sender.canceler ]
src/lib_p2p/p2p_discovery.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Inductive pool : Type :=
| Pool : forall {meta meta_conn msg : Type},
  (Tezos_p2p.P2p_pool.t msg meta meta_conn) -> pool.

Module Message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (string * Tezos_base__TzPervasives.P2p_peer.Id.t * Z) :=
    tup3 (Fixed.string 10) P2p_peer.Id.encoding int16.
  
  Definition length : Z := Data_encoding.Binary.fixed_length_exn encoding.
  
  Definition key : string := "DISCOMAGIC" % string.
  
  Definition make (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) (port : Z)
    : Stdlib.Bytes.t :=
    Data_encoding.Binary.to_bytes_exn encoding (key, peer_id, port).
End Message.

Module Answer.
  Record t := {
    my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    pool : pool;
    discovery_port : Z;
    canceler : Tezos_stdlib.Lwt_canceler.t;
    trust_discovered_peers : bool;
    worker : Lwt.t unit }.
  
  Definition create_socket (st : t) : Lwt.t Lwt_unix.file_descr :=
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        let socket := Lwt_unix.socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Lwt_canceler.on_cancel (canceler st)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt_utils_unix.safe_close socket) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_unix.setsockopt socket Lwt_unix.SO_REUSEADDR true in
        let addr := Lwt_unix.ADDR_INET Unix.inet_addr_any (discovery_port st) in
        op_gtgteq (Lwt_unix.bind socket addr)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt._return socket))
      (fun exn =>
        op_gtgteq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Error creating a socket" % string
                CamlinternalFormatBasics.End_of_format)
              "Error creating a socket" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt.fail exn)).
  
  Definition loop {A : Type} (st : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    op_gtgteqquestion
      (protect None (Some (canceler st))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (create_socket st) (fun socket => _return socket)))
      (fun socket =>
        let fix aux {B : Type} (function_parameter : unit)
          : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
          let 'tt := function_parameter in
          let buf := Stdlib.Bytes.create Message.length in
          op_gtgteqquestion
            (protect None (Some (canceler st))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Lwt_unix.recvfrom socket buf 0 Message.length [])
                  (fun content =>
                    op_gtgteq
                      (lwt_debug
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Received discovery message..." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Received discovery message..." % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        _return content))))
            (fun function_parameter =>
              match function_parameter with
              | (len, Lwt_unix.ADDR_INET remote_addr _) =>
                match Data_encoding.Binary.of_bytes Message.encoding buf with
                | Some (key, remote_peer_id, remote_port) =>
                  let s_addr := Unix.string_of_inet_addr remote_addr in
                  match P2p_addr.of_string_opt s_addr with
                  | None =>
                    op_gtgteq
                      (lwt_debug
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Failed to parse " % string
                            (CamlinternalFormatBasics.Caml_string
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Char_literal
                                "010" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format))))
                          "Failed to parse %S
@." % string) s_addr)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        aux tt)
                  | Some addr =>
                    let 'Pool pool := pool st in
                    op_gtgteq
                      (lwt_log_info
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Registering new point " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal ":" % char
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  CamlinternalFormatBasics.End_of_format))))
                          "Registering new point %a:%d" % string) P2p_addr.pp
                        addr remote_port)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          OCaml.Stdlib.reverse_apply
                            (P2p_pool.register_new_point
                              (Some (trust_discovered_peers st)) pool
                              (addr, remote_port)) OCaml.Stdlib.ignore in
                        aux tt)
                  end
                | _ => aux tt
                end
              | _ => aux tt
              end) in
        aux tt).
  
  Definition worker_loop (st : t) : Lwt.t unit :=
    op_gtgteq (loop st)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
          Lwt.return_unit
        | Stdlib.Error err =>
          op_gtgteq
            (lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected error in answer worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "@[<v 2>Unexpected error in answer worker@ %a@]" % string)
              pp_print_error err)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt_canceler.cancel (canceler st))
        | Stdlib.Ok tt =>
          op_gtgteq
            (lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected exit in answer worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))
                "@[<v 2>Unexpected exit in answer worker@]" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt_canceler.cancel (canceler st))
        end).
  
  Definition create {A B C : Type}
    (my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    (pool : Tezos_p2p.P2p_pool.t A B C) (trust_discovered_peers : bool)
    (discovery_port : Z) : t :=
    {| my_peer_id := my_peer_id; pool := Pool pool;
      discovery_port := discovery_port; canceler := Lwt_canceler.create tt;
      trust_discovered_peers := trust_discovered_peers;
      worker := Lwt.return_unit |}.
  
  Definition activate (st : t) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field st "worker" % string
      (Lwt_utils.worker "discovery_answer" % string
        Internal_event.Lwt_worker_event.on_event
        (fun function_parameter =>
          let 'tt := function_parameter in
          worker_loop st)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt_canceler.cancel (canceler st))).
End Answer.

Module Sender.
  Record t := {
    canceler : Tezos_stdlib.Lwt_canceler.t;
    my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    listening_port : Z;
    discovery_port : Z;
    discovery_addr : Ipaddr.V4.t;
    pool : pool;
    restart_discovery : Lwt_condition.t unit;
    worker : Lwt.t unit }.
  
  Module Config.
    Record t := {
      delay : Z;
      loop : Z }.
    
    Definition initial : t :=
      {|
        delay :=
          (* ❌ Float constant 0.1 is approximated by the integer 0 *)
          0; loop := 0 |}.
    
    Definition increase_delay (config : t) : t :=
      (* ❌ Record substitution not handled *)
      record_substitution.
    
    Definition max_loop : Z := 10.
  End Config.
  
  Definition broadcast_message (st : t) : Lwt.t unit :=
    let msg := Message.make (my_peer_id st) (listening_port st) in
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        let socket := socket Lwt_unix.PF_INET Lwt_unix.SOCK_DGRAM 0 in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Lwt_canceler.on_cancel (canceler st)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt_utils_unix.safe_close socket) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_unix.setsockopt socket Lwt_unix.SO_BROADCAST true in
        let broadcast_ipv4 := Ipaddr_unix.V4.to_inet_addr (discovery_addr st) in
        let addr := Lwt_unix.ADDR_INET broadcast_ipv4 (discovery_port st) in
        op_gtgteq (Lwt_unix.connect socket addr)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (lwt_debug
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Broadcasting discovery message..." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Broadcasting discovery message..." % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Lwt_unix.sendto socket msg 0 Message.length [] addr)
                  (fun _len => Lwt_utils_unix.safe_close socket))))
      (fun _exn =>
        lwt_debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Error broadcasting a discovery request" % string
              CamlinternalFormatBasics.End_of_format)
            "Error broadcasting a discovery request" % string)).
  
  Fixpoint worker_loop (sender_config : Config.t) (st : t) : Lwt.t unit :=
    op_gtgteq
      (op_gtgteqquestion
        (protect None (Some (canceler st))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (broadcast_message st)
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          protect None (Some (canceler st))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.pick
                (cons
                  (op_gtgteq (Lwt_condition.wait None (restart_discovery st))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return Config.initial))
                  (cons
                    (op_gtgteq (Lwt_unix.sleep (Config.delay sender_config))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        _return
                          (* ❌ Record substitution not handled *)
                          record_substitution)) [])))))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok config =>
          let new_sender_config :=
            (* ❌ Record substitution not handled *)
            record_substitution in
          worker_loop new_sender_config st
        | Stdlib.Ok config =>
          let new_sender_config := Config.increase_delay config in
          worker_loop new_sender_config st
        | Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
          Lwt.return_unit
        | Stdlib.Error err =>
          op_gtgteq
            (lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected error in sender worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "@[<v 2>Unexpected error in sender worker@ %a@]" % string)
              pp_print_error err)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt_canceler.cancel (canceler st))
        end).
  
  Definition create {A B C : Type}
    (my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    (pool : Tezos_p2p.P2p_pool.t A B C) (listening_port : Z)
    (discovery_port : Z) (discovery_addr : Ipaddr.V4.t) : t :=
    {| canceler := Lwt_canceler.create tt; my_peer_id := my_peer_id;
      listening_port := listening_port; discovery_port := discovery_port;
      discovery_addr := discovery_addr; pool := Pool pool;
      restart_discovery := Lwt_condition.create tt; worker := Lwt.return_unit |}.
  
  Definition activate (st : t) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field st "worker" % string
      (Lwt_utils.worker "discovery_sender" % string
        Internal_event.Lwt_worker_event.on_event
        (fun function_parameter =>
          let 'tt := function_parameter in
          worker_loop Config.initial st)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt_canceler.cancel (canceler st))).
End Sender.

Record t := {
  answer : Answer.t;
  sender : Sender.t }.

Definition create {A B C : Type}
  (listening_port : Z) (discovery_port : Z) (discovery_addr : Ipaddr.V4.t)
  (trust_discovered_peers : bool) (pool : Tezos_p2p.P2p_pool.t A B C)
  (my_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) : t :=
  let answer :=
    Answer.create my_peer_id pool trust_discovered_peers discovery_port in
  let sender :=
    Sender.create my_peer_id pool listening_port discovery_port discovery_addr
    in
  {| answer := answer; sender := sender |}.

Definition activate (function_parameter : t) : unit :=
  let '{| answer := answer; sender := sender |} := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Answer.activate answer in
  Sender.activate sender.

Definition wakeup (t : t) : unit :=
  Lwt_condition.signal (restart_discovery (sender t)) tt.

Definition shutdown (t : t) : Lwt.t unit :=
  Lwt.join
    (cons (Lwt_canceler.cancel (canceler (answer t)))
      (cons (Lwt_canceler.cancel (canceler (sender t))) [])).

src/lib_p2p/p2p_errors.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(************************ p2p io scheduler ********************************)

type error += Connection_closed

let () =
  (* Connection closed *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_io_scheduler.connection_closed"
    ~title:"Connection closed"
    ~description:"IO error: connection with a peer is closed."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "IO error: connection with a peer is closed.")
    Data_encoding.empty
    (function Connection_closed -> Some () | _ -> None)
    (fun () -> Connection_closed)

(***************************** p2p socket *********************************)

type error += Decipher_error

type error += Invalid_message_size

type error += Encoding_error

type error += Rejected_socket_connection

type error += Rejected_no_common_protocol of {announced : Network_version.t}

type error += Decoding_error

type error += Myself of P2p_connection.Id.t

type error += Not_enough_proof_of_work of P2p_peer.Id.t

type error += Invalid_auth

type error += Invalid_chunks_size of {value : int; min : int; max : int}

let () =
  (* Decipher error *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.decipher_error"
    ~title:"Decipher error"
    ~description:"An error occurred while deciphering."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "An error occurred while deciphering.")
    Data_encoding.empty
    (function Decipher_error -> Some () | _ -> None)
    (fun () -> Decipher_error) ;
  (* Invalid message size *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.invalid_message_size"
    ~title:"Invalid message size"
    ~description:"The size of the message to be written is invalid."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The size of the message to be written is invalid.")
    Data_encoding.empty
    (function Invalid_message_size -> Some () | _ -> None)
    (fun () -> Invalid_message_size) ;
  (* Encoding error *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.encoding_error"
    ~title:"Encoding error"
    ~description:"An error occurred while encoding."
    ~pp:(fun ppf () -> Format.fprintf ppf "An error occurred while encoding.")
    Data_encoding.empty
    (function Encoding_error -> Some () | _ -> None)
    (fun () -> Encoding_error) ;
  (* Rejected socket connection *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.rejected_socket_connection"
    ~title:"Rejected socket connection"
    ~description:"Rejected peer connection: rejected socket connection."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Rejected peer connection: rejected socket connection.")
    Data_encoding.empty
    (function Rejected_socket_connection -> Some () | _ -> None)
    (fun () -> Rejected_socket_connection) ;
  (* Rejected socket connection, no common network protocol *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.rejected_no_common_protocol"
    ~title:"Rejected socket connection - no common network protocol"
    ~description:
      "Rejected peer connection: rejected socket connection as we have no \
       common network protocol with the peer."
    ~pp:(fun ppf _lst ->
      Format.fprintf
        ppf
        "Rejected peer connection: no common network protocol.")
    Data_encoding.(obj1 (req "announced_version" Network_version.encoding))
    (function
      | Rejected_no_common_protocol {announced} -> Some announced | _ -> None)
    (fun announced -> Rejected_no_common_protocol {announced}) ;
  (* Decoding error *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.decoding_error"
    ~title:"Decoding error"
    ~description:"An error occurred while decoding."
    ~pp:(fun ppf () -> Format.fprintf ppf "An error occurred while decoding.")
    Data_encoding.empty
    (function Decoding_error -> Some () | _ -> None)
    (fun () -> Decoding_error) ;
  (* Myself *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.myself"
    ~title:"Myself"
    ~description:"Remote peer is actually yourself."
    ~pp:(fun ppf id ->
      Format.fprintf
        ppf
        "Remote peer %a cannot be authenticated: peer is actually yourself."
        P2p_connection.Id.pp
        id)
    Data_encoding.(obj1 (req "connection id" P2p_connection.Id.encoding))
    (function Myself id -> Some id | _ -> None)
    (fun id -> Myself id) ;
  (* Not enough proof of work *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.not_enough_proof_of_work"
    ~title:"Not enough proof of work"
    ~description:
      "Remote peer cannot be authenticated: not enough proof of work."
    ~pp:(fun ppf id ->
      Format.fprintf
        ppf
        "Remote peer %a cannot be authenticated: not enough proof of work."
        P2p_peer.Id.pp
        id)
    Data_encoding.(obj1 (req "peer id" P2p_peer.Id.encoding))
    (function Not_enough_proof_of_work id -> Some id | _ -> None)
    (fun id -> Not_enough_proof_of_work id) ;
  (* Invalid authentication *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.invalid_auth"
    ~title:"Invalid authentication"
    ~description:"Rejected peer connection: invalid authentication."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Rejected peer connection: invalid authentication.")
    Data_encoding.empty
    (function Invalid_auth -> Some () | _ -> None)
    (fun () -> Invalid_auth) ;
  (* Invalid chunks size *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_socket.invalid_chunks_size"
    ~title:"Invalid chunks size"
    ~description:"Size of chunks is not valid."
    ~pp:(fun ppf (value, min, max) ->
      Format.fprintf
        ppf
        "Size of chunks is invalid: should be between %d and %d but is %d"
        min
        max
        value)
    Data_encoding.(
      obj3 (req "value" int31) (req "min" int31) (req "max" int31))
    (function
      | Invalid_chunks_size {value; min; max} ->
          Some (value, min, max)
      | _ ->
          None)
    (fun (value, min, max) -> Invalid_chunks_size {value; min; max})

(***************************** p2p pool ***********************************)

type error += Pending_connection

type error += Connected

type error += Connection_refused

type error += Rejected of P2p_peer.Id.t

type error += Too_many_connections

type error += Private_mode

type error += Point_banned of P2p_point.Id.t

type error += Peer_banned of P2p_peer.Id.t

let () =
  (* Pending connection *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.pending_connection"
    ~title:"Pending connection"
    ~description:
      "Fail to connect with a peer: a connection is already pending."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Fail to connect with a peer: a connection is already pending.")
    Data_encoding.empty
    (function Pending_connection -> Some () | _ -> None)
    (fun () -> Pending_connection) ;
  (* Connected *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.connected"
    ~title:"Connected"
    ~description:
      "Fail to connect with a peer: a connection is already established."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Fail to connect with a peer: a connection is already established.")
    Data_encoding.empty
    (function Connected -> Some () | _ -> None)
    (fun () -> Connected) ;
  (* Connected refused *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.connection_refused"
    ~title:"Connection refused"
    ~description:"Connection was refused."
    ~pp:(fun ppf () -> Format.fprintf ppf "Connection was refused.")
    Data_encoding.empty
    (function Connection_refused -> Some () | _ -> None)
    (fun () -> Connection_refused) ;
  (* Rejected *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.rejected"
    ~title:"Rejected peer"
    ~description:"Connection to peer was rejected."
    ~pp:(fun ppf id ->
      Format.fprintf
        ppf
        "Connection to peer %a was rejected."
        P2p_peer.Id.pp
        id)
    Data_encoding.(obj1 (req "peer id" P2p_peer.Id.encoding))
    (function Rejected id -> Some id | _ -> None)
    (fun id -> Rejected id) ;
  (* Too many connections *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.too_many_connections"
    ~title:"Too many connections"
    ~description:"Too many connections."
    ~pp:(fun ppf () -> Format.fprintf ppf "Too many connections.")
    Data_encoding.empty
    (function Too_many_connections -> Some () | _ -> None)
    (fun () -> Too_many_connections) ;
  (* Private mode *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.private_mode"
    ~title:"Private mode"
    ~description:"Node is in private mode."
    ~pp:(fun ppf () -> Format.fprintf ppf "Node is in private mode.")
    Data_encoding.empty
    (function Private_mode -> Some () | _ -> None)
    (fun () -> Private_mode) ;
  (* Point Banned *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.point_banned"
    ~title:"Point Banned"
    ~description:"The address you tried to connect is banned."
    ~pp:(fun ppf (addr, _port) ->
      Format.fprintf
        ppf
        "The address you tried to connect (%a) is banned."
        P2p_addr.pp
        addr)
    Data_encoding.(obj1 (req "point" P2p_point.Id.encoding))
    (function Point_banned point -> Some point | _ -> None)
    (fun point -> Point_banned point) ;
  (* Peer Banned *)
  register_error_kind
    `Permanent
    ~id:"node.p2p_pool.peer_banned"
    ~title:"Peer Banned"
    ~description:"The peer identity you tried to connect is banned."
    ~pp:(fun ppf peer_id ->
      Format.fprintf
        ppf
        "The peer identity you tried to connect (%a) is banned."
        P2p_peer.Id.pp
        peer_id)
    Data_encoding.(obj1 (req "peer" P2p_peer.Id.encoding))
    (function Peer_banned peer_id -> Some peer_id | _ -> None)
    (fun peer_id -> Peer_banned peer_id)
src/lib_p2p/p2p_errors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



src/lib_p2p/p2p_fd.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* logging facility to monitor sockets *)

let is_not_windows = Sys.os_type <> "Win32"

let () =
  (* Otherwise some writes trigger a SIGPIPE instead of raising an
     Lwt_unit exception. In the node, this is already done by
     Cohttp, so this is only useful when using the P2P layer as a
     stand alone library.  *)
  if is_not_windows then Sys.(set_signal sigpipe Signal_ignore)

(* Logging facility for the P2P layer *)
module Log = Internal_event.Legacy_logging.Make (struct
  let name = "p2p.fd"
end)

type t = {
  fd : Lwt_unix.file_descr;
  id : int;
  mutable nread : int;
  mutable nwrit : int;
}

(* we use a prefix ' cnx:' that allows easy grepping in the log to lookup
   everything related to a particular connection. *)
let log t fmt = Format.kasprintf (fun s -> Log.debug "cnx:%d:%s" t.id s) fmt

let create =
  let counter = ref 0 in
  function
  | fd ->
      incr counter ;
      let t = {fd; id = !counter; nread = 0; nwrit = 0} in
      log t "create: fd %d" t.id ; t

let string_of_sockaddr addr =
  match addr with
  | Lwt_unix.ADDR_INET (ip, port) ->
      Printf.sprintf "%s:%d" (Unix.string_of_inet_addr ip) port
  | Lwt_unix.ADDR_UNIX file ->
      Printf.sprintf "@%s" file

let id t = t.id

let socket proto kind arg = create (Lwt_unix.socket proto kind arg)

let close t =
  log t "close: stats %d/%d" t.nread t.nwrit ;
  Lwt_utils_unix.safe_close t.fd

let read t buf pos len =
  log t "try-read: %d" len ;
  Lwt_unix.read t.fd buf pos len
  >>= fun nread ->
  t.nread <- t.nread + nread ;
  log t "read: %d (%d)" nread t.nread ;
  Lwt.return nread

let write t buf =
  let len = Bytes.length buf in
  log t "try-write: %d" len ;
  Lwt_utils_unix.write_mbytes t.fd buf
  >>= fun () ->
  t.nwrit <- t.nwrit + len ;
  log t "written: %d (%d)" len t.nwrit ;
  Lwt.return_unit

let connect t saddr =
  log t "connect: %s" (string_of_sockaddr saddr) ;
  Lwt_unix.connect t.fd saddr

let accept sock =
  Lwt_unix.accept sock
  >>= fun (fd, saddr) ->
  let t = create fd in
  log t "accept: %s" (string_of_sockaddr saddr) ;
  Lwt.return (t, saddr)

module Table = Hashtbl.Make (struct
  type nonrec t = t

  let equal {id = x; _} {id = y; _} = x = y

  let hash {id; _} = Hashtbl.hash id
end)
src/lib_p2p/p2p_fd.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition is_not_windows : bool := nequiv_decb Sys.os_type "Win32" % string.



(* ❌ Applications of functors are not handled. *)
functor_application

Record t := {
  fd : Lwt_unix.file_descr;
  id : Z;
  nread : Z;
  nwrit : Z }.

Definition log {A : Type}
  (t : t) (fmt : Stdlib.format4 A Stdlib.Format.formatter unit unit) : A :=
  Format.kasprintf
    (fun s =>
      Log.debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "cnx:" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "cnx:%d:%s" % string) (id t) s) fmt.

Definition create : Lwt_unix.file_descr -> t :=
  let counter := Stdlib.ref 0 in
  fun fd =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.incr counter in
    let t :=
      {| fd := fd; id := Stdlib.op_exclamation counter; nread := 0; nwrit := 0
        |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log t
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "create: fd " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format)) "create: fd %d" % string)
        (id t) in
    t.

Definition string_of_sockaddr (addr : Lwt_unix.sockaddr) : string :=
  match addr with
  | Lwt_unix.ADDR_INET ip port =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal ":" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s:%d" % string)
      (Unix.string_of_inet_addr ip) port
  | Lwt_unix.ADDR_UNIX file =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "@" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "@%s" % string) file
  end.

Definition id (t : t) : Z := id t.

Definition socket
  (proto : Lwt_unix.socket_domain) (kind : Lwt_unix.socket_type) (arg : Z)
  : t := create (Lwt_unix.socket proto kind arg).

Definition close (t : t) : Lwt.t unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    log t
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "close: stats " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "/" % char
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format))))
        "close: stats %d/%d" % string) (nread t) (nwrit t) in
  Lwt_utils_unix.safe_close (fd t).

Definition read (t : t) (buf : string) (pos : Z) (len : Z) : Lwt.t Z :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    log t
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "try-read: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "try-read: %d" % string)
      len in
  op_gtgteq (Lwt_unix.read (fd t) buf pos len)
    (fun nread =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field t "nread" % string (Z.add (nread t) nread) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        log t
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "read: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " (" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))
            "read: %d (%d)" % string) nread (nread t) in
      Lwt._return nread).

Definition write (t : t) (buf : Stdlib.Bytes.t) : Lwt.t unit :=
  let len := String.length buf in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    log t
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "try-write: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "try-write: %d" % string)
      len in
  op_gtgteq (Lwt_utils_unix.write_mbytes None None (fd t) buf)
    (fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field t "nwrit" % string (Z.add (nwrit t) len) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        log t
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "written: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " (" % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))
            "written: %d (%d)" % string) len (nwrit t) in
      Lwt.return_unit).

Definition connect (t : t) (saddr : Lwt_unix.sockaddr) : Lwt.t unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    log t
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "connect: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "connect: %s" % string)
      (string_of_sockaddr saddr) in
  Lwt_unix.connect (fd t) saddr.

Definition accept (sock : Lwt_unix.file_descr)
  : Lwt.t (t * Lwt_unix.sockaddr) :=
  op_gtgteq (Lwt_unix.accept sock)
    (fun function_parameter =>
      let '(fd, saddr) := function_parameter in
      let t := create fd in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        log t
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "accept: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)) "accept: %s" % string)
          (string_of_sockaddr saddr) in
      Lwt._return (t, saddr)).

(* ❌ Applications of functors are not handled. *)
functor_application

src/lib_p2p/p2p_io_scheduler.ml 58 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* TODO decide whether we need to preallocate buffers or not. *)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.io-scheduler"
end)

let alpha = 0.2

module type IO = sig
  val name : string

  type in_param

  val pop : in_param -> Bytes.t tzresult Lwt.t

  type out_param

  val push : out_param -> Bytes.t -> unit tzresult Lwt.t

  val close : out_param -> error list -> unit Lwt.t
end

module Scheduler (IO : IO) = struct
  [@@@ocaml.warning "-30"]

  type t = {
    canceler : Lwt_canceler.t;
    mutable worker : unit Lwt.t;
    counter : Moving_average.t;
    max_speed : int option;
    mutable quota : int;
    quota_updated : unit Lwt_condition.t;
    readys : unit Lwt_condition.t;
    readys_high : (connection * Bytes.t tzresult) Queue.t;
    readys_low : (connection * Bytes.t tzresult) Queue.t;
  }

  and connection = {
    id : int;
    mutable closed : bool;
    canceler : Lwt_canceler.t;
    in_param : IO.in_param;
    out_param : IO.out_param;
    mutable current_pop : Bytes.t tzresult Lwt.t;
    mutable current_push : unit tzresult Lwt.t;
    counter : Moving_average.t;
    mutable quota : int;
    mutable last_quota : int;
  }

  let cancel (conn : connection) err =
    Lwt_utils.unless conn.closed (fun () ->
        lwt_debug "Connection closed (%d, %s) " conn.id IO.name
        >>= fun () ->
        conn.closed <- true ;
        Lwt.catch
          (fun () -> IO.close conn.out_param err)
          (fun _ -> Lwt.return_unit)
        >>= fun () -> Lwt_canceler.cancel conn.canceler)

  let waiter st conn =
    assert (Lwt.state conn.current_pop <> Sleep) ;
    conn.current_pop <- IO.pop conn.in_param ;
    Lwt.async (fun () ->
        conn.current_pop
        >>= fun res ->
        conn.current_push
        >>= fun _ ->
        let was_empty =
          Queue.is_empty st.readys_high && Queue.is_empty st.readys_low
        in
        if conn.quota > 0 then Queue.push (conn, res) st.readys_high
        else Queue.push (conn, res) st.readys_low ;
        if was_empty then Lwt_condition.broadcast st.readys () ;
        Lwt.return_unit)

  let wait_data st =
    let is_empty =
      Queue.is_empty st.readys_high && Queue.is_empty st.readys_low
    in
    if is_empty then Lwt_condition.wait st.readys else Lwt.return_unit

  let check_quota st =
    if st.max_speed <> None && st.quota < 0 then
      lwt_debug "scheduler.wait_quota(%s)" IO.name
      >>= fun () -> Lwt_condition.wait st.quota_updated
    else Lwt_unix.yield ()

  let rec worker_loop st =
    check_quota st
    >>= fun () ->
    lwt_debug "scheduler.wait(%s)" IO.name
    >>= fun () ->
    Lwt.pick [Lwt_canceler.cancellation st.canceler; wait_data st]
    >>= fun () ->
    if Lwt_canceler.canceled st.canceler then Lwt.return_unit
    else
      let (prio, (conn, msg)) =
        if not (Queue.is_empty st.readys_high) then
          (true, Queue.pop st.readys_high)
        else (false, Queue.pop st.readys_low)
      in
      match msg with
      | Error (Canceled :: _) ->
          worker_loop st
      | Error (P2p_errors.Connection_closed :: _ as err)
      | Error (Exn Lwt_pipe.Closed :: _ as err)
      | Error (Exn (Unix.Unix_error ((EBADF | ETIMEDOUT), _, _)) :: _ as err)
        ->
          lwt_debug "Connection closed (pop: %d, %s)" conn.id IO.name
          >>= fun () -> cancel conn err >>= fun () -> worker_loop st
      | Error err ->
          lwt_log_error
            "@[Unexpected error in connection (pop: %d, %s):@ %a@]"
            conn.id
            IO.name
            pp_print_error
            err
          >>= fun () -> cancel conn err >>= fun () -> worker_loop st
      | Ok msg ->
          conn.current_push <-
            ( IO.push conn.out_param msg
            >>= function
            | Ok () | Error (Canceled :: _) ->
                return_unit
            | Error (P2p_errors.Connection_closed :: _ as err)
            | Error (Exn (Unix.Unix_error (EBADF, _, _)) :: _ as err)
            | Error (Exn Lwt_pipe.Closed :: _ as err) ->
                lwt_debug "Connection closed (push: %d, %s)" conn.id IO.name
                >>= fun () -> cancel conn err >>= fun () -> return_unit
            | Error err ->
                lwt_log_error
                  "@[Unexpected error in connection (push: %d, %s):@ %a@]"
                  conn.id
                  IO.name
                  pp_print_error
                  err
                >>= fun () ->
                cancel conn err >>= fun () -> Lwt.return_error err ) ;
          let len = Bytes.length msg in
          lwt_debug "Handle: %d (%d, %s)" len conn.id IO.name
          >>= fun () ->
          Moving_average.add st.counter len ;
          st.quota <- st.quota - len ;
          Moving_average.add conn.counter len ;
          if prio then conn.quota <- conn.quota - len ;
          waiter st conn ;
          worker_loop st

  let create max_speed =
    let st =
      {
        canceler = Lwt_canceler.create ();
        worker = Lwt.return_unit;
        counter = Moving_average.create ~init:0 ~alpha;
        max_speed;
        quota = Option.unopt ~default:0 max_speed;
        quota_updated = Lwt_condition.create ();
        readys = Lwt_condition.create ();
        readys_high = Queue.create ();
        readys_low = Queue.create ();
      }
    in
    st.worker <-
      Lwt_utils.worker
        IO.name
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
    st

  let create_connection st in_param out_param canceler id =
    debug "scheduler(%s).create_connection (%d)" IO.name id ;
    let conn =
      {
        id;
        closed = false;
        canceler;
        in_param;
        out_param;
        current_pop = Lwt.fail Not_found (* dummy *);
        current_push = return_unit;
        counter = Moving_average.create ~init:0 ~alpha;
        quota = 0;
        last_quota = 0;
      }
    in
    waiter st conn ; conn

  let update_quota st =
    debug "scheduler(%s).update_quota" IO.name ;
    Option.iter st.max_speed ~f:(fun quota ->
        st.quota <- min st.quota 0 + quota ;
        Lwt_condition.broadcast st.quota_updated ()) ;
    if not (Queue.is_empty st.readys_low) then (
      let tmp = Queue.create () in
      Queue.iter
        (fun (((conn : connection), _) as msg) ->
          if conn.quota > 0 then Queue.push msg st.readys_high
          else Queue.push msg tmp)
        st.readys_low ;
      Queue.clear st.readys_low ;
      Queue.transfer tmp st.readys_low )

  let shutdown st =
    lwt_debug "--> scheduler(%s).shutdown" IO.name
    >>= fun () ->
    Lwt_canceler.cancel st.canceler
    >>= fun () ->
    st.worker >>= fun () -> lwt_debug "<-- scheduler(%s).shutdown" IO.name
end

module ReadScheduler = Scheduler (struct
  let name = "io_scheduler(read)"

  type in_param = P2p_fd.t * int

  let pop (fd, maxlen) =
    Lwt.catch
      (fun () ->
        let buf = Bytes.create maxlen in
        P2p_fd.read fd buf 0 maxlen
        >>= fun len ->
        if len = 0 then fail P2p_errors.Connection_closed
        else return (Bytes.sub buf 0 len))
      (function
        | Unix.Unix_error (Unix.ECONNRESET, _, _) ->
            fail P2p_errors.Connection_closed
        | exn ->
            Lwt.return (error_exn exn))

  type out_param = Bytes.t tzresult Lwt_pipe.t

  let push p msg =
    Lwt.catch
      (fun () -> Lwt_pipe.push p (Ok msg) >>= fun () -> return_unit)
      (fun exn -> fail (Exn exn))

  let close p err =
    Lwt.catch
      (fun () -> Lwt_pipe.push p (Error err))
      (fun _ -> Lwt.return_unit)
end)

module WriteScheduler = Scheduler (struct
  let name = "io_scheduler(write)"

  type in_param = Bytes.t Lwt_pipe.t

  let pop p =
    Lwt.catch
      (fun () -> Lwt_pipe.pop p >>= return)
      (fun _ -> fail (Exn Lwt_pipe.Closed))

  type out_param = P2p_fd.t

  let push fd buf =
    Lwt.catch
      (fun () -> P2p_fd.write fd buf >>= return)
      (function
        | Unix.Unix_error (Unix.ECONNRESET, _, _)
        | Unix.Unix_error (Unix.EPIPE, _, _)
        | Lwt.Canceled
        | End_of_file ->
            fail P2p_errors.Connection_closed
        | exn ->
            Lwt.return (error_exn exn))

  let close _p _err = Lwt.return_unit
end)

type connection = {
  sched : t;
  fd : P2p_fd.t;
  canceler : Lwt_canceler.t;
  read_conn : ReadScheduler.connection;
  read_queue : Bytes.t tzresult Lwt_pipe.t;
  write_conn : WriteScheduler.connection;
  write_queue : Bytes.t Lwt_pipe.t;
  mutable partial_read : Bytes.t option;
}

and t = {
  mutable closed : bool;
  connected : connection P2p_fd.Table.t;
  read_scheduler : ReadScheduler.t;
  write_scheduler : WriteScheduler.t;
  max_upload_speed : int option;
  (* bytes per second. *)
  max_download_speed : int option;
  read_buffer_size : int;
  read_queue_size : int option;
  write_queue_size : int option;
}

let reset_quota st =
  debug "--> reset quota" ;
  let {Moving_average.average = current_inflow; _} =
    Moving_average.stat st.read_scheduler.counter
  and {Moving_average.average = current_outflow; _} =
    Moving_average.stat st.write_scheduler.counter
  in
  let nb_conn = P2p_fd.Table.length st.connected in
  ( if nb_conn > 0 then
    let fair_read_quota = current_inflow / nb_conn
    and fair_write_quota = current_outflow / nb_conn in
    P2p_fd.Table.iter
      (fun _id conn ->
        conn.read_conn.last_quota <- fair_read_quota ;
        conn.read_conn.quota <- min conn.read_conn.quota 0 + fair_read_quota ;
        conn.write_conn.last_quota <- fair_write_quota ;
        conn.write_conn.quota <- min conn.write_conn.quota 0 + fair_write_quota)
      st.connected ) ;
  ReadScheduler.update_quota st.read_scheduler ;
  WriteScheduler.update_quota st.write_scheduler

let create ?max_upload_speed ?max_download_speed ?read_queue_size
    ?write_queue_size ~read_buffer_size () =
  log_info "--> create" ;
  let st =
    {
      closed = false;
      connected = P2p_fd.Table.create 53;
      read_scheduler = ReadScheduler.create max_download_speed;
      write_scheduler = WriteScheduler.create max_upload_speed;
      max_upload_speed;
      max_download_speed;
      read_buffer_size;
      read_queue_size;
      write_queue_size;
    }
  in
  Moving_average.on_update (fun () -> reset_quota st) ;
  st

exception Closed

let read_size = function
  | Ok buf ->
      (Sys.word_size / 8 * 8) + Bytes.length buf + Lwt_pipe.push_overhead
  | Error _ ->
      0

(* we push Error only when we close the socket,
                    we don't fear memory leaks in that case... *)

let write_size mbytes =
  (Sys.word_size / 8 * 6) + Bytes.length mbytes + Lwt_pipe.push_overhead

let register st fd =
  if st.closed then (
    Lwt.async (fun () -> P2p_fd.close fd) ;
    raise Closed )
  else
    let id = P2p_fd.id fd in
    let canceler = Lwt_canceler.create () in
    let read_size =
      Option.map st.read_queue_size ~f:(fun v -> (v, read_size))
    in
    let write_size =
      Option.map st.write_queue_size ~f:(fun v -> (v, write_size))
    in
    let read_queue = Lwt_pipe.create ?size:read_size () in
    let write_queue = Lwt_pipe.create ?size:write_size () in
    let read_conn =
      ReadScheduler.create_connection
        st.read_scheduler
        (fd, st.read_buffer_size)
        read_queue
        canceler
        id
    and write_conn =
      WriteScheduler.create_connection
        st.write_scheduler
        write_queue
        fd
        canceler
        id
    in
    Lwt_canceler.on_cancel canceler (fun () ->
        P2p_fd.Table.remove st.connected fd ;
        Moving_average.destroy read_conn.counter ;
        Moving_average.destroy write_conn.counter ;
        Lwt_pipe.close write_queue ;
        Lwt_pipe.close read_queue ;
        P2p_fd.close fd) ;
    let conn =
      {
        sched = st;
        fd;
        canceler;
        read_queue;
        read_conn;
        write_queue;
        write_conn;
        partial_read = None;
      }
    in
    P2p_fd.Table.add st.connected conn.fd conn ;
    log_info "--> register (%d)" id ;
    conn

let write ?canceler {write_queue; _} msg =
  trace P2p_errors.Connection_closed
  @@ protect ?canceler (fun () ->
         Lwt_pipe.push write_queue msg >>= fun () -> return_unit)

let write_now {write_queue; _} msg = Lwt_pipe.push_now write_queue msg

let read_from conn ?pos ?len buf msg =
  let maxlen = Bytes.length buf in
  let pos = Option.unopt ~default:0 pos in
  assert (0 <= pos && pos < maxlen) ;
  let len = Option.unopt ~default:(maxlen - pos) len in
  assert (len <= maxlen - pos) ;
  match msg with
  | Ok msg ->
      let msg_len = Bytes.length msg in
      let read_len = min len msg_len in
      Bytes.blit msg 0 buf pos read_len ;
      if read_len < msg_len then
        conn.partial_read <- Some (Bytes.sub msg read_len (msg_len - read_len)) ;
      Ok read_len
  | Error _ ->
      error P2p_errors.Connection_closed

let read_now conn ?pos ?len buf =
  match conn.partial_read with
  | Some msg ->
      conn.partial_read <- None ;
      Some (read_from conn ?pos ?len buf (Ok msg))
  | None -> (
    try
      Option.map
        ~f:(read_from conn ?pos ?len buf)
        (Lwt_pipe.pop_now conn.read_queue)
    with Lwt_pipe.Closed -> Some (error P2p_errors.Connection_closed) )

let read ?canceler conn ?pos ?len buf =
  match conn.partial_read with
  | Some msg ->
      conn.partial_read <- None ;
      Lwt.return (read_from conn ?pos ?len buf (Ok msg))
  | None ->
      Lwt.catch
        (fun () ->
          protect ?canceler (fun () -> Lwt_pipe.pop conn.read_queue)
          >|= fun msg -> read_from conn ?pos ?len buf msg)
        (fun _ -> fail P2p_errors.Connection_closed)

let read_full ?canceler conn ?pos ?len buf =
  let maxlen = Bytes.length buf in
  let pos = Option.unopt ~default:0 pos in
  let len = Option.unopt ~default:(maxlen - pos) len in
  assert (0 <= pos && pos < maxlen) ;
  assert (len <= maxlen - pos) ;
  let rec loop pos len =
    if len = 0 then return_unit
    else
      read ?canceler conn ~pos ~len buf
      >>=? fun read_len -> loop (pos + read_len) (len - read_len)
  in
  loop pos len

let convert ~ws ~rs =
  {
    P2p_stat.total_sent = ws.Moving_average.total;
    total_recv = rs.Moving_average.total;
    current_outflow = ws.average;
    current_inflow = rs.average;
  }

let global_stat {read_scheduler; write_scheduler; _} =
  let rs = Moving_average.stat read_scheduler.counter
  and ws = Moving_average.stat write_scheduler.counter in
  convert ~rs ~ws

let stat {read_conn; write_conn; _} =
  let rs = Moving_average.stat read_conn.counter
  and ws = Moving_average.stat write_conn.counter in
  convert ~rs ~ws

let close ?timeout conn =
  let id = P2p_fd.id conn.fd in
  lwt_log_info "--> close (%d)" id
  >>= fun () ->
  P2p_fd.Table.remove conn.sched.connected conn.fd ;
  Lwt_pipe.close conn.write_queue ;
  ( match timeout with
  | None ->
      return (Lwt_canceler.cancellation conn.canceler)
  | Some timeout ->
      with_timeout
        ~canceler:conn.canceler
        (Lwt_unix.sleep timeout)
        (fun canceler -> return (Lwt_canceler.cancellation canceler)) )
  >>=? fun _ ->
  conn.write_conn.current_push
  >>= fun res -> lwt_log_info "<-- close (%d)" id >>= fun () -> Lwt.return res

let iter_connection {connected; _} f =
  P2p_fd.Table.iter (fun _ conn -> f conn) connected

let shutdown ?timeout st =
  lwt_log_info "--> shutdown"
  >>= fun () ->
  st.closed <- true ;
  ReadScheduler.shutdown st.read_scheduler
  >>= fun () ->
  P2p_fd.Table.fold
    (fun _peer_id conn acc -> close ?timeout conn >>= fun _ -> acc)
    st.connected
    Lwt.return_unit
  >>= fun () ->
  WriteScheduler.shutdown st.write_scheduler
  >>= fun () -> lwt_log_info "<-- shutdown"

let id conn = P2p_fd.id conn.fd
src/lib_p2p/p2p_io_scheduler.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition alpha : Z :=
  (* ❌ Float constant 0.2 is approximated by the integer 0 *)
  0.

Module IO.
  Record signature {in_param out_param : Type} := {
    name : string;
    in_param := in_param;
    pop : in_param -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t);
    out_param := out_param;
    push : out_param ->
      Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    close : out_param -> (list Tezos_base__TzPervasives.error) -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End IO.

(* ❌ Functors are not handled. *)
functor

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

.

Definition reset_quota (st : t) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    debug
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> reset quota" % string
          CamlinternalFormatBasics.End_of_format) "--> reset quota" % string) in
  in
  let nb_conn := P2p_fd.Table.length (connected st) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if OCaml.Stdlib.gt nb_conn 0 then
      let fair_read_quota : Z :=
        Z.div current_inflow nb_conn
      with fair_write_quota : Z :=
        Z.div current_outflow nb_conn in
      P2p_fd.Table.iter
        (fun _id =>
          fun conn =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field (read_conn conn) "last_quota" % string
                fair_read_quota in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field (read_conn conn) "quota" % string
                (Z.add (OCaml.Stdlib.min (quota (read_conn conn)) 0)
                  fair_read_quota) in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field (write_conn conn) "last_quota" % string
                fair_write_quota in
            (* ❌ Set record field not handled. *)
            set_record_field (write_conn conn) "quota" % string
              (Z.add (OCaml.Stdlib.min (quota (write_conn conn)) 0)
                fair_write_quota)) (connected st)
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := ReadScheduler.update_quota (read_scheduler st) in
  WriteScheduler.update_quota (write_scheduler st).

Definition create
  (max_upload_speed : option Z) (max_download_speed : option Z)
  (read_queue_size : option Z) (write_queue_size : option Z)
  (read_buffer_size : Z) (function_parameter : unit) : t :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> create" % string
          CamlinternalFormatBasics.End_of_format) "--> create" % string) in
  let st :=
    {| closed := false; connected := P2p_fd.Table.create 53;
      read_scheduler := ReadScheduler.create max_download_speed;
      write_scheduler := WriteScheduler.create max_upload_speed;
      max_upload_speed := max_upload_speed;
      max_download_speed := max_download_speed;
      read_buffer_size := read_buffer_size; read_queue_size := read_queue_size;
      write_queue_size := write_queue_size |} in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Moving_average.on_update
      (fun function_parameter =>
        let 'tt := function_parameter in
        reset_quota st) in
  st.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition read_size {A : Type} (function_parameter : sum string A) : Z :=
  match function_parameter with
  | Stdlib.Ok buf =>
    Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 8) (String.length buf))
      Lwt_pipe.push_overhead
  | Stdlib.Error _ => 0
  end.

Definition write_size (mbytes : string) : Z :=
  Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 6) (String.length mbytes))
    Lwt_pipe.push_overhead.

Definition register (st : t) (fd : Tezos_p2p.P2p_fd.t) : connection :=
  if closed st then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Lwt.async
        (fun function_parameter =>
          let 'tt := function_parameter in
          P2p_fd.close fd) in
    Stdlib.raise Closed
  else
    let id := P2p_fd.id fd in
    let canceler := Lwt_canceler.create tt in
    let read_size := Option.map (fun v => (v, read_size)) (read_queue_size st)
      in
    let write_size :=
      Option.map (fun v => (v, write_size)) (write_queue_size st) in
    let read_queue := Lwt_pipe.create read_size tt in
    let write_queue := Lwt_pipe.create write_size tt in
    let read_conn : ReadScheduler.connection :=
      ReadScheduler.create_connection (read_scheduler st)
        (fd, (read_buffer_size st)) read_queue canceler id
    with write_conn : WriteScheduler.connection :=
      WriteScheduler.create_connection (write_scheduler st) write_queue fd
        canceler id in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Lwt_canceler.on_cancel canceler
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := P2p_fd.Table.remove (connected st) fd in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Moving_average.destroy (counter read_conn) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Moving_average.destroy (counter write_conn) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_pipe.close write_queue in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_pipe.close read_queue in
          P2p_fd.close fd) in
    let conn :=
      {| sched := st; fd := fd; canceler := canceler; read_conn := read_conn;
        read_queue := read_queue; write_conn := write_conn;
        write_queue := write_queue; partial_read := None |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_fd.Table.add (connected st) (fd conn) conn in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "--> register (" % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "--> register (%d)" % string) id in
    conn.

Definition write
  (canceler : option Tezos_stdlib.Lwt_canceler.t)
  (function_parameter : connection)
  : Stdlib.Bytes.t -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{| write_queue := write_queue |} := function_parameter in
  fun msg =>
    apply (trace Tezos_base__TzPervasives.Connection_closed)
      (protect None canceler
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Lwt_pipe.push write_queue msg)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit))).

Definition write_now (function_parameter : connection)
  : Stdlib.Bytes.t -> bool :=
  let '{| write_queue := write_queue |} := function_parameter in
  fun msg => Lwt_pipe.push_now write_queue msg.

Definition read_from {A : Type}
  (conn : connection) (pos : option Z) (len : option Z) (buf : string)
  (msg : sum string A) : sum Z Tezos_base__TzPervasives.trace :=
  let maxlen := String.length buf in
  let pos := Option.unopt 0 pos in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (andb (OCaml.Stdlib.le 0 pos) (OCaml.Stdlib.lt pos maxlen)) in
  let len := Option.unopt (Z.sub maxlen pos) len in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.le len (Z.sub maxlen pos)) in
  match msg with
  | Stdlib.Ok msg =>
    let msg_len := String.length msg in
    let read_len := OCaml.Stdlib.min len msg_len in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.Bytes.blit msg 0 buf pos read_len in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if OCaml.Stdlib.lt read_len msg_len then
        (* ❌ Set record field not handled. *)
        set_record_field conn "partial_read" % string
          (Some (String.sub msg read_len (Z.sub msg_len read_len)))
      else
        tt in
    Stdlib.Ok read_len
  | Stdlib.Error _ => error Tezos_base__TzPervasives.Connection_closed
  end.

Definition read_now
  (conn : connection) (pos : option Z) (len : option Z) (buf : string)
  : option (sum Z Tezos_base__TzPervasives.trace) :=
  match partial_read conn with
  | Some msg =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field conn "partial_read" % string None in
    Some (read_from conn pos len buf (Stdlib.Ok msg))
  | None =>
    (* ❌ Try-with are not handled *)
    try
      (Option.map (read_from conn pos len buf)
        (Lwt_pipe.pop_now (read_queue conn)))
  end.

Definition read
  (canceler : option Tezos_stdlib.Lwt_canceler.t) (conn : connection)
  (pos : option Z) (len : option Z) (buf : string)
  : Lwt.t (sum Z Tezos_base__TzPervasives.trace) :=
  match partial_read conn with
  | Some msg =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field conn "partial_read" % string None in
    Lwt._return (read_from conn pos len buf (Stdlib.Ok msg))
  | None =>
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtpipeeq
          (protect None canceler
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt_pipe.pop (read_queue conn)))
          (fun msg => read_from conn pos len buf msg))
      (fun function_parameter =>
        let '_ := function_parameter in
        fail Tezos_base__TzPervasives.Connection_closed)
  end.

Definition read_full
  (canceler : option Tezos_stdlib.Lwt_canceler.t) (conn : connection)
  (pos : option Z) (len : option Z) (buf : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let maxlen := String.length buf in
  let pos := Option.unopt 0 pos in
  let len := Option.unopt (Z.sub maxlen pos) len in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (andb (OCaml.Stdlib.le 0 pos) (OCaml.Stdlib.lt pos maxlen)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.le len (Z.sub maxlen pos)) in
  let fix loop (pos : Z) (len : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    if equiv_decb len 0 then
      return_unit
    else
      op_gtgteqquestion (read canceler conn (Some pos) (Some len) buf)
        (fun read_len => loop (Z.add pos read_len) (Z.sub len read_len)) in
  loop pos len.

Definition convert
  (ws : Tezos_stdlib_unix.Moving_average.stat)
  (rs : Tezos_stdlib_unix.Moving_average.stat)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  {| P2p_stat.total_sent := Moving_average.total ws;
    P2p_stat.total_recv := Moving_average.total rs;
    P2p_stat.current_inflow := average rs;
    P2p_stat.current_outflow := average ws |}.

Definition global_stat (function_parameter : t)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  let '{|
    read_scheduler := read_scheduler; write_scheduler := write_scheduler |} :=
    function_parameter in
  let rs : Tezos_stdlib_unix.Moving_average.stat :=
    Moving_average.stat (counter read_scheduler)
  with ws : Tezos_stdlib_unix.Moving_average.stat :=
    Moving_average.stat (counter write_scheduler) in
  convert ws rs.

Definition stat (function_parameter : connection)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  let '{| read_conn := read_conn; write_conn := write_conn |} :=
    function_parameter in
  let rs : Tezos_stdlib_unix.Moving_average.stat :=
    Moving_average.stat (counter read_conn)
  with ws : Tezos_stdlib_unix.Moving_average.stat :=
    Moving_average.stat (counter write_conn) in
  convert ws rs.

Definition close (timeout : option Z) (conn : connection)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let id := P2p_fd.id (fd conn) in
  op_gtgteq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> close (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "--> close (%d)" % string) id)
    (fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := P2p_fd.Table.remove (connected (sched conn)) (fd conn) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Lwt_pipe.close (write_queue conn) in
      op_gtgteqquestion
        match timeout with
        | None => _return (Lwt_canceler.cancellation (canceler conn))
        | Some timeout =>
          with_timeout (Some (canceler conn)) (Lwt_unix.sleep timeout)
            (fun canceler => _return (Lwt_canceler.cancellation canceler))
        end
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteq (current_push (write_conn conn))
            (fun res =>
              op_gtgteq
                (lwt_log_info
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "<-- close (" % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "<-- close (%d)" % string) id)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt._return res)))).

Definition iter_connection (function_parameter : t)
  : (connection -> unit) -> unit :=
  let '{| connected := connected |} := function_parameter in
  fun f =>
    P2p_fd.Table.iter
      (fun function_parameter =>
        let '_ := function_parameter in
        fun conn => f conn) connected.

Definition shutdown (timeout : option Z) (st : t) : Lwt.t unit :=
  op_gtgteq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "--> shutdown" % string
          CamlinternalFormatBasics.End_of_format) "--> shutdown" % string))
    (fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field st "closed" % string true in
      op_gtgteq (ReadScheduler.shutdown (read_scheduler st))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (P2p_fd.Table.fold
              (fun _peer_id =>
                fun conn =>
                  fun acc =>
                    op_gtgteq (close timeout conn)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        acc)) (connected st) Lwt.return_unit)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (WriteScheduler.shutdown (write_scheduler st))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  lwt_log_info
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<-- shutdown" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<-- shutdown" % string))))).

Definition id (conn : connection) : Z := P2p_fd.id (fd conn).

src/lib_p2p/p2p_maintenance.ml 59 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.maintenance"
end)

let time_between_looking_for_peers = 5.0 (* TODO put this in config *)

type bounds = {
  min_threshold : int;
  min_target : int;
  max_target : int;
  max_threshold : int;
}

type config = {
  maintenance_idle_time : Time.System.Span.t;
  greylist_timeout : Time.System.Span.t;
  private_mode : bool;
  min_connections : int;
  max_connections : int;
  expected_connections : int;
}

type ('msg, 'meta, 'meta_conn) t = {
  canceler : Lwt_canceler.t;
  config : config;
  bounds : bounds;
  pool : ('msg, 'meta, 'meta_conn) P2p_pool.t;
  connect_handler : ('msg, 'meta, 'meta_conn) P2p_connect_handler.t;
  discovery : P2p_discovery.t option;
  just_maintained : unit Lwt_condition.t;
  please_maintain : unit Lwt_condition.t;
  mutable maintain_worker : unit Lwt.t;
  triggers : P2p_trigger.t;
  log : P2p_connection.P2p_event.t -> unit;
}

let broadcast_bootstrap_msg pool =
  P2p_peer.Table.iter
    (fun _peer_id peer_info ->
      match P2p_peer_state.get peer_info with
      | Running {data = conn; _} ->
          if not (P2p_conn.private_node conn) then
            ignore (P2p_conn.write_bootstrap conn)
      | _ ->
          ())
    (P2p_pool.connected_peer_ids pool)

let send_swap_request t =
  match P2p_pool.Connection.propose_swap_request t.pool with
  | None ->
      ()
  | Some (proposed_point, proposed_peer_id, recipient) ->
      let recipient_peer_id = (P2p_conn.info recipient).peer_id in
      t.log (Swap_request_sent {source = recipient_peer_id}) ;
      ignore
        (P2p_conn.write_swap_request recipient proposed_point proposed_peer_id)

let classify pool private_mode start_time seen_points point pi =
  let now = Systime_os.now () in
  if
    P2p_point.Set.mem point seen_points
    || P2p_pool.Points.banned pool point
    || (private_mode && not (P2p_point_state.Info.trusted pi))
  then `Ignore
  else
    match P2p_point_state.get pi with
    | Disconnected -> (
      match P2p_point_state.Info.last_miss pi with
      | Some last
        when Time.System.(start_time < last)
             || P2p_point_state.Info.greylisted ~now pi ->
          `Seen
      | last ->
          `Candidate last )
    | _ ->
        `Seen

(** [establish t contactable] tries to establish as many connection as possible
    with points in [contactable]. It returns the number of established
    connections *)
let establish t contactable =
  let try_to_connect acc point =
    protect ~canceler:t.canceler (fun () ->
        P2p_connect_handler.connect t.connect_handler point)
    >>= function Ok _ -> acc >|= succ | Error _ -> acc
  in
  List.fold_left try_to_connect (Lwt.return 0) contactable

(* [connectable t start_time expected seen_points] selects at most
   [expected] connections candidates from the known points, not in [seen]
   points. *)
let connectable t start_time expected seen_points =
  let module Bounded_point_info = List.Bounded (struct
    type t = Time.System.t option * P2p_point.Id.t

    let compare (t1, _) (t2, _) =
      match (t1, t2) with
      | (None, None) ->
          0
      | (None, Some _) ->
          1
      | (Some _, None) ->
          -1
      | (Some t1, Some t2) ->
          Time.System.compare t2 t1
  end) in
  let acc = Bounded_point_info.create expected in
  let f point pi seen_points =
    match
      classify t.pool t.config.private_mode start_time seen_points point pi
    with
    | `Ignore ->
        seen_points (* Ignored points can be retried again *)
    | `Candidate last ->
        Bounded_point_info.insert (last, point) acc ;
        P2p_point.Set.add point seen_points
    | `Seen ->
        P2p_point.Set.add point seen_points
  in
  let seen_points = P2p_pool.Points.fold_known t.pool ~init:seen_points ~f in
  (List.map snd (Bounded_point_info.get acc), seen_points)

(* [try_to_contact_loop t start_time ~seen_points] is the main loop
    for contacting points. [start_time] is set when calling the function
    and remains constant in the loop. [seen_points] simply accumulates the
    points already seen, to avoid trying to contact them again.

    It repeats two operations until the number of connections is reached:
      - get [max_to_contact] points
      - connect to many of them as possible

   TODO why not the simpler implementation. Sort all candidates points,
        and try to connect to [n] of them. *)
let rec try_to_contact_loop t start_time ~seen_points min_to_contact
    max_to_contact =
  if min_to_contact <= 0 then Lwt.return_true
  else
    let (candidates, seen_points) =
      connectable t start_time max_to_contact seen_points
    in
    if candidates = [] then Lwt_unix.yield () >>= fun () -> Lwt.return_false
    else
      establish t candidates
      >>= fun established ->
      try_to_contact_loop
        t
        start_time
        ~seen_points
        (min_to_contact - established)
        (max_to_contact - established)

(** [try_to_contact t min_to_contact max_to_contact] tries to create
    between [min_to_contact] and [max_to_contact] new connections.

    It goes through all know points, and ignores points which are
    - greylisted,
    - banned,
    - for which a connection failed after the time this function is called
    - Non-trusted points if option --private-mode is set.

    It tries to favor points for which the last failed missed connection is old.

    Note that this function works as a sequence of lwt tasks that tries
    to incrementally reach the number of connections. The set of
    known points maybe be concurrently updated. *)
let try_to_contact t min_to_contact max_to_contact =
  let start_time = Systime_os.now () in
  let seen_points = P2p_point.Set.empty in
  try_to_contact_loop t start_time min_to_contact max_to_contact ~seen_points

(** not enough contacts, ask the pals of our pals,
    discover the local network and then wait *)
let ask_for_more_contacts t =
  broadcast_bootstrap_msg t.pool ;
  Option.iter ~f:P2p_discovery.wakeup t.discovery ;
  protect ~canceler:t.canceler (fun () ->
      Lwt.pick
        [ P2p_trigger.wait_new_peer t.triggers;
          P2p_trigger.wait_new_point t.triggers;
          (* TODO exponential back-off, or wait for the existence
         of a non grey-listed peer? *)
          Lwt_unix.sleep time_between_looking_for_peers ]
      >>= fun () -> return_unit)

(** Selects [n] random connections. Ignore connections to
    nodes who are both private and trusted. *)
let random_connections pool n =
  let open P2p_conn in
  let f _ conn acc =
    if private_node conn && trusted_node conn then acc else conn :: acc
  in
  let candidates =
    P2p_pool.Connection.fold pool ~init:[] ~f |> TzList.shuffle
  in
  TzList.rev_sub candidates n

(** GC peers from the greylist that has been greylisted for more than
    [t.config.greylist_timeout] *)
let trigger_greylist_gc t =
  let now = Systime_os.now () in
  let minus_greylist_timeout = Ptime.Span.neg t.config.greylist_timeout in
  let time = Ptime.add_span now minus_greylist_timeout in
  let older_than =
    Option.unopt_exn (Failure "P2p_maintenance.maintain: time overflow") time
  in
  P2p_pool.gc_greylist t.pool ~older_than

(** Maintenance step.
    1. trigger greylist gc
    2. tries *forever* to achieve a number of connections
       between `min_threshold` and `max_threshold`. *)
let rec do_maintain t =
  trigger_greylist_gc t ;
  let n_connected = P2p_pool.active_connections t.pool in
  if n_connected < t.bounds.min_threshold then
    too_few_connections t n_connected
  else if t.bounds.max_threshold < n_connected then
    too_many_connections t n_connected
  else (
    (* end of maintenance when enough users have been reached *)
    Lwt_condition.broadcast t.just_maintained () ;
    lwt_debug "Maintenance step ended" >>= fun () -> return_unit )

and too_few_connections t n_connected =
  (* try and contact new peers *)
  lwt_log_notice "Too few connections (%d)" n_connected
  >>= fun () ->
  let min_to_contact = t.bounds.min_target - n_connected in
  let max_to_contact = t.bounds.max_target - n_connected in
  try_to_contact t min_to_contact max_to_contact
  >>= fun success ->
  (if success then return_unit else ask_for_more_contacts t)
  >>=? fun () -> do_maintain t

and too_many_connections t n_connected =
  (* kill random connections *)
  let n = n_connected - t.bounds.max_target in
  lwt_log_notice "Too many connections, will kill %d" n
  >>= fun () ->
  let connections = random_connections t.pool n in
  Lwt_list.iter_p P2p_conn.disconnect connections >>= fun () -> do_maintain t

let rec worker_loop t =
  (let n_connected = P2p_pool.active_connections t.pool in
   if
     n_connected < t.bounds.min_threshold
     || t.bounds.max_threshold < n_connected
   then do_maintain t
   else
     ( if not t.config.private_mode then send_swap_request t ;
       return_unit )
     >>=? fun () ->
     protect ~canceler:t.canceler (fun () ->
         Lwt.pick
           [ Systime_os.sleep t.config.maintenance_idle_time;
             Lwt_condition.wait t.please_maintain;
             (* when asked *)
             P2p_trigger.wait_too_few_connections t.triggers;
             (* limits *)
             P2p_trigger.wait_too_many_connections t.triggers ]
         >>= fun () -> return_unit))
  >>= function
  | Ok () ->
      worker_loop t
  | Error (Canceled :: _) ->
      Lwt.return_unit
  | Error _ ->
      Lwt.return_unit

let bounds ~min ~expected ~max =
  assert (min <= expected) ;
  assert (expected <= max) ;
  let step_min = (expected - min) / 3 and step_max = (max - expected) / 3 in
  {
    min_threshold = min + step_min;
    min_target = min + (2 * step_min);
    max_target = max - (2 * step_max);
    max_threshold = max - step_max;
  }

let create ?discovery config pool connect_handler triggers ~log =
  let bounds =
    bounds
      ~min:config.min_connections
      ~expected:config.expected_connections
      ~max:config.max_connections
  in
  {
    canceler = Lwt_canceler.create ();
    config;
    bounds;
    discovery;
    pool;
    connect_handler;
    just_maintained = Lwt_condition.create ();
    please_maintain = Lwt_condition.create ();
    maintain_worker = Lwt.return_unit;
    triggers;
    log;
  }

let activate t =
  t.maintain_worker <-
    Lwt_utils.worker
      "maintenance"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop t)
      ~cancel:(fun () -> Lwt_canceler.cancel t.canceler) ;
  Option.iter t.discovery ~f:P2p_discovery.activate

let maintain t =
  let wait = Lwt_condition.wait t.just_maintained in
  Lwt_condition.broadcast t.please_maintain () ;
  wait

let shutdown {canceler; discovery; maintain_worker; just_maintained; _} =
  Lwt_canceler.cancel canceler
  >>= fun () ->
  Lwt_utils.may ~f:P2p_discovery.shutdown discovery
  >>= fun () ->
  maintain_worker
  >>= fun () ->
  Lwt_condition.broadcast just_maintained () ;
  Lwt.return_unit
src/lib_p2p/p2p_maintenance.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition time_between_looking_for_peers : Z :=
  (* ❌ Float constant 5.0 is approximated by the integer 5 *)
  5.

Record bounds := {
  min_threshold : Z;
  min_target : Z;
  max_target : Z;
  max_threshold : Z }.

Record config := {
  maintenance_idle_time : Tezos_base__TzPervasives.Time.System.Span.t;
  greylist_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  private_mode : bool;
  min_connections : Z;
  max_connections : Z;
  expected_connections : Z }.

Record t {msg meta meta_conn : Type} := {
  canceler : Tezos_stdlib.Lwt_canceler.t;
  config : config;
  bounds : bounds;
  pool : Tezos_p2p.P2p_pool.t msg meta meta_conn;
  connect_handler : Tezos_p2p.P2p_connect_handler.t msg meta meta_conn;
  discovery : option Tezos_p2p.P2p_discovery.t;
  just_maintained : Lwt_condition.t unit;
  please_maintain : Lwt_condition.t unit;
  maintain_worker : Lwt.t unit;
  triggers : Tezos_p2p.P2p_trigger.t;
  log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit }.
Arguments t : clear implicits.

Definition broadcast_bootstrap_msg {A B C : Type}
  (pool : Tezos_p2p.P2p_pool.t A B C) : unit :=
  P2p_peer.Table.iter
    (fun _peer_id =>
      fun peer_info =>
        match P2p_peer_state.get peer_info with
        | Tezos_p2p.P2p_peer_state.Running {| data := conn |} =>
          if negb (P2p_conn.private_node conn) then
            OCaml.Stdlib.ignore (P2p_conn.write_bootstrap conn)
          else
            tt
        | _ => tt
        end) (P2p_pool.connected_peer_ids pool).

Definition send_swap_request {A B C : Type} (t : t A B C) : unit :=
  match P2p_pool.Connection.propose_swap_request (pool t) with
  | None => tt
  | Some (proposed_point, proposed_peer_id, recipient) =>
    let recipient_peer_id := peer_id (P2p_conn.info recipient) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (log t)
        (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_sent
          {| source := recipient_peer_id |}) in
    OCaml.Stdlib.ignore
      (P2p_conn.write_swap_request recipient proposed_point proposed_peer_id)
  end.

Definition classify {A B C D : Type}
  (pool : Tezos_p2p__P2p_pool.t A B C) (private_mode : bool)
  (start_time : Tezos_base__TzPervasives.Time.System.t)
  (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t)
  (point : Tezos_base__TzPervasives.P2p_point.Set.elt)
  (pi : Tezos_p2p.P2p_point_state.Info.point_info D) : variant :=
  let now := Systime_os.now tt in
  if
    orb (P2p_point.Set.mem point seen_points)
      (orb (P2p_pool.Points.banned pool point)
        (andb private_mode (negb (P2p_point_state.Info.trusted pi)))) then
    (* ❌ Variants not supported *)
    variant
  else
    match P2p_point_state.get pi with
    | Tezos_p2p.P2p_point_state.Disconnected =>
      match P2p_point_state.Info.last_miss pi with
      | Some last =>
        (* ❌ Variants not supported *)
        variant
      | last =>
        (* ❌ Variants not supported *)
        variant
      end
    | _ =>
      (* ❌ Variants not supported *)
      variant
    end.

Definition establish {A B C : Type}
  (t : t A B C) (contactable : list Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t Z :=
  let try_to_connect
    (acc : Lwt.t Z) (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t Z :=
    op_gtgteq
      (protect None (Some (canceler t))
        (fun function_parameter =>
          let 'tt := function_parameter in
          P2p_connect_handler.connect None (connect_handler t) point))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok _ => op_gtpipeeq acc Z.succ
        | Stdlib.Error _ => acc
        end) in
  List.fold_left try_to_connect (Lwt._return 0) contactable.

Definition connectable {A B C : Type}
  (t : t A B C) (start_time : Tezos_base__TzPervasives.Time.System.t)
  (expected : Z) (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t)
  : (list Tezos_base__TzPervasives.P2p_point.Id.t) *
    Tezos_base__TzPervasives.P2p_point.Set.t :=
  let Bounded_point_info :=
    (* ❌ Applications of functors are not supported for first-class module values *)
    unsupported_functor_application in
  let acc := Bounded_point_info.create expected in
  let f {D : Type}
    (point : Tezos_base__TzPervasives.P2p_point.Set.elt) (pi :
    Tezos_p2p.P2p_point_state.Info.point_info D) (seen_points :
    Tezos_base__TzPervasives.P2p_point.Set.t)
    : Tezos_base__TzPervasives.P2p_point.Set.t :=
    match
      classify (pool t) (private_mode (config t)) start_time seen_points point
        pi with
    | Ignore => seen_points
    | Candidate last =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Bounded_point_info.insert (last, point) acc in
      P2p_point.Set.add point seen_points
    | Seen => P2p_point.Set.add point seen_points
    end in
  let seen_points := P2p_pool.Points.fold_known (pool t) seen_points f in
  ((List.map snd (Bounded_point_info.get acc)), seen_points).

Fixpoint try_to_contact_loop {A B C : Type}
  (t : t A B C) (start_time : Tezos_base__TzPervasives.Time.System.t)
  (seen_points : Tezos_base__TzPervasives.P2p_point.Set.t) (min_to_contact : Z)
  (max_to_contact : Z) : Lwt.t bool :=
  if OCaml.Stdlib.le min_to_contact 0 then
    Lwt.return_true
  else
    let '(candidates, seen_points) :=
      connectable t start_time max_to_contact seen_points in
    if equiv_decb candidates [] then
      op_gtgteq (Lwt_unix.yield tt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt.return_false)
    else
      op_gtgteq (establish t candidates)
        (fun established =>
          try_to_contact_loop t start_time seen_points
            (Z.sub min_to_contact established)
            (Z.sub max_to_contact established)).

Definition try_to_contact {A B C : Type}
  (t : t A B C) (min_to_contact : Z) (max_to_contact : Z) : Lwt.t bool :=
  let start_time := Systime_os.now tt in
  let seen_points := P2p_point.Set.empty in
  try_to_contact_loop t start_time seen_points min_to_contact max_to_contact.

Definition ask_for_more_contacts {A B C : Type} (t : t A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := broadcast_bootstrap_msg (pool t) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Option.iter P2p_discovery.wakeup (discovery t) in
  protect None (Some (canceler t))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (Lwt.pick
          (cons (P2p_trigger.wait_new_peer (triggers t))
            (cons (P2p_trigger.wait_new_point (triggers t))
              (cons (Lwt_unix.sleep time_between_looking_for_peers) []))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition random_connections {A B C : Type}
  (pool : Tezos_p2p__P2p_pool.t A B C) (n : Z)
  : list (Tezos_p2p.P2p_conn.t A B C) :=
  let f {D E F G : Type} (function_parameter : D)
    : (Tezos_p2p.P2p_conn.t E F G) ->
      (list (Tezos_p2p.P2p_conn.t E F G)) -> list (Tezos_p2p.P2p_conn.t E F G) :=
    let '_ := function_parameter in
    fun conn =>
      fun acc =>
        if andb (private_node conn) (trusted_node conn) then
          acc
        else
          cons conn acc in
  let candidates :=
    OCaml.Stdlib.reverse_apply (P2p_pool.Connection.fold pool [] f)
      TzList.shuffle in
  TzList.rev_sub candidates n.

Definition trigger_greylist_gc {A B C : Type} (t : t A B C) : unit :=
  let now := Systime_os.now tt in
  let minus_greylist_timeout := Ptime.Span.neg (greylist_timeout (config t)) in
  let time := Ptime.add_span now minus_greylist_timeout in
  let older_than :=
    Option.unopt_exn
      (OCaml.Failure "P2p_maintenance.maintain: time overflow" % string) time in
  P2p_pool.gc_greylist older_than (pool t).

Fixpoint do_maintain {A B C : Type} (t : t A B C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := trigger_greylist_gc t in
  let n_connected := P2p_pool.active_connections (pool t) in
  if OCaml.Stdlib.lt n_connected (min_threshold (bounds t)) then
    too_few_connections t n_connected
  else
    if OCaml.Stdlib.lt (max_threshold (bounds t)) n_connected then
      too_many_connections t n_connected
    else
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Lwt_condition.broadcast (just_maintained t) tt in
      op_gtgteq
        (lwt_debug
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Maintenance step ended" % string
              CamlinternalFormatBasics.End_of_format)
            "Maintenance step ended" % string))
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)

with too_few_connections {A B C : Type} (t : t A B C) (n_connected : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    (lwt_log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Too few connections (" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Too few connections (%d)" % string) n_connected)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let min_to_contact := Z.sub (min_target (bounds t)) n_connected in
      let max_to_contact := Z.sub (max_target (bounds t)) n_connected in
      op_gtgteq (try_to_contact t min_to_contact max_to_contact)
        (fun success =>
          op_gtgteqquestion
            (if success then
              return_unit
            else
              ask_for_more_contacts t)
            (fun function_parameter =>
              let 'tt := function_parameter in
              do_maintain t)))

with too_many_connections {A B C : Type} (t : t A B C) (n_connected : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let n := Z.sub n_connected (max_target (bounds t)) in
  op_gtgteq
    (lwt_log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Too many connections, will kill " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "Too many connections, will kill %d" % string) n)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let connections := random_connections (pool t) n in
      op_gtgteq
        (Lwt_list.iter_p
          (let arg := P2p_conn.disconnect in
          fun eta => arg None eta) connections)
        (fun function_parameter =>
          let 'tt := function_parameter in
          do_maintain t)).

Fixpoint worker_loop {A B C : Type} (t : t A B C) : Lwt.t unit :=
  op_gtgteq
    (let n_connected := P2p_pool.active_connections (pool t) in
    if
      orb (OCaml.Stdlib.lt n_connected (min_threshold (bounds t)))
        (OCaml.Stdlib.lt (max_threshold (bounds t)) n_connected) then
      do_maintain t
    else
      op_gtgteqquestion
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        (let _ :=
          if negb (private_mode (config t)) then
            send_swap_request t
          else
            tt in
        return_unit)
        (fun function_parameter =>
          let 'tt := function_parameter in
          protect None (Some (canceler t))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (Lwt.pick
                  (cons (Systime_os.sleep (maintenance_idle_time (config t)))
                    (cons (Lwt_condition.wait None (please_maintain t))
                      (cons (P2p_trigger.wait_too_few_connections (triggers t))
                        (cons
                          (P2p_trigger.wait_too_many_connections (triggers t))
                          [])))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit))))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => worker_loop t
      | Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
        Lwt.return_unit
      | Stdlib.Error _ => Lwt.return_unit
      end).

Definition bounds (min : Z) (expected : Z) (max : Z) : bounds :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.le min expected) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.le expected max) in
  let step_min : Z :=
    Z.div (Z.sub expected min) 3
  with step_max : Z :=
    Z.div (Z.sub max expected) 3 in
  {| min_threshold := Z.add min step_min;
    min_target := Z.add min (Z.mul 2 step_min);
    max_target := Z.sub max (Z.mul 2 step_max);
    max_threshold := Z.sub max step_max |}.

Definition create {A B C : Type}
  (discovery : option Tezos_p2p.P2p_discovery.t) (config : config)
  (pool : Tezos_p2p.P2p_pool.t A B C)
  (connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
  (triggers : Tezos_p2p.P2p_trigger.t)
  (log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
  : t A B C :=
  let bounds :=
    bounds (min_connections config) (expected_connections config)
      (max_connections config) in
  {| canceler := Lwt_canceler.create tt; config := config; bounds := bounds;
    pool := pool; connect_handler := connect_handler; discovery := discovery;
    just_maintained := Lwt_condition.create tt;
    please_maintain := Lwt_condition.create tt;
    maintain_worker := Lwt.return_unit; triggers := triggers; log := log |}.

Definition activate {A B C : Type} (t : t A B C) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field t "maintain_worker" % string
      (Lwt_utils.worker "maintenance" % string
        Internal_event.Lwt_worker_event.on_event
        (fun function_parameter =>
          let 'tt := function_parameter in
          worker_loop t)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt_canceler.cancel (canceler t))) in
  Option.iter P2p_discovery.activate (discovery t).

Definition maintain {A B C : Type} (t : t A B C) : Lwt.t unit :=
  let wait := Lwt_condition.wait None (just_maintained t) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Lwt_condition.broadcast (please_maintain t) tt in
  wait.

Definition shutdown {A B C : Type} (function_parameter : t A B C)
  : Lwt.t unit :=
  let '{|
    canceler := canceler;
      discovery := discovery;
      just_maintained := just_maintained;
      maintain_worker := maintain_worker
      |} := function_parameter in
  op_gtgteq (Lwt_canceler.cancel canceler)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_utils.may P2p_discovery.shutdown discovery)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq maintain_worker
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Lwt_condition.broadcast just_maintained tt in
              Lwt.return_unit))).

src/lib_p2p/p2p_message.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'msg encoding =
  | Encoding : {
      tag : int;
      title : string;
      encoding : 'a Data_encoding.t;
      wrap : 'a -> 'msg;
      unwrap : 'msg -> 'a option;
      max_length : int option;
    }
      -> 'msg encoding

type 'msg t =
  | Bootstrap
  | Advertise of P2p_point.Id.t list
  | Swap_request of P2p_point.Id.t * P2p_peer.Id.t
  | Swap_ack of P2p_point.Id.t * P2p_peer.Id.t
  | Message of 'msg
  | Disconnect

let encoding msg_encoding =
  let open Data_encoding in
  dynamic_size
  @@ union
       ~tag_size:`Uint16
       ( [ case
             (Tag 0x01)
             ~title:"Disconnect"
             (obj1 (req "kind" (constant "Disconnect")))
             (function Disconnect -> Some () | _ -> None)
             (fun () -> Disconnect);
           case
             (Tag 0x02)
             ~title:"Bootstrap"
             (obj1 (req "kind" (constant "Bootstrap")))
             (function Bootstrap -> Some () | _ -> None)
             (fun () -> Bootstrap);
           case
             (Tag 0x03)
             ~title:"Advertise"
             (obj2
                (req "id" (Variable.list P2p_point.Id.encoding))
                (req "kind" (constant "Advertise")))
             (function Advertise points -> Some (points, ()) | _ -> None)
             (fun (points, ()) -> Advertise points);
           case
             (Tag 0x04)
             ~title:"Swap_request"
             (obj3
                (req "point" P2p_point.Id.encoding)
                (req "peer_id" P2p_peer.Id.encoding)
                (req "kind" (constant "Swap_request")))
             (function
               | Swap_request (point, peer_id) ->
                   Some (point, peer_id, ())
               | _ ->
                   None)
             (fun (point, peer_id, ()) -> Swap_request (point, peer_id));
           case
             (Tag 0x05)
             ~title:"Swap_ack"
             (obj3
                (req "point" P2p_point.Id.encoding)
                (req "peer_id" P2p_peer.Id.encoding)
                (req "kind" (constant "Swap_ack")))
             (function
               | Swap_ack (point, peer_id) ->
                   Some (point, peer_id, ())
               | _ ->
                   None)
             (fun (point, peer_id, ()) -> Swap_ack (point, peer_id)) ]
       @ ListLabels.map msg_encoding ~f:(function
             | Encoding
                 {tag; title; encoding; wrap; unwrap; max_length = _ (* ?? *)}
             ->
             Data_encoding.case
               (Tag tag)
               ~title
               encoding
               (function Message msg -> unwrap msg | _ -> None)
               (fun msg -> Message (wrap msg))) )
src/lib_p2p/p2p_message.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive encoding (msg : Type) : Type :=
| Encoding : forall {a : Type}, Z -> string ->
  (Tezos_base__TzPervasives.Data_encoding.t a) -> (a -> msg) ->
  (msg -> option a) -> (option Z) -> encoding msg.

Arguments Encoding {_}.

Inductive t (msg : Type) : Type :=
| Bootstrap : t msg
| Advertise : (list Tezos_base__TzPervasives.P2p_point.Id.t) -> t msg
| Swap_request : Tezos_base__TzPervasives.P2p_point.Id.t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Swap_ack : Tezos_base__TzPervasives.P2p_point.Id.t ->
  Tezos_base__TzPervasives.P2p_peer.Id.t -> t msg
| Message : msg -> t msg
| Disconnect : t msg.

Arguments Bootstrap {_}.
Arguments Advertise {_}.
Arguments Swap_request {_}.
Arguments Swap_ack {_}.
Arguments Message {_}.
Arguments Disconnect {_}.

Definition encoding {A : Type} (msg_encoding : list (encoding A))
  : Tezos_base__TzPervasives.Data_encoding.encoding (t A) :=
  apply
    (let arg := dynamic_size in
    fun eta => arg None eta)
    (union
      (Some
        (* ❌ Variants not supported *)
        variant)
      (OCaml.Stdlib.app
        (cons
          (case "Disconnect" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1)
            (obj1
              (req None None "kind" % string (constant "Disconnect" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Disconnect => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Disconnect))
          (cons
            (case "Bootstrap" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 2)
              (obj1
                (req None None "kind" % string (constant "Bootstrap" % string)))
              (fun function_parameter =>
                match function_parameter with
                | Bootstrap => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Bootstrap))
            (cons
              (case "Advertise" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 3)
                (obj2
                  (req None None "id" % string
                    (Variable.list None P2p_point.Id.encoding))
                  (req None None "kind" % string (constant "Advertise" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | Advertise points => Some (points, tt)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(points, tt) := function_parameter in
                  Advertise points))
              (cons
                (case "Swap_request" % string None
                  (Tezos_base__TzPervasives.Data_encoding.Tag 4)
                  (obj3 (req None None "point" % string P2p_point.Id.encoding)
                    (req None None "peer_id" % string P2p_peer.Id.encoding)
                    (req None None "kind" % string
                      (constant "Swap_request" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Swap_request point peer_id => Some (point, peer_id, tt)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let '(point, peer_id, tt) := function_parameter in
                    Swap_request point peer_id))
                (cons
                  (case "Swap_ack" % string None
                    (Tezos_base__TzPervasives.Data_encoding.Tag 5)
                    (obj3 (req None None "point" % string P2p_point.Id.encoding)
                      (req None None "peer_id" % string P2p_peer.Id.encoding)
                      (req None None "kind" % string
                        (constant "Swap_ack" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Swap_ack point peer_id => Some (point, peer_id, tt)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let '(point, peer_id, tt) := function_parameter in
                      Swap_ack point peer_id)) [])))))
        (ListLabels.map
          (fun function_parameter =>
            let
              'Encoding {|
                tag := tag;
                  title := title;
                  encoding := encoding;
                  wrap := wrap;
                  unwrap := unwrap;
                  max_length := _
                  |} := function_parameter in
            Data_encoding.case title None
              (Tezos_base__TzPervasives.Data_encoding.Tag tag) encoding
              (fun function_parameter =>
                match function_parameter with
                | Message msg => unwrap msg
                | _ => None
                end) (fun msg => Message (wrap msg))) msg_encoding))).

src/lib_p2p/p2p_peer_state.ml 84 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open P2p_peer

type ('conn, 'conn_meta) t =
  | Accepted of {current_point : P2p_connection.Id.t; cancel : Lwt_canceler.t}
  | Running of {
      data : 'conn;
      conn_metadata : 'conn_meta;
      current_point : P2p_connection.Id.t;
    }
  | Disconnected

type ('conn, 'conn_meta) state = ('conn, 'conn_meta) t

let pp ppf = function
  | Accepted {current_point; _} ->
      Format.fprintf ppf "accepted %a" P2p_connection.Id.pp current_point
  | Running {current_point; _} ->
      Format.fprintf ppf "running %a" P2p_connection.Id.pp current_point
  | Disconnected ->
      Format.fprintf ppf "disconnected"

module Info = struct
  type ('conn, 'peer_meta, 'conn_meta) t = {
    peer_id : Id.t;
    created : Time.System.t;
    mutable state : ('conn, 'conn_meta) state;
    mutable peer_metadata : 'peer_meta;
    mutable trusted : bool;
    mutable last_failed_connection :
      (P2p_connection.Id.t * Time.System.t) option;
    mutable last_rejected_connection :
      (P2p_connection.Id.t * Time.System.t) option;
    mutable last_established_connection :
      (P2p_connection.Id.t * Time.System.t) option;
    mutable last_disconnection : (P2p_connection.Id.t * Time.System.t) option;
    events : Pool_event.t Ring.t;
    watchers : Pool_event.t Lwt_watcher.input;
  }

  type ('conn, 'peer_meta, 'conn_meta) peer_info =
    ('conn, 'peer_meta, 'conn_meta) t

  let compare gi1 gi2 = Id.compare gi1.peer_id gi2.peer_id

  let log_size = 100

  let create ?(created = Systime_os.now ()) ?(trusted = false) ~peer_metadata
      peer_id =
    {
      peer_id;
      created;
      state = Disconnected;
      peer_metadata;
      trusted;
      last_failed_connection = None;
      last_rejected_connection = None;
      last_established_connection = None;
      last_disconnection = None;
      events = Ring.create log_size;
      watchers = Lwt_watcher.create_input ();
    }

  let encoding peer_metadata_encoding =
    let open Data_encoding in
    conv
      (fun { peer_id;
             trusted;
             peer_metadata;
             events;
             created;
             last_failed_connection;
             last_rejected_connection;
             last_established_connection;
             last_disconnection;
             _ } ->
        ( peer_id,
          created,
          trusted,
          peer_metadata,
          Ring.elements events,
          last_failed_connection,
          last_rejected_connection,
          last_established_connection,
          last_disconnection ))
      (fun ( peer_id,
             created,
             trusted,
             peer_metadata,
             event_list,
             last_failed_connection,
             last_rejected_connection,
             last_established_connection,
             last_disconnection ) ->
        let info = create ~trusted ~peer_metadata peer_id in
        let events = Ring.create log_size in
        Ring.add_list info.events event_list ;
        {
          state = Disconnected;
          trusted;
          peer_id;
          peer_metadata;
          created;
          last_failed_connection;
          last_rejected_connection;
          last_established_connection;
          last_disconnection;
          events;
          watchers = Lwt_watcher.create_input ();
        })
      (obj9
         (req "peer_id" Id.encoding)
         (req "created" Time.System.encoding)
         (dft "trusted" bool false)
         (req "peer_metadata" peer_metadata_encoding)
         (dft "events" (list Pool_event.encoding) [])
         (opt
            "last_failed_connection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
         (opt
            "last_rejected_connection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
         (opt
            "last_established_connection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding))
         (opt
            "last_disconnection"
            (tup2 P2p_connection.Id.encoding Time.System.encoding)))

  let peer_id {peer_id; _} = peer_id

  let created {created; _} = created

  let peer_metadata {peer_metadata; _} = peer_metadata

  let set_peer_metadata gi peer_metadata = gi.peer_metadata <- peer_metadata

  let trusted {trusted; _} = trusted

  let set_trusted gi = gi.trusted <- true

  let unset_trusted gi = gi.trusted <- false

  let last_established_connection s = s.last_established_connection

  let last_disconnection s = s.last_disconnection

  let last_failed_connection s = s.last_failed_connection

  let last_rejected_connection s = s.last_rejected_connection

  let last_seen s =
    Time.System.recent
      s.last_established_connection
      (Time.System.recent s.last_rejected_connection s.last_disconnection)

  let last_miss s =
    Time.System.recent
      s.last_failed_connection
      (Time.System.recent s.last_rejected_connection s.last_disconnection)

  let log {events; watchers; _} ?(timestamp = Systime_os.now ()) point kind =
    let event = {Pool_event.kind; timestamp; point} in
    Ring.add events event ;
    Lwt_watcher.notify watchers event

  let log_incoming_rejection ?timestamp peer_info point =
    log peer_info ?timestamp point Rejecting_request

  module File = struct
    let load path peer_metadata_encoding =
      let enc = Data_encoding.list (encoding peer_metadata_encoding) in
      if path <> "/dev/null" && Sys.file_exists path then
        Lwt_utils_unix.Json.read_file path
        >>=? fun json -> return (Data_encoding.Json.destruct enc json)
      else return_nil

    let save path peer_metadata_encoding peers =
      let open Data_encoding in
      Lwt_utils_unix.Json.write_file path
      @@ Json.construct (list (encoding peer_metadata_encoding)) peers
  end

  let watch {watchers; _} = Lwt_watcher.create_stream watchers

  let fold {events; _} ~init ~f = Ring.fold events ~init ~f
end

let get {Info.state; _} = state

let is_disconnected {Info.state; _} =
  match state with Disconnected -> true | Accepted _ | Running _ -> false

let set_accepted ?(timestamp = Systime_os.now ()) peer_info current_point
    cancel =
  assert (
    match peer_info.Info.state with
    | Accepted _ | Running _ ->
        false
    | Disconnected ->
        true ) ;
  peer_info.state <- Accepted {current_point; cancel} ;
  Info.log peer_info ~timestamp current_point Accepting_request

let set_running ?(timestamp = Systime_os.now ()) peer_info point data
    conn_metadata =
  assert (
    match peer_info.Info.state with
    | Disconnected ->
        true (* request to unknown peer_id. *)
    | Running _ ->
        false
    | Accepted {current_point; _} ->
        P2p_connection.Id.equal point current_point ) ;
  peer_info.state <- Running {data; conn_metadata; current_point = point} ;
  peer_info.last_established_connection <- Some (point, timestamp) ;
  Info.log peer_info ~timestamp point Connection_established

let set_disconnected ?(timestamp = Systime_os.now ()) ?(requested = false)
    peer_info =
  let (current_point, (event : Pool_event.kind)) =
    match peer_info.Info.state with
    | Accepted {current_point; _} ->
        peer_info.last_rejected_connection <- Some (current_point, timestamp) ;
        (current_point, Request_rejected)
    | Running {current_point; _} ->
        peer_info.last_disconnection <- Some (current_point, timestamp) ;
        ( current_point,
          if requested then Disconnection else External_disconnection )
    | Disconnected ->
        assert false
  in
  peer_info.state <- Disconnected ;
  Info.log peer_info ~timestamp current_point event
src/lib_p2p/p2p_peer_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import P2p_peer.

Inductive t (conn conn_meta : Type) : Type :=
| Accepted : Tezos_base__TzPervasives.P2p_connection.Id.t ->
  Tezos_stdlib.Lwt_canceler.t -> t conn conn_meta
| Running : conn -> conn_meta -> Tezos_base__TzPervasives.P2p_connection.Id.t ->
  t conn conn_meta
| Disconnected : t conn conn_meta.

Arguments Accepted {_ _}.
Arguments Running {_ _}.
Arguments Disconnected {_ _}.

Definition state (conn conn_meta : Type) := t conn conn_meta.

Definition pp {A B : Type}
  (ppf : Stdlib.Format.formatter) (function_parameter : t A B) : unit :=
  match function_parameter with
  | Accepted {| current_point := current_point |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "accepted " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "accepted %a" % string) P2p_connection.Id.pp current_point
  | Running {| current_point := current_point |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "running " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "running %a" % string) P2p_connection.Id.pp current_point
  | Disconnected =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "disconnected" % string
          CamlinternalFormatBasics.End_of_format) "disconnected" % string)
  end.

Module Info.
  Record t {conn peer_meta conn_meta : Type} := {
    peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    created : Tezos_base__TzPervasives.Time.System.t;
    state : state conn conn_meta;
    peer_metadata : peer_meta;
    trusted : bool;
    last_failed_connection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_rejected_connection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_established_connection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_disconnection :
      option
        (Tezos_base__TzPervasives.P2p_connection.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    events : Tezos_stdlib.Ring.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t;
    watchers :
      Tezos_stdlib.Lwt_watcher.input
        Tezos_base__TzPervasives.P2p_peer.Pool_event.t }.
  Arguments t : clear implicits.
  
  Definition peer_info (conn peer_meta conn_meta : Type) :=
    t conn peer_meta conn_meta.
  
  Definition compare {A B C D E F : Type} (gi1 : t A B C) (gi2 : t D E F) : Z :=
    Id.compare (peer_id gi1) (peer_id gi2).
  
  Definition log_size : Z := 100.
  
  Definition create {A B C : Type}
    (op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
    : (option bool) -> A -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t B A C :=
    let created :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Systime_os.now tt
      end in
    fun op_staroptstar =>
      let trusted :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => false
        end in
      fun peer_metadata =>
        fun peer_id =>
          {| peer_id := peer_id; created := created; state := Disconnected;
            peer_metadata := peer_metadata; trusted := trusted;
            last_failed_connection := None; last_rejected_connection := None;
            last_established_connection := None; last_disconnection := None;
            events := Ring.create log_size;
            watchers := Lwt_watcher.create_input tt |}.
  
  Definition encoding {A B C : Type}
    (peer_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.encoding A)
    : Tezos_base__TzPervasives.Data_encoding.encoding (t B A C) :=
    conv
      (fun function_parameter =>
        let '{|
          peer_id := peer_id;
            created := created;
            peer_metadata := peer_metadata;
            trusted := trusted;
            last_failed_connection := last_failed_connection;
            last_rejected_connection := last_rejected_connection;
            last_established_connection := last_established_connection;
            last_disconnection := last_disconnection;
            events := events
            |} := function_parameter in
        (peer_id, created, trusted, peer_metadata, (Ring.elements events),
          last_failed_connection, last_rejected_connection,
          last_established_connection, last_disconnection))
      (fun function_parameter =>
        let
          '(peer_id, created, trusted, peer_metadata, event_list,
            last_failed_connection, last_rejected_connection,
            last_established_connection, last_disconnection) :=
          function_parameter in
        let info := create None (Some trusted) peer_metadata peer_id in
        let events := Ring.create log_size in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Ring.add_list (events info) event_list in
        {| peer_id := peer_id; created := created; state := Disconnected;
          peer_metadata := peer_metadata; trusted := trusted;
          last_failed_connection := last_failed_connection;
          last_rejected_connection := last_rejected_connection;
          last_established_connection := last_established_connection;
          last_disconnection := last_disconnection; events := events;
          watchers := Lwt_watcher.create_input tt |}) None
      (obj9 (req None None "peer_id" % string Id.encoding)
        (req None None "created" % string Time.System.encoding)
        (dft None None "trusted" % string bool false)
        (req None None "peer_metadata" % string peer_metadata_encoding)
        (dft None None "events" % string (list None Pool_event.encoding) [])
        (opt None None "last_failed_connection" % string
          (tup2 P2p_connection.Id.encoding Time.System.encoding))
        (opt None None "last_rejected_connection" % string
          (tup2 P2p_connection.Id.encoding Time.System.encoding))
        (opt None None "last_established_connection" % string
          (tup2 P2p_connection.Id.encoding Time.System.encoding))
        (opt None None "last_disconnection" % string
          (tup2 P2p_connection.Id.encoding Time.System.encoding))).
  
  Definition peer_id {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.P2p_peer.Id.t :=
    let '{| peer_id := peer_id |} := function_parameter in
    peer_id.
  
  Definition created {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.Time.System.t :=
    let '{| created := created |} := function_parameter in
    created.
  
  Definition peer_metadata {A B C : Type} (function_parameter : t A B C) : B :=
    let '{| peer_metadata := peer_metadata |} := function_parameter in
    peer_metadata.
  
  Definition set_peer_metadata {A B C : Type} (gi : t A B C) (peer_metadata : B)
    : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field gi "peer_metadata" % string peer_metadata.
  
  Definition trusted {A B C : Type} (function_parameter : t A B C) : bool :=
    let '{| trusted := trusted |} := function_parameter in
    trusted.
  
  Definition set_trusted {A B C : Type} (gi : t A B C) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field gi "trusted" % string true.
  
  Definition unset_trusted {A B C : Type} (gi : t A B C) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field gi "trusted" % string false.
  
  Definition last_established_connection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_established_connection s.
  
  Definition last_disconnection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_disconnection s.
  
  Definition last_failed_connection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_failed_connection s.
  
  Definition last_rejected_connection {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_rejected_connection s.
  
  Definition last_seen {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) :=
    Time.System.recent (last_established_connection s)
      (Time.System.recent (last_rejected_connection s) (last_disconnection s)).
  
  Definition last_miss {A B C : Type} (s : t A B C)
    : option
      (Tezos_base__TzPervasives.P2p_connection.Id.t *
        Tezos_base__TzPervasives.Time.System.t) :=
    Time.System.recent (last_failed_connection s)
      (Time.System.recent (last_rejected_connection s) (last_disconnection s)).
  
  Definition log {A B C : Type} (function_parameter : t A B C)
    : (option Tezos_base.Time.System.t) ->
      Tezos_base.P2p_connection.Id.t ->
        Tezos_base__TzPervasives.P2p_peer.Pool_event.kind -> unit :=
    let '{| events := events; watchers := watchers |} := function_parameter in
    fun op_staroptstar =>
      let timestamp :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => Systime_os.now tt
        end in
      fun point =>
        fun kind =>
          let event :=
            {| Pool_event.kind := kind; Pool_event.timestamp := timestamp;
              Pool_event.point := point |} in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Ring.add events event in
          Lwt_watcher.notify watchers event.
  
  Definition log_incoming_rejection {A B C : Type}
    (timestamp : option Tezos_base.Time.System.t) (peer_info : t A B C)
    (point : Tezos_base.P2p_connection.Id.t) : unit :=
    log peer_info timestamp point
      Tezos_base__TzPervasives.P2p_peer.Pool_event.Rejecting_request.
  
  Module File.
    Definition load {A B C : Type}
      (path : string)
      (peer_metadata_encoding :
        Tezos_base__TzPervasives.Data_encoding.encoding A)
      : Lwt.t (Tezos_base__TzPervasives.tzresult (list (t B A C))) :=
      let enc := Data_encoding.list None (encoding peer_metadata_encoding) in
      if andb (nequiv_decb path "/dev/null" % string) (Sys.file_exists path)
        then
        op_gtgteqquestion (Lwt_utils_unix.Json.read_file path)
          (fun json => _return (Data_encoding.Json.destruct enc json))
      else
        return_nil.
    
    Definition save {A B C : Type}
      (path : string)
      (peer_metadata_encoding :
        Tezos_base__TzPervasives.Data_encoding.encoding A)
      (peers : list (t B A C))
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
      apply (Lwt_utils_unix.Json.write_file path)
        (Json.construct (list None (encoding peer_metadata_encoding)) peers).
  End File.
  
  Definition watch {A B C : Type} (function_parameter : t A B C)
    : (Lwt_stream.t Tezos_base__TzPervasives.P2p_peer.Pool_event.t) *
      Tezos_stdlib.Lwt_watcher.stopper :=
    let '{| watchers := watchers |} := function_parameter in
    Lwt_watcher.create_stream watchers.
  
  Definition fold {A B C D : Type} (function_parameter : t A B C)
    : D -> (D -> Tezos_base__TzPervasives.P2p_peer.Pool_event.t -> D) -> D :=
    let '{| events := events |} := function_parameter in
    fun init => fun f => Ring.fold events init f.
End Info.

Definition get {A B C : Type} (function_parameter : Info.t A B C) : state A C :=
  let '{| Info.state := state |} := function_parameter in
  state.

Definition is_disconnected {A B C : Type} (function_parameter : Info.t A B C)
  : bool :=
  let '{| Info.state := state |} := function_parameter in
  match state with
  | Disconnected => true
  | Accepted _ | Running _ => false
  end.

Definition set_accepted {A B C : Type}
  (op_staroptstar : option Tezos_base.Time.System.t)
  : (Info.t A B C) ->
    Tezos_base__TzPervasives.P2p_connection.Id.t ->
      Tezos_stdlib.Lwt_canceler.t -> unit :=
  let timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Systime_os.now tt
    end in
  fun peer_info =>
    fun current_point =>
      fun cancel =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            match Info.state peer_info with
            | Accepted _ | Running _ => false
            | Disconnected => true
            end in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field peer_info "state" % string
            (Accepted {| current_point := current_point; cancel := cancel |}) in
        Info.log peer_info (Some timestamp) current_point
          Tezos_base__TzPervasives.P2p_peer.Pool_event.Accepting_request.

Definition set_running {A B C : Type}
  (op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
  : (Info.t A B C) ->
    Tezos_base__TzPervasives.P2p_connection.Id.t -> A -> C -> unit :=
  let timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Systime_os.now tt
    end in
  fun peer_info =>
    fun point =>
      fun data =>
        fun conn_metadata =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert
              match Info.state peer_info with
              | Disconnected => true
              | Running _ => false
              | Accepted {| current_point := current_point |} =>
                P2p_connection.Id.equal point current_point
              end in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field peer_info "state" % string
              (Running
                {| data := data; conn_metadata := conn_metadata;
                  current_point := point |}) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field peer_info "last_established_connection" % string
              (Some (point, timestamp)) in
          Info.log peer_info (Some timestamp) point
            Tezos_base__TzPervasives.P2p_peer.Pool_event.Connection_established.

Definition set_disconnected {A B C : Type}
  (op_staroptstar : option Tezos_base.Time.System.t)
  : (option bool) -> (Info.t A B C) -> unit :=
  let timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Systime_os.now tt
    end in
  fun op_staroptstar =>
    let requested :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun peer_info =>
      let '(current_point, _ as event) :=
        match Info.state peer_info with
        | Accepted {| current_point := current_point |} =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field peer_info "last_rejected_connection" % string
              (Some (current_point, timestamp)) in
          (current_point,
            Tezos_base__TzPervasives.P2p_peer.Pool_event.Request_rejected)
        | Running {| current_point := current_point |} =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field peer_info "last_disconnection" % string
              (Some (current_point, timestamp)) in
          (current_point,
            (if requested then
              Tezos_base__TzPervasives.P2p_peer.Pool_event.Disconnection
            else
              Tezos_base__TzPervasives.P2p_peer.Pool_event.External_disconnection))
        | Disconnected =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        end in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field peer_info "state" % string Disconnected in
      Info.log peer_info (Some timestamp) current_point event.

src/lib_p2p/p2p_point_state.ml 89 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open P2p_point

type 'data t =
  | Requested of {cancel : Lwt_canceler.t}
  | Accepted of {current_peer_id : P2p_peer.Id.t; cancel : Lwt_canceler.t}
  | Running of {data : 'data; current_peer_id : P2p_peer.Id.t}
  | Disconnected

type 'data state = 'data t

let pp ppf = function
  | Requested _ ->
      Format.fprintf ppf "requested"
  | Accepted {current_peer_id; _} ->
      Format.fprintf ppf "accepted %a" P2p_peer.Id.pp current_peer_id
  | Running {current_peer_id; _} ->
      Format.fprintf ppf "running %a" P2p_peer.Id.pp current_peer_id
  | Disconnected ->
      Format.fprintf ppf "disconnected"

module Info = struct
  type greylisting_config = {
    factor : float;
    initial_delay : Time.System.Span.t;
    disconnection_delay : Time.System.Span.t;
    increase_cap : Time.System.Span.t;
  }

  type 'data t = {
    point : Id.t;
    mutable trusted : bool;
    mutable state : 'data state;
    mutable last_failed_connection : Time.System.t option;
    mutable last_rejected_connection : (P2p_peer.Id.t * Time.System.t) option;
    mutable last_established_connection :
      (P2p_peer.Id.t * Time.System.t) option;
    mutable known_public : bool;
    mutable last_disconnection : (P2p_peer.Id.t * Time.System.t) option;
    mutable greylisting_delay : Time.System.Span.t;
    mutable greylisting_end : Time.System.t;
    events : Pool_event.t Ring.t;
    watchers : Pool_event.t Lwt_watcher.input;
  }

  type 'data point_info = 'data t

  let compare pi1 pi2 = Id.compare pi1.point pi2.point

  let log_size = 100

  let default_greylisting_config =
    {
      factor = 1.2;
      initial_delay = Ptime.Span.of_int_s 1;
      disconnection_delay = Ptime.Span.of_int_s 60;
      increase_cap = Ptime.Span.of_int_s 172800 (* 2 days *);
    }

  let greylisting_config_encoding =
    let open Data_encoding in
    conv
      (fun {factor; initial_delay; disconnection_delay; increase_cap} ->
        (factor, initial_delay, disconnection_delay, increase_cap))
      (fun (factor, initial_delay, disconnection_delay, increase_cap) ->
        {factor; initial_delay; disconnection_delay; increase_cap})
      (obj4
         (dft
            "factor"
            ~description:
              "The factor by which the greylisting delay is increased when an \
               already greylisted peer is greylisted again. This value should \
               be set to 1 for a linear back-off and to >1 for an exponential \
               back-off."
            float
            default_greylisting_config.factor)
         (dft
            "initial-delay"
            ~description:
              "The span of time a peer is greylisted for when it is first \
               greylisted."
            Time.System.Span.encoding
            default_greylisting_config.initial_delay)
         (dft
            "disconnection-delay"
            ~description:
              "The span of time a peer is greylisted for when it is \
               greylisted as the result of an abrupt disconnection."
            Time.System.Span.encoding
            default_greylisting_config.disconnection_delay)
         (dft
            "increase-cap"
            ~description:
              "The maximum amount by which the greylisting is extended. This \
               limits the rate of the exponential back-off, which eventually \
               becomes linear when it reaches this limit. This limit is set \
               to avoid reaching the End-of-Time when repeatedly greylisting \
               a peer."
            Time.System.Span.encoding
            default_greylisting_config.increase_cap))

  let create ?(trusted = false) addr port =
    {
      point = (addr, port);
      trusted;
      state = Disconnected;
      last_failed_connection = None;
      last_rejected_connection = None;
      last_established_connection = None;
      last_disconnection = None;
      known_public = false;
      events = Ring.create log_size;
      greylisting_delay = Ptime.Span.of_int_s 1;
      greylisting_end = Time.System.epoch;
      watchers = Lwt_watcher.create_input ();
    }

  let point s = s.point

  let trusted s = s.trusted

  let set_trusted gi = gi.trusted <- true

  let unset_trusted gi = gi.trusted <- false

  let last_established_connection s = s.last_established_connection

  let last_disconnection s = s.last_disconnection

  let last_failed_connection s = s.last_failed_connection

  let last_rejected_connection s = s.last_rejected_connection

  let known_public s = s.known_public

  let greylisted ?(now = Systime_os.now ()) s =
    Time.System.compare now s.greylisting_end <= 0

  let greylisted_until s = s.greylisting_end

  let last_seen s =
    Time.System.recent
      s.last_rejected_connection
      (Time.System.recent s.last_established_connection s.last_disconnection)

  let last_miss s =
    match
      ( s.last_failed_connection,
        Option.map ~f:(fun (_, time) -> time)
        @@ Time.System.recent s.last_rejected_connection s.last_disconnection
      )
    with
    | (None, None) ->
        None
    | (None, (Some _ as a)) | ((Some _ as a), None) ->
        a
    | ((Some t1 as a1), (Some t2 as a2)) ->
        if Time.System.compare t1 t2 < 0 then a2 else a1

  let log {events; watchers; _} ?timestamp kind =
    let time = Option.unopt ~default:(Systime_os.now ()) timestamp in
    let event = Time.System.stamp ~time kind in
    Ring.add events event ;
    Lwt_watcher.notify watchers event

  let log_incoming_rejection ?timestamp point_info peer_id =
    log point_info ?timestamp (Rejecting_request peer_id)

  let fold {events; _} ~init ~f = Ring.fold events ~init ~f

  let watch {watchers; _} = Lwt_watcher.create_stream watchers
end

let get {Info.state; _} = state

let is_disconnected {Info.state; _} =
  match state with
  | Disconnected ->
      true
  | Requested _ | Accepted _ | Running _ ->
      false

let set_requested ?timestamp point_info cancel =
  assert (
    match point_info.Info.state with
    | Requested _ ->
        true
    | Accepted _ | Running _ ->
        false
    | Disconnected ->
        true ) ;
  point_info.state <- Requested {cancel} ;
  Info.log point_info ?timestamp Outgoing_request

let set_accepted ?(timestamp = Systime_os.now ()) point_info current_peer_id
    cancel =
  (* log_notice "SET_ACCEPTED %a@." P2p_point.pp point_info.point ; *)
  assert (
    match point_info.Info.state with
    | Accepted _ | Running _ ->
        false
    | Requested _ | Disconnected ->
        true ) ;
  point_info.state <- Accepted {current_peer_id; cancel} ;
  Info.log point_info ~timestamp (Accepting_request current_peer_id)

let set_private point_info known_private =
  point_info.Info.known_public <- not known_private

let set_running ?(timestamp = Systime_os.now ()) point_info peer_id data =
  assert (
    match point_info.Info.state with
    | Disconnected ->
        true (* request to unknown peer_id. *)
    | Running _ ->
        false
    | Accepted {current_peer_id; _} ->
        P2p_peer.Id.equal peer_id current_peer_id
    | Requested _ ->
        true ) ;
  point_info.state <- Running {data; current_peer_id = peer_id} ;
  point_info.last_established_connection <- Some (peer_id, timestamp) ;
  Info.log point_info ~timestamp (Connection_established peer_id)

let maxed_time_add t s =
  match Ptime.add_span t s with Some t -> t | None -> Ptime.max

let set_greylisted greylisting_config timestamp point_info =
  point_info.Info.greylisting_end <-
    maxed_time_add timestamp point_info.Info.greylisting_delay ;
  point_info.greylisting_delay <-
    (let new_delay =
       Time.System.Span.multiply_exn
         greylisting_config.Info.factor
         point_info.greylisting_delay
     in
     if Ptime.Span.compare greylisting_config.Info.increase_cap new_delay > 0
     then new_delay
     else greylisting_config.Info.increase_cap)

let set_disconnected ?(timestamp = Systime_os.now ()) ?(requested = false)
    greylisting_config point_info =
  let event : Pool_event.kind =
    match point_info.Info.state with
    | Requested _ ->
        set_greylisted greylisting_config timestamp point_info ;
        point_info.last_failed_connection <- Some timestamp ;
        Request_rejected None
    | Accepted {current_peer_id; _} ->
        set_greylisted greylisting_config timestamp point_info ;
        point_info.last_rejected_connection <- Some (current_peer_id, timestamp) ;
        Request_rejected (Some current_peer_id)
    | Running {current_peer_id; _} ->
        point_info.greylisting_delay <- greylisting_config.Info.initial_delay ;
        point_info.greylisting_end <-
          maxed_time_add timestamp greylisting_config.Info.disconnection_delay ;
        point_info.last_disconnection <- Some (current_peer_id, timestamp) ;
        if requested then Disconnection current_peer_id
        else External_disconnection current_peer_id
    | Disconnected ->
        assert false
  in
  point_info.state <- Disconnected ;
  Info.log point_info ~timestamp event
src/lib_p2p/p2p_point_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import P2p_point.

Inductive t (data : Type) : Type :=
| Requested : Tezos_stdlib.Lwt_canceler.t -> t data
| Accepted : Tezos_base__TzPervasives.P2p_peer.Id.t ->
  Tezos_stdlib.Lwt_canceler.t -> t data
| Running : data -> Tezos_base__TzPervasives.P2p_peer.Id.t -> t data
| Disconnected : t data.

Arguments Requested {_}.
Arguments Accepted {_}.
Arguments Running {_}.
Arguments Disconnected {_}.

Definition state (data : Type) := t data.

Definition pp {A : Type}
  (ppf : Stdlib.Format.formatter) (function_parameter : t A) : unit :=
  match function_parameter with
  | Requested _ =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "requested" % string
          CamlinternalFormatBasics.End_of_format) "requested" % string)
  | Accepted {| current_peer_id := current_peer_id |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "accepted " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "accepted %a" % string) P2p_peer.Id.pp current_peer_id
  | Running {| current_peer_id := current_peer_id |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "running " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "running %a" % string) P2p_peer.Id.pp current_peer_id
  | Disconnected =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "disconnected" % string
          CamlinternalFormatBasics.End_of_format) "disconnected" % string)
  end.

Module Info.
  Record greylisting_config := {
    factor : Z;
    initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    disconnection_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    increase_cap : Tezos_base__TzPervasives.Time.System.Span.t }.
  
  Record t {data : Type} := {
    point : Tezos_base__TzPervasives.P2p_point.Id.t;
    trusted : bool;
    state : state data;
    last_failed_connection : option Tezos_base__TzPervasives.Time.System.t;
    last_rejected_connection :
      option
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    last_established_connection :
      option
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    known_public : bool;
    last_disconnection :
      option
        (Tezos_base__TzPervasives.P2p_peer.Id.t *
          Tezos_base__TzPervasives.Time.System.t);
    greylisting_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    greylisting_end : Tezos_base__TzPervasives.Time.System.t;
    events : Tezos_stdlib.Ring.t Tezos_base__TzPervasives.P2p_point.Pool_event.t;
    watchers :
      Tezos_stdlib.Lwt_watcher.input
        Tezos_base__TzPervasives.P2p_point.Pool_event.t }.
  Arguments t : clear implicits.
  
  Definition point_info (data : Type) := t data.
  
  Definition compare {A B : Type} (pi1 : t A) (pi2 : t B) : Z :=
    Id.compare (point pi1) (point pi2).
  
  Definition log_size : Z := 100.
  
  Definition default_greylisting_config : greylisting_config :=
    {|
      factor :=
        (* ❌ Float constant 1.2 is approximated by the integer 1 *)
        1; initial_delay := Ptime.Span.of_int_s 1;
      disconnection_delay := Ptime.Span.of_int_s 60;
      increase_cap := Ptime.Span.of_int_s 172800 |}.
  
  Definition greylisting_config_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding greylisting_config :=
    conv
      (fun function_parameter =>
        let '{|
          factor := factor;
            initial_delay := initial_delay;
            disconnection_delay := disconnection_delay;
            increase_cap := increase_cap
            |} := function_parameter in
        (factor, initial_delay, disconnection_delay, increase_cap))
      (fun function_parameter =>
        let '(factor, initial_delay, disconnection_delay, increase_cap) :=
          function_parameter in
        {| factor := factor; initial_delay := initial_delay;
          disconnection_delay := disconnection_delay;
          increase_cap := increase_cap |}) None
      (obj4
        (dft None
          (Some
            "The factor by which the greylisting delay is increased when an already greylisted peer is greylisted again. This value should be set to 1 for a linear back-off and to >1 for an exponential back-off."
              % string) "factor" % string float
          (factor default_greylisting_config))
        (dft None
          (Some
            "The span of time a peer is greylisted for when it is first greylisted."
              % string) "initial-delay" % string Time.System.Span.encoding
          (initial_delay default_greylisting_config))
        (dft None
          (Some
            "The span of time a peer is greylisted for when it is greylisted as the result of an abrupt disconnection."
              % string) "disconnection-delay" % string Time.System.Span.encoding
          (disconnection_delay default_greylisting_config))
        (dft None
          (Some
            "The maximum amount by which the greylisting is extended. This limits the rate of the exponential back-off, which eventually becomes linear when it reaches this limit. This limit is set to avoid reaching the End-of-Time when repeatedly greylisting a peer."
              % string) "increase-cap" % string Time.System.Span.encoding
          (increase_cap default_greylisting_config))).
  
  Definition create {A : Type} (op_staroptstar : option bool)
    : Tezos_base.P2p_addr.t -> Tezos_base.P2p_addr.port -> t A :=
    let trusted :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun addr =>
      fun port =>
        {| point := (addr, port); trusted := trusted; state := Disconnected;
          last_failed_connection := None; last_rejected_connection := None;
          last_established_connection := None; known_public := false;
          last_disconnection := None;
          greylisting_delay := Ptime.Span.of_int_s 1;
          greylisting_end := Time.System.epoch; events := Ring.create log_size;
          watchers := Lwt_watcher.create_input tt |}.
  
  Definition point {A : Type} (s : t A)
    : Tezos_base__TzPervasives.P2p_point.Id.t := point s.
  
  Definition trusted {A : Type} (s : t A) : bool := trusted s.
  
  Definition set_trusted {A : Type} (gi : t A) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field gi "trusted" % string true.
  
  Definition unset_trusted {A : Type} (gi : t A) : unit :=
    (* ❌ Set record field not handled. *)
    set_record_field gi "trusted" % string false.
  
  Definition last_established_connection {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_established_connection s.
  
  Definition last_disconnection {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_disconnection s.
  
  Definition last_failed_connection {A : Type} (s : t A)
    : option Tezos_base__TzPervasives.Time.System.t := last_failed_connection s.
  
  Definition last_rejected_connection {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) := last_rejected_connection s.
  
  Definition known_public {A : Type} (s : t A) : bool := known_public s.
  
  Definition greylisted {A : Type}
    (op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
    : (t A) -> bool :=
    let now :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Systime_os.now tt
      end in
    fun s => OCaml.Stdlib.le (Time.System.compare now (greylisting_end s)) 0.
  
  Definition greylisted_until {A : Type} (s : t A)
    : Tezos_base__TzPervasives.Time.System.t := greylisting_end s.
  
  Definition last_seen {A : Type} (s : t A)
    : option
      (Tezos_base__TzPervasives.P2p_peer.Id.t *
        Tezos_base__TzPervasives.Time.System.t) :=
    Time.System.recent (last_rejected_connection s)
      (Time.System.recent (last_established_connection s) (last_disconnection s)).
  
  Definition last_miss {A : Type} (s : t A)
    : option Tezos_base__TzPervasives.Time.System.t :=
    match
      ((last_failed_connection s),
        (apply
          (Option.map
            (fun function_parameter =>
              let '(_, time) := function_parameter in
              time))
          (Time.System.recent (last_rejected_connection s)
            (last_disconnection s)))) with
    | (None, None) => None
    | (None, (Some _) as a) | ((Some _) as a, None) => a
    | ((Some t1) as a1, (Some t2) as a2) =>
      if OCaml.Stdlib.lt (Time.System.compare t1 t2) 0 then
        a2
      else
        a1
    end.
  
  Definition log {A : Type} (function_parameter : t A)
    : (option Tezos_base__TzPervasives.Time.System.t) ->
      Tezos_base__TzPervasives.P2p_point.Pool_event.kind -> unit :=
    let '{| events := events; watchers := watchers |} := function_parameter in
    fun timestamp =>
      fun kind =>
        let time := Option.unopt (Systime_os.now tt) timestamp in
        let event := Time.System.stamp time kind in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Ring.add events event in
        Lwt_watcher.notify watchers event.
  
  Definition log_incoming_rejection {A : Type}
    (timestamp : option Tezos_base__TzPervasives.Time.System.t)
    (point_info : t A) (peer_id : Tezos_base.P2p_peer_id.t) : unit :=
    log point_info timestamp
      (Tezos_base__TzPervasives.P2p_point.Pool_event.Rejecting_request peer_id).
  
  Definition fold {A B : Type} (function_parameter : t A)
    : B -> (B -> Tezos_base__TzPervasives.P2p_point.Pool_event.t -> B) -> B :=
    let '{| events := events |} := function_parameter in
    fun init => fun f => Ring.fold events init f.
  
  Definition watch {A : Type} (function_parameter : t A)
    : (Lwt_stream.t Tezos_base__TzPervasives.P2p_point.Pool_event.t) *
      Tezos_stdlib.Lwt_watcher.stopper :=
    let '{| watchers := watchers |} := function_parameter in
    Lwt_watcher.create_stream watchers.
End Info.

Definition get {A : Type} (function_parameter : Info.t A) : state A :=
  let '{| Info.state := state |} := function_parameter in
  state.

Definition is_disconnected {A : Type} (function_parameter : Info.t A) : bool :=
  let '{| Info.state := state |} := function_parameter in
  match state with
  | Disconnected => true
  | Requested _ | Accepted _ | Running _ => false
  end.

Definition set_requested {A : Type}
  (timestamp : option Tezos_base__TzPervasives.Time.System.t)
  (point_info : Info.t A) (cancel : Tezos_stdlib.Lwt_canceler.t) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      match Info.state point_info with
      | Requested _ => true
      | Accepted _ | Running _ => false
      | Disconnected => true
      end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field point_info "state" % string
      (Requested {| cancel := cancel |}) in
  Info.log point_info timestamp
    Tezos_base__TzPervasives.P2p_point.Pool_event.Outgoing_request.

Definition set_accepted {A : Type}
  (op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
  : (Info.t A) ->
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_stdlib.Lwt_canceler.t -> unit :=
  let timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Systime_os.now tt
    end in
  fun point_info =>
    fun current_peer_id =>
      fun cancel =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            match Info.state point_info with
            | Accepted _ | Running _ => false
            | Requested _ | Disconnected => true
            end in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field point_info "state" % string
            (Accepted {| current_peer_id := current_peer_id; cancel := cancel |})
          in
        Info.log point_info (Some timestamp)
          (Tezos_base__TzPervasives.P2p_point.Pool_event.Accepting_request
            current_peer_id).

Definition set_private {A : Type} (point_info : Info.t A) (known_private : bool)
  : unit :=
  (* ❌ Set record field not handled. *)
  set_record_field point_info "known_public" % string (negb known_private).

Definition set_running {A : Type}
  (op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
  : (Info.t A) -> Tezos_base__TzPervasives.P2p_peer.Id.t -> A -> unit :=
  let timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Systime_os.now tt
    end in
  fun point_info =>
    fun peer_id =>
      fun data =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            match Info.state point_info with
            | Disconnected => true
            | Running _ => false
            | Accepted {| current_peer_id := current_peer_id |} =>
              P2p_peer.Id.equal peer_id current_peer_id
            | Requested _ => true
            end in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field point_info "state" % string
            (Running {| data := data; current_peer_id := peer_id |}) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field point_info "last_established_connection" % string
            (Some (peer_id, timestamp)) in
        Info.log point_info (Some timestamp)
          (Tezos_base__TzPervasives.P2p_point.Pool_event.Connection_established
            peer_id).

Definition maxed_time_add (t : Ptime.t) (s : Ptime.span) : Ptime.t :=
  match Ptime.add_span t s with
  | Some t => t
  | None => Ptime.max
  end.

Definition set_greylisted {A : Type}
  (greylisting_config : Info.greylisting_config) (timestamp : Ptime.t)
  (point_info : Info.t A) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field point_info "greylisting_end" % string
      (maxed_time_add timestamp (Info.greylisting_delay point_info)) in
  (* ❌ Set record field not handled. *)
  set_record_field point_info "greylisting_delay" % string
    (let new_delay :=
      Time.System.Span.multiply_exn (Info.factor greylisting_config)
        (greylisting_delay point_info) in
    if
      OCaml.Stdlib.gt
        (Ptime.Span.compare (Info.increase_cap greylisting_config) new_delay) 0
      then
      new_delay
    else
      Info.increase_cap greylisting_config).

Definition set_disconnected {A : Type}
  (op_staroptstar : option Tezos_base__TzPervasives.Time.System.t)
  : (option bool) -> Info.greylisting_config -> (Info.t A) -> unit :=
  let timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Systime_os.now tt
    end in
  fun op_staroptstar =>
    let requested :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun greylisting_config =>
      fun point_info =>
        let event :=
          match Info.state point_info with
          | Requested _ =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := set_greylisted greylisting_config timestamp point_info in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field point_info "last_failed_connection" % string
                (Some timestamp) in
            Tezos_base__TzPervasives.P2p_point.Pool_event.Request_rejected None
          | Accepted {| current_peer_id := current_peer_id |} =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := set_greylisted greylisting_config timestamp point_info in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field point_info "last_rejected_connection" % string
                (Some (current_peer_id, timestamp)) in
            Tezos_base__TzPervasives.P2p_point.Pool_event.Request_rejected
              (Some current_peer_id)
          | Running {| current_peer_id := current_peer_id |} =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field point_info "greylisting_delay" % string
                (Info.initial_delay greylisting_config) in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field point_info "greylisting_end" % string
                (maxed_time_add timestamp
                  (Info.disconnection_delay greylisting_config)) in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field point_info "last_disconnection" % string
                (Some (current_peer_id, timestamp)) in
            if requested then
              Tezos_base__TzPervasives.P2p_point.Pool_event.Disconnection
                current_peer_id
            else
              Tezos_base__TzPervasives.P2p_point.Pool_event.External_disconnection
                current_peer_id
          | Disconnected =>
            (* ❌ Assert instruction is not handled. *)
            assert false
          end in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field point_info "state" % string Disconnected in
        Info.log point_info (Some timestamp) event.

src/lib_p2p/p2p_pool.ml 128 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* TODO Test cancellation of a (pending) connection *)

(* TODO do not recompute list_known_points at each requests... but
        only once in a while, e.g. every minutes or when a point
        or the associated peer_id is blacklisted. *)

(* TODO allow to track "requested peer_ids" when we reconnect to a point. *)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.pool"
end)

type config = {
  identity : P2p_identity.t;
  trusted_points : P2p_point.Id.t list;
  peers_file : string;
  private_mode : bool;
  max_known_points : (int * int) option;
  max_known_peer_ids : (int * int) option;
}

type 'peer peer_meta_config = {
  peer_meta_encoding : 'peer Data_encoding.t;
  peer_meta_initial : unit -> 'peer;
  score : 'peer -> float;
}

type ('msg, 'peer, 'conn) t = {
  config : config;
  peer_meta_config : 'peer peer_meta_config;
  (* Set of points corresponding to this peer *)
  my_id_points : unit P2p_point.Table.t;
  known_peer_ids :
    (('msg, 'peer, 'conn) P2p_conn.t, 'peer, 'conn) P2p_peer_state.Info.t
    P2p_peer.Table.t;
  connected_peer_ids :
    (('msg, 'peer, 'conn) P2p_conn.t, 'peer, 'conn) P2p_peer_state.Info.t
    P2p_peer.Table.t;
  known_points :
    ('msg, 'peer, 'conn) P2p_conn.t P2p_point_state.Info.t P2p_point.Table.t;
  connected_points :
    ('msg, 'peer, 'conn) P2p_conn.t P2p_point_state.Info.t P2p_point.Table.t;
  triggers : P2p_trigger.t;
  log : P2p_connection.P2p_event.t -> unit;
  acl : P2p_acl.t;
}

module Gc_point_set = List.Bounded (struct
  type t = Time.System.t * P2p_point.Id.t

  let compare (x, _) (y, _) = -Time.System.compare x y
end)

let gc_points {config = {max_known_points; _}; known_points; log; _} =
  match max_known_points with
  | None ->
      ()
  | Some (_, target) ->
      let current_size = P2p_point.Table.length known_points in
      if current_size > target then (
        let to_remove_target = current_size - target in
        let now = Systime_os.now () in
        (* TODO: maybe time of discovery? *)
        let table = Gc_point_set.create to_remove_target in
        P2p_point.Table.iter
          (fun p point_info ->
            if P2p_point_state.is_disconnected point_info then
              let time =
                match P2p_point_state.Info.last_miss point_info with
                | None ->
                    now
                | Some t ->
                    t
              in
              Gc_point_set.insert (time, p) table)
          known_points ;
        let to_remove = Gc_point_set.get table in
        ListLabels.iter to_remove ~f:(fun (_, p) ->
            P2p_point.Table.remove known_points p) ;
        log Gc_points )

let register_point ?trusted pool ((addr, port) as point) =
  match P2p_point.Table.find_opt pool.known_points point with
  | None ->
      let point_info = P2p_point_state.Info.create ?trusted addr port in
      Option.iter pool.config.max_known_points ~f:(fun (max, _) ->
          if P2p_point.Table.length pool.known_points >= max then
            gc_points pool) ;
      P2p_point.Table.add pool.known_points point point_info ;
      P2p_trigger.broadcast_new_point pool.triggers ;
      pool.log (New_point point) ;
      point_info
  | Some point_info ->
      ( match trusted with
      | Some true ->
          P2p_point_state.Info.set_trusted point_info
      | Some false ->
          P2p_point_state.Info.unset_trusted point_info
      | None ->
          () ) ;
      point_info

let register_new_point ?trusted t point =
  if not (P2p_point.Table.mem t.my_id_points point) then
    Some (register_point ?trusted t point)
  else None

(* Bounded table used to garbage collect peer_id infos when needed. The
   strategy used is to remove the info of the peer_id with the lowest
   score first. In case of equality, the info of the most recent added
   peer_id is removed. The rationale behind this choice is that in the
   case of a flood attack, the newly added infos will probably belong
   to peer_ids with the same (low) score and removing the most recent ones
   ensure that older (and probably legit) peer_id infos are kept. *)
module Gc_peer_set = List.Bounded (struct
  type t = float * Time.System.t * P2p_peer.Id.t

  let compare (s, t, _) (s', t', _) =
    let score_cmp = Pervasives.compare s s' in
    if score_cmp = 0 then Time.System.compare t t' else -score_cmp
end)

let gc_peer_ids
    { peer_meta_config = {score; _};
      config = {max_known_peer_ids; _};
      known_peer_ids;
      log;
      _ } =
  match max_known_peer_ids with
  | None ->
      ()
  | Some (_, target) ->
      let current_size = P2p_peer.Table.length known_peer_ids in
      if current_size > target then (
        let to_remove_target = current_size - target in
        let table = Gc_peer_set.create to_remove_target in
        P2p_peer.Table.iter
          (fun peer_id peer_info ->
            let created = P2p_peer_state.Info.created peer_info in
            let score = score @@ P2p_peer_state.Info.peer_metadata peer_info in
            if P2p_peer_state.is_disconnected peer_info then
              Gc_peer_set.insert (score, created, peer_id) table)
          known_peer_ids ;
        let to_remove = Gc_peer_set.get table in
        ListLabels.iter to_remove ~f:(fun (_, _, peer_id) ->
            P2p_peer.Table.remove known_peer_ids peer_id) ;
        log Gc_peer_ids )

let register_peer pool peer_id =
  match P2p_peer.Table.find_opt pool.known_peer_ids peer_id with
  | None ->
      P2p_trigger.broadcast_new_peer pool.triggers ;
      let peer =
        P2p_peer_state.Info.create
          peer_id
          ~peer_metadata:(pool.peer_meta_config.peer_meta_initial ())
      in
      Option.iter pool.config.max_known_peer_ids ~f:(fun (max, _) ->
          if P2p_peer.Table.length pool.known_peer_ids >= max then
            gc_peer_ids pool) ;
      P2p_peer.Table.add pool.known_peer_ids peer_id peer ;
      pool.log (New_peer peer_id) ;
      peer
  | Some peer ->
      peer

(* this function duplicates bit of code from the modules below to avoid
   creating mutually recursive modules *)
let connection_of_peer_id pool peer_id =
  Option.apply
    (P2p_peer.Table.find_opt pool.known_peer_ids peer_id)
    ~f:(fun p ->
      match P2p_peer_state.get p with
      | Running {data; _} ->
          Some data
      | _ ->
          None)

(* Every running connection matching the point's ip address is returned. *)
let connections_of_addr pool addr =
  P2p_point.Table.fold
    (fun (addr', _) p acc ->
      if Ipaddr.V6.compare addr addr' = 0 then
        match P2p_point_state.get p with
        | P2p_point_state.Running {data; _} ->
            data :: acc
        | _ ->
            acc
      else acc)
    pool.connected_points
    []

let get_addr pool peer_id =
  Option.map (connection_of_peer_id pool peer_id) ~f:(fun ci ->
      (P2p_conn.info ci).id_point)

module Points = struct
  type ('msg, 'peer, 'conn) info =
    ('msg, 'peer, 'conn) P2p_conn.t P2p_point_state.Info.t

  let info {known_points; _} point =
    P2p_point.Table.find_opt known_points point

  let get_trusted pool point =
    Option.unopt_map
      ~default:false
      ~f:P2p_point_state.Info.trusted
      (P2p_point.Table.find_opt pool.known_points point)

  let set_trusted pool point =
    ignore @@ register_point ~trusted:true pool point

  let unset_trusted pool point =
    Option.iter
      ~f:P2p_point_state.Info.unset_trusted
      (P2p_point.Table.find_opt pool.known_points point)

  let fold_known pool ~init ~f = P2p_point.Table.fold f pool.known_points init

  let fold_connected pool ~init ~f =
    P2p_point.Table.fold f pool.connected_points init

  let add_connected t point point_info =
    P2p_point.Table.add t.connected_points point point_info

  let remove_connected t point_info =
    P2p_point.Table.remove
      t.connected_points
      (P2p_point_state.Info.point point_info)

  let banned pool (addr, _port) = P2p_acl.banned_addr pool.acl addr

  let ban pool (addr, _port) =
    P2p_acl.IPBlacklist.add pool.acl addr ;
    (* Kick [addr]:* if it is in `Running` state. *)
    List.iter
      (fun conn -> Lwt.async (fun () -> P2p_conn.disconnect conn))
      (connections_of_addr pool addr)

  let unban pool (addr, _port) = P2p_acl.unban_addr pool.acl addr

  let trust pool point = unban pool point ; set_trusted pool point

  let untrust pool point = unset_trusted pool point
end

module Peers = struct
  type ('msg, 'peer, 'conn) info =
    (('msg, 'peer, 'conn) P2p_conn.t, 'peer, 'conn) P2p_peer_state.Info.t

  let info {known_peer_ids; _} peer_id =
    try Some (P2p_peer.Table.find known_peer_ids peer_id)
    with Not_found -> None

  let get_peer_metadata pool peer_id =
    try
      P2p_peer_state.Info.peer_metadata
        (P2p_peer.Table.find pool.known_peer_ids peer_id)
    with Not_found -> pool.peer_meta_config.peer_meta_initial ()

  let get_score pool peer_id =
    pool.peer_meta_config.score (get_peer_metadata pool peer_id)

  let set_peer_metadata pool peer_id data =
    P2p_peer_state.Info.set_peer_metadata (register_peer pool peer_id) data

  let get_trusted pool peer_id =
    try
      P2p_peer_state.Info.trusted
        (P2p_peer.Table.find pool.known_peer_ids peer_id)
    with Not_found -> false

  let set_trusted pool peer_id =
    try P2p_peer_state.Info.set_trusted (register_peer pool peer_id)
    with Not_found -> ()

  (* TODO can this exception occur *)

  let unset_trusted pool peer_id =
    try
      P2p_peer_state.Info.unset_trusted
        (P2p_peer.Table.find pool.known_peer_ids peer_id)
    with Not_found -> ()

  let fold_known pool ~init ~f = P2p_peer.Table.fold f pool.known_peer_ids init

  let fold_connected pool ~init ~f =
    P2p_peer.Table.fold f pool.connected_peer_ids init

  let add_connected pool peer_id peer_info =
    P2p_peer.Table.add pool.connected_peer_ids peer_id peer_info

  let remove_connected t peer_id =
    P2p_peer.Table.remove t.connected_peer_ids peer_id

  let ban pool peer =
    P2p_acl.PeerBlacklist.add pool.acl peer ;
    (* Kick [peer] if it is in `Running` state. *)
    let f conn = Lwt.async (fun () -> P2p_conn.disconnect conn) in
    Option.iter (connection_of_peer_id pool peer) ~f

  let unban pool peer = P2p_acl.unban_peer pool.acl peer

  let trust pool peer = unban pool peer ; set_trusted pool peer

  let untrust pool peer = unset_trusted pool peer

  let banned pool peer = P2p_acl.banned_peer pool.acl peer
end

module Connection = struct
  let fold pool ~init ~f =
    Peers.fold_connected pool ~init ~f:(fun peer_id peer_info acc ->
        match P2p_peer_state.get peer_info with
        | Running {data; _} ->
            f peer_id data acc
        | _ ->
            acc)

  let list pool =
    fold pool ~init:[] ~f:(fun peer_id c acc -> (peer_id, c) :: acc)

  let random_elt l =
    let n = List.length l in
    let r = Random.int n in
    List.nth l r

  let random_addr ?different_than ~no_private pool =
    let candidates =
      fold pool ~init:[] ~f:(fun _peer conn acc ->
          if no_private && P2p_conn.private_node conn then acc
          else
            match different_than with
            | Some excluded_conn when P2p_conn.equal_sock conn excluded_conn ->
                acc
            | Some _ | None -> (
                let ci = P2p_conn.info conn in
                match ci.id_point with
                | (_, None) ->
                    acc
                | (addr, Some port) ->
                    ((addr, port), ci.peer_id) :: acc ))
    in
    match candidates with [] -> None | _ -> Some (random_elt candidates)

  (** [random_connection ?conn no_private t] returns a random connection from
      the pool of connections. It ignores:
      - connections to private peers if [no_private] is set to [true]
      - connection [conn]
      Unlike [random_addr], it may return a connection to a peer who didn't
      provide a listening port *)
  let random_connection ?different_than ~no_private pool =
    let candidates =
      fold pool ~init:[] ~f:(fun _peer conn acc ->
          if no_private && P2p_conn.private_node conn then acc
          else
            match different_than with
            | Some excluded_conn when P2p_conn.equal_sock conn excluded_conn ->
                acc
            | Some _ | None ->
                conn :: acc)
    in
    match candidates with [] -> None | _ -> Some (random_elt candidates)

  let propose_swap_request pool =
    match random_connection ~no_private:true pool with
    | Some recipient -> (
      match random_addr ~different_than:recipient ~no_private:true pool with
      | None ->
          None
      | Some (proposed_point, proposed_peer_id) ->
          Some (proposed_point, proposed_peer_id, recipient) )
    | None ->
        None

  let find_by_peer_id pool peer_id =
    Option.apply (Peers.info pool peer_id) ~f:(fun p ->
        match P2p_peer_state.get p with
        | Running {data; _} ->
            Some data
        | _ ->
            None)

  let find_by_point pool point =
    Option.apply (Points.info pool point) ~f:(fun p ->
        match P2p_point_state.get p with
        | Running {data; _} ->
            Some data
        | _ ->
            None)
end

let connected_peer_ids pool = pool.connected_peer_ids

let greylist_addr pool addr =
  P2p_acl.IPGreylist.add pool.acl addr (Systime_os.now ())

let greylist_peer pool peer =
  Option.iter (get_addr pool peer) ~f:(fun (addr, _port) ->
      greylist_addr pool addr ;
      P2p_acl.PeerGreylist.add pool.acl peer)

let acl_clear pool = P2p_acl.clear pool.acl

let gc_greylist ~older_than pool =
  P2p_acl.IPGreylist.remove_old ~older_than pool.acl

let config {config; _} = config

let score {peer_meta_config = {score; _}; _} meta = score meta

let active_connections pool = P2p_peer.Table.length pool.connected_peer_ids

let create config peer_meta_config triggers ~log =
  let pool =
    {
      config;
      peer_meta_config;
      my_id_points = P2p_point.Table.create 7;
      known_peer_ids = P2p_peer.Table.create 53;
      connected_peer_ids = P2p_peer.Table.create 53;
      known_points = P2p_point.Table.create 53;
      connected_points = P2p_point.Table.create 53;
      triggers;
      acl = P2p_acl.create 1023;
      log;
    }
  in
  List.iter (Points.set_trusted pool) config.trusted_points ;
  P2p_peer_state.Info.File.load
    config.peers_file
    peer_meta_config.peer_meta_encoding
  >>= function
  | Ok peer_ids ->
      List.iter
        (fun peer_info ->
          let peer_id = P2p_peer_state.Info.peer_id peer_info in
          P2p_peer.Table.add pool.known_peer_ids peer_id peer_info ;
          match P2p_peer_state.Info.last_seen peer_info with
          | None | Some ((_, None (* no reachable port stored*)), _) ->
              ()
          | Some ((addr, Some port), _) ->
              register_point pool (addr, port) |> ignore)
        peer_ids ;
      Lwt.return pool
  | Error err ->
      log_error "@[Failed to parse peers file:@ %a@]" pp_print_error err ;
      Lwt.return pool

let destroy {config; peer_meta_config; known_peer_ids; known_points; _} =
  lwt_log_info "Saving metadata in %s" config.peers_file
  >>= fun () ->
  P2p_peer_state.Info.File.save
    config.peers_file
    peer_meta_config.peer_meta_encoding
    (P2p_peer.Table.fold (fun _ a b -> a :: b) known_peer_ids [])
  >>= (function
        | Error err ->
            log_error "@[Failed to save peers file:@ %a@]" pp_print_error err ;
            Lwt.return_unit
        | Ok () ->
            Lwt.return_unit)
  >>= fun () ->
  P2p_point.Table.fold
    (fun _point point_info acc ->
      match P2p_point_state.get point_info with
      | Requested {cancel} | Accepted {cancel; _} ->
          Lwt_canceler.cancel cancel >>= fun () -> acc
      | Running {data = conn; _} ->
          P2p_conn.disconnect conn >>= fun () -> acc
      | Disconnected ->
          acc)
    known_points
  @@ P2p_peer.Table.fold
       (fun _peer_id peer_info acc ->
         match P2p_peer_state.get peer_info with
         | Accepted {cancel; _} ->
             Lwt_canceler.cancel cancel >>= fun () -> acc
         | Running {data = conn; _} ->
             P2p_conn.disconnect conn >>= fun () -> acc
         | Disconnected ->
             acc)
       known_peer_ids
       Lwt.return_unit

let add_to_id_points t point =
  P2p_point.Table.add t.my_id_points point () ;
  P2p_point.Table.remove t.known_points point

(* [sample best other points] return a list of elements selected in [points].
   The [best] first elements are taken, then [other] elements are chosen
   randomly in the rest of the list.
   Note that it might select fewer elements than [other] if it the same index
   close to the end of the list is picked multiple times. *)
let sample best other points =
  let l = List.length points in
  if l <= best + other then points
  else
    let best_indexes = List.init best (fun i -> i) in
    let other_indexes =
      List.sort compare
      @@ List.init other (fun _ -> best + Random.int (l - best))
    in
    let indexes = best_indexes @ other_indexes in
    (* Note: we are doing a [fold_left_i] by hand, passing [i] manually *)
    (fun (_, _, result) -> result)
    @@ List.fold_left
         (fun (i, indexes, acc) point ->
           match indexes with
           | [] ->
               (0, [], acc) (* TODO: early return *)
           | index :: indexes when i >= index ->
               (* We compare `i >= index` (rather than `i = index`) to avoid a
                corner case whereby two identical `index`es are present in the
                list. In that case, using `>=` makes it so that if `i` overtakes
                `index` we still pick elements. *)
               (succ i, indexes, point :: acc)
           | _ ->
               (succ i, indexes, acc))
         (0, indexes, [])
         points

let compare_known_point_info p1 p2 =
  (* The most-recently disconnected peers are greater. *)
  (* Then come long-standing connected peers. *)
  let disconnected1 = P2p_point_state.is_disconnected p1
  and disconnected2 = P2p_point_state.is_disconnected p2 in
  let compare_last_seen p1 p2 =
    match
      (P2p_point_state.Info.last_seen p1, P2p_point_state.Info.last_seen p2)
    with
    | (None, None) ->
        (Random.int 2 * 2) - 1 (* HACK... *)
    | (Some _, None) ->
        1
    | (None, Some _) ->
        -1
    | (Some (_, time1), Some (_, time2)) -> (
      match compare time1 time2 with
      | 0 ->
          (Random.int 2 * 2) - 1 (* HACK... *)
      | x ->
          x )
  in
  match (disconnected1, disconnected2) with
  | (false, false) ->
      compare_last_seen p1 p2
  | (false, true) ->
      -1
  | (true, false) ->
      1
  | (true, true) ->
      compare_last_seen p2 p1

let list_known_points ~ignore_private pool =
  P2p_point.Table.fold
    (fun point_id point_info acc ->
      if
        (ignore_private && not (P2p_point_state.Info.known_public point_info))
        || Points.banned pool point_id
      then acc
      else point_info :: acc)
    pool.known_points
    []
  |> List.sort compare_known_point_info
  |> sample 30 20
  |> List.map P2p_point_state.Info.point
  |> Lwt.return
src/lib_p2p/p2p_pool.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Record config := {
  identity : Tezos_base__TzPervasives.P2p_identity.t;
  trusted_points : list Tezos_base__TzPervasives.P2p_point.Id.t;
  peers_file : string;
  private_mode : bool;
  max_known_points : option (Z * Z);
  max_known_peer_ids : option (Z * Z) }.

Record peer_meta_config {peer : Type} := {
  peer_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t peer;
  peer_meta_initial : unit -> peer;
  score : peer -> Z }.
Arguments peer_meta_config : clear implicits.

Record t {msg peer conn : Type} := {
  config : config;
  peer_meta_config : peer_meta_config peer;
  my_id_points : Tezos_base__TzPervasives.P2p_point.Table.t unit;
  known_peer_ids :
    Tezos_base__TzPervasives.P2p_peer.Table.t
      (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn) peer
        conn);
  connected_peer_ids :
    Tezos_base__TzPervasives.P2p_peer.Table.t
      (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn) peer
        conn);
  known_points :
    Tezos_base__TzPervasives.P2p_point.Table.t
      (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn));
  connected_points :
    Tezos_base__TzPervasives.P2p_point.Table.t
      (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn));
  triggers : Tezos_p2p.P2p_trigger.t;
  log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit;
  acl : Tezos_p2p.P2p_acl.t }.
Arguments t : clear implicits.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition gc_points {A B C : Type} (function_parameter : t A B C) : unit :=
  let '{|
    config := {| max_known_points := max_known_points |};
      known_points := known_points;
      log := log
      |} := function_parameter in
  match max_known_points with
  | None => tt
  | Some (_, target) =>
    let current_size := P2p_point.Table.length known_points in
    if OCaml.Stdlib.gt current_size target then
      let to_remove_target := Z.sub current_size target in
      let now := Systime_os.now tt in
      let table := Gc_point_set.create to_remove_target in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        P2p_point.Table.iter
          (fun p =>
            fun point_info =>
              if P2p_point_state.is_disconnected point_info then
                let time :=
                  match P2p_point_state.Info.last_miss point_info with
                  | None => now
                  | Some t => t
                  end in
                Gc_point_set.insert (time, p) table
              else
                tt) known_points in
      let to_remove := Gc_point_set.get table in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        ListLabels.iter
          (fun function_parameter =>
            let '(_, p) := function_parameter in
            P2p_point.Table.remove known_points p) to_remove in
      log Tezos_base__TzPervasives.P2p_connection.P2p_event.Gc_points
    else
      tt
  end.

Definition register_point {A B C : Type}
  (trusted : option bool) (pool : t A B C)
  (function_parameter : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
  : Tezos_p2p.P2p_point_state.Info.point_info (Tezos_p2p.P2p_conn.t A B C) :=
  let '(addr, port) as point := function_parameter in
  match P2p_point.Table.find_opt (known_points pool) point with
  | None =>
    let point_info := P2p_point_state.Info.create trusted addr port in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Option.iter
        (fun function_parameter =>
          let '(max, _) := function_parameter in
          if OCaml.Stdlib.ge (P2p_point.Table.length (known_points pool)) max
            then
            gc_points pool
          else
            tt) (max_known_points (config pool)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_point.Table.add (known_points pool) point point_info in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_trigger.broadcast_new_point (triggers pool) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (log pool)
        (Tezos_base__TzPervasives.P2p_connection.P2p_event.New_point point) in
    point_info
  | Some point_info =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match trusted with
      | Some true => P2p_point_state.Info.set_trusted point_info
      | Some false => P2p_point_state.Info.unset_trusted point_info
      | None => tt
      end in
    point_info
  end.

Definition register_new_point {A B C : Type}
  (trusted : option bool) (t : t A B C)
  (point : Tezos_base__TzPervasives.P2p_point.Table.key)
  : option
    (Tezos_p2p.P2p_point_state.Info.point_info (Tezos_p2p.P2p_conn.t A B C)) :=
  if negb (P2p_point.Table.mem (my_id_points t) point) then
    Some (register_point trusted t point)
  else
    None.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition gc_peer_ids {A B C : Type} (function_parameter : t A B C) : unit :=
  let '{|
    config := {| max_known_peer_ids := max_known_peer_ids |};
      peer_meta_config := {| score := score |};
      known_peer_ids := known_peer_ids;
      log := log
      |} := function_parameter in
  match max_known_peer_ids with
  | None => tt
  | Some (_, target) =>
    let current_size := P2p_peer.Table.length known_peer_ids in
    if OCaml.Stdlib.gt current_size target then
      let to_remove_target := Z.sub current_size target in
      let table := Gc_peer_set.create to_remove_target in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        P2p_peer.Table.iter
          (fun peer_id =>
            fun peer_info =>
              let created := P2p_peer_state.Info.created peer_info in
              let score :=
                apply score (P2p_peer_state.Info.peer_metadata peer_info) in
              if P2p_peer_state.is_disconnected peer_info then
                Gc_peer_set.insert (score, created, peer_id) table
              else
                tt) known_peer_ids in
      let to_remove := Gc_peer_set.get table in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        ListLabels.iter
          (fun function_parameter =>
            let '(_, _, peer_id) := function_parameter in
            P2p_peer.Table.remove known_peer_ids peer_id) to_remove in
      log Tezos_base__TzPervasives.P2p_connection.P2p_event.Gc_peer_ids
    else
      tt
  end.

Definition register_peer {A B C : Type}
  (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  : Tezos_p2p.P2p_peer_state.Info.peer_info (Tezos_p2p.P2p_conn.t A B C) B C :=
  match P2p_peer.Table.find_opt (known_peer_ids pool) peer_id with
  | None =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_trigger.broadcast_new_peer (triggers pool) in
    let peer :=
      P2p_peer_state.Info.create None None
        ((peer_meta_initial (peer_meta_config pool)) tt) peer_id in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Option.iter
        (fun function_parameter =>
          let '(max, _) := function_parameter in
          if OCaml.Stdlib.ge (P2p_peer.Table.length (known_peer_ids pool)) max
            then
            gc_peer_ids pool
          else
            tt) (max_known_peer_ids (config pool)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_peer.Table.add (known_peer_ids pool) peer_id peer in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (log pool)
        (Tezos_base__TzPervasives.P2p_connection.P2p_event.New_peer peer_id) in
    peer
  | Some peer => peer
  end.

Definition connection_of_peer_id {A B C : Type}
  (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  : option (Tezos_p2p.P2p_conn.t A B C) :=
  Option.apply
    (fun p =>
      match P2p_peer_state.get p with
      | Tezos_p2p.P2p_peer_state.Running {| data := data |} => Some data
      | _ => None
      end) (P2p_peer.Table.find_opt (known_peer_ids pool) peer_id).

Definition connections_of_addr {A B C : Type}
  (pool : t A B C) (addr : Ipaddr.V6.t) : list (Tezos_p2p.P2p_conn.t A B C) :=
  P2p_point.Table.fold
    (fun function_parameter =>
      let '(addr', _) := function_parameter in
      fun p =>
        fun acc =>
          if equiv_decb (Ipaddr.V6.compare addr addr') 0 then
            match P2p_point_state.get p with
            | Tezos_p2p.P2p_point_state.Running {| data := data |} =>
              cons data acc
            | _ => acc
            end
          else
            acc) (connected_points pool) [].

Definition get_addr {A B C : Type}
  (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  : option Tezos_base__P2p_connection.Id.t :=
  Option.map (fun ci => id_point (P2p_conn.info ci))
    (connection_of_peer_id pool peer_id).

Module Points.
  Definition info (msg peer conn : Type) :=
    Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn).
  
  Definition info {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.P2p_point.Table.key ->
      option (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)) :=
    let '{| known_points := known_points |} := function_parameter in
    fun point => P2p_point.Table.find_opt known_points point.
  
  Definition get_trusted {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : bool :=
    Option.unopt_map P2p_point_state.Info.trusted false
      (P2p_point.Table.find_opt (known_points pool) point).
  
  Definition set_trusted {A B C : Type}
    (pool : t A B C) (point : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
    : unit := apply OCaml.Stdlib.ignore (register_point (Some true) pool point).
  
  Definition unset_trusted {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : unit :=
    Option.iter P2p_point_state.Info.unset_trusted
      (P2p_point.Table.find_opt (known_points pool) point).
  
  Definition fold_known {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_point.Table.key ->
        (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)) ->
          D -> D) : D := P2p_point.Table.fold f (known_points pool) init.
  
  Definition fold_connected {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_point.Table.key ->
        (Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C)) ->
          D -> D) : D := P2p_point.Table.fold f (connected_points pool) init.
  
  Definition add_connected {A B C : Type}
    (t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    (point_info : Tezos_p2p.P2p_point_state.Info.t (Tezos_p2p.P2p_conn.t A B C))
    : unit := P2p_point.Table.add (connected_points t) point point_info.
  
  Definition remove_connected {A B C D : Type}
    (t : t A B C) (point_info : Tezos_p2p.P2p_point_state.Info.point_info D)
    : unit :=
    P2p_point.Table.remove (connected_points t)
      (P2p_point_state.Info.point point_info).
  
  Definition banned {A B C D : Type}
    (pool : t A B C)
    (function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : bool :=
    let '(addr, _port) := function_parameter in
    P2p_acl.banned_addr (acl pool) addr.
  
  Definition ban {A B C D : Type}
    (pool : t A B C)
    (function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : unit :=
    let '(addr, _port) := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_acl.IPBlacklist.add (acl pool) addr in
    List.iter
      (fun conn =>
        Lwt.async
          (fun function_parameter =>
            let 'tt := function_parameter in
            P2p_conn.disconnect None conn)) (connections_of_addr pool addr).
  
  Definition unban {A B C D : Type}
    (pool : t A B C)
    (function_parameter : Tezos_base__TzPervasives.P2p_addr.t * D) : unit :=
    let '(addr, _port) := function_parameter in
    P2p_acl.unban_addr (acl pool) addr.
  
  Definition trust {A B C : Type}
    (pool : t A B C) (point : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
    : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := unban pool point in
    set_trusted pool point.
  
  Definition untrust {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : unit := unset_trusted pool point.
End Points.

Module Peers.
  Definition info (msg peer conn : Type) :=
    Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t msg peer conn) peer
      conn.
  
  Definition info {A B C : Type} (function_parameter : t A B C)
    : Tezos_base__TzPervasives.P2p_peer.Table.key ->
      option (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) :=
    let '{| known_peer_ids := known_peer_ids |} := function_parameter in
    fun peer_id =>
      (* ❌ Try-with are not handled *)
      try (Some (P2p_peer.Table.find known_peer_ids peer_id)).
  
  Definition get_peer_metadata {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : B :=
    (* ❌ Try-with are not handled *)
    try
      (P2p_peer_state.Info.peer_metadata
        (P2p_peer.Table.find (known_peer_ids pool) peer_id)).
  
  Definition get_score {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : Z := (score (peer_meta_config pool)) (get_peer_metadata pool peer_id).
  
  Definition set_peer_metadata {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    (data : B) : unit :=
    P2p_peer_state.Info.set_peer_metadata (register_peer pool peer_id) data.
  
  Definition get_trusted {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : bool :=
    (* ❌ Try-with are not handled *)
    try
      (P2p_peer_state.Info.trusted
        (P2p_peer.Table.find (known_peer_ids pool) peer_id)).
  
  Definition set_trusted {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit :=
    (* ❌ Try-with are not handled *)
    try (P2p_peer_state.Info.set_trusted (register_peer pool peer_id)).
  
  Definition unset_trusted {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit :=
    (* ❌ Try-with are not handled *)
    try
      (P2p_peer_state.Info.unset_trusted
        (P2p_peer.Table.find (known_peer_ids pool) peer_id)).
  
  Definition fold_known {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_peer.Table.key ->
        (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) ->
          D -> D) : D := P2p_peer.Table.fold f (known_peer_ids pool) init.
  
  Definition fold_connected {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_peer.Table.key ->
        (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) ->
          D -> D) : D := P2p_peer.Table.fold f (connected_peer_ids pool) init.
  
  Definition add_connected {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    (peer_info :
      Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C)
    : unit := P2p_peer.Table.add (connected_peer_ids pool) peer_id peer_info.
  
  Definition remove_connected {A B C : Type}
    (t : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit := P2p_peer.Table.remove (connected_peer_ids t) peer_id.
  
  Definition ban {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p_acl.PeerBlacklist.add (acl pool) peer in
    let f {D E F : Type} (conn : Tezos_p2p.P2p_conn.t D E F) : unit :=
      Lwt.async
        (fun function_parameter =>
          let 'tt := function_parameter in
          P2p_conn.disconnect None conn) in
    Option.iter f (connection_of_peer_id pool peer).
  
  Definition unban {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    P2p_acl.unban_peer (acl pool) peer.
  
  Definition trust {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := unban pool peer in
    set_trusted pool peer.
  
  Definition untrust {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : unit := unset_trusted pool peer.
  
  Definition banned {A B C : Type}
    (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : bool :=
    P2p_acl.banned_peer (acl pool) peer.
End Peers.

Module Connection.
  Definition fold {A B C D : Type}
    (pool : t A B C) (init : D)
    (f :
      Tezos_base__TzPervasives.P2p_peer.Table.key ->
        (Tezos_p2p.P2p_conn.t A B C) -> D -> D) : D :=
    Peers.fold_connected pool init
      (fun peer_id =>
        fun peer_info =>
          fun acc =>
            match P2p_peer_state.get peer_info with
            | Tezos_p2p.P2p_peer_state.Running {| data := data |} =>
              f peer_id data acc
            | _ => acc
            end).
  
  Definition list {A B C : Type} (pool : t A B C)
    : list
      (Tezos_base__TzPervasives.P2p_peer.Table.key *
        (Tezos_p2p.P2p_conn.t A B C)) :=
    fold pool [] (fun peer_id => fun c => fun acc => cons (peer_id, c) acc).
  
  Definition random_elt {A : Type} (l : list A) : A :=
    let n := List.length l in
    let r := Random.int n in
    List.nth l r.
  
  Definition random_addr {A B C : Type}
    (different_than : option (Tezos_p2p.P2p_conn.t A B C)) (no_private : bool)
    (pool : t A B C)
    : option
      ((Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port) *
        Tezos_base.P2p_peer_id.t) :=
    let candidates :=
      fold pool []
        (fun _peer =>
          fun conn =>
            fun acc =>
              if andb no_private (P2p_conn.private_node conn) then
                acc
              else
                match different_than with
                | Some excluded_conn => acc
                | Some _ | None =>
                  let ci := P2p_conn.info conn in
                  match id_point ci with
                  | (_, None) => acc
                  | (addr, Some port) => cons ((addr, port), (peer_id ci)) acc
                  end
                end) in
    match candidates with
    | [] => None
    | _ => Some (random_elt candidates)
    end.
  
  Definition random_connection {A B C : Type}
    (different_than : option (Tezos_p2p.P2p_conn.t A B C)) (no_private : bool)
    (pool : t A B C) : option (Tezos_p2p.P2p_conn.t A B C) :=
    let candidates :=
      fold pool []
        (fun _peer =>
          fun conn =>
            fun acc =>
              if andb no_private (P2p_conn.private_node conn) then
                acc
              else
                match different_than with
                | Some excluded_conn => acc
                | Some _ | None => cons conn acc
                end) in
    match candidates with
    | [] => None
    | _ => Some (random_elt candidates)
    end.
  
  Definition propose_swap_request {A B C : Type} (pool : t A B C)
    : option
      ((Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port) *
        Tezos_base.P2p_peer_id.t * (Tezos_p2p.P2p_conn.t A B C)) :=
    match random_connection None true pool with
    | Some recipient =>
      match random_addr (Some recipient) true pool with
      | None => None
      | Some (proposed_point, proposed_peer_id) =>
        Some (proposed_point, proposed_peer_id, recipient)
      end
    | None => None
    end.
  
  Definition find_by_peer_id {A B C : Type}
    (pool : t A B C) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
    : option (Tezos_p2p.P2p_conn.t A B C) :=
    Option.apply
      (fun p =>
        match P2p_peer_state.get p with
        | Tezos_p2p.P2p_peer_state.Running {| data := data |} => Some data
        | _ => None
        end) (Peers.info pool peer_id).
  
  Definition find_by_point {A B C : Type}
    (pool : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key)
    : option (Tezos_p2p.P2p_conn.t A B C) :=
    Option.apply
      (fun p =>
        match P2p_point_state.get p with
        | Tezos_p2p.P2p_point_state.Running {| data := data |} => Some data
        | _ => None
        end) (Points.info pool point).
End Connection.

Definition connected_peer_ids {A B C : Type} (pool : t A B C)
  : Tezos_base__TzPervasives.P2p_peer.Table.t
    (Tezos_p2p.P2p_peer_state.Info.t (Tezos_p2p.P2p_conn.t A B C) B C) :=
  connected_peer_ids pool.

Definition greylist_addr {A B C : Type}
  (pool : t A B C) (addr : Tezos_base__TzPervasives.P2p_addr.t) : unit :=
  P2p_acl.IPGreylist.add (acl pool) addr (Systime_os.now tt).

Definition greylist_peer {A B C : Type}
  (pool : t A B C) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
  Option.iter
    (fun function_parameter =>
      let '(addr, _port) := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := greylist_addr pool addr in
      P2p_acl.PeerGreylist.add (acl pool) peer) (get_addr pool peer).

Definition acl_clear {A B C : Type} (pool : t A B C) : unit :=
  P2p_acl.clear (acl pool).

Definition gc_greylist {A B C : Type}
  (older_than : Tezos_base__TzPervasives.Time.System.t) (pool : t A B C)
  : unit := P2p_acl.IPGreylist.remove_old (acl pool) older_than.

Definition config {A B C : Type} (function_parameter : t A B C) : config :=
  let '{| config := config |} := function_parameter in
  config.

Definition score {A B C : Type} (function_parameter : t A B C) : B -> Z :=
  let '{| peer_meta_config := {| score := score |} |} := function_parameter in
  fun meta => score meta.

Definition active_connections {A B C : Type} (pool : t A B C) : Z :=
  P2p_peer.Table.length (connected_peer_ids pool).

Definition create {A B C : Type}
  (config : config) (peer_meta_config : peer_meta_config A)
  (triggers : Tezos_p2p.P2p_trigger.t)
  (log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit)
  : Lwt.t (t B A C) :=
  let pool :=
    {| config := config; peer_meta_config := peer_meta_config;
      my_id_points := P2p_point.Table.create 7;
      known_peer_ids := P2p_peer.Table.create 53;
      connected_peer_ids := P2p_peer.Table.create 53;
      known_points := P2p_point.Table.create 53;
      connected_points := P2p_point.Table.create 53; triggers := triggers;
      log := log; acl := P2p_acl.create 1023 |} in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := List.iter (Points.set_trusted pool) (trusted_points config) in
  op_gtgteq
    (P2p_peer_state.Info.File.load (peers_file config)
      (peer_meta_encoding peer_meta_config))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok peer_ids =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          List.iter
            (fun peer_info =>
              let peer_id := P2p_peer_state.Info.peer_id peer_info in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                P2p_peer.Table.add (known_peer_ids pool) peer_id peer_info in
              match P2p_peer_state.Info.last_seen peer_info with
              | None | Some ((_, None), _) => tt
              | Some ((addr, Some port), _) =>
                OCaml.Stdlib.reverse_apply
                  (register_point None pool (addr, port)) OCaml.Stdlib.ignore
              end) peer_ids in
        Lwt._return pool
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.String_literal
                  "Failed to parse peers file:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "@[Failed to parse peers file:@ %a@]" % string) pp_print_error err
          in
        Lwt._return pool
      end).

Definition destroy {A B C : Type} (function_parameter : t A B C) : Lwt.t unit :=
  let '{|
    config := config;
      peer_meta_config := peer_meta_config;
      known_peer_ids := known_peer_ids;
      known_points := known_points
      |} := function_parameter in
  op_gtgteq
    (lwt_log_info
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Saving metadata in " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format))
        "Saving metadata in %s" % string) (peers_file config))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (op_gtgteq
          (P2p_peer_state.Info.File.save (peers_file config)
            (peer_meta_encoding peer_meta_config)
            (P2p_peer.Table.fold
              (fun function_parameter =>
                let '_ := function_parameter in
                fun a => fun b => cons a b) known_peer_ids []))
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error err =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                log_error
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Failed to save peers file:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))
                    "@[Failed to save peers file:@ %a@]" % string)
                  pp_print_error err in
              Lwt.return_unit
            | Stdlib.Ok tt => Lwt.return_unit
            end))
        (fun function_parameter =>
          let 'tt := function_parameter in
          apply
            (P2p_point.Table.fold
              (fun _point =>
                fun point_info =>
                  fun acc =>
                    match P2p_point_state.get point_info with
                    |
                      Tezos_p2p.P2p_point_state.Requested {| cancel := cancel |}
                        |
                        Tezos_p2p.P2p_point_state.Accepted {|
                          cancel := cancel |} =>
                      op_gtgteq (Lwt_canceler.cancel cancel)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          acc)
                    | Tezos_p2p.P2p_point_state.Running {| data := conn |} =>
                      op_gtgteq (P2p_conn.disconnect None conn)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          acc)
                    | Tezos_p2p.P2p_point_state.Disconnected => acc
                    end) known_points)
            (P2p_peer.Table.fold
              (fun _peer_id =>
                fun peer_info =>
                  fun acc =>
                    match P2p_peer_state.get peer_info with
                    | Tezos_p2p.P2p_peer_state.Accepted {| cancel := cancel |}
                      =>
                      op_gtgteq (Lwt_canceler.cancel cancel)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          acc)
                    | Tezos_p2p.P2p_peer_state.Running {| data := conn |} =>
                      op_gtgteq (P2p_conn.disconnect None conn)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          acc)
                    | Tezos_p2p.P2p_peer_state.Disconnected => acc
                    end) known_peer_ids Lwt.return_unit))).

Definition add_to_id_points {A B C : Type}
  (t : t A B C) (point : Tezos_base__TzPervasives.P2p_point.Table.key) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_point.Table.add (my_id_points t) point tt in
  P2p_point.Table.remove (known_points t) point.

Definition sample {A : Type} (best : Z) (other : Z) (points : list A)
  : list A :=
  let l := List.length points in
  if OCaml.Stdlib.le l (Z.add best other) then
    points
  else
    let best_indexes := List.init best (fun i => i) in
    let other_indexes :=
      apply (List.sort OCaml.Stdlib.compare)
        (List.init other
          (fun function_parameter =>
            let '_ := function_parameter in
            Z.add best (Random.int (Z.sub l best)))) in
    let indexes := OCaml.Stdlib.app best_indexes other_indexes in
    apply
      (fun function_parameter =>
        let '(_, _, result) := function_parameter in
        result)
      (List.fold_left
        (fun function_parameter =>
          let '(i, indexes, acc) := function_parameter in
          fun point =>
            match indexes with
            | [] => (0, [], acc)
            | cons index indexes => ((Z.succ i), indexes, (cons point acc))
            | _ => ((Z.succ i), indexes, acc)
            end) (0, indexes, []) points).

Definition compare_known_point_info {A B : Type}
  (p1 : Tezos_p2p.P2p_point_state.Info.t A)
  (p2 : Tezos_p2p.P2p_point_state.Info.t B) : Z :=
  let disconnected1 : bool :=
    P2p_point_state.is_disconnected p1
  with disconnected2 : bool :=
    P2p_point_state.is_disconnected p2 in
  let compare_last_seen {C D : Type}
    (p1 : Tezos_p2p.P2p_point_state.Info.point_info C) (p2 :
    Tezos_p2p.P2p_point_state.Info.point_info D) : Z :=
    match
      ((P2p_point_state.Info.last_seen p1), (P2p_point_state.Info.last_seen p2))
      with
    | (None, None) => Z.sub (Z.mul (Random.int 2) 2) 1
    | (Some _, None) => 1
    | (None, Some _) => (-1)
    | (Some (_, time1), Some (_, time2)) =>
      match OCaml.Stdlib.compare time1 time2 with
      | 0 => Z.sub (Z.mul (Random.int 2) 2) 1
      | x => x
      end
    end in
  match (disconnected1, disconnected2) with
  | (false, false) => compare_last_seen p1 p2
  | (false, true) => (-1)
  | (true, false) => 1
  | (true, true) => compare_last_seen p2 p1
  end.

Definition list_known_points {A B C : Type}
  (ignore_private : bool) (pool : t A B C)
  : Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t) :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (P2p_point.Table.fold
            (fun point_id =>
              fun point_info =>
                fun acc =>
                  if
                    orb
                      (andb ignore_private
                        (negb (P2p_point_state.Info.known_public point_info)))
                      (Points.banned pool point_id) then
                    acc
                  else
                    cons point_info acc) (known_points pool) [])
          (List.sort compare_known_point_info)) (sample 30 20))
      (List.map P2p_point_state.Info.point)) Lwt._return.

src/lib_p2p/p2p_protocol.ml 36 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.protocol"
end)

type ('msg, 'peer, 'conn) config = {
  swap_linger : Time.System.Span.t;
  pool : ('msg, 'peer, 'conn) P2p_pool.t;
  log : P2p_connection.P2p_event.t -> unit;
  connect : P2p_point.Id.t -> ('msg, 'peer, 'conn) P2p_conn.t tzresult Lwt.t;
  mutable latest_accepted_swap : Time.System.t;
  mutable latest_successful_swap : Time.System.t;
}

let private_node_warn fmt =
  Format.kasprintf (fun s -> lwt_warn "[private node] %s" s) fmt

open P2p_answerer

let message conn _request size msg = Lwt_pipe.push conn.messages (size, msg)

module Private_answerer = struct
  let advertise conn _request _points =
    private_node_warn
      "Received new peers addresses from %a"
      P2p_peer.Id.pp
      conn.peer_id

  let bootstrap conn _request =
    private_node_warn
      "Receive requests for peers addresses from %a"
      P2p_peer.Id.pp
      conn.peer_id
    >>= fun () -> Lwt.return_nil

  let swap_request conn _request _new_point _peer =
    private_node_warn
      "Received swap requests from %a"
      P2p_peer.Id.pp
      conn.peer_id

  let swap_ack conn _request _point _peer_id =
    private_node_warn "Received swap ack from %a" P2p_peer.Id.pp conn.peer_id

  let create conn =
    P2p_answerer.
      {
        message = message conn;
        advertise = advertise conn;
        bootstrap = bootstrap conn;
        swap_request = swap_request conn;
        swap_ack = swap_ack conn;
      }
end

module Default_answerer = struct
  open P2p_connection.P2p_event

  let advertise config _conn _request points =
    let f point = P2p_pool.register_new_point config.pool point |> ignore in
    List.iter f points ; Lwt.return_unit

  let bootstrap config conn _request_info =
    if conn.is_private then
      private_node_warn
        "Private peer (%a) asked other peers addresses"
        P2p_peer.Id.pp
        conn.peer_id
      >>= fun () -> Lwt.return_nil
    else P2p_pool.list_known_points ~ignore_private:true config.pool

  let swap t pool source_peer_id ~connect current_peer_id new_point =
    t.latest_accepted_swap <- Systime_os.now () ;
    connect new_point
    >>= function
    | Ok _new_conn -> (
        t.latest_successful_swap <- Systime_os.now () ;
        t.log (Swap_success {source = source_peer_id}) ;
        lwt_log_info "Swap to %a succeeded" P2p_point.Id.pp new_point
        >>= fun () ->
        match P2p_pool.Connection.find_by_peer_id pool current_peer_id with
        | None ->
            Lwt.return_unit
        | Some conn ->
            P2p_conn.disconnect conn )
    | Error err -> (
        t.latest_accepted_swap <- t.latest_successful_swap ;
        t.log (Swap_failure {source = source_peer_id}) ;
        match err with
        | [Timeout] ->
            lwt_debug
              "Swap to %a was interrupted: %a"
              P2p_point.Id.pp
              new_point
              pp_print_error
              err
        | _ ->
            lwt_log_error
              "Swap to %a failed: %a"
              P2p_point.Id.pp
              new_point
              pp_print_error
              err )

  let swap_ack config conn request new_point _peer =
    let source_peer_id = conn.peer_id in
    let pool = config.pool in
    let connect = config.connect in
    let log = config.log in
    log (Swap_ack_received {source = source_peer_id}) ;
    lwt_log_info "Swap ack received from %a" P2p_peer.Id.pp source_peer_id
    >>= fun () ->
    match request.last_sent_swap_request with
    | None ->
        Lwt.return_unit (* ignore *)
    | Some (_time, proposed_peer_id) -> (
      match P2p_pool.Connection.find_by_peer_id pool proposed_peer_id with
      | None ->
          swap config pool source_peer_id ~connect proposed_peer_id new_point
          >>= fun () -> Lwt.return_unit
      | Some _ ->
          Lwt.return_unit )

  let swap_request config conn _request new_point _peer =
    let source_peer_id = conn.peer_id in
    let pool = config.pool in
    let swap_linger = config.swap_linger in
    let connect = config.connect in
    let log = config.log in
    log (Swap_request_received {source = source_peer_id}) ;
    lwt_log_info "Swap request received from %a" P2p_peer.Id.pp source_peer_id
    >>= fun () ->
    (* Ignore if already connected to peer or already swapped less
       than <swap_linger> seconds ago. *)
    let span_since_last_swap =
      Ptime.diff
        (Systime_os.now ())
        (Time.System.max
           config.latest_successful_swap
           config.latest_accepted_swap)
    in
    let new_point_info = P2p_pool.register_point pool new_point in
    if
      Ptime.Span.compare span_since_last_swap swap_linger < 0
      || not (P2p_point_state.is_disconnected new_point_info)
    then (
      log (Swap_request_ignored {source = source_peer_id}) ;
      lwt_log_info
        "Ignoring swap request from %a"
        P2p_peer.Id.pp
        source_peer_id )
    else
      match P2p_pool.Connection.random_addr pool ~no_private:true with
      | None ->
          lwt_log_info "No swap candidate for %a" P2p_peer.Id.pp source_peer_id
      | Some (proposed_point, proposed_peer_id) -> (
        match conn.write_swap_ack proposed_point proposed_peer_id with
        | Ok true ->
            log (Swap_ack_sent {source = source_peer_id}) ;
            swap config pool source_peer_id ~connect proposed_peer_id new_point
            >>= fun () -> Lwt.return_unit
        | Ok false ->
            log (Swap_request_received {source = source_peer_id}) ;
            Lwt.return_unit
        | Error _ ->
            log (Swap_request_received {source = source_peer_id}) ;
            Lwt.return_unit )

  let create config conn =
    P2p_answerer.
      {
        message = message conn;
        advertise = advertise config conn;
        bootstrap = bootstrap config conn;
        swap_request = swap_request config conn;
        swap_ack = swap_ack config conn;
      }
end

let create_default = Default_answerer.create

let create_private () = Private_answerer.create
src/lib_p2p/p2p_protocol.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Record config {msg peer conn : Type} := {
  swap_linger : Tezos_base__TzPervasives.Time.System.Span.t;
  pool : Tezos_p2p.P2p_pool.t msg peer conn;
  log : Tezos_base__TzPervasives.P2p_connection.P2p_event.t -> unit;
  connect :
    Tezos_base__TzPervasives.P2p_point.Id.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t msg peer conn));
  latest_accepted_swap : Tezos_base__TzPervasives.Time.System.t;
  latest_successful_swap : Tezos_base__TzPervasives.Time.System.t }.
Arguments config : clear implicits.

Definition private_node_warn {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  Format.kasprintf
    (fun s =>
      lwt_warn
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "[private node] " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format))
          "[private node] %s" % string) s) fmt.

Import P2p_answerer.

Definition message {A B : Type}
  (conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (size : Z)
  (msg : A) : Lwt.t unit := Lwt_pipe.push (messages conn) (size, msg).

Module Private_answerer.
  Definition advertise {A B C : Type}
    (conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (_points : C)
    : Lwt.t unit :=
    private_node_warn
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Received new peers addresses from " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Received new peers addresses from %a" % string) P2p_peer.Id.pp
      (peer_id conn).
  
  Definition bootstrap {A B C : Type}
    (conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B)
    : Lwt.t (list C) :=
    op_gtgteq
      (private_node_warn
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Receive requests for peers addresses from " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "Receive requests for peers addresses from %a" % string)
        P2p_peer.Id.pp (peer_id conn))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt.return_nil).
  
  Definition swap_request {A B C D : Type}
    (conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (_new_point : C)
    (_peer : D) : Lwt.t unit :=
    private_node_warn
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Received swap requests from " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Received swap requests from %a" % string) P2p_peer.Id.pp (peer_id conn).
  
  Definition swap_ack {A B C D : Type}
    (conn : Tezos_p2p.P2p_answerer.conn_info A) (_request : B) (_point : C)
    (_peer_id : D) : Lwt.t unit :=
    private_node_warn
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Received swap ack from " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Received swap ack from %a" % string) P2p_peer.Id.pp (peer_id conn).
  
  Definition create {A : Type} (conn : Tezos_p2p.P2p_answerer.conn_info A)
    : Tezos_p2p.P2p_answerer.callback A :=
    {| bootstrap := bootstrap conn; advertise := advertise conn;
      message := message conn; swap_request := swap_request conn;
      swap_ack := swap_ack conn |}.
End Private_answerer.

Module Default_answerer.
  Import P2p_connection.P2p_event.
  
  Definition advertise {A B C D E : Type}
    (config : config A B C) (_conn : D) (_request : E)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t unit :=
    let f (point : Tezos_base__TzPervasives.P2p_point.Id.t) : unit :=
      OCaml.Stdlib.reverse_apply
        (P2p_pool.register_new_point None (pool config) point)
        OCaml.Stdlib.ignore in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := List.iter f points in
    Lwt.return_unit.
  
  Definition bootstrap {A B C D E : Type}
    (config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
    (_request_info : E)
    : Lwt.t (list Tezos_base__TzPervasives.P2p_point.Id.t) :=
    if is_private conn then
      op_gtgteq
        (private_node_warn
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Private peer (" % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  ") asked other peers addresses" % string
                  CamlinternalFormatBasics.End_of_format)))
            "Private peer (%a) asked other peers addresses" % string)
          P2p_peer.Id.pp (peer_id conn))
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt.return_nil)
    else
      P2p_pool.list_known_points true (pool config).
  
  Definition swap {A B C D E F G : Type}
    (t : config A B C) (pool : Tezos_p2p__P2p_pool.t D E F)
    (source_peer_id : Tezos_base.P2p_peer_id.t)
    (connect :
      Tezos_base__TzPervasives.P2p_point.Id.t ->
        Lwt.t (sum G Tezos_base__TzPervasives.trace))
    (current_peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    (new_point : Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field t "latest_accepted_swap" % string (Systime_os.now tt) in
    op_gtgteq (connect new_point)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok _new_conn =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field t "latest_successful_swap" % string
              (Systime_os.now tt) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (log t)
              (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_success
                {| source := source_peer_id |}) in
          op_gtgteq
            (lwt_log_info
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Swap to " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " succeeded" % string
                      CamlinternalFormatBasics.End_of_format)))
                "Swap to %a succeeded" % string) P2p_point.Id.pp new_point)
            (fun function_parameter =>
              let 'tt := function_parameter in
              match P2p_pool.Connection.find_by_peer_id pool current_peer_id
                with
              | None => Lwt.return_unit
              | Some conn => P2p_conn.disconnect None conn
              end)
        | Stdlib.Error err =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field t "latest_accepted_swap" % string
              (latest_successful_swap t) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (log t)
              (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_failure
                {| source := source_peer_id |}) in
          match err with
          | cons Tezos_base__TzPervasives.Timeout [] =>
            lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Swap to " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " was interrupted: " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "Swap to %a was interrupted: %a" % string) P2p_point.Id.pp
              new_point pp_print_error err
          | _ =>
            lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Swap to " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " failed: " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "Swap to %a failed: %a" % string) P2p_point.Id.pp new_point
              pp_print_error err
          end
        end).
  
  Definition swap_ack {A B C D E : Type}
    (config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
    (request : Tezos_p2p.P2p_answerer.request_info)
    (new_point : Tezos_base__TzPervasives.P2p_point.Id.t) (_peer : E)
    : Lwt.t unit :=
    let source_peer_id := peer_id conn in
    let pool := pool config in
    let connect := connect config in
    let log := log config in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log
        (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_ack_received
          {| source := source_peer_id |}) in
    op_gtgteq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Swap ack received from " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "Swap ack received from %a" % string) P2p_peer.Id.pp source_peer_id)
      (fun function_parameter =>
        let 'tt := function_parameter in
        match last_sent_swap_request request with
        | None => Lwt.return_unit
        | Some (_time, proposed_peer_id) =>
          match P2p_pool.Connection.find_by_peer_id pool proposed_peer_id with
          | None =>
            op_gtgteq
              (swap config pool source_peer_id connect proposed_peer_id
                new_point)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.return_unit)
          | Some _ => Lwt.return_unit
          end
        end).
  
  Definition swap_request {A B C D E F : Type}
    (config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
    (_request : E) (new_point : Tezos_base__TzPervasives.P2p_point.Id.t)
    (_peer : F) : Lwt.t unit :=
    let source_peer_id := peer_id conn in
    let pool := pool config in
    let swap_linger := swap_linger config in
    let connect := connect config in
    let log := log config in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log
        (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_received
          {| source := source_peer_id |}) in
    op_gtgteq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Swap request received from " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "Swap request received from %a" % string) P2p_peer.Id.pp
        source_peer_id)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let span_since_last_swap :=
          Ptime.diff (Systime_os.now tt)
            (Time.System.max (latest_successful_swap config)
              (latest_accepted_swap config)) in
        let new_point_info := P2p_pool.register_point None pool new_point in
        if
          orb
            (OCaml.Stdlib.lt
              (Ptime.Span.compare span_since_last_swap swap_linger) 0)
            (negb (P2p_point_state.is_disconnected new_point_info)) then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            log
              (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_ignored
                {| source := source_peer_id |}) in
          lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Ignoring swap request from " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "Ignoring swap request from %a" % string) P2p_peer.Id.pp
            source_peer_id
        else
          match P2p_pool.Connection.random_addr None true pool with
          | None =>
            lwt_log_info
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "No swap candidate for " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "No swap candidate for %a" % string) P2p_peer.Id.pp
              source_peer_id
          | Some (proposed_point, proposed_peer_id) =>
            match (write_swap_ack conn) proposed_point proposed_peer_id with
            | Stdlib.Ok true =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                log
                  (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_ack_sent
                    {| source := source_peer_id |}) in
              op_gtgteq
                (swap config pool source_peer_id connect proposed_peer_id
                  new_point)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt.return_unit)
            | Stdlib.Ok false =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                log
                  (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_received
                    {| source := source_peer_id |}) in
              Lwt.return_unit
            | Stdlib.Error _ =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                log
                  (Tezos_base__TzPervasives.P2p_connection.P2p_event.Swap_request_received
                    {| source := source_peer_id |}) in
              Lwt.return_unit
            end
          end).
  
  Definition create {A B C D : Type}
    (config : config A B C) (conn : Tezos_p2p.P2p_answerer.conn_info D)
    : Tezos_p2p.P2p_answerer.callback D :=
    {| bootstrap := bootstrap config conn; advertise := advertise config conn;
      message := message conn; swap_request := swap_request config conn;
      swap_ack := swap_ack config conn |}.
End Default_answerer.

Definition create_default {A B C D : Type}
  : (config A B C) ->
    (Tezos_p2p.P2p_answerer.conn_info D) -> Tezos_p2p.P2p_answerer.callback D :=
  Default_answerer.create.

Definition create_private {A : Type} (function_parameter : unit)
  : (Tezos_p2p.P2p_answerer.conn_info A) -> Tezos_p2p.P2p_answerer.callback A :=
  let 'tt := function_parameter in
  Private_answerer.create.

src/lib_p2p/p2p_socket.ml 58 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* TODO test `close ~wait:true`. *)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.connection"
end)

module Crypto = struct
  (* maximal size of the buffer *)
  let bufsize = (1 lsl 16) - 1

  let header_length = 2

  let max_content_length = bufsize - Crypto_box.zerobytes

  (* The size of extra data added by encryption. *)
  let boxextrabytes = Crypto_box.zerobytes - Crypto_box.boxzerobytes

  (* The number of bytes added by encryption + header *)
  let extrabytes = header_length + boxextrabytes

  type data = {
    channel_key : Crypto_box.channel_key;
    mutable local_nonce : Crypto_box.nonce;
    mutable remote_nonce : Crypto_box.nonce;
  }

  (* We do the following assumptions on the NaCl library.  Note that
     we also make the assumption, here, that the NaCl library allows
     in-place boxing and unboxing, since we use the same buffer for
     input and output. *)
  let () = assert (Crypto_box.boxzerobytes >= header_length)

  let write_chunk ?canceler fd cryptobox_data msg =
    let msglen = Bytes.length msg in
    fail_unless (msglen <= max_content_length) P2p_errors.Invalid_message_size
    >>=? fun () ->
    let buf_length = msglen + Crypto_box.zerobytes in
    let buf = Bytes.make buf_length '\x00' in
    Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
    let local_nonce = cryptobox_data.local_nonce in
    cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
    Crypto_box.fast_box_noalloc cryptobox_data.channel_key local_nonce buf ;
    let encrypted_length = buf_length - Crypto_box.boxzerobytes in
    let header_pos = Crypto_box.boxzerobytes - header_length in
    TzEndian.set_int16 buf header_pos encrypted_length ;
    let payload = Bytes.sub buf header_pos (buf_length - header_pos) in
    P2p_io_scheduler.write ?canceler fd payload

  let read_chunk ?canceler fd cryptobox_data =
    let header_buf = Bytes.create header_length in
    P2p_io_scheduler.read_full ?canceler ~len:header_length fd header_buf
    >>=? fun () ->
    let encrypted_length = TzEndian.get_uint16 header_buf 0 in
    let buf_length = encrypted_length + Crypto_box.boxzerobytes in
    let buf = Bytes.make buf_length '\x00' in
    P2p_io_scheduler.read_full
      ?canceler
      ~pos:Crypto_box.boxzerobytes
      ~len:encrypted_length
      fd
      buf
    >>=? fun () ->
    let remote_nonce = cryptobox_data.remote_nonce in
    cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
    match
      Crypto_box.fast_box_open_noalloc
        cryptobox_data.channel_key
        remote_nonce
        buf
    with
    | false ->
        fail P2p_errors.Decipher_error
    | true ->
        return
          (Bytes.sub
             buf
             Crypto_box.zerobytes
             (buf_length - Crypto_box.zerobytes))
end

(* Note: there is an inconsistency here, since we display an error in
   bytes, whereas the option is set in kbytes. Also, since the default
   size is 64kB-1, it is actually impossible to set the default
   size using the option (the max is 63 kB). *)
let check_binary_chunks_size size =
  let value = size - Crypto.extrabytes in
  fail_unless
    (value > 0 && value <= Crypto.max_content_length)
    (P2p_errors.Invalid_chunks_size
       {value = size; min = Crypto.extrabytes + 1; max = Crypto.bufsize})

module Connection_message = struct
  type t = {
    port : int option;
    public_key : Crypto_box.public_key;
    proof_of_work_stamp : Crypto_box.nonce;
    message_nonce : Crypto_box.nonce;
    version : Network_version.t;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {port; public_key; proof_of_work_stamp; message_nonce; version} ->
        let port = match port with None -> 0 | Some port -> port in
        (port, public_key, proof_of_work_stamp, message_nonce, version))
      (fun (port, public_key, proof_of_work_stamp, message_nonce, version) ->
        let port = if port = 0 then None else Some port in
        {port; public_key; proof_of_work_stamp; message_nonce; version})
      (obj5
         (req "port" uint16)
         (req "pubkey" Crypto_box.public_key_encoding)
         (req "proof_of_work_stamp" Crypto_box.nonce_encoding)
         (req "message_nonce" Crypto_box.nonce_encoding)
         (req "version" Network_version.encoding))

  let write ~canceler fd message =
    let encoded_message_len = Data_encoding.Binary.length encoding message in
    fail_unless
      (encoded_message_len < 1 lsl (Crypto.header_length * 8))
      P2p_errors.Encoding_error
    >>=? fun () ->
    let len = Crypto.header_length + encoded_message_len in
    let buf = Bytes.create len in
    match
      Data_encoding.Binary.write encoding message buf Crypto.header_length len
    with
    | None ->
        fail P2p_errors.Encoding_error
    | Some last ->
        fail_unless (last = len) P2p_errors.Encoding_error
        >>=? fun () ->
        TzEndian.set_int16 buf 0 encoded_message_len ;
        P2p_io_scheduler.write ~canceler fd buf
        >>=? fun () ->
        (* We return the raw message as it is used later to compute
           the nonces *)
        return buf

  let read ~canceler fd =
    let header_buf = Bytes.create Crypto.header_length in
    P2p_io_scheduler.read_full
      ~canceler
      ~len:Crypto.header_length
      fd
      header_buf
    >>=? fun () ->
    let len = TzEndian.get_uint16 header_buf 0 in
    let pos = Crypto.header_length in
    let buf = Bytes.create (pos + len) in
    TzEndian.set_int16 buf 0 len ;
    P2p_io_scheduler.read_full ~canceler ~len ~pos fd buf
    >>=? fun () ->
    match Data_encoding.Binary.read encoding buf pos len with
    | None ->
        fail P2p_errors.Decoding_error
    | Some (next_pos, message) ->
        if next_pos <> pos + len then fail P2p_errors.Decoding_error
        else return (message, buf)
end

type 'meta metadata_config = {
  conn_meta_encoding : 'meta Data_encoding.t;
  conn_meta_value : P2p_peer.Id.t -> 'meta;
  private_node : 'meta -> bool;
}

module Metadata = struct
  let write ~canceler metadata_config cryptobox_data fd message =
    let encoded_message_len =
      Data_encoding.Binary.length metadata_config.conn_meta_encoding message
    in
    let buf = Bytes.create encoded_message_len in
    match
      Data_encoding.Binary.write
        metadata_config.conn_meta_encoding
        message
        buf
        0
        encoded_message_len
    with
    | None ->
        fail P2p_errors.Encoding_error
    | Some last ->
        fail_unless (last = encoded_message_len) P2p_errors.Encoding_error
        >>=? fun () -> Crypto.write_chunk ~canceler cryptobox_data fd buf

  let read ~canceler metadata_config fd cryptobox_data =
    Crypto.read_chunk ~canceler fd cryptobox_data
    >>=? fun buf ->
    let length = Bytes.length buf in
    let encoding = metadata_config.conn_meta_encoding in
    match Data_encoding.Binary.read encoding buf 0 length with
    | None ->
        fail P2p_errors.Decoding_error
    | Some (read_len, message) ->
        if read_len <> length then fail P2p_errors.Decoding_error
        else return message
end

module Ack = struct
  type t = Ack | Nack

  let encoding =
    let open Data_encoding in
    let ack_encoding = obj1 (req "ack" empty) in
    let nack_encoding = obj1 (req "nack" empty) in
    let ack_case tag =
      case
        tag
        ack_encoding
        ~title:"Ack"
        (function Ack -> Some () | _ -> None)
        (fun () -> Ack)
    in
    let nack_case tag =
      case
        tag
        nack_encoding
        ~title:"Nack"
        (function Nack -> Some () | _ -> None)
        (fun _ -> Nack)
    in
    union [ack_case (Tag 0); nack_case (Tag 255)]

  let write ?canceler fd cryptobox_data message =
    let encoded_message_len = Data_encoding.Binary.length encoding message in
    let buf = Bytes.create encoded_message_len in
    match
      Data_encoding.Binary.write encoding message buf 0 encoded_message_len
    with
    | None ->
        fail P2p_errors.Encoding_error
    | Some last ->
        fail_unless (last = encoded_message_len) P2p_errors.Encoding_error
        >>=? fun () -> Crypto.write_chunk ?canceler fd cryptobox_data buf

  let read ?canceler fd cryptobox_data =
    Crypto.read_chunk ?canceler fd cryptobox_data
    >>=? fun buf ->
    let length = Bytes.length buf in
    match Data_encoding.Binary.read encoding buf 0 length with
    | None ->
        fail P2p_errors.Decoding_error
    | Some (read_len, message) ->
        if read_len <> length then fail P2p_errors.Decoding_error
        else return message
end

type 'meta authenticated_connection = {
  fd : P2p_io_scheduler.connection;
  info : 'meta P2p_connection.Info.t;
  cryptobox_data : Crypto.data;
}

let kick {fd; cryptobox_data; _} =
  Ack.write fd cryptobox_data Nack
  >>= fun _ -> P2p_io_scheduler.close fd >>= fun _ -> Lwt.return_unit

(* First step: write and read credentials, makes no difference
   whether we're trying to connect to a peer or checking an incoming
   connection, both parties must first introduce themselves. *)
let authenticate ~canceler ~proof_of_work_target ~incoming fd
    ((remote_addr, remote_socket_port) as point) ?listening_port identity
    announced_version metadata_config =
  let local_nonce_seed = Crypto_box.random_nonce () in
  lwt_debug "Sending authenfication to %a" P2p_point.Id.pp point
  >>= fun () ->
  Connection_message.write
    ~canceler
    fd
    {
      public_key = identity.P2p_identity.public_key;
      proof_of_work_stamp = identity.proof_of_work_stamp;
      message_nonce = local_nonce_seed;
      port = listening_port;
      version = announced_version;
    }
  >>=? fun sent_msg ->
  Connection_message.read ~canceler fd
  >>=? fun (msg, recv_msg) ->
  let remote_listening_port =
    if incoming then msg.port else Some remote_socket_port
  in
  let id_point = (remote_addr, remote_listening_port) in
  let remote_peer_id = Crypto_box.hash msg.public_key in
  fail_unless
    (remote_peer_id <> identity.P2p_identity.peer_id)
    (P2p_errors.Myself id_point)
  >>=? fun () ->
  fail_unless
    (Crypto_box.check_proof_of_work
       msg.public_key
       msg.proof_of_work_stamp
       proof_of_work_target)
    (P2p_errors.Not_enough_proof_of_work remote_peer_id)
  >>=? fun () ->
  let channel_key =
    Crypto_box.precompute identity.P2p_identity.secret_key msg.public_key
  in
  let (local_nonce, remote_nonce) =
    Crypto_box.generate_nonces ~incoming ~sent_msg ~recv_msg
  in
  let cryptobox_data = {Crypto.channel_key; local_nonce; remote_nonce} in
  let local_metadata = metadata_config.conn_meta_value remote_peer_id in
  Metadata.write ~canceler metadata_config fd cryptobox_data local_metadata
  >>=? fun () ->
  Metadata.read ~canceler metadata_config fd cryptobox_data
  >>=? fun remote_metadata ->
  let info =
    {
      P2p_connection.Info.peer_id = remote_peer_id;
      announced_version = msg.version;
      incoming;
      id_point;
      remote_socket_port;
      private_node = metadata_config.private_node remote_metadata;
      local_metadata;
      remote_metadata;
    }
  in
  return (info, {fd; info; cryptobox_data})

module Reader = struct
  type ('msg, 'meta) t = {
    canceler : Lwt_canceler.t;
    conn : 'meta authenticated_connection;
    encoding : 'msg Data_encoding.t;
    messages : (int * 'msg) tzresult Lwt_pipe.t;
    mutable worker : unit Lwt.t;
  }

  let read_message st init =
    let rec loop status =
      Lwt_unix.yield ()
      >>= fun () ->
      let open Data_encoding.Binary in
      match status with
      | Success {result; size; stream} ->
          return_some (result, size, stream)
      | Error _err ->
          lwt_debug "[read_message] incremental decoding error"
          >>= fun () -> return_none
      | Await decode_next_buf ->
          Crypto.read_chunk
            ~canceler:st.canceler
            st.conn.fd
            st.conn.cryptobox_data
          >>=? fun buf ->
          lwt_debug
            "reading %d bytes from %a"
            (Bytes.length buf)
            P2p_peer.Id.pp
            st.conn.info.peer_id
          >>= fun () -> loop (decode_next_buf buf)
    in
    loop (Data_encoding.Binary.read_stream ?init st.encoding)

  let rec worker_loop st stream =
    read_message st stream
    >>=? (fun msg ->
           match msg with
           | None ->
               protect ~canceler:st.canceler (fun () ->
                   Lwt_pipe.push st.messages (error P2p_errors.Decoding_error)
                   >>= fun () -> return_none)
           | Some (msg, size, stream) ->
               protect ~canceler:st.canceler (fun () ->
                   Lwt_pipe.push st.messages (Ok (size, msg))
                   >>= fun () -> return_some stream))
    >>= function
    | Ok (Some stream) ->
        worker_loop st (Some stream)
    | Ok None ->
        Lwt_canceler.cancel st.canceler
    | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
        lwt_debug "connection closed to %a" P2p_peer.Id.pp st.conn.info.peer_id
    | Error _ as err ->
        Lwt_pipe.safe_push_now st.messages err ;
        Lwt_canceler.cancel st.canceler

  let run ?size conn encoding canceler =
    let compute_size = function
      | Ok (size, _) ->
          (Sys.word_size / 8 * 11) + size + Lwt_pipe.push_overhead
      | Error _ ->
          0
      (* we push Error only when we close the socket,
                        we don't fear memory leaks in that case... *)
    in
    let size = Option.map size ~f:(fun max -> (max, compute_size)) in
    let st =
      {
        canceler;
        conn;
        encoding;
        messages = Lwt_pipe.create ?size ();
        worker = Lwt.return_unit;
      }
    in
    Lwt_canceler.on_cancel st.canceler (fun () ->
        Lwt_pipe.close st.messages ; Lwt.return_unit) ;
    st.worker <-
      Lwt_utils.worker
        "reader"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st None)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
    st

  let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
end

module Writer = struct
  type ('msg, 'meta) t = {
    canceler : Lwt_canceler.t;
    conn : 'meta authenticated_connection;
    encoding : 'msg Data_encoding.t;
    messages : (Bytes.t list * unit tzresult Lwt.u option) Lwt_pipe.t;
    mutable worker : unit Lwt.t;
    binary_chunks_size : int; (* in bytes *)
  }

  let send_message st buf =
    let rec loop = function
      | [] ->
          return_unit
      | buf :: l ->
          Crypto.write_chunk
            ~canceler:st.canceler
            st.conn.fd
            st.conn.cryptobox_data
            buf
          >>=? fun () ->
          lwt_debug
            "writing %d bytes to %a"
            (Bytes.length buf)
            P2p_peer.Id.pp
            st.conn.info.peer_id
          >>= fun () -> loop l
    in
    loop buf

  let encode_message st msg =
    try
      ok
        (Utils.cut
           st.binary_chunks_size
           (Data_encoding.Binary.to_bytes_exn st.encoding msg))
    with Data_encoding.Binary.Write_error _ ->
      error P2p_errors.Encoding_error

  let rec worker_loop st =
    Lwt_unix.yield ()
    >>= fun () ->
    protect ~canceler:st.canceler (fun () ->
        Lwt_pipe.pop st.messages >>= return)
    >>= function
    | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
        lwt_debug "connection closed to %a" P2p_peer.Id.pp st.conn.info.peer_id
    | Error err ->
        lwt_log_error
          "@[<v 2>error writing to %a@ %a@]"
          P2p_peer.Id.pp
          st.conn.info.peer_id
          pp_print_error
          err
        >>= fun () -> Lwt_canceler.cancel st.canceler
    | Ok (buf, wakener) -> (
        send_message st buf
        >>= fun res ->
        match res with
        | Ok () ->
            Option.iter wakener ~f:(fun u -> Lwt.wakeup_later u res) ;
            worker_loop st
        | Error err -> (
            Option.iter wakener ~f:(fun u ->
                Lwt.wakeup_later u (error P2p_errors.Connection_closed)) ;
            match err with
            | (Canceled | Exn Lwt_pipe.Closed) :: _ ->
                lwt_debug
                  "connection closed to %a"
                  P2p_peer.Id.pp
                  st.conn.info.peer_id
            | P2p_errors.Connection_closed :: _ ->
                lwt_debug
                  "connection closed to %a"
                  P2p_peer.Id.pp
                  st.conn.info.peer_id
                >>= fun () -> Lwt_canceler.cancel st.canceler
            | err ->
                lwt_log_error
                  "@[<v 2>error writing to %a@ %a@]"
                  P2p_peer.Id.pp
                  st.conn.info.peer_id
                  pp_print_error
                  err
                >>= fun () -> Lwt_canceler.cancel st.canceler ) )

  let run ?size ?binary_chunks_size conn encoding canceler =
    let binary_chunks_size =
      match binary_chunks_size with
      | None ->
          Crypto.max_content_length
      | Some size ->
          let size = size - Crypto.extrabytes in
          assert (size > 0) ;
          assert (size <= Crypto.max_content_length) ;
          size
    in
    let compute_size =
      let buf_list_size =
        List.fold_left
          (fun sz buf -> sz + Bytes.length buf + (2 * Sys.word_size))
          0
      in
      function
      | (buf_l, None) ->
          Sys.word_size + buf_list_size buf_l + Lwt_pipe.push_overhead
      | (buf_l, Some _) ->
          (2 * Sys.word_size) + buf_list_size buf_l + Lwt_pipe.push_overhead
    in
    let size = Option.map size ~f:(fun max -> (max, compute_size)) in
    let st =
      {
        canceler;
        conn;
        encoding;
        messages = Lwt_pipe.create ?size ();
        worker = Lwt.return_unit;
        binary_chunks_size;
      }
    in
    Lwt_canceler.on_cancel st.canceler (fun () ->
        Lwt_pipe.close st.messages ;
        while not (Lwt_pipe.is_empty st.messages) do
          let (_, w) = Lwt_pipe.pop_now_exn st.messages in
          Option.iter w ~f:(fun u ->
              Lwt.wakeup_later u (error (Exn Lwt_pipe.Closed)))
        done ;
        Lwt.return_unit) ;
    st.worker <-
      Lwt_utils.worker
        "writer"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop st)
        ~cancel:(fun () -> Lwt_canceler.cancel st.canceler) ;
    st

  let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
end

type ('msg, 'meta) t = {
  conn : 'meta authenticated_connection;
  reader : ('msg, 'meta) Reader.t;
  writer : ('msg, 'meta) Writer.t;
}

let equal {conn = {fd = fd2; _}; _} {conn = {fd = fd1; _}; _} =
  P2p_io_scheduler.id fd1 = P2p_io_scheduler.id fd2

let pp ppf {conn; _} = P2p_connection.Info.pp (fun _ _ -> ()) ppf conn.info

let info {conn; _} = conn.info

let local_metadata {conn; _} = conn.info.local_metadata

let remote_metadata {conn; _} = conn.info.remote_metadata

let private_node {conn; _} = conn.info.private_node

let accept ?incoming_message_queue_size ?outgoing_message_queue_size
    ?binary_chunks_size ~canceler conn encoding =
  protect
    (fun () ->
      Ack.write ~canceler conn.fd conn.cryptobox_data Ack
      >>=? fun () -> Ack.read ~canceler conn.fd conn.cryptobox_data)
    ~on_error:(fun err ->
      P2p_io_scheduler.close conn.fd
      >>= fun _ ->
      match err with
      | [P2p_errors.Connection_closed] ->
          fail P2p_errors.Rejected_socket_connection
      | [P2p_errors.Decipher_error] ->
          fail P2p_errors.Invalid_auth
      | err ->
          Lwt.return_error err)
  >>=? function
  | Ack ->
      let canceler = Lwt_canceler.create () in
      let reader =
        Reader.run ?size:incoming_message_queue_size conn encoding canceler
      and writer =
        Writer.run
          ?size:outgoing_message_queue_size
          ?binary_chunks_size
          conn
          encoding
          canceler
      in
      let conn = {conn; reader; writer} in
      Lwt_canceler.on_cancel canceler (fun () ->
          P2p_io_scheduler.close conn.conn.fd >>= fun _ -> Lwt.return_unit) ;
      return conn
  | Nack ->
      fail P2p_errors.Rejected_socket_connection

let catch_closed_pipe f =
  Lwt.catch f (function
      | Lwt_pipe.Closed ->
          fail P2p_errors.Connection_closed
      | exn ->
          fail (Exn exn))
  >>= function
  | Error (Exn Lwt_pipe.Closed :: _) ->
      fail P2p_errors.Connection_closed
  | (Error _ | Ok _) as v ->
      Lwt.return v

let pp_json encoding ppf msg =
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding msg)

let write {writer; conn; _} msg =
  catch_closed_pipe (fun () ->
      debug
        "Sending message to %a: %a"
        P2p_peer.Id.pp_short
        conn.info.peer_id
        (pp_json writer.encoding)
        msg ;
      Lwt.return (Writer.encode_message writer msg)
      >>=? fun buf ->
      Lwt_pipe.push writer.messages (buf, None) >>= fun () -> return_unit)

let write_sync {writer; conn; _} msg =
  catch_closed_pipe (fun () ->
      let (waiter, wakener) = Lwt.wait () in
      debug
        "Sending message to %a: %a"
        P2p_peer.Id.pp_short
        conn.info.peer_id
        (pp_json writer.encoding)
        msg ;
      Lwt.return (Writer.encode_message writer msg)
      >>=? fun buf ->
      Lwt_pipe.push writer.messages (buf, Some wakener) >>= fun () -> waiter)

let write_now {writer; conn; _} msg =
  debug
    "Try sending message to %a: %a"
    P2p_peer.Id.pp_short
    conn.info.peer_id
    (pp_json writer.encoding)
    msg ;
  Writer.encode_message writer msg
  >>? fun buf ->
  try Ok (Lwt_pipe.push_now writer.messages (buf, None))
  with Lwt_pipe.Closed -> error P2p_errors.Connection_closed

let rec split_bytes size bytes =
  if Bytes.length bytes <= size then [bytes]
  else
    Bytes.sub bytes 0 size
    :: split_bytes size (Bytes.sub bytes size (Bytes.length bytes - size))

let raw_write_sync {writer; _} bytes =
  let bytes = split_bytes writer.binary_chunks_size bytes in
  catch_closed_pipe (fun () ->
      let (waiter, wakener) = Lwt.wait () in
      Lwt_pipe.push writer.messages (bytes, Some wakener) >>= fun () -> waiter)

let is_readable {reader; _} = not (Lwt_pipe.is_empty reader.messages)

let wait_readable {reader; _} =
  catch_closed_pipe (fun () ->
      Lwt_pipe.values_available reader.messages >>= fun () -> return_unit)

let read {reader; _} =
  catch_closed_pipe (fun () -> Lwt_pipe.pop reader.messages)

let read_now {reader; _} =
  try Lwt_pipe.pop_now reader.messages
  with Lwt_pipe.Closed -> Some (error P2p_errors.Connection_closed)

let stat {conn = {fd; _}; _} = P2p_io_scheduler.stat fd

let close ?(wait = false) st =
  ( if not wait then Lwt.return_unit
  else (
    Lwt_pipe.close st.reader.messages ;
    Lwt_pipe.close st.writer.messages ;
    st.writer.worker ) )
  >>= fun () ->
  Reader.shutdown st.reader
  >>= fun () ->
  Writer.shutdown st.writer
  >>= fun () -> P2p_io_scheduler.close st.conn.fd >>= fun _ -> Lwt.return_unit
src/lib_p2p/p2p_socket.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Module Crypto.
  Definition bufsize : Z := Z.sub (Z.shiftl 1 16) 1.
  
  Definition header_length : Z := 2.
  
  Definition max_content_length : Z := Z.sub bufsize Crypto_box.zerobytes.
  
  Definition boxextrabytes : Z :=
    Z.sub Crypto_box.zerobytes Crypto_box.boxzerobytes.
  
  Definition extrabytes : Z := Z.add header_length boxextrabytes.
  
  Record data := {
    channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key;
    local_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
    remote_nonce : Tezos_base__TzPervasives.Crypto_box.nonce }.
  
  
  
  Definition write_chunk
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : data)
    (msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let msglen := String.length msg in
    op_gtgteqquestion
      (fail_unless (OCaml.Stdlib.le msglen max_content_length)
        Tezos_base__TzPervasives.Invalid_message_size)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let buf_length := Z.add msglen Crypto_box.zerobytes in
        let buf := Stdlib.Bytes.make buf_length "000" % char in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
        let local_nonce := local_nonce cryptobox_data in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field cryptobox_data "local_nonce" % string
            (Crypto_box.increment_nonce None local_nonce) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Crypto_box.fast_box_noalloc (channel_key cryptobox_data) local_nonce
            buf in
        let encrypted_length := Z.sub buf_length Crypto_box.boxzerobytes in
        let header_pos := Z.sub Crypto_box.boxzerobytes header_length in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := TzEndian.set_int16 buf header_pos encrypted_length in
        let payload := String.sub buf header_pos (Z.sub buf_length header_pos)
          in
        P2p_io_scheduler.write canceler fd payload).
  
  Definition read_chunk
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let header_buf := Stdlib.Bytes.create header_length in
    op_gtgteqquestion
      (P2p_io_scheduler.read_full canceler fd None (Some header_length)
        header_buf)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let encrypted_length := TzEndian.get_uint16 header_buf 0 in
        let buf_length := Z.add encrypted_length Crypto_box.boxzerobytes in
        let buf := Stdlib.Bytes.make buf_length "000" % char in
        op_gtgteqquestion
          (P2p_io_scheduler.read_full canceler fd (Some Crypto_box.boxzerobytes)
            (Some encrypted_length) buf)
          (fun function_parameter =>
            let 'tt := function_parameter in
            let remote_nonce := remote_nonce cryptobox_data in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field cryptobox_data "remote_nonce" % string
                (Crypto_box.increment_nonce None remote_nonce) in
            match
              Crypto_box.fast_box_open_noalloc (channel_key cryptobox_data)
                remote_nonce buf with
            | false => fail Tezos_base__TzPervasives.Decipher_error
            | true =>
              _return
                (String.sub buf Crypto_box.zerobytes
                  (Z.sub buf_length Crypto_box.zerobytes))
            end)).
End Crypto.

Definition check_binary_chunks_size (size : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let value := Z.sub size Crypto.extrabytes in
  fail_unless
    (andb (OCaml.Stdlib.gt value 0)
      (OCaml.Stdlib.le value Crypto.max_content_length))
    (Tezos_base__TzPervasives.Invalid_chunks_size
      {| value := size; min := Z.add Crypto.extrabytes 1; max := Crypto.bufsize
        |}).

Module Connection_message.
  Record t := {
    port : option Z;
    public_key : Tezos_base__TzPervasives.Crypto_box.public_key;
    proof_of_work_stamp : Tezos_base__TzPervasives.Crypto_box.nonce;
    message_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
    version : Tezos_base__TzPervasives.Network_version.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    conv
      (fun function_parameter =>
        let '{|
          port := port;
            public_key := public_key;
            proof_of_work_stamp := proof_of_work_stamp;
            message_nonce := message_nonce;
            version := version
            |} := function_parameter in
        let port :=
          match port with
          | None => 0
          | Some port => port
          end in
        (port, public_key, proof_of_work_stamp, message_nonce, version))
      (fun function_parameter =>
        let '(port, public_key, proof_of_work_stamp, message_nonce, version) :=
          function_parameter in
        let port :=
          if equiv_decb port 0 then
            None
          else
            Some port in
        {| port := port; public_key := public_key;
          proof_of_work_stamp := proof_of_work_stamp;
          message_nonce := message_nonce; version := version |}) None
      (obj5 (req None None "port" % string uint16)
        (req None None "pubkey" % string Crypto_box.public_key_encoding)
        (req None None "proof_of_work_stamp" % string Crypto_box.nonce_encoding)
        (req None None "message_nonce" % string Crypto_box.nonce_encoding)
        (req None None "version" % string Network_version.encoding)).
  
  Definition write
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (message : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let encoded_message_len := Data_encoding.Binary.length encoding message in
    op_gtgteqquestion
      (fail_unless
        (OCaml.Stdlib.lt encoded_message_len
          (Z.shiftl 1 (Z.mul Crypto.header_length 8)))
        Tezos_base__TzPervasives.Encoding_error)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let len := Z.add Crypto.header_length encoded_message_len in
        let buf := Stdlib.Bytes.create len in
        match
          Data_encoding.Binary.write encoding message buf Crypto.header_length
            len with
        | None => fail Tezos_base__TzPervasives.Encoding_error
        | Some last =>
          op_gtgteqquestion
            (fail_unless (equiv_decb last len)
              Tezos_base__TzPervasives.Encoding_error)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := TzEndian.set_int16 buf 0 encoded_message_len in
              op_gtgteqquestion (P2p_io_scheduler.write (Some canceler) fd buf)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return buf))
        end).
  
  Definition read
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (t * string)) :=
    let header_buf := Stdlib.Bytes.create Crypto.header_length in
    op_gtgteqquestion
      (P2p_io_scheduler.read_full (Some canceler) fd None
        (Some Crypto.header_length) header_buf)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let len := TzEndian.get_uint16 header_buf 0 in
        let pos := Crypto.header_length in
        let buf := Stdlib.Bytes.create (Z.add pos len) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := TzEndian.set_int16 buf 0 len in
        op_gtgteqquestion
          (P2p_io_scheduler.read_full (Some canceler) fd (Some pos) (Some len)
            buf)
          (fun function_parameter =>
            let 'tt := function_parameter in
            match Data_encoding.Binary.read encoding buf pos len with
            | None => fail Tezos_base__TzPervasives.Decoding_error
            | Some (next_pos, message) =>
              if nequiv_decb next_pos (Z.add pos len) then
                fail Tezos_base__TzPervasives.Decoding_error
              else
                _return (message, buf)
            end)).
End Connection_message.

Record metadata_config {meta : Type} := {
  conn_meta_encoding : Tezos_base__TzPervasives.Data_encoding.t meta;
  conn_meta_value : Tezos_base__TzPervasives.P2p_peer.Id.t -> meta;
  private_node : meta -> bool }.
Arguments metadata_config : clear implicits.

Module Metadata.
  Definition write {A : Type}
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (metadata_config : metadata_config A)
    (cryptobox_data : Tezos_p2p.P2p_io_scheduler.connection) (fd : Crypto.data)
    (message : A) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let encoded_message_len :=
      Data_encoding.Binary.length (conn_meta_encoding metadata_config) message
      in
    let buf := Stdlib.Bytes.create encoded_message_len in
    match
      Data_encoding.Binary.write (conn_meta_encoding metadata_config) message
        buf 0 encoded_message_len with
    | None => fail Tezos_base__TzPervasives.Encoding_error
    | Some last =>
      op_gtgteqquestion
        (fail_unless (equiv_decb last encoded_message_len)
          Tezos_base__TzPervasives.Encoding_error)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Crypto.write_chunk (Some canceler) cryptobox_data fd buf)
    end.
  
  Definition read {A : Type}
    (canceler : Tezos_stdlib.Lwt_canceler.t)
    (metadata_config : metadata_config A)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    op_gtgteqquestion (Crypto.read_chunk (Some canceler) fd cryptobox_data)
      (fun buf =>
        let length := String.length buf in
        let encoding := conn_meta_encoding metadata_config in
        match Data_encoding.Binary.read encoding buf 0 length with
        | None => fail Tezos_base__TzPervasives.Decoding_error
        | Some (read_len, message) =>
          if nequiv_decb read_len length then
            fail Tezos_base__TzPervasives.Decoding_error
          else
            _return message
        end).
End Metadata.

Module Ack.
  Inductive t : Type :=
  | Ack : t
  | Nack : t.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    let ack_encoding := obj1 (req None None "ack" % string empty) in
    let nack_encoding := obj1 (req None None "nack" % string empty) in
    let ack_case (tag : Tezos_base__TzPervasives.Data_encoding.case_tag)
      : Tezos_base__TzPervasives.Data_encoding.case t :=
      case "Ack" % string None tag ack_encoding
        (fun function_parameter =>
          match function_parameter with
          | Ack => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Ack) in
    let nack_case (tag : Tezos_base__TzPervasives.Data_encoding.case_tag)
      : Tezos_base__TzPervasives.Data_encoding.case t :=
      case "Nack" % string None tag nack_encoding
        (fun function_parameter =>
          match function_parameter with
          | Nack => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let '_ := function_parameter in
          Nack) in
    union None
      (cons (ack_case (Tezos_base__TzPervasives.Data_encoding.Tag 0))
        (cons (nack_case (Tezos_base__TzPervasives.Data_encoding.Tag 255)) [])).
  
  Definition write
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
    (message : t) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let encoded_message_len := Data_encoding.Binary.length encoding message in
    let buf := Stdlib.Bytes.create encoded_message_len in
    match Data_encoding.Binary.write encoding message buf 0 encoded_message_len
      with
    | None => fail Tezos_base__TzPervasives.Encoding_error
    | Some last =>
      op_gtgteqquestion
        (fail_unless (equiv_decb last encoded_message_len)
          Tezos_base__TzPervasives.Encoding_error)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Crypto.write_chunk canceler fd cryptobox_data buf)
    end.
  
  Definition read
    (canceler : option Tezos_stdlib.Lwt_canceler.t)
    (fd : Tezos_p2p.P2p_io_scheduler.connection) (cryptobox_data : Crypto.data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    op_gtgteqquestion (Crypto.read_chunk canceler fd cryptobox_data)
      (fun buf =>
        let length := String.length buf in
        match Data_encoding.Binary.read encoding buf 0 length with
        | None => fail Tezos_base__TzPervasives.Decoding_error
        | Some (read_len, message) =>
          if nequiv_decb read_len length then
            fail Tezos_base__TzPervasives.Decoding_error
          else
            _return message
        end).
End Ack.

Record authenticated_connection {meta : Type} := {
  fd : Tezos_p2p.P2p_io_scheduler.connection;
  info : Tezos_base__TzPervasives.P2p_connection.Info.t meta;
  cryptobox_data : Crypto.data }.
Arguments authenticated_connection : clear implicits.

Definition kick {A : Type} (function_parameter : authenticated_connection A)
  : Lwt.t unit :=
  let '{| fd := fd; cryptobox_data := cryptobox_data |} := function_parameter in
  op_gtgteq (Ack.write None fd cryptobox_data Ack.Nack)
    (fun function_parameter =>
      let '_ := function_parameter in
      op_gtgteq (P2p_io_scheduler.close None fd)
        (fun function_parameter =>
          let '_ := function_parameter in
          Lwt.return_unit)).

Definition authenticate {A : Type}
  (canceler : Tezos_stdlib.Lwt_canceler.t)
  (proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target)
  (incoming : bool) (fd : Tezos_p2p.P2p_io_scheduler.connection)
  (function_parameter : Tezos_base.P2p_addr.t * Tezos_base.P2p_addr.port)
  : (option Z) ->
    Tezos_base__TzPervasives.P2p_identity.t ->
      Tezos_base__TzPervasives.Network_version.t ->
        (metadata_config A) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              ((Tezos_base__TzPervasives.P2p_connection.Info.t A) *
                (authenticated_connection A))) :=
  let '(remote_addr, remote_socket_port) as point := function_parameter in
  fun listening_port =>
    fun identity =>
      fun announced_version =>
        fun metadata_config =>
          let local_nonce_seed := Crypto_box.random_nonce tt in
          op_gtgteq
            (lwt_debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Sending authenfication to " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Sending authenfication to %a" % string) P2p_point.Id.pp point)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (Connection_message.write canceler fd
                  {| port := listening_port;
                    public_key := P2p_identity.public_key identity;
                    proof_of_work_stamp := proof_of_work_stamp identity;
                    message_nonce := local_nonce_seed;
                    version := announced_version |})
                (fun sent_msg =>
                  op_gtgteqquestion (Connection_message.read canceler fd)
                    (fun function_parameter =>
                      let '(msg, recv_msg) := function_parameter in
                      let remote_listening_port :=
                        if incoming then
                          port msg
                        else
                          Some remote_socket_port in
                      let id_point := (remote_addr, remote_listening_port) in
                      let remote_peer_id := Crypto_box.hash (public_key msg) in
                      op_gtgteqquestion
                        (fail_unless
                          (nequiv_decb remote_peer_id
                            (P2p_identity.peer_id identity))
                          (Tezos_base__TzPervasives.Myself id_point))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (fail_unless
                              (Crypto_box.check_proof_of_work (public_key msg)
                                (proof_of_work_stamp msg) proof_of_work_target)
                              (Tezos_base__TzPervasives.Not_enough_proof_of_work
                                remote_peer_id))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              let channel_key :=
                                Crypto_box.precompute
                                  (P2p_identity.secret_key identity)
                                  (public_key msg) in
                              let '(local_nonce, remote_nonce) :=
                                Crypto_box.generate_nonces incoming sent_msg
                                  recv_msg in
                              let cryptobox_data :=
                                {| Crypto.channel_key := channel_key;
                                  Crypto.local_nonce := local_nonce;
                                  Crypto.remote_nonce := remote_nonce |} in
                              let local_metadata :=
                                (conn_meta_value metadata_config) remote_peer_id
                                in
                              op_gtgteqquestion
                                (Metadata.write canceler metadata_config fd
                                  cryptobox_data local_metadata)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (Metadata.read canceler metadata_config fd
                                      cryptobox_data)
                                    (fun remote_metadata =>
                                      let info :=
                                        {|
                                          P2p_connection.Info.incoming :=
                                            incoming;
                                          P2p_connection.Info.peer_id :=
                                            remote_peer_id;
                                          P2p_connection.Info.id_point :=
                                            id_point;
                                          P2p_connection.Info.remote_socket_port :=
                                            remote_socket_port;
                                          P2p_connection.Info.announced_version :=
                                            version msg;
                                          P2p_connection.Info.private_node :=
                                            (private_node metadata_config)
                                              remote_metadata;
                                          P2p_connection.Info.local_metadata :=
                                            local_metadata;
                                          P2p_connection.Info.remote_metadata :=
                                            remote_metadata |} in
                                      _return
                                        (info,
                                          {| fd := fd; info := info;
                                            cryptobox_data := cryptobox_data |})))))))).

Module Reader.
  Record t {msg meta : Type} := {
    canceler : Tezos_stdlib.Lwt_canceler.t;
    conn : authenticated_connection meta;
    encoding : Tezos_base__TzPervasives.Data_encoding.t msg;
    messages :
      Tezos_stdlib.Lwt_pipe.t (Tezos_base__TzPervasives.tzresult (Z * msg));
    worker : Lwt.t unit }.
  Arguments t : clear implicits.
  
  Definition read_message {A B : Type}
    (st : t A B) (init : option Tezos_data_encoding.Binary_stream.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option (A * Z * Tezos_data_encoding.Binary_stream.t))) :=
    let fix loop {C : Type}
      (status : Tezos_base__TzPervasives.Data_encoding.Binary.status C)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (option (C * Z * Tezos_data_encoding.Binary_stream.t))) :=
      op_gtgteq (Lwt_unix.yield tt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          match status with
          |
            Tezos_base__TzPervasives.Data_encoding.Binary.Success {|
              result := result; size := size; stream := stream |} =>
            return_some (result, size, stream)
          | Tezos_base__TzPervasives.Data_encoding.Binary.Error _err =>
            op_gtgteq
              (lwt_debug
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "[read_message] incremental decoding error" % string
                    CamlinternalFormatBasics.End_of_format)
                  "[read_message] incremental decoding error" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_none)
          | Tezos_base__TzPervasives.Data_encoding.Binary.Await decode_next_buf
            =>
            op_gtgteqquestion
              (Crypto.read_chunk (Some (canceler st)) (fd (conn st))
                (cryptobox_data (conn st)))
              (fun buf =>
                op_gtgteq
                  (lwt_debug
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "reading " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal
                            " bytes from " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))))
                      "reading %d bytes from %a" % string) (String.length buf)
                    P2p_peer.Id.pp (peer_id (info (conn st))))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    loop (decode_next_buf buf)))
          end) in
    loop (Data_encoding.Binary.read_stream init (encoding st)).
  
  Fixpoint worker_loop {A B : Type}
    (st : t A B) (stream : option Tezos_data_encoding.Binary_stream.t)
    : Lwt.t unit :=
    op_gtgteq
      (op_gtgteqquestion (read_message st stream)
        (fun msg =>
          match msg with
          | None =>
            protect None (Some (canceler st))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Lwt_pipe.push (messages st)
                    (error Tezos_base__TzPervasives.Decoding_error))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_none))
          | Some (msg, size, stream) =>
            protect None (Some (canceler st))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Lwt_pipe.push (messages st) (Stdlib.Ok (size, msg)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_some stream))
          end))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok (Some stream) => worker_loop st (Some stream)
        | Stdlib.Ok None => Lwt_canceler.cancel (canceler st)
        |
          Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
            Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
          lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "connection closed to " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "connection closed to %a" % string) P2p_peer.Id.pp
            (peer_id (info (conn st)))
        | (Stdlib.Error _) as err =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_pipe.safe_push_now (messages st) err in
          Lwt_canceler.cancel (canceler st)
        end).
  
  Definition run {A B : Type}
    (size : option Z) (conn : authenticated_connection A)
    (encoding : Tezos_base__TzPervasives.Data_encoding.t B)
    (canceler : Tezos_stdlib.Lwt_canceler.t) : t B A :=
    let compute_size {C D : Type} (function_parameter : sum (Z * C) D) : Z :=
      match function_parameter with
      | Stdlib.Ok (size, _) =>
        Z.add (Z.add (Z.mul (Z.div Sys.word_size 8) 11) size)
          Lwt_pipe.push_overhead
      | Stdlib.Error _ => 0
      end in
    let size := Option.map (fun max => (max, compute_size)) size in
    let st :=
      {| canceler := canceler; conn := conn; encoding := encoding;
        messages := Lwt_pipe.create size tt; worker := Lwt.return_unit |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Lwt_canceler.on_cancel (canceler st)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_pipe.close (messages st) in
          Lwt.return_unit) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field st "worker" % string
        (Lwt_utils.worker "reader" % string
          Internal_event.Lwt_worker_event.on_event
          (fun function_parameter =>
            let 'tt := function_parameter in
            worker_loop st None)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler st))) in
    st.
  
  Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
    op_gtgteq (Lwt_canceler.cancel (canceler st))
      (fun function_parameter =>
        let 'tt := function_parameter in
        worker st).
End Reader.

Module Writer.
  Record t {msg meta : Type} := {
    canceler : Tezos_stdlib.Lwt_canceler.t;
    conn : authenticated_connection meta;
    encoding : Tezos_base__TzPervasives.Data_encoding.t msg;
    messages :
      Tezos_stdlib.Lwt_pipe.t
        ((list Stdlib.Bytes.t) *
          (option (Lwt.u (Tezos_base__TzPervasives.tzresult unit))));
    worker : Lwt.t unit;
    binary_chunks_size : Z }.
  Arguments t : clear implicits.
  
  Definition send_message {A B : Type} (st : t A B) (buf : list string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let fix loop (function_parameter : list string)
      : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
      match function_parameter with
      | [] => return_unit
      | cons buf l =>
        op_gtgteqquestion
          (Crypto.write_chunk (Some (canceler st)) (fd (conn st))
            (cryptobox_data (conn st)) buf)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (lwt_debug
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "writing " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        " bytes to " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))))
                  "writing %d bytes to %a" % string) (String.length buf)
                P2p_peer.Id.pp (peer_id (info (conn st))))
              (fun function_parameter =>
                let 'tt := function_parameter in
                loop l))
      end in
    loop buf.
  
  Definition encode_message {A B : Type} (st : t A B) (msg : A)
    : Tezos_base__TzPervasives.tzresult (list Stdlib.Bytes.t) :=
    (* ❌ Try-with are not handled *)
    try
      (ok
        (Utils.cut None (binary_chunks_size st)
          (Data_encoding.Binary.to_bytes_exn (encoding st) msg))).
  
  Fixpoint worker_loop {A B : Type} (st : t A B) : Lwt.t unit :=
    op_gtgteq (Lwt_unix.yield tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (protect None (Some (canceler st))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Lwt_pipe.pop (messages st)) _return))
          (fun function_parameter =>
            match function_parameter with
            |
              Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
                Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
              lwt_debug
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "connection closed to " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "connection closed to %a" % string) P2p_peer.Id.pp
                (peer_id (info (conn st)))
            | Stdlib.Error err =>
              op_gtgteq
                (lwt_log_error
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "error writing to " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))
                    "@[<v 2>error writing to %a@ %a@]" % string) P2p_peer.Id.pp
                  (peer_id (info (conn st))) pp_print_error err)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt_canceler.cancel (canceler st))
            | Stdlib.Ok (buf, wakener) =>
              op_gtgteq (send_message st buf)
                (fun res =>
                  match res with
                  | Stdlib.Ok tt =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Option.iter (fun u => Lwt.wakeup_later u res) wakener in
                    worker_loop st
                  | Stdlib.Error err =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      Option.iter
                        (fun u =>
                          Lwt.wakeup_later u
                            (error Tezos_base__TzPervasives.Connection_closed))
                        wakener in
                    match err with
                    |
                      cons
                        (Tezos_base__TzPervasives.Canceled |
                          Tezos_base__TzPervasives.Exn Closed) _ =>
                      lwt_debug
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "connection closed to " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "connection closed to %a" % string) P2p_peer.Id.pp
                        (peer_id (info (conn st)))
                    | cons Tezos_base__TzPervasives.Connection_closed _ =>
                      op_gtgteq
                        (lwt_debug
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "connection closed to " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            "connection closed to %a" % string) P2p_peer.Id.pp
                          (peer_id (info (conn st))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Lwt_canceler.cancel (canceler st))
                    | err =>
                      op_gtgteq
                        (lwt_log_error
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<v 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<v 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "error writing to " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))
                            "@[<v 2>error writing to %a@ %a@]" % string)
                          P2p_peer.Id.pp (peer_id (info (conn st)))
                          pp_print_error err)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Lwt_canceler.cancel (canceler st))
                    end
                  end)
            end)).
  
  Definition run {A B : Type}
    (size : option Z) (binary_chunks_size : option Z)
    (conn : authenticated_connection A)
    (encoding : Tezos_base__TzPervasives.Data_encoding.t B)
    (canceler : Tezos_stdlib.Lwt_canceler.t) : t B A :=
    let binary_chunks_size :=
      match binary_chunks_size with
      | None => Crypto.max_content_length
      | Some size =>
        let size := Z.sub size Crypto.extrabytes in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert (OCaml.Stdlib.gt size 0) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert (OCaml.Stdlib.le size Crypto.max_content_length) in
        size
      end in
    let compute_size :=
      let buf_list_size :=
        List.fold_left
          (fun sz =>
            fun buf =>
              Z.add (Z.add sz (String.length buf)) (Z.mul 2 Sys.word_size)) 0 in
      fun function_parameter =>
        match function_parameter with
        | (buf_l, None) =>
          Z.add (Z.add Sys.word_size (buf_list_size buf_l))
            Lwt_pipe.push_overhead
        | (buf_l, Some _) =>
          Z.add (Z.add (Z.mul 2 Sys.word_size) (buf_list_size buf_l))
            Lwt_pipe.push_overhead
        end in
    let size := Option.map (fun max => (max, compute_size)) size in
    let st :=
      {| canceler := canceler; conn := conn; encoding := encoding;
        messages := Lwt_pipe.create size tt; worker := Lwt.return_unit;
        binary_chunks_size := binary_chunks_size |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Lwt_canceler.on_cancel (canceler st)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_pipe.close (messages st) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ While loops not handled. *)
            while in
          Lwt.return_unit) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field st "worker" % string
        (Lwt_utils.worker "writer" % string
          Internal_event.Lwt_worker_event.on_event
          (fun function_parameter =>
            let 'tt := function_parameter in
            worker_loop st)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler st))) in
    st.
  
  Definition shutdown {A B : Type} (st : t A B) : Lwt.t unit :=
    op_gtgteq (Lwt_canceler.cancel (canceler st))
      (fun function_parameter =>
        let 'tt := function_parameter in
        worker st).
End Writer.

Record t {msg meta : Type} := {
  conn : authenticated_connection meta;
  reader : Reader.t msg meta;
  writer : Writer.t msg meta }.
Arguments t : clear implicits.

Definition equal {A B C D : Type} (function_parameter : t A B)
  : (t C D) -> bool :=
  let '{| conn := {| fd := fd2 |} |} := function_parameter in
  fun function_parameter =>
    let '{| conn := {| fd := fd1 |} |} := function_parameter in
    equiv_decb (P2p_io_scheduler.id fd1) (P2p_io_scheduler.id fd2).

Definition pp {A B : Type}
  (ppf : Stdlib.Format.formatter) (function_parameter : t A B) : unit :=
  let '{| conn := conn |} := function_parameter in
  P2p_connection.Info.pp
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        tt) ppf (info conn).

Definition info {A B : Type} (function_parameter : t A B)
  : Tezos_base__TzPervasives.P2p_connection.Info.t B :=
  let '{| conn := conn |} := function_parameter in
  info conn.

Definition local_metadata {A B : Type} (function_parameter : t A B) : B :=
  let '{| conn := conn |} := function_parameter in
  local_metadata (info conn).

Definition remote_metadata {A B : Type} (function_parameter : t A B) : B :=
  let '{| conn := conn |} := function_parameter in
  remote_metadata (info conn).

Definition private_node {A B : Type} (function_parameter : t A B) : bool :=
  let '{| conn := conn |} := function_parameter in
  private_node (info conn).

Definition accept {A B : Type}
  (incoming_message_queue_size : option Z)
  (outgoing_message_queue_size : option Z) (binary_chunks_size : option Z)
  (canceler : Tezos_stdlib.Lwt_canceler.t) (conn : authenticated_connection A)
  (encoding : Tezos_base__TzPervasives.Data_encoding.t B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (t B A)) :=
  op_gtgteqquestion
    (protect
      (Some
        (fun err =>
          op_gtgteq (P2p_io_scheduler.close None (fd conn))
            (fun function_parameter =>
              let '_ := function_parameter in
              match err with
              | cons Tezos_base__TzPervasives.Connection_closed [] =>
                fail Tezos_base__TzPervasives.Rejected_socket_connection
              | cons Tezos_base__TzPervasives.Decipher_error [] =>
                fail Tezos_base__TzPervasives.Invalid_auth
              | err => Lwt.return_error err
              end))) None
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (Ack.write (Some canceler) (fd conn) (cryptobox_data conn) Ack.Ack)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Ack.read (Some canceler) (fd conn) (cryptobox_data conn))))
    (fun function_parameter =>
      match function_parameter with
      | Ack.Ack =>
        let canceler := Lwt_canceler.create tt in
        let reader : Reader.t B A :=
          Reader.run incoming_message_queue_size conn encoding canceler
        with writer : Writer.t B A :=
          Writer.run outgoing_message_queue_size binary_chunks_size conn
            encoding canceler in
        let conn := {| conn := conn; reader := reader; writer := writer |} in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Lwt_canceler.on_cancel canceler
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (P2p_io_scheduler.close None (fd (conn conn)))
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Lwt.return_unit)) in
        _return conn
      | Ack.Nack => fail Tezos_base__TzPervasives.Rejected_socket_connection
      end).

Definition catch_closed_pipe {A : Type}
  (f : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult A))
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  op_gtgteq
    (Lwt.catch f
      (fun function_parameter =>
        match function_parameter with
        | Closed => fail Tezos_base__TzPervasives.Connection_closed
        | exn => fail (Tezos_base__TzPervasives.Exn exn)
        end))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
        fail Tezos_base__TzPervasives.Connection_closed
      | (Stdlib.Error _ | Stdlib.Ok _) as v => Lwt._return v
      end).

Definition pp_json {A : Type}
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
  (ppf : Stdlib.Format.formatter) (msg : A) : unit :=
  Data_encoding.Json.pp ppf (Data_encoding.Json.construct encoding msg).

Definition write {A B : Type} (function_parameter : t A B)
  : A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{| conn := conn; writer := writer |} := function_parameter in
  fun msg =>
    catch_closed_pipe
      (fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Sending message to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal ": " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "Sending message to %a: %a" % string) P2p_peer.Id.pp_short
            (peer_id (info conn)) (pp_json (encoding writer)) msg in
        op_gtgteqquestion (Lwt._return (Writer.encode_message writer msg))
          (fun buf =>
            op_gtgteq (Lwt_pipe.push (messages writer) (buf, None))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit))).

Definition write_sync {A B : Type} (function_parameter : t A B)
  : A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{| conn := conn; writer := writer |} := function_parameter in
  fun msg =>
    catch_closed_pipe
      (fun function_parameter =>
        let 'tt := function_parameter in
        let '(waiter, wakener) := Lwt.wait tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Sending message to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal ": " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))
              "Sending message to %a: %a" % string) P2p_peer.Id.pp_short
            (peer_id (info conn)) (pp_json (encoding writer)) msg in
        op_gtgteqquestion (Lwt._return (Writer.encode_message writer msg))
          (fun buf =>
            op_gtgteq (Lwt_pipe.push (messages writer) (buf, (Some wakener)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                waiter))).

Definition write_now {A B : Type} (function_parameter : t A B)
  : A -> Tezos_base__TzPervasives.tzresult bool :=
  let '{| conn := conn; writer := writer |} := function_parameter in
  fun msg =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Try sending message to " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal ": " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))))
          "Try sending message to %a: %a" % string) P2p_peer.Id.pp_short
        (peer_id (info conn)) (pp_json (encoding writer)) msg in
    op_gtgtquestion (Writer.encode_message writer msg)
      (fun buf =>
        (* ❌ Try-with are not handled *)
        try (Stdlib.Ok (Lwt_pipe.push_now (messages writer) (buf, None)))).

Fixpoint split_bytes (size : Z) (bytes : string) : list string :=
  if OCaml.Stdlib.le (String.length string) size then
    cons string []
  else
    cons (String.sub string 0 size)
      (split_bytes size
        (String.sub string size (Z.sub (String.length string) size))).

Definition raw_write_sync {A B : Type} (function_parameter : t A B)
  : string -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{| writer := writer |} := function_parameter in
  fun bytes =>
    let bytes := split_bytes (binary_chunks_size writer) string in
    catch_closed_pipe
      (fun function_parameter =>
        let 'tt := function_parameter in
        let '(waiter, wakener) := Lwt.wait tt in
        op_gtgteq (Lwt_pipe.push (messages writer) (string, (Some wakener)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            waiter)).

Definition is_readable {A B : Type} (function_parameter : t A B) : bool :=
  let '{| reader := reader |} := function_parameter in
  negb (Lwt_pipe.is_empty (messages reader)).

Definition wait_readable {A B : Type} (function_parameter : t A B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{| reader := reader |} := function_parameter in
  catch_closed_pipe
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_pipe.values_available (messages reader))
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition read {A B : Type} (function_parameter : t A B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (Z * A)) :=
  let '{| reader := reader |} := function_parameter in
  catch_closed_pipe
    (fun function_parameter =>
      let 'tt := function_parameter in
      Lwt_pipe.pop (messages reader)).

Definition read_now {A B : Type} (function_parameter : t A B)
  : option (Tezos_base__TzPervasives.tzresult (Z * A)) :=
  let '{| reader := reader |} := function_parameter in
  (* ❌ Try-with are not handled *)
  try (Lwt_pipe.pop_now (messages reader)).

Definition stat {A B : Type} (function_parameter : t A B)
  : Tezos_base__TzPervasives.P2p_stat.t :=
  let '{| conn := {| fd := fd |} |} := function_parameter in
  P2p_io_scheduler.stat fd.

Definition close {A B : Type} (op_staroptstar : option bool)
  : (t A B) -> Lwt.t unit :=
  let wait :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun st =>
    op_gtgteq
      (if negb wait then
        Lwt.return_unit
      else
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_pipe.close (messages (reader st)) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_pipe.close (messages (writer st)) in
        worker (writer st))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Reader.shutdown (reader st))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Writer.shutdown (writer st))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_io_scheduler.close None (fd (conn st)))
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Lwt.return_unit)))).

src/lib_p2p/p2p_trigger.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  too_few_connections : unit Lwt_condition.t;
  too_many_connections : unit Lwt_condition.t;
  new_peer : unit Lwt_condition.t;
  new_point : unit Lwt_condition.t;
  new_connection : unit Lwt_condition.t;
}

let create () =
  {
    too_few_connections = Lwt_condition.create ();
    too_many_connections = Lwt_condition.create ();
    new_peer = Lwt_condition.create ();
    new_point = Lwt_condition.create ();
    new_connection = Lwt_condition.create ();
  }

let wait_too_few_connections t = Lwt_condition.wait t.too_few_connections

let wait_too_many_connections t = Lwt_condition.wait t.too_many_connections

let wait_new_peer t = Lwt_condition.wait t.new_peer

let wait_new_point t = Lwt_condition.wait t.new_point

let wait_new_connection t = Lwt_condition.wait t.new_connection

let broadcast_new_point t = Lwt_condition.broadcast t.new_point ()

let broadcast_new_connection t = Lwt_condition.broadcast t.new_connection ()

let broadcast_new_peer t = Lwt_condition.broadcast t.new_peer ()

let broadcast_too_few_connections t =
  Lwt_condition.broadcast t.too_few_connections ()

let broadcast_too_many_connections t =
  Lwt_condition.broadcast t.too_many_connections ()
src/lib_p2p/p2p_trigger.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  too_few_connections : Lwt_condition.t unit;
  too_many_connections : Lwt_condition.t unit;
  new_peer : Lwt_condition.t unit;
  new_point : Lwt_condition.t unit;
  new_connection : Lwt_condition.t unit }.

Definition create (function_parameter : unit) : t :=
  let 'tt := function_parameter in
  {| too_few_connections := Lwt_condition.create tt;
    too_many_connections := Lwt_condition.create tt;
    new_peer := Lwt_condition.create tt; new_point := Lwt_condition.create tt;
    new_connection := Lwt_condition.create tt |}.

Definition wait_too_few_connections (t : t) : Lwt.t unit :=
  Lwt_condition.wait None (too_few_connections t).

Definition wait_too_many_connections (t : t) : Lwt.t unit :=
  Lwt_condition.wait None (too_many_connections t).

Definition wait_new_peer (t : t) : Lwt.t unit :=
  Lwt_condition.wait None (new_peer t).

Definition wait_new_point (t : t) : Lwt.t unit :=
  Lwt_condition.wait None (new_point t).

Definition wait_new_connection (t : t) : Lwt.t unit :=
  Lwt_condition.wait None (new_connection t).

Definition broadcast_new_point (t : t) : unit :=
  Lwt_condition.broadcast (new_point t) tt.

Definition broadcast_new_connection (t : t) : unit :=
  Lwt_condition.broadcast (new_connection t) tt.

Definition broadcast_new_peer (t : t) : unit :=
  Lwt_condition.broadcast (new_peer t) tt.

Definition broadcast_too_few_connections (t : t) : unit :=
  Lwt_condition.broadcast (too_few_connections t) tt.

Definition broadcast_too_many_connections (t : t) : unit :=
  Lwt_condition.broadcast (too_many_connections t) tt.

src/lib_p2p/p2p_welcome.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "p2p.welcome"
end)

type connect_handler =
  | Connect_handler :
      ('msg, 'meta, 'meta_conn) P2p_connect_handler.t
      -> connect_handler

type t = {
  socket : Lwt_unix.file_descr;
  canceler : Lwt_canceler.t;
  connect_handler : connect_handler;
  mutable worker : unit Lwt.t;
}

let rec worker_loop st =
  let (Connect_handler pool) = st.connect_handler in
  Lwt_unix.yield ()
  >>= fun () ->
  protect ~canceler:st.canceler (fun () -> P2p_fd.accept st.socket >>= return)
  >>= function
  | Ok (fd, addr) ->
      let point =
        match addr with
        | Lwt_unix.ADDR_UNIX _ ->
            assert false
        | Lwt_unix.ADDR_INET (addr, port) ->
            (Ipaddr_unix.V6.of_inet_addr_exn addr, port)
      in
      P2p_connect_handler.accept pool fd point ;
      worker_loop st
  (* Unix errors related to the failure to create one connection,
     No reason to abort just now, but we want to stress out that we
     have a problem preventing us from accepting new connections. *)
  | Error
      ( Exn
          (Unix.Unix_error
            ( ( EMFILE (* Too many open files by the process *)
              | ENFILE (* Too many open files in the system *)
              | ENETDOWN (* Network is down *) ),
              _,
              _ ))
        :: _ as err ) ->
      lwt_log_error
        "@[<v 2>Incoming connection failed with %a in the\n\
        \      Welcome worker. Resuming in 5s.@]"
        pp_print_error
        err
      >>= fun () ->
      (* These are temporary system errors, giving some time for the system to
         recover *)
      Lwt_unix.sleep 5. >>= fun () -> worker_loop st
  | Error
      ( Exn
          (Unix.Unix_error
            ( ( EAGAIN (* Resource temporarily unavailable; try again *)
              | EWOULDBLOCK (* Operation would block *)
              | ENOPROTOOPT (* Protocol not available *)
              | EOPNOTSUPP (* Operation not supported on socket *)
              | ENETUNREACH (* Network is unreachable *)
              | ECONNABORTED (* Software caused connection abort *)
              | ECONNRESET (* Connection reset by peer *)
              | ETIMEDOUT (* Connection timed out *)
              | EHOSTDOWN (* Host is down *)
              | EHOSTUNREACH (* No route to host *)
              (* Ugly hack to catch EPROTO and ENONET, Protocol error, which are not
       defined in the Unix module (which is 20 years late on the POSIX
       standard). A better solution is to use the package ocaml-unix-errno or
       redo the work *)
              | EUNKNOWNERR (71 | 64)
              (* On Linux EPROTO is 71, ENONET is 64
       On BSD systems, accept cannot raise EPROTO.
       71 is EREMOTE   for openBSD, NetBSD, Darwin, which is irrelevant here
       64 is EHOSTDOWN for openBSD, NetBSD, Darwin, which is already caught
    *)
                ),
              _,
              _ ))
        :: _ as err ) ->
      (* These are socket-specific errors, ignoring. *)
      lwt_log_error
        "@[<v 2>Incoming connection failed with %a in the Welcome worker@]"
        pp_print_error
        err
      >>= fun () -> worker_loop st
  | Error (Canceled :: _) ->
      Lwt.return_unit
  | Error err ->
      lwt_log_error
        "@[<v 2>Unexpected error in the Welcome worker@ %a@]"
        pp_print_error
        err

let create_listening_socket ~backlog ?(addr = Ipaddr.V6.unspecified) port =
  let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
  Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
  Lwt_unix.bind
    main_socket
    Unix.(ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port))
  >>= fun () ->
  Lwt_unix.listen main_socket backlog ;
  Lwt.return main_socket

let create ?addr ~backlog connect_handler port =
  Lwt.catch
    (fun () ->
      create_listening_socket ~backlog ?addr port
      >>= fun socket ->
      let canceler = Lwt_canceler.create () in
      Lwt_canceler.on_cancel canceler (fun () ->
          Lwt_utils_unix.safe_close socket) ;
      let st =
        {
          socket;
          canceler;
          connect_handler = Connect_handler connect_handler;
          worker = Lwt.return_unit;
        }
      in
      Lwt.return st)
    (fun exn ->
      lwt_log_error
        "@[<v 2>Cannot accept incoming connections@ %a@]"
        pp_exn
        exn
      >>= fun () -> Lwt.fail exn)

let activate st =
  st.worker <-
    Lwt_utils.worker
      "welcome"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop st)
      ~cancel:(fun () -> Lwt_canceler.cancel st.canceler)

let shutdown st = Lwt_canceler.cancel st.canceler >>= fun () -> st.worker
src/lib_p2p/p2p_welcome.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Inductive connect_handler : Type :=
| Connect_handler : forall {meta meta_conn msg : Type},
  (Tezos_p2p.P2p_connect_handler.t msg meta meta_conn) -> connect_handler.

Record t := {
  socket : Lwt_unix.file_descr;
  canceler : Tezos_stdlib.Lwt_canceler.t;
  connect_handler : connect_handler;
  worker : Lwt.t unit }.

Fixpoint worker_loop (st : t) : Lwt.t unit :=
  let 'Connect_handler pool := connect_handler st in
  op_gtgteq (Lwt_unix.yield tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (protect None (Some (canceler st))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (P2p_fd.accept (socket st)) _return))
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok (fd, addr) =>
            let point :=
              match addr with
              | Lwt_unix.ADDR_UNIX _ =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              | Lwt_unix.ADDR_INET addr port =>
                ((Ipaddr_unix.V6.of_inet_addr_exn addr), port)
              end in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := P2p_connect_handler.accept pool fd point in
            worker_loop st
          |
            Stdlib.Error
              ((cons
                (Tezos_base__TzPervasives.Exn
                  (Unix_error (Unix.EMFILE | Unix.ENFILE | Unix.ENETDOWN) _ _))
                _) as err) =>
            op_gtgteq
              (lwt_log_error
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Incoming connection failed with " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " in the
      Welcome worker. Resuming in 5s." %
                            string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))
                  "@[<v 2>Incoming connection failed with %a in the
      Welcome worker. Resuming in 5s.@]"
                    % string) pp_print_error err)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Lwt_unix.sleep
                    (* ❌ Float constant 5. is approximated by the integer 5 *)
                    5)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    worker_loop st))
          |
            Stdlib.Error
              ((cons
                (Tezos_base__TzPervasives.Exn
                  (Unix_error
                    (Unix.EAGAIN | Unix.EWOULDBLOCK | Unix.ENOPROTOOPT |
                      Unix.EOPNOTSUPP | Unix.ENETUNREACH | Unix.ECONNABORTED |
                      Unix.ECONNRESET | Unix.ETIMEDOUT | Unix.EHOSTDOWN |
                      Unix.EHOSTUNREACH | Unix.EUNKNOWNERR (71 | 64)) _ _)) _)
                as err) =>
            op_gtgteq
              (lwt_log_error
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Incoming connection failed with " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " in the Welcome worker" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))
                  "@[<v 2>Incoming connection failed with %a in the Welcome worker@]"
                    % string) pp_print_error err)
              (fun function_parameter =>
                let 'tt := function_parameter in
                worker_loop st)
          | Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) =>
            Lwt.return_unit
          | Stdlib.Error err =>
            lwt_log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal "<v 2>" % string
                        CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Unexpected error in the Welcome worker" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))
                "@[<v 2>Unexpected error in the Welcome worker@ %a@]" % string)
              pp_print_error err
          end)).

Definition create_listening_socket
  (backlog : Z) (op_staroptstar : option Ipaddr.V6.t)
  : Z -> Lwt.t Lwt_unix.file_descr :=
  let addr :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Ipaddr.V6.unspecified
    end in
  fun port =>
    let main_socket := socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := setsockopt main_socket Lwt_unix.SO_REUSEADDR true in
    op_gtgteq
      (Lwt_unix.bind main_socket
        (Unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port))
      (fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_unix.listen main_socket backlog in
        Lwt._return main_socket).

Definition create {A B C : Type}
  (addr : option Ipaddr.V6.t) (backlog : Z)
  (connect_handler : Tezos_p2p.P2p_connect_handler.t A B C) (port : Z)
  : Lwt.t t :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (create_listening_socket backlog addr port)
        (fun socket =>
          let canceler := Lwt_canceler.create tt in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Lwt_canceler.on_cancel canceler
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt_utils_unix.safe_close socket) in
          let st :=
            {| socket := socket; canceler := canceler;
              connect_handler := Connect_handler connect_handler;
              worker := Lwt.return_unit |} in
          Lwt._return st))
    (fun exn =>
      op_gtgteq
        (lwt_log_error
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Cannot accept incoming connections" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 2>Cannot accept incoming connections@ %a@]" % string) pp_exn
          exn)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt.fail exn)).

Definition activate (st : t) : unit :=
  (* ❌ Set record field not handled. *)
  set_record_field st "worker" % string
    (Lwt_utils.worker "welcome" % string
      Internal_event.Lwt_worker_event.on_event
      (fun function_parameter =>
        let 'tt := function_parameter in
        worker_loop st)
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_canceler.cancel (canceler st))).

Definition shutdown (st : t) : Lwt.t unit :=
  op_gtgteq (Lwt_canceler.cancel (canceler st))
    (fun function_parameter =>
      let 'tt := function_parameter in
      worker st).

src/lib_p2p/test/process.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

let () = Lwt_unix.set_default_async_method Async_none

let section = Lwt_log.Section.make "process"

let log_f ~level format =
  if level < Lwt_log.Section.level section then
    Format.ikfprintf (fun _ -> Lwt.return_unit) Format.std_formatter format
  else Format.kasprintf (fun msg -> Lwt_log.log ~section ~level msg) format

let lwt_debug fmt = log_f ~level:Lwt_log.Debug fmt

let lwt_log_notice fmt = log_f ~level:Lwt_log.Notice fmt

let lwt_log_info fmt = log_f ~level:Lwt_log.Info fmt

let lwt_log_error fmt = log_f ~level:Lwt_log.Error fmt

exception Exited of int

exception Signaled of int

exception Stopped of int

let handle_error f =
  Lwt.catch f (fun exn -> Lwt.return_error [Exn exn])
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error err ->
      lwt_debug "%a" pp_print_error err >>= fun () -> exit 1

module Channel = struct
  type ('a, 'b) t = Lwt_io.input_channel * Lwt_io.output_channel

  let push (_, outch) v =
    Lwt.catch
      (fun () -> Lwt_io.write_value outch v >>= Lwt.return_ok)
      (fun exn -> Lwt.return_error [Exn exn])

  let pop (inch, _) =
    Lwt.catch
      (fun () -> Lwt_io.read_value inch >>= Lwt.return_ok)
      (fun exn -> Lwt.return_error [Exn exn])
end

let wait pid =
  Lwt.catch
    (fun () ->
      Lwt_unix.waitpid [] pid
      >>= function
      | (_, Lwt_unix.WEXITED 0) ->
          Lwt.return_ok ()
      | (_, Lwt_unix.WEXITED n) ->
          Lwt.return_error [Exn (Exited n)]
      | (_, Lwt_unix.WSIGNALED n) ->
          Lwt.return_error [Exn (Signaled n)]
      | (_, Lwt_unix.WSTOPPED n) ->
          Lwt.return_error [Exn (Stopped n)])
    (function
      | Lwt.Canceled ->
          Unix.kill pid Sys.sigkill ; Lwt.return_ok ()
      | exn ->
          Lwt.return_error [Exn exn])

type ('a, 'b) t = {
  termination : unit tzresult Lwt.t;
  channel : ('b, 'a) Channel.t;
}

let template = "$(date) - $(section): $(message)"

let detach ?(prefix = "") f =
  Lwt_io.flush_all ()
  >>= fun () ->
  let (main_in, child_out) = Lwt_io.pipe () in
  let (child_in, main_out) = Lwt_io.pipe () in
  match Lwt_unix.fork () with
  | 0 ->
      Lwt_log.default :=
        Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ;
      Random.self_init () ;
      let template = Format.asprintf "%s$(message)" prefix in
      Lwt_main.run
        ( Lwt_io.close main_in
        >>= fun () ->
        Lwt_io.close main_out
        >>= fun () ->
        Lwt_log.default :=
          Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr () ;
        lwt_log_notice "PID: %d" (Unix.getpid ())
        >>= fun () -> handle_error (fun () -> f (child_in, child_out)) ) ;
      exit 0
  | pid ->
      let termination = wait pid in
      Lwt_io.close child_in
      >>= fun () ->
      Lwt_io.close child_out
      >>= fun () -> Lwt.return {termination; channel = (main_in, main_out)}

let signal_name =
  let names =
    [ (Sys.sigabrt, "ABRT");
      (Sys.sigalrm, "ALRM");
      (Sys.sigfpe, "FPE");
      (Sys.sighup, "HUP");
      (Sys.sigill, "ILL");
      (Sys.sigint, "INT");
      (Sys.sigkill, "KILL");
      (Sys.sigpipe, "PIPE");
      (Sys.sigquit, "QUIT");
      (Sys.sigsegv, "SEGV");
      (Sys.sigterm, "TERM");
      (Sys.sigusr1, "USR1");
      (Sys.sigusr2, "USR2");
      (Sys.sigchld, "CHLD");
      (Sys.sigcont, "CONT");
      (Sys.sigstop, "STOP");
      (Sys.sigtstp, "TSTP");
      (Sys.sigttin, "TTIN");
      (Sys.sigttou, "TTOU");
      (Sys.sigvtalrm, "VTALRM");
      (Sys.sigprof, "PROF");
      (Sys.sigbus, "BUS");
      (Sys.sigpoll, "POLL");
      (Sys.sigsys, "SYS");
      (Sys.sigtrap, "TRAP");
      (Sys.sigurg, "URG");
      (Sys.sigxcpu, "XCPU");
      (Sys.sigxfsz, "XFSZ") ]
  in
  fun n -> List.assoc n names

let wait_all processes =
  let rec loop processes =
    match processes with
    | [] ->
        Lwt.return_none
    | processes -> (
        Lwt.nchoose_split processes
        >>= function
        | (finished, remaining) ->
            let rec handle = function
              | [] ->
                  loop remaining
              | Ok () :: finished ->
                  handle finished
              | Error err :: _ ->
                  Lwt.return_some (err, remaining)
            in
            handle finished )
  in
  loop (List.map (fun p -> p.termination) processes)
  >>= function
  | None ->
      lwt_log_info "All done!" >>= fun () -> Lwt.return_ok ()
  | Some ([Exn (Exited n)], remaining) ->
      lwt_log_error "Early error!"
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ -> failwith "A process finished with error %d !" n
  | Some ([Exn (Signaled n)], remaining) ->
      lwt_log_error "Early error!"
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ -> failwith "A process was killed by a SIG%s !" (signal_name n)
  | Some ([Exn (Stopped n)], remaining) ->
      lwt_log_error "Early error!"
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ ->
      failwith "A process was stopped by a SIG%s !" (signal_name n)
  | Some (err, remaining) ->
      lwt_log_error "@[<v 2>Unexpected error!@,%a@]" pp_print_error err
      >>= fun () ->
      List.iter Lwt.cancel remaining ;
      join remaining
      >>= fun _ -> failwith "A process finished with an unexpected error !"
src/lib_p2p/test/process.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.



Definition section : Lwt_log_core.section :=
  Lwt_log.Section.make "process" % string.

Definition log_f {A : Type}
  (level : Lwt_log.level)
  (format : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  if OCaml.Stdlib.lt level (Lwt_log.Section.level section) then
    Format.ikfprintf
      (fun function_parameter =>
        let '_ := function_parameter in
        Lwt.return_unit) Format.std_formatter format
  else
    Format.kasprintf
      (fun msg => Lwt_log.log None (Some section) None None level msg) format.

Definition lwt_debug {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Debug fmt.

Definition lwt_log_notice {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Notice fmt.

Definition lwt_log_info {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Info fmt.

Definition lwt_log_error {A : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit (Lwt.t unit)) : A :=
  log_f Lwt_log.Error fmt.

(* ❌ The definition of exceptions is not handled. *)
exception

(* ❌ The definition of exceptions is not handled. *)
exception

(* ❌ The definition of exceptions is not handled. *)
exception

Definition handle_error
  (f :
    unit ->
      Lwt.t
        (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)))
  : Lwt.t unit :=
  op_gtgteq
    (Lwt.catch f
      (fun exn =>
        Lwt.return_error
          (cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => Lwt.return_unit
      | Stdlib.Error err =>
        op_gtgteq
          (lwt_debug
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            pp_print_error err)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Stdlib.exit 1)
      end).

Module Channel.
  Definition t (a b : Type) := Lwt_io.input_channel * Lwt_io.output_channel.
  
  Definition push {A B : Type} (function_parameter : A * Lwt_io.output_channel)
    : B ->
      Lwt.t
        (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
    let '(_, outch) := function_parameter in
    fun v =>
      Lwt.catch
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Lwt_io.write_value outch None v) Lwt.return_ok)
        (fun exn =>
          Lwt.return_error
            (cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])).
  
  Definition pop {A B : Type} (function_parameter : Lwt_io.input_channel * A)
    : Lwt.t (Result.result B (list Tezos_base__TzPervasives.Error_monad.error)) :=
    let '(inch, _) := function_parameter in
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Lwt_io.read_value inch) Lwt.return_ok)
      (fun exn =>
        Lwt.return_error
          (cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])).
End Channel.

Definition wait (pid : Z)
  : Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_unix.waitpid [] pid)
        (fun function_parameter =>
          match function_parameter with
          | (_, Lwt_unix.WEXITED 0) => Lwt.return_ok tt
          | (_, Lwt_unix.WEXITED n) =>
            Lwt.return_error
              (cons (Tezos_base__TzPervasives.Error_monad.Exn (Exited n)) [])
          | (_, Lwt_unix.WSIGNALED n) =>
            Lwt.return_error
              (cons (Tezos_base__TzPervasives.Error_monad.Exn (Signaled n)) [])
          | (_, Lwt_unix.WSTOPPED n) =>
            Lwt.return_error
              (cons (Tezos_base__TzPervasives.Error_monad.Exn (Stopped n)) [])
          end))
    (fun function_parameter =>
      match function_parameter with
      | Canceled =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Unix.kill pid Sys.sigkill in
        Lwt.return_ok tt
      | exn =>
        Lwt.return_error
          (cons (Tezos_base__TzPervasives.Error_monad.Exn exn) [])
      end).

Record t {a b : Type} := {
  termination : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit);
  channel : Channel.t b a }.
Arguments t : clear implicits.

Definition template : string := "$(date) - $(section): $(message)" % string.

Definition detach {A B : Type} (op_staroptstar : option string)
  : ((Lwt_io.input_channel * Lwt_io.output_channel) ->
    Lwt.t (Result.result unit (list Tezos_base__TzPervasives.Error_monad.error)))
    -> Lwt.t (t A B) :=
  let prefix :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun f =>
    op_gtgteq (Lwt_io.flush_all tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let '(main_in, child_out) := Lwt_io.pipe None None tt in
        let '(child_in, main_out) := Lwt_io.pipe None None tt in
        match Lwt_unix.fork tt with
        | 0 =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Stdlib.op_coloneq Lwt_log.default
              (Lwt_log.channel (Some template)
                (* ❌ Variants not supported *)
                variant Lwt_io.stderr tt) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Random.self_init tt in
          let template :=
            Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal "$(message)" % string
                    CamlinternalFormatBasics.End_of_format))
                "%s$(message)" % string) prefix in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Lwt_main.run
              (op_gtgteq (Lwt_io.close main_in)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq (Lwt_io.close main_out)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Stdlib.op_coloneq Lwt_log.default
                          (Lwt_log.channel (Some template)
                            (* ❌ Variants not supported *)
                            variant Lwt_io.stderr tt) in
                      op_gtgteq
                        (lwt_log_notice
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "PID: " % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                CamlinternalFormatBasics.End_of_format))
                            "PID: %d" % string) (Unix.getpid tt))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          handle_error
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              f (child_in, child_out)))))) in
          Stdlib.exit 0
        | pid =>
          let termination := wait pid in
          op_gtgteq (Lwt_io.close child_in)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Lwt_io.close child_out)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt._return
                    {| termination := termination;
                      channel := (main_in, main_out) |}))
        end).

Definition signal_name : Z -> string :=
  let names :=
    cons (Sys.sigabrt, "ABRT" % string)
      (cons (Sys.sigalrm, "ALRM" % string)
        (cons (Sys.sigfpe, "FPE" % string)
          (cons (Sys.sighup, "HUP" % string)
            (cons (Sys.sigill, "ILL" % string)
              (cons (Sys.sigint, "INT" % string)
                (cons (Sys.sigkill, "KILL" % string)
                  (cons (Sys.sigpipe, "PIPE" % string)
                    (cons (Sys.sigquit, "QUIT" % string)
                      (cons (Sys.sigsegv, "SEGV" % string)
                        (cons (Sys.sigterm, "TERM" % string)
                          (cons (Sys.sigusr1, "USR1" % string)
                            (cons (Sys.sigusr2, "USR2" % string)
                              (cons (Sys.sigchld, "CHLD" % string)
                                (cons (Sys.sigcont, "CONT" % string)
                                  (cons (Sys.sigstop, "STOP" % string)
                                    (cons (Sys.sigtstp, "TSTP" % string)
                                      (cons (Sys.sigttin, "TTIN" % string)
                                        (cons (Sys.sigttou, "TTOU" % string)
                                          (cons
                                            (Sys.sigvtalrm, "VTALRM" % string)
                                            (cons (Sys.sigprof, "PROF" % string)
                                              (cons (Sys.sigbus, "BUS" % string)
                                                (cons
                                                  (Sys.sigpoll, "POLL" % string)
                                                  (cons
                                                    (Sys.sigsys, "SYS" % string)
                                                    (cons
                                                      (Sys.sigtrap,
                                                        "TRAP" % string)
                                                      (cons
                                                        (Sys.sigurg,
                                                          "URG" % string)
                                                        (cons
                                                          (Sys.sigxcpu,
                                                            "XCPU" % string)
                                                          (cons
                                                            (Sys.sigxfsz,
                                                              "XFSZ" % string)
                                                            [])))))))))))))))))))))))))))
    in
  fun n => List.assoc n names.

Definition wait_all {A B : Type} (processes : list (t A B))
  : Lwt.t (Result.result unit Tezos_base__TzPervasives.Error_monad.trace) :=
  let fix loop {C : Type} (processes : list (Lwt.t (sum unit C)))
    : Lwt.t (option (C * (list (Lwt.t (sum unit C))))) :=
    match processes with
    | [] => Lwt.return_none
    | processes =>
      op_gtgteq (Lwt.nchoose_split processes)
        (fun function_parameter =>
          let '(finished, remaining) := function_parameter in
          let fix handle (function_parameter : list (sum unit C))
            : Lwt.t (option (C * (list (Lwt.t (sum unit C))))) :=
            match function_parameter with
            | [] => loop remaining
            | cons (Stdlib.Ok tt) finished => handle finished
            | cons (Stdlib.Error err) _ => Lwt.return_some (err, remaining)
            end in
          handle finished)
    end in
  op_gtgteq (loop (List.map (fun p => termination p) processes))
    (fun function_parameter =>
      match function_parameter with
      | None =>
        op_gtgteq
          (lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "All done!" % string
                CamlinternalFormatBasics.End_of_format) "All done!" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt.return_ok tt)
      |
        Some
          (cons (Tezos_base__TzPervasives.Error_monad.Exn (Exited n)) [],
            remaining) =>
        op_gtgteq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Early error!" % string
                CamlinternalFormatBasics.End_of_format) "Early error!" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := List.iter Lwt.cancel remaining in
            op_gtgteq (join remaining)
              (fun function_parameter =>
                let '_ := function_parameter in
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "A process finished with error " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal " !" % string
                          CamlinternalFormatBasics.End_of_format)))
                    "A process finished with error %d !" % string) n))
      |
        Some
          (cons (Tezos_base__TzPervasives.Error_monad.Exn (Signaled n)) [],
            remaining) =>
        op_gtgteq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Early error!" % string
                CamlinternalFormatBasics.End_of_format) "Early error!" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := List.iter Lwt.cancel remaining in
            op_gtgteq (join remaining)
              (fun function_parameter =>
                let '_ := function_parameter in
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "A process was killed by a SIG" % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal " !" % string
                          CamlinternalFormatBasics.End_of_format)))
                    "A process was killed by a SIG%s !" % string)
                  (signal_name n)))
      |
        Some
          (cons (Tezos_base__TzPervasives.Error_monad.Exn (Stopped n)) [],
            remaining) =>
        op_gtgteq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Early error!" % string
                CamlinternalFormatBasics.End_of_format) "Early error!" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := List.iter Lwt.cancel remaining in
            op_gtgteq (join remaining)
              (fun function_parameter =>
                let '_ := function_parameter in
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "A process was stopped by a SIG" % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal " !" % string
                          CamlinternalFormatBasics.End_of_format)))
                    "A process was stopped by a SIG%s !" % string)
                  (signal_name n)))
      | Some (err, remaining) =>
        op_gtgteq
          (lwt_log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Unexpected error!" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "@[<v 2>Unexpected error!@,%a@]" % string) pp_print_error err)
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := List.iter Lwt.cancel remaining in
            op_gtgteq (join remaining)
              (fun function_parameter =>
                let '_ := function_parameter in
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "A process finished with an unexpected error !" % string
                      CamlinternalFormatBasics.End_of_format)
                    "A process finished with an unexpected error !" % string)))
      end).

src/lib_p2p/test/test_p2p_banned_peers.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-banned_peers"
end)

let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg

let a (peer, addr) =
  (P2p_peer.Id.hash_string [peer], Ipaddr.V6.of_string_exn addr)

let foo = a ("foo", "ffff::3")

let bar = a ("bar", "ffff:00::ff")

let baz = a ("baz", "a::2")

let peers = [foo; bar; baz]

let test_empty _ =
  let empty = P2p_acl.create 10 in
  List.iter
    (fun (_peer, addr) ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr empty addr))
    peers ;
  Lwt.return_unit

let test_ban _ =
  let set = P2p_acl.create 10 in
  List.iter
    (fun (_, addr) -> P2p_acl.IPGreylist.add set addr Ptime.epoch)
    peers ;
  List.iter
    (fun (_, addr) ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr))
    peers ;
  Lwt.return_unit

let test_gc _ =
  let set = P2p_acl.create 10 in
  List.iter
    (fun (_, addr) -> P2p_acl.IPGreylist.add set addr Ptime.epoch)
    peers ;
  List.iter
    (fun (_peer, addr) ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.banned_addr set addr))
    peers ;
  (* remove all peers *)
  P2p_acl.IPGreylist.remove_old set ~older_than:Ptime.max ;
  List.iter
    (fun (_peer, addr) ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.banned_addr set addr))
    peers ;
  Lwt.return_unit

let () =
  let init_logs = lazy (Internal_event_unix.init ()) in
  let wrap (n, f) =
    Alcotest_lwt.test_case n `Quick (fun _ () ->
        Lazy.force init_logs >>= fun () -> f ())
  in
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.peerset",
        List.map
          wrap
          [("empty", test_empty); ("ban", test_ban); ("gc", test_gc)] ) ]
src/lib_p2p/test/test_p2p_banned_peers.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition assert_equal_bool {A B : Type} (msg : A) (a : B) (b : B) : unit :=
  if nequiv_decb a b then
    op_startypeminuserrorstar msg
  else
    tt.

Definition a (function_parameter : string * string)
  : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  let '(peer, addr) := function_parameter in
  ((P2p_peer.Id.hash_string None (cons peer [])), (Ipaddr.V6.of_string_exn addr)).

Definition foo : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  a ("foo" % string, "ffff::3" % string).

Definition bar : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  a ("bar" % string, "ffff:00::ff" % string).

Definition baz : Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t :=
  a ("baz" % string, "a::2" % string).

Definition peers
  : list (Tezos_base__TzPervasives.P2p_peer.Id.t * Ipaddr.V6.t) :=
  cons foo (cons bar (cons baz [])).

Definition test_empty {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  let empty := P2p_acl.create 10 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(_peer, addr) := function_parameter in
        assert_equal_bool Stdlib.__LOC__ false (P2p_acl.banned_addr empty addr))
      peers in
  Lwt.return_unit.

Definition test_ban {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  let set := P2p_acl.create 10 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(_, addr) := function_parameter in
        P2p_acl.IPGreylist.add set addr Ptime.epoch) peers in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(_, addr) := function_parameter in
        assert_equal_bool Stdlib.__LOC__ true (P2p_acl.banned_addr set addr))
      peers in
  Lwt.return_unit.

Definition test_gc {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  let set := P2p_acl.create 10 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(_, addr) := function_parameter in
        P2p_acl.IPGreylist.add set addr Ptime.epoch) peers in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(_peer, addr) := function_parameter in
        assert_equal_bool Stdlib.__LOC__ true (P2p_acl.banned_addr set addr))
      peers in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_acl.IPGreylist.remove_old set Ptime.max in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(_peer, addr) := function_parameter in
        assert_equal_bool Stdlib.__LOC__ false (P2p_acl.banned_addr set addr))
      peers in
  Lwt.return_unit.



src/lib_p2p/test/test_p2p_io_scheduler.ml 18 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-io-scheduler"
end)

exception Error of error list

let rec listen ?port addr =
  let tentative_port =
    match port with None -> 1024 + Random.int 8192 | Some port -> port
  in
  let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
  Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
  Lwt.catch
    (fun () ->
      Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port))
      >>= fun () ->
      Lwt_unix.listen main_socket 50 ;
      Lwt.return (main_socket, tentative_port))
    (function
      | Unix.Unix_error ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _)
        when port = None ->
          listen addr
      | exn ->
          Lwt.fail exn)

let accept main_socket =
  P2p_fd.accept main_socket >>= fun (fd, _sockaddr) -> return fd

let rec accept_n main_socket n =
  if n <= 0 then return_nil
  else
    accept_n main_socket (n - 1)
    >>=? fun acc -> accept main_socket >>=? fun conn -> return (conn :: acc)

let connect addr port =
  let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr = Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
  P2p_fd.connect fd uaddr >>= fun () -> return fd

let simple_msgs =
  [| Bytes.create (1 lsl 6);
     Bytes.create (1 lsl 7);
     Bytes.create (1 lsl 8);
     Bytes.create (1 lsl 9);
     Bytes.create (1 lsl 10);
     Bytes.create (1 lsl 11);
     Bytes.create (1 lsl 12);
     Bytes.create (1 lsl 13);
     Bytes.create (1 lsl 14);
     Bytes.create (1 lsl 15);
     Bytes.create (1 lsl 16) |]

let nb_simple_msgs = Array.length simple_msgs

let receive conn =
  let buf = Bytes.create (1 lsl 16) in
  let rec loop () =
    P2p_io_scheduler.read conn buf
    >>= function
    | Ok _ ->
        loop ()
    | Error (P2p_errors.Connection_closed :: _) ->
        Lwt.return_unit
    | Error err ->
        Lwt.fail (Error err)
  in
  loop ()

let server ?(display_client_stat = true) ?max_download_speed ?read_queue_size
    ~read_buffer_size main_socket n =
  let sched =
    P2p_io_scheduler.create
      ?max_download_speed
      ?read_queue_size
      ~read_buffer_size
      ()
  in
  Moving_average.on_update (fun () ->
      log_notice "Stat: %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
      if display_client_stat then
        P2p_io_scheduler.iter_connection sched (fun conn ->
            log_notice
              " client(%d) %a"
              (P2p_io_scheduler.id conn)
              P2p_stat.pp
              (P2p_io_scheduler.stat conn))) ;
  (* Accept and read message until the connection is closed. *)
  accept_n main_socket n
  >>=? fun conns ->
  let conns = List.map (P2p_io_scheduler.register sched) conns in
  Lwt.join (List.map receive conns)
  >>= fun () ->
  iter_p P2p_io_scheduler.close conns
  >>=? fun () ->
  log_notice "OK %a" P2p_stat.pp (P2p_io_scheduler.global_stat sched) ;
  return_unit

let max_size ?max_upload_speed () =
  match max_upload_speed with
  | None ->
      nb_simple_msgs
  | Some max_upload_speed ->
      let rec loop n =
        if n <= 1 then 1
        else if Bytes.length simple_msgs.(n - 1) <= max_upload_speed then n
        else loop (n - 1)
      in
      loop nb_simple_msgs

let rec send conn nb_simple_msgs =
  Lwt_main.yield ()
  >>= fun () ->
  let msg = simple_msgs.(Random.int nb_simple_msgs) in
  P2p_io_scheduler.write conn msg >>=? fun () -> send conn nb_simple_msgs

let client ?max_upload_speed ?write_queue_size addr port time _n =
  let sched =
    P2p_io_scheduler.create
      ?max_upload_speed
      ?write_queue_size
      ~read_buffer_size:(1 lsl 12)
      ()
  in
  connect addr port
  >>=? fun conn ->
  let conn = P2p_io_scheduler.register sched conn in
  let nb_simple_msgs = max_size ?max_upload_speed () in
  Lwt.pick [send conn nb_simple_msgs; Lwt_unix.sleep time >>= return]
  >>=? fun () ->
  P2p_io_scheduler.close conn
  >>=? fun () ->
  let stat = P2p_io_scheduler.stat conn in
  lwt_log_notice "Client OK %a" P2p_stat.pp stat >>= fun () -> return_unit

let run ?display_client_stat ?max_download_speed ?max_upload_speed
    ~read_buffer_size ?read_queue_size ?write_queue_size addr port time n =
  Internal_event_unix.init ()
  >>= fun () ->
  listen ?port addr
  >>= fun (main_socket, port) ->
  Process.detach ~prefix:"server: " (fun _ ->
      server
        ?display_client_stat
        ?max_download_speed
        ~read_buffer_size
        ?read_queue_size
        main_socket
        n)
  >>= fun server_node ->
  let client n =
    let prefix = Printf.sprintf "client(%d): " n in
    Process.detach ~prefix (fun _ ->
        Lwt_utils_unix.safe_close main_socket
        >>= fun () ->
        client ?max_upload_speed ?write_queue_size addr port time n)
  in
  Lwt_list.map_p client (1 -- n)
  >>= fun client_nodes -> Process.wait_all (server_node :: client_nodes)

let () = Random.self_init ()

let addr = ref Ipaddr.V6.localhost

let port = ref None

let max_download_speed = ref None

let max_upload_speed = ref None

let read_buffer_size = ref (1 lsl 14)

let read_queue_size = ref (Some (1 lsl 14))

let write_queue_size = ref (Some (1 lsl 14))

let delay = ref 60.

let clients = ref 8

let display_client_stat = ref None

let spec =
  Arg.
    [ ("--port", Int (fun p -> port := Some p), " Listening port");
      ( "--addr",
        String (fun p -> addr := Ipaddr.V6.of_string_exn p),
        " Listening addr" );
      ( "--max-download-speed",
        Int (fun i -> max_download_speed := Some i),
        " Max download speed in B/s (default: unbounded)" );
      ( "--max-upload-speed",
        Int (fun i -> max_upload_speed := Some i),
        " Max upload speed in B/s (default: unbounded)" );
      ( "--read-buffer-size",
        Set_int read_buffer_size,
        " Size of the read buffers" );
      ( "--read-queue-size",
        Int (fun i -> read_queue_size := if i <= 0 then None else Some i),
        " Size of the read queue (0=unbounded)" );
      ( "--write-queue-size",
        Int (fun i -> write_queue_size := if i <= 0 then None else Some i),
        " Size of the write queue (0=unbounded)" );
      ("--delay", Set_float delay, " Client execution time.");
      ("--clients", Set_int clients, " Number of concurrent clients.");
      ( "--hide-clients-stat",
        Unit (fun () -> display_client_stat := Some false),
        " Hide the client bandwidth statistic." );
      ( "--display_clients_stat",
        Unit (fun () -> display_client_stat := Some true),
        " Display the client bandwidth statistic." ) ]

let () =
  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
  let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg

let init_logs = lazy (Internal_event_unix.init ())

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lazy.force init_logs
      >>= fun () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.io-scheduler",
        [ wrap "trivial-quota" (fun () ->
              run
                ?display_client_stat:!display_client_stat
                ?max_download_speed:!max_download_speed
                ?max_upload_speed:!max_upload_speed
                ~read_buffer_size:!read_buffer_size
                ?read_queue_size:!read_queue_size
                ?write_queue_size:!write_queue_size
                !addr
                !port
                !delay
                !clients) ] ) ]
src/lib_p2p/test/test_p2p_io_scheduler.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ The definition of exceptions is not handled. *)
exception

Fixpoint listen (port : option Z) (addr : Ipaddr.V6.t)
  : Lwt.t (Lwt_unix.file_descr * Z) :=
  let tentative_port :=
    match port with
    | None => Z.add 1024 (Random.int 8192)
    | Some port => port
    end in
  let uaddr := Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket := socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := setsockopt main_socket Lwt_unix.SO_REUSEADDR true in
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (Lwt_unix.bind main_socket (Lwt_unix.ADDR_INET uaddr tentative_port))
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_unix.listen main_socket 50 in
          Lwt._return (main_socket, tentative_port)))
    (fun function_parameter =>
      match function_parameter with
      | Unix_error (Unix.EADDRINUSE | Unix.EADDRNOTAVAIL) _ _ =>
        listen None addr
      | exn => Lwt.fail exn
      end).

Definition accept (main_socket : Lwt_unix.file_descr)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_p2p.P2p_fd.t) :=
  op_gtgteq (P2p_fd.accept main_socket)
    (fun function_parameter =>
      let '(fd, _sockaddr) := function_parameter in
      _return fd).

Fixpoint accept_n (main_socket : Lwt_unix.file_descr) (n : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (list Tezos_p2p.P2p_fd.t)) :=
  if OCaml.Stdlib.le n 0 then
    return_nil
  else
    op_gtgteqquestion (accept_n main_socket (Z.sub n 1))
      (fun acc =>
        op_gtgteqquestion (accept main_socket)
          (fun conn => _return (cons conn acc))).

Definition connect (addr : Ipaddr.V6.t) (port : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_p2p.P2p_fd.t) :=
  let fd := P2p_fd.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
  let uaddr := Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port in
  op_gtgteq (P2p_fd.connect fd uaddr)
    (fun function_parameter =>
      let 'tt := function_parameter in
      _return fd).

Definition simple_msgs : array string :=
  (* ❌ Arrays not handled. *)
  [
    Stdlib.Bytes.create (Z.shiftl 1 6);
    Stdlib.Bytes.create (Z.shiftl 1 7);
    Stdlib.Bytes.create (Z.shiftl 1 8);
    Stdlib.Bytes.create (Z.shiftl 1 9);
    Stdlib.Bytes.create (Z.shiftl 1 10);
    Stdlib.Bytes.create (Z.shiftl 1 11);
    Stdlib.Bytes.create (Z.shiftl 1 12);
    Stdlib.Bytes.create (Z.shiftl 1 13);
    Stdlib.Bytes.create (Z.shiftl 1 14);
    Stdlib.Bytes.create (Z.shiftl 1 15);
    Stdlib.Bytes.create (Z.shiftl 1 16)
  ].

Definition nb_simple_msgs : Z := Array.length simple_msgs.

Definition receive (conn : Tezos_p2p.P2p_io_scheduler.connection)
  : Lwt.t unit :=
  let buf := Stdlib.Bytes.create (Z.shiftl 1 16) in
  let fix loop (function_parameter : unit) : Lwt.t unit :=
    let 'tt := function_parameter in
    op_gtgteq (P2p_io_scheduler.read None conn None None buf)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok _ => loop tt
        | Stdlib.Error (cons Tezos_base__TzPervasives.Connection_closed _) =>
          Lwt.return_unit
        | Stdlib.Error err => Lwt.fail (inr err)
        end) in
  loop tt.

Definition server (op_staroptstar : option bool)
  : (option Z) ->
    (option Z) ->
      Z ->
        Lwt_unix.file_descr ->
          Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let display_client_stat :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun max_download_speed =>
    fun read_queue_size =>
      fun read_buffer_size =>
        fun main_socket =>
          fun n =>
            let sched :=
              P2p_io_scheduler.create None max_download_speed read_queue_size
                None read_buffer_size tt in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Moving_average.on_update
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    log_notice
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Stat: " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "Stat: %a" % string) P2p_stat.pp
                      (P2p_io_scheduler.global_stat sched) in
                  if display_client_stat then
                    P2p_io_scheduler.iter_connection sched
                      (fun conn =>
                        log_notice
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              " client(" % string
                              (CamlinternalFormatBasics.Int
                                CamlinternalFormatBasics.Int_d
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.No_precision
                                (CamlinternalFormatBasics.String_literal
                                  ") " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))))
                            " client(%d) %a" % string)
                          (P2p_io_scheduler.id conn) P2p_stat.pp
                          (P2p_io_scheduler.stat conn))
                  else
                    tt) in
            op_gtgteqquestion (accept_n main_socket n)
              (fun conns =>
                let conns := List.map (P2p_io_scheduler.register sched) conns in
                op_gtgteq (Lwt.join (List.map receive conns))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion
                      (iter_p
                        (let arg := P2p_io_scheduler.close in
                        fun eta => arg None eta) conns)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          log_notice
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "OK " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))
                              "OK %a" % string) P2p_stat.pp
                            (P2p_io_scheduler.global_stat sched) in
                        return_unit))).

Definition max_size (max_upload_speed : option Z) (function_parameter : unit)
  : Z :=
  let 'tt := function_parameter in
  match max_upload_speed with
  | None => nb_simple_msgs
  | Some max_upload_speed =>
    let fix loop (n : Z) : Z :=
      if OCaml.Stdlib.le n 1 then
        1
      else
        if
          OCaml.Stdlib.le (String.length (Array.get simple_msgs (Z.sub n 1)))
            max_upload_speed then
          n
        else
          loop (Z.sub n 1) in
    loop nb_simple_msgs
  end.

Fixpoint send {A : Type}
  (conn : Tezos_p2p.P2p_io_scheduler.connection) (nb_simple_msgs : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  op_gtgteq (Lwt_main.yield tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let msg := Array.get simple_msgs (Random.int nb_simple_msgs) in
      op_gtgteqquestion (P2p_io_scheduler.write None conn msg)
        (fun function_parameter =>
          let 'tt := function_parameter in
          send conn nb_simple_msgs)).

Definition client {A : Type}
  (max_upload_speed : option Z) (write_queue_size : option Z)
  (addr : Ipaddr.V6.t) (port : Z) (time : Z) (_n : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let sched :=
    P2p_io_scheduler.create max_upload_speed None None write_queue_size
      (Z.shiftl 1 12) tt in
  op_gtgteqquestion (connect addr port)
    (fun conn =>
      let conn := P2p_io_scheduler.register sched conn in
      let nb_simple_msgs := max_size max_upload_speed tt in
      op_gtgteqquestion
        (Lwt.pick
          (cons (send conn nb_simple_msgs)
            (cons (op_gtgteq (Lwt_unix.sleep time) _return) [])))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion (P2p_io_scheduler.close None conn)
            (fun function_parameter =>
              let 'tt := function_parameter in
              let stat := P2p_io_scheduler.stat conn in
              op_gtgteq
                (lwt_log_notice
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Client OK " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "Client OK %a" % string) P2p_stat.pp stat)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)))).

Definition run {A : Type}
  (display_client_stat : option bool) (max_download_speed : option Z)
  (max_upload_speed : option Z) (read_buffer_size : Z)
  (read_queue_size : option Z) (write_queue_size : option Z)
  (addr : Ipaddr.V6.t) (port : option Z) (time : Z) (n : Z) : Lwt.t A :=
  op_gtgteq (Internal_event_unix.init None None tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (listen port addr)
        (fun function_parameter =>
          let '(main_socket, port) := function_parameter in
          op_gtgteq
            (op_startypeminuserrorstar "server: " % string
              (fun function_parameter =>
                let '_ := function_parameter in
                server display_client_stat max_download_speed read_queue_size
                  read_buffer_size main_socket n))
            (fun server_node =>
              let client {B : Type} (n : Z) : B :=
                let prefix :=
                  Printf.sprintf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "client(" % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal
                            "): " % string
                            CamlinternalFormatBasics.End_of_format)))
                      "client(%d): " % string) n in
                op_startypeminuserrorstar prefix
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    op_gtgteq (Lwt_utils_unix.safe_close main_socket)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        client max_upload_speed write_queue_size addr port time
                          n)) in
              op_gtgteq (Lwt_list.map_p client (op_minusminus 1 n))
                (fun client_nodes =>
                  op_startypeminuserrorstar (cons server_node client_nodes))))).



Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.

Definition port : Stdlib.ref (option Z) := Stdlib.ref None.

Definition max_download_speed : Stdlib.ref (option Z) := Stdlib.ref None.

Definition max_upload_speed : Stdlib.ref (option Z) := Stdlib.ref None.

Definition read_buffer_size : Stdlib.ref Z := Stdlib.ref (Z.shiftl 1 14).

Definition read_queue_size : Stdlib.ref (option Z) :=
  Stdlib.ref (Some (Z.shiftl 1 14)).

Definition write_queue_size : Stdlib.ref (option Z) :=
  Stdlib.ref (Some (Z.shiftl 1 14)).

Definition delay : Stdlib.ref Z :=
  Stdlib.ref
    (* ❌ Float constant 60. is approximated by the integer 60 *)
    60.

Definition clients : Stdlib.ref Z := Stdlib.ref 8.

Definition display_client_stat : Stdlib.ref (option bool) := Stdlib.ref None.

Definition spec : list (string * Stdlib.Arg.spec * string) :=
  cons
    ("--port" % string,
      (Stdlib.Arg.Int (fun p => Stdlib.op_coloneq port (Some p))),
      " Listening port" % string)
    (cons
      ("--addr" % string,
        (Stdlib.Arg.String
          (fun p => Stdlib.op_coloneq addr (Ipaddr.V6.of_string_exn p))),
        " Listening addr" % string)
      (cons
        ("--max-download-speed" % string,
          (Stdlib.Arg.Int
            (fun i => Stdlib.op_coloneq max_download_speed (Some i))),
          " Max download speed in B/s (default: unbounded)" % string)
        (cons
          ("--max-upload-speed" % string,
            (Stdlib.Arg.Int
              (fun i => Stdlib.op_coloneq max_upload_speed (Some i))),
            " Max upload speed in B/s (default: unbounded)" % string)
          (cons
            ("--read-buffer-size" % string,
              (Stdlib.Arg.Set_int read_buffer_size),
              " Size of the read buffers" % string)
            (cons
              ("--read-queue-size" % string,
                (Stdlib.Arg.Int
                  (fun i =>
                    Stdlib.op_coloneq read_queue_size
                      (if OCaml.Stdlib.le i 0 then
                        None
                      else
                        Some i))),
                " Size of the read queue (0=unbounded)" % string)
              (cons
                ("--write-queue-size" % string,
                  (Stdlib.Arg.Int
                    (fun i =>
                      Stdlib.op_coloneq write_queue_size
                        (if OCaml.Stdlib.le i 0 then
                          None
                        else
                          Some i))),
                  " Size of the write queue (0=unbounded)" % string)
                (cons
                  ("--delay" % string, (Stdlib.Arg.Set_float delay),
                    " Client execution time." % string)
                  (cons
                    ("--clients" % string, (Stdlib.Arg.Set_int clients),
                      " Number of concurrent clients." % string)
                    (cons
                      ("--hide-clients-stat" % string,
                        (Stdlib.Arg.Unit
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            Stdlib.op_coloneq display_client_stat (Some false))),
                        " Hide the client bandwidth statistic." % string)
                      (cons
                        ("--display_clients_stat" % string,
                          (Stdlib.Arg.Unit
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              Stdlib.op_coloneq display_client_stat (Some true))),
                          " Display the client bandwidth statistic." % string)
                        [])))))))))).



Definition init_logs : lazy_t (Lwt.t unit) :=
  (* ❌ Lazy expressions are not handled *)
  lazy (Internal_event_unix.init None None tt).

Definition wrap {A B : Type}
  (n : A) (f : unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Lazy.force init_logs)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (f tt)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => Lwt.return_unit
                | Stdlib.Error error =>
                  Format.kasprintf Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    pp_print_error error
                end))).



src/lib_p2p/test/test_p2p_ipv6set.ml 59 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-banned_ip"
end)

let assert_equal ?(eq = ( = )) ?prn ~msg a b =
  let msg =
    match prn with
    | None ->
        msg
    | Some prn ->
        Format.asprintf "@[<v 2>%s@,n(%a)@,<>@,(%a)@]" msg prn a prn b
  in
  if not (eq a b) then Alcotest.fail msg

let assert_equal_bool = assert_equal

let a = Ipaddr.V6.of_string_exn

let p = Ipaddr.V6.Prefix.of_string_exn

let timenow = Systime_os.now ()

let of_list l =
  List.fold_left
    (fun acc k -> P2p_acl.IpSet.add_prefix k timenow acc)
    P2p_acl.IpSet.empty
    l

let test_empty _ =
  let addrs = List.map a ["::"; "ffff::"; "a::2"] in
  List.iter
    (fun addr ->
      assert_equal_bool
        ~msg:__LOC__
        false
        (P2p_acl.IpSet.mem addr P2p_acl.IpSet.empty))
    addrs

let test_inclusion _ =
  let set =
    P2p_acl.IpSet.add_prefix (p "ffff::/16") timenow P2p_acl.IpSet.empty
  in
  let included = List.map a ["ffff::3"; "ffff:ffff::"; "ffff:00::ff"] in
  let not_included = List.map a ["fffe::3"; "ffee:ffff::"; "::"] in
  List.iter
    (fun addr ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.IpSet.mem addr set))
    included ;
  List.iter
    (fun addr ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.IpSet.mem addr set))
    not_included ;
  let set =
    P2p_acl.IpSet.add_prefix (p "f000::/4") timenow P2p_acl.IpSet.empty
  in
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "e000::") set) ;
  (* Add one IP *)
  let set =
    P2p_acl.IpSet.add_prefix (p "::/128") timenow P2p_acl.IpSet.empty
  in
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "1::") set) ;
  let set =
    P2p_acl.IpSet.add_prefix (p "ffff:eeee::/32") timenow P2p_acl.IpSet.empty
  in
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "eeee:ffff::1") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "ffff:eeee::1") set) ;
  let set = P2p_acl.IpSet.add_prefix (p "::/17") timenow P2p_acl.IpSet.empty in
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "0000:0000::") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "0000:7000::") set) ;
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "0000:8000::1") set) ;
  let setlist = [p "e000::/4"; p "a000::/4"; p "ffff::/16"] in
  let set = of_list setlist in
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "ffff::1") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "a111:8000::1") set) ;
  let set =
    of_list [p "e000::/4"; p "a000::/4"; p "1234:5678::1/128"; p "ffff::/16"]
  in
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "1234:5678::1") set) ;
  assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem (a "a111:8000::1") set) ;
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "b111:8000::1") set) ;
  assert_equal ~msg:__LOC__ false (P2p_acl.IpSet.mem (a "1234:5678::100") set)

let test_contiguous _ =
  let set = of_list [p "::/1"; p "8000::/1"] in
  List.iter
    (fun addr -> assert_equal ~msg:__LOC__ true (P2p_acl.IpSet.mem addr set))
    [a "00::"; a "01::"; a "ff::"]

module PSet = Set.Make (Ipaddr.V6.Prefix)

let test_fold _ =
  let addr_list = [p "::/1"; p "8000::/1"; p "ffff:ffff::/32"] in
  let pset = PSet.of_list addr_list in
  let ipv6set =
    P2p_acl.IpSet.fold
      (fun prefix _value s -> PSet.add prefix s)
      (of_list addr_list)
      PSet.empty
  in
  assert_equal ~eq:PSet.equal ~msg:__LOC__ ipv6set pset

let print_pset ppf pset =
  PSet.iter (fun p -> Format.fprintf ppf "%a " Ipaddr.V6.Prefix.pp p) pset

let print_list ppf l =
  List.iter (fun p -> Format.fprintf ppf "%a " Ipaddr.V6.Prefix.pp p) l

let test_to_list _ =
  let to_list s = P2p_acl.IpSet.fold (fun k _v acc -> k :: acc) s [] in
  let list_eq = List.for_all2 (fun x y -> Ipaddr.V6.Prefix.compare x y = 0) in
  let assert_equal_set ~msg a b =
    let a = List.sort compare a in
    let b = List.sort compare (to_list b) in
    assert_equal ~prn:print_list ~eq:list_eq ~msg a b
  in
  let set = P2p_acl.IpSet.add_prefix (p "::/0") timenow P2p_acl.IpSet.empty in
  assert_equal
    ~eq:list_eq
    ~prn:print_list
    ~msg:__LOC__
    [p "::/0"]
    (to_list set) ;
  let set = of_list [p "::/1"; p "8000::/1"] in
  assert_equal
    ~eq:list_eq
    ~prn:print_list
    ~msg:__LOC__
    [p "8000::/1"; p "::/1"]
    (to_list set) ;
  let setlist = [p "1234:5678::/32"] in
  let set = of_list setlist in
  assert_equal_set ~msg:__LOC__ setlist set ;
  let setlist =
    [p "e000::/4"; p "a000::/4"; p "ffff::/16"; p "1234:5678::/32"]
  in
  let set = of_list setlist in
  assert_equal_set ~msg:__LOC__ setlist set

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.ipv6set",
        [ ("empty", `Quick, test_empty);
          ("inclusion", `Quick, test_inclusion);
          ("contiguous", `Quick, test_contiguous);
          ("test_fold", `Quick, test_fold);
          ("to_list", `Quick, test_to_list) ] ) ]
src/lib_p2p/test/test_p2p_ipv6set.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition assert_equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (Stdlib.Format.formatter -> A -> unit)) -> string -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun prn =>
    fun msg =>
      fun a =>
        fun b =>
          let msg :=
            match prn with
            | None => msg
            | Some prn =>
              Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal "n(" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "<>" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Char_literal
                                      "(" % char
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          ")" % char
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))))))))))
                  "@[<v 2>%s@,n(%a)@,<>@,(%a)@]" % string) msg prn a prn b
            end in
          if negb (eq a b) then
            op_startypeminuserrorstar msg
          else
            tt.

Definition assert_equal_bool {A : Type}
  : (option (A -> A -> bool)) ->
    (option (Stdlib.Format.formatter -> A -> unit)) -> string -> A -> A -> unit :=
  assert_equal.

Definition a : string -> Ipaddr.V6.t := Ipaddr.V6.of_string_exn.

Definition p : string -> Ipaddr.V6.Prefix.t := Ipaddr.V6.Prefix.of_string_exn.

Definition timenow : Ptime.t := Systime_os.now tt.

Definition of_list (l : list Ipaddr.V6.Prefix.t) : Tezos_p2p.P2p_acl.IpSet.t :=
  List.fold_left (fun acc => fun k => P2p_acl.IpSet.add_prefix k timenow acc)
    P2p_acl.IpSet.empty l.

Definition test_empty {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let addrs :=
    List.map a
      (cons "::" % string (cons "ffff::" % string (cons "a::2" % string []))) in
  List.iter
    (fun addr =>
      assert_equal_bool None None Stdlib.__LOC__ false
        (P2p_acl.IpSet.mem addr P2p_acl.IpSet.empty)) addrs.

Definition test_inclusion {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let set :=
    P2p_acl.IpSet.add_prefix (p "ffff::/16" % string) timenow
      P2p_acl.IpSet.empty in
  let included :=
    List.map a
      (cons "ffff::3" % string
        (cons "ffff:ffff::" % string (cons "ffff:00::ff" % string []))) in
  let not_included :=
    List.map a
      (cons "fffe::3" % string
        (cons "ffee:ffff::" % string (cons "::" % string []))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun addr =>
        assert_equal_bool None None Stdlib.__LOC__ true
          (P2p_acl.IpSet.mem addr set)) included in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun addr =>
        assert_equal_bool None None Stdlib.__LOC__ false
          (P2p_acl.IpSet.mem addr set)) not_included in
  let set :=
    P2p_acl.IpSet.add_prefix (p "f000::/4" % string) timenow P2p_acl.IpSet.empty
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ false
      (P2p_acl.IpSet.mem (a "e000::" % string) set) in
  let set :=
    P2p_acl.IpSet.add_prefix (p "::/128" % string) timenow P2p_acl.IpSet.empty
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ false
      (P2p_acl.IpSet.mem (a "1::" % string) set) in
  let set :=
    P2p_acl.IpSet.add_prefix (p "ffff:eeee::/32" % string) timenow
      P2p_acl.IpSet.empty in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ false
      (P2p_acl.IpSet.mem (a "eeee:ffff::1" % string) set) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "ffff:eeee::1" % string) set) in
  let set :=
    P2p_acl.IpSet.add_prefix (p "::/17" % string) timenow P2p_acl.IpSet.empty in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "0000:0000::" % string) set) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "0000:7000::" % string) set) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ false
      (P2p_acl.IpSet.mem (a "0000:8000::1" % string) set) in
  let setlist :=
    cons (p "e000::/4" % string)
      (cons (p "a000::/4" % string) (cons (p "ffff::/16" % string) [])) in
  let set := of_list setlist in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "ffff::1" % string) set) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "a111:8000::1" % string) set) in
  let set :=
    of_list
      (cons (p "e000::/4" % string)
        (cons (p "a000::/4" % string)
          (cons (p "1234:5678::1/128" % string)
            (cons (p "ffff::/16" % string) [])))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "1234:5678::1" % string) set) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ true
      (P2p_acl.IpSet.mem (a "a111:8000::1" % string) set) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal None None Stdlib.__LOC__ false
      (P2p_acl.IpSet.mem (a "b111:8000::1" % string) set) in
  assert_equal None None Stdlib.__LOC__ false
    (P2p_acl.IpSet.mem (a "1234:5678::100" % string) set).

Definition test_contiguous {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let set :=
    of_list (cons (p "::/1" % string) (cons (p "8000::/1" % string) [])) in
  List.iter
    (fun addr =>
      assert_equal None None Stdlib.__LOC__ true (P2p_acl.IpSet.mem addr set))
    (cons (a "00::" % string)
      (cons (a "01::" % string) (cons (a "ff::" % string) []))).

(* ❌ Applications of functors are not handled. *)
functor_application

Definition test_fold {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let addr_list :=
    cons (p "::/1" % string)
      (cons (p "8000::/1" % string) (cons (p "ffff:ffff::/32" % string) [])) in
  let pset := PSet.of_list addr_list in
  let ipv6set :=
    P2p_acl.IpSet.fold (fun prefix => fun _value => fun s => PSet.add prefix s)
      (of_list addr_list) PSet.empty in
  assert_equal (Some PSet.equal) None Stdlib.__LOC__ ipv6set pset.

Definition print_pset (ppf : Stdlib.Format.formatter) (pset : PSet.t) : unit :=
  PSet.iter
    (fun p =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal " " % char
              CamlinternalFormatBasics.End_of_format)) "%a " % string)
        Ipaddr.V6.Prefix.pp p) pset.

Definition print_list
  (ppf : Stdlib.Format.formatter) (l : list Ipaddr.V6.Prefix.t) : unit :=
  List.iter
    (fun p =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal " " % char
              CamlinternalFormatBasics.End_of_format)) "%a " % string)
        Ipaddr.V6.Prefix.pp p) l.

Definition test_to_list {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let to_list (s : Tezos_p2p.P2p_acl.IpSet.t) : list Ipaddr.V6.Prefix.t :=
    P2p_acl.IpSet.fold (fun k => fun _v => fun acc => cons k acc) s [] in
  let list_eq :=
    List.for_all2
      (fun x => fun y => equiv_decb (Ipaddr.V6.Prefix.compare x y) 0) in
  let assert_equal_set
    (msg : string) (a : list Ipaddr.V6.Prefix.t) (b : Tezos_p2p.P2p_acl.IpSet.t)
    : unit :=
    let a := List.sort OCaml.Stdlib.compare a in
    let b := List.sort OCaml.Stdlib.compare (to_list b) in
    assert_equal (Some list_eq) (Some print_list) msg a b in
  let set :=
    P2p_acl.IpSet.add_prefix (p "::/0" % string) timenow P2p_acl.IpSet.empty in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal (Some list_eq) (Some print_list) Stdlib.__LOC__
      (cons (p "::/0" % string) []) (to_list set) in
  let set :=
    of_list (cons (p "::/1" % string) (cons (p "8000::/1" % string) [])) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal (Some list_eq) (Some print_list) Stdlib.__LOC__
      (cons (p "8000::/1" % string) (cons (p "::/1" % string) [])) (to_list set)
    in
  let setlist := cons (p "1234:5678::/32" % string) [] in
  let set := of_list setlist in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := assert_equal_set Stdlib.__LOC__ setlist set in
  let setlist :=
    cons (p "e000::/4" % string)
      (cons (p "a000::/4" % string)
        (cons (p "ffff::/16" % string) (cons (p "1234:5678::/32" % string) [])))
    in
  let set := of_list setlist in
  assert_equal_set Stdlib.__LOC__ setlist set.



src/lib_p2p/test/test_p2p_peerset.ml 32 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test-p2p-banned_peers"
end)

let assert_equal_bool ~msg a b = if a <> b then Alcotest.fail msg

let a s = P2p_peer.Id.hash_string [s]

let test_empty _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let empty = P2p_acl.PeerRing.create 10 in
  List.iter
    (fun peer ->
      assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem empty peer))
    peers

let test_add _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let set = P2p_acl.PeerRing.create 10 in
  List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
  List.iter
    (fun peer ->
      assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set peer))
    peers

let test_remove _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let set = P2p_acl.PeerRing.create 10 in
  List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "bar")) ;
  P2p_acl.PeerRing.remove set (a "bar") ;
  assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem set (a "bar"))

let test_overflow _ =
  let peers = List.map a ["foo"; "bar"; "baz"] in
  let set = P2p_acl.PeerRing.create 3 in
  List.iter (fun peer -> P2p_acl.PeerRing.add set peer) peers ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "baz")) ;
  P2p_acl.PeerRing.add set (a "zor") ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "zor")) ;
  assert_equal_bool ~msg:__LOC__ false (P2p_acl.PeerRing.mem set (a "foo")) ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "bar")) ;
  assert_equal_bool ~msg:__LOC__ true (P2p_acl.PeerRing.mem set (a "baz"))

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p.peerset",
        [ ("empty", `Quick, test_empty);
          ("add", `Quick, test_add);
          ("overflow", `Quick, test_overflow);
          ("remove", `Quick, test_remove) ] ) ]
src/lib_p2p/test/test_p2p_peerset.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition assert_equal_bool {A B : Type} (msg : A) (a : B) (b : B) : unit :=
  if nequiv_decb a b then
    op_startypeminuserrorstar msg
  else
    tt.

Definition a (s : string) : Tezos_base__TzPervasives.P2p_peer.Id.t :=
  P2p_peer.Id.hash_string None (cons s []).

Definition test_empty {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let peers :=
    List.map a
      (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
  let empty := P2p_acl.PeerRing.create 10 in
  List.iter
    (fun peer =>
      assert_equal_bool Stdlib.__LOC__ false (P2p_acl.PeerRing.mem empty peer))
    peers.

Definition test_add {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let peers :=
    List.map a
      (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
  let set := P2p_acl.PeerRing.create 10 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := List.iter (fun peer => P2p_acl.PeerRing.add set peer) peers in
  List.iter
    (fun peer =>
      assert_equal_bool Stdlib.__LOC__ true (P2p_acl.PeerRing.mem set peer))
    peers.

Definition test_remove {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let peers :=
    List.map a
      (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
  let set := P2p_acl.PeerRing.create 10 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := List.iter (fun peer => P2p_acl.PeerRing.add set peer) peers in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal_bool Stdlib.__LOC__ true
      (P2p_acl.PeerRing.mem set (a "bar" % string)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_acl.PeerRing.remove set (a "bar" % string) in
  assert_equal_bool Stdlib.__LOC__ false
    (P2p_acl.PeerRing.mem set (a "bar" % string)).

Definition test_overflow {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  let peers :=
    List.map a
      (cons "foo" % string (cons "bar" % string (cons "baz" % string []))) in
  let set := P2p_acl.PeerRing.create 3 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := List.iter (fun peer => P2p_acl.PeerRing.add set peer) peers in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal_bool Stdlib.__LOC__ true
      (P2p_acl.PeerRing.mem set (a "baz" % string)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := P2p_acl.PeerRing.add set (a "zor" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal_bool Stdlib.__LOC__ true
      (P2p_acl.PeerRing.mem set (a "zor" % string)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal_bool Stdlib.__LOC__ false
      (P2p_acl.PeerRing.mem set (a "foo" % string)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    assert_equal_bool Stdlib.__LOC__ true
      (P2p_acl.PeerRing.mem set (a "bar" % string)) in
  assert_equal_bool Stdlib.__LOC__ true
    (P2p_acl.PeerRing.mem set (a "baz" % string)).



src/lib_p2p/test/test_p2p_pool.ml 58 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test.p2p.connection-pool"
end)

type message = Ping

let msg_config : message P2p_connect_handler.message_config =
  {
    encoding =
      [ P2p_message.Encoding
          {
            tag = 0x10;
            title = "Ping";
            encoding = Data_encoding.empty;
            wrap = (function () -> Ping);
            unwrap = (function Ping -> Some ());
            max_length = None;
          } ];
    chain_name = Distributed_db_version.sandboxed_chain_name;
    distributed_db_versions = [Distributed_db_version.zero];
  }

type metadata = unit

let peer_meta_config : metadata P2p_pool.peer_meta_config =
  {
    peer_meta_encoding = Data_encoding.empty;
    peer_meta_initial = (fun _ -> ());
    score = (fun () -> 0.);
  }

let conn_meta_config : metadata P2p_socket.metadata_config =
  {
    conn_meta_encoding = Data_encoding.empty;
    conn_meta_value = (fun _ -> ());
    private_node = (fun _ -> false);
  }

let sync ch =
  Process.Channel.push ch ()
  >>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit

let rec sync_nodes nodes =
  iter_p (fun {Process.channel; _} -> Process.Channel.pop channel) nodes
  >>=? fun () ->
  iter_p (fun {Process.channel; _} -> Process.Channel.push channel ()) nodes
  >>=? fun () -> sync_nodes nodes

let sync_nodes nodes =
  sync_nodes nodes
  >>= function
  | Ok () | Error (Exn End_of_file :: _) ->
      return_unit
  | Error _ as err ->
      Lwt.return err

let detach_node f points n =
  let ((addr, port), points) = List.select n points in
  let proof_of_work_target = Crypto_box.make_target 0. in
  let identity = P2p_identity.generate proof_of_work_target in
  let private_mode = true in
  let nb_points = List.length points in
  let connect_handler_cfg =
    P2p_connect_handler.
      {
        identity;
        proof_of_work_target;
        listening_port = Some port;
        private_mode;
        greylisting_config = P2p_point_state.Info.default_greylisting_config;
        min_connections = nb_points;
        max_connections = nb_points;
        max_incoming_connections = nb_points;
        connection_timeout = Time.System.Span.of_seconds_exn 10.;
        authentication_timeout = Time.System.Span.of_seconds_exn 2.;
        incoming_app_message_queue_size = None;
        incoming_message_queue_size = None;
        outgoing_message_queue_size = None;
        binary_chunks_size = None;
      }
  in
  let pool_config =
    P2p_pool.
      {
        identity;
        trusted_points = points;
        peers_file = "/dev/null";
        private_mode;
        max_known_points = None;
        max_known_peer_ids = None;
      }
  in
  (* swap_linger = Time.System.Span.of_seconds_exn 0. ; *)
  Process.detach
    ~prefix:(Format.asprintf "%a: " P2p_peer.Id.pp_short identity.peer_id)
    (fun channel ->
      let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
      let triggers = P2p_trigger.create () in
      let log _ = () in
      P2p_pool.create pool_config peer_meta_config ~log triggers
      >>= fun pool ->
      let answerer = lazy (P2p_protocol.create_private ()) in
      let connect_handler =
        P2p_connect_handler.create
          connect_handler_cfg
          pool
          msg_config
          conn_meta_config
          sched
          triggers
          ~log
          ~answerer
      in
      P2p_welcome.create ~backlog:10 connect_handler ~addr port
      >>= fun welcome ->
      P2p_welcome.activate welcome ;
      lwt_log_info "Node ready (port: %d)" port
      >>= fun () ->
      sync channel
      >>=? fun () ->
      f channel connect_handler pool points
      >>=? fun () ->
      lwt_log_info "Shutting down..."
      >>= fun () ->
      P2p_welcome.shutdown welcome
      >>= fun () ->
      P2p_pool.destroy pool
      >>= fun () ->
      P2p_connect_handler.destroy connect_handler
      >>= fun () ->
      P2p_io_scheduler.shutdown sched
      >>= fun () -> lwt_log_info "Bye." >>= fun () -> return_unit)

let detach_nodes run_node points =
  let clients = List.length points in
  Lwt_list.map_p (detach_node run_node points) (0 -- (clients - 1))
  >>= fun nodes ->
  Lwt.ignore_result (sync_nodes nodes) ;
  Process.wait_all nodes

type error += Connect | Write | Read

module Simple = struct
  let rec connect ~timeout connect_handler pool point =
    lwt_log_info "Connect to %a" P2p_point.Id.pp point
    >>= fun () ->
    P2p_connect_handler.connect connect_handler point ~timeout
    >>= function
    | Error (P2p_errors.Connected :: _) -> (
      match P2p_pool.Connection.find_by_point pool point with
      | Some conn ->
          return conn
      | None ->
          failwith "Woops..." )
    | Error
        (( ( P2p_errors.Connection_refused
           | P2p_errors.Pending_connection
           | P2p_errors.Rejected_socket_connection
           | Canceled
           | Timeout
           | P2p_errors.Rejected _ ) as head_err )
        :: _) ->
        lwt_log_info
          "Connection to %a failed (%a)"
          P2p_point.Id.pp
          point
          (fun ppf err ->
            match err with
            | P2p_errors.Connection_refused ->
                Format.fprintf ppf "connection refused"
            | P2p_errors.Pending_connection ->
                Format.fprintf ppf "pending connection"
            | P2p_errors.Rejected_socket_connection ->
                Format.fprintf ppf "rejected"
            | Canceled ->
                Format.fprintf ppf "canceled"
            | Timeout ->
                Format.fprintf ppf "timeout"
            | P2p_errors.Rejected peer ->
                Format.fprintf ppf "rejected (%a)" P2p_peer.Id.pp peer
            | _ ->
                assert false)
          head_err
        >>= fun () ->
        Lwt_unix.sleep (0.5 +. Random.float 2.)
        >>= fun () -> connect ~timeout connect_handler pool point
    | (Ok _ | Error _) as res ->
        Lwt.return res

  let connect_all ~timeout connect_handler pool points =
    map_p (connect ~timeout connect_handler pool) points

  let write_all conns msg =
    iter_p (fun conn -> trace Write @@ P2p_conn.write_sync conn msg) conns

  let read_all conns =
    iter_p
      (fun conn ->
        trace Read @@ P2p_conn.read conn >>=? fun Ping -> return_unit)
      conns

  let close_all conns = Lwt_list.iter_p P2p_conn.disconnect conns

  let node channel connect_handler pool points =
    connect_all
      ~timeout:(Time.System.Span.of_seconds_exn 2.)
      connect_handler
      pool
      points
    >>=? fun conns ->
    lwt_log_info "Bootstrap OK"
    >>= fun () ->
    sync channel
    >>=? fun () ->
    write_all conns Ping
    >>=? fun () ->
    lwt_log_info "Sent all messages."
    >>= fun () ->
    sync channel
    >>=? fun () ->
    read_all conns
    >>=? fun () ->
    lwt_log_info "Read all messages."
    >>= fun () ->
    sync channel
    >>=? fun () ->
    close_all conns
    >>= fun () ->
    lwt_log_info "All connections successfully closed."
    >>= fun () -> return_unit

  let run points = detach_nodes node points
end

module Random_connections = struct
  let rec connect_random connect_handler pool total rem point n =
    Lwt_unix.sleep (0.2 +. Random.float 1.0)
    >>= fun () ->
    trace Connect
    @@ Simple.connect
         ~timeout:(Time.System.Span.of_seconds_exn 2.)
         connect_handler
         pool
         point
    >>=? fun conn ->
    trace Write @@ P2p_conn.write conn Ping
    >>= fun _ ->
    trace Read @@ P2p_conn.read conn
    >>=? fun Ping ->
    Lwt_unix.sleep (0.2 +. Random.float 1.0)
    >>= fun () ->
    P2p_conn.disconnect conn
    >>= fun () ->
    ( decr rem ;
      if !rem mod total = 0 then lwt_log_info "Remaining: %d." (!rem / total)
      else Lwt.return_unit )
    >>= fun () ->
    if n > 1 then connect_random connect_handler pool total rem point (pred n)
    else return_unit

  let connect_random_all connect_handler pool points n =
    let total = List.length points in
    let rem = ref (n * total) in
    iter_p
      (fun point -> connect_random connect_handler pool total rem point n)
      points

  let node repeat _channel connect_handler pool points =
    lwt_log_info "Begin random connections."
    >>= fun () ->
    connect_random_all connect_handler pool points repeat
    >>=? fun () ->
    lwt_log_info "Random connections OK." >>= fun () -> return_unit

  let run points repeat = detach_nodes (node repeat) points
end

module Garbled = struct
  let is_connection_closed = function
    | Error ((Write | Read) :: P2p_errors.Connection_closed :: _) ->
        true
    | Ok _ ->
        false
    | Error err ->
        log_info "Unexpected error: %a" pp_print_error err ;
        false

  let write_bad_all conns =
    let bad_msg = Bytes.of_string (String.make 16 '\000') in
    iter_p
      (fun conn -> trace Write @@ P2p_conn.raw_write_sync conn bad_msg)
      conns

  let node ch connect_handler pool points =
    Simple.connect_all
      ~timeout:(Time.System.Span.of_seconds_exn 2.)
      connect_handler
      pool
      points
    >>=? fun conns ->
    sync ch
    >>=? fun () ->
    write_bad_all conns
    >>=? (fun () -> Simple.read_all conns)
    >>= fun err -> _assert (is_connection_closed err) __LOC__ ""

  let run points = detach_nodes node points
end

let () = Random.self_init ()

let addr = ref Ipaddr.V6.localhost

let port = ref (1024 + Random.int 8192)

let clients = ref 10

let repeat_connections = ref 5

let log_config = ref None

let spec =
  Arg.
    [ ("--port", Int (fun p -> port := p), " Listening port of the first peer.");
      ( "--addr",
        String (fun p -> addr := Ipaddr.V6.of_string_exn p),
        " Listening addr" );
      ("--clients", Set_int clients, " Number of concurrent clients.");
      ( "--repeat",
        Set_int repeat_connections,
        " Number of connections/disconnections." );
      ( "-v",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:
                     "test.p2p.connection-pool -> info; p2p.connection-pool \
                      -> info"
                   ())),
        " Log up to info msgs" );
      ( "-vv",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:
                     "test.p2p.connection-pool -> debug; p2p.connection-pool \
                      -> debug"
                   ())),
        " Log up to debug msgs" ) ]

let init_logs = lazy (Internal_event_unix.init ?lwt_log_sink:!log_config ())

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lazy.force init_logs
      >>= fun () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let main () =
  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
  let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg ;
  let ports = !port -- (!port + !clients - 1) in
  let points = List.map (fun port -> (!addr, port)) ports in
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p-connection-pool",
        [ wrap "simple" (fun _ -> Simple.run points);
          wrap "random" (fun _ ->
              Random_connections.run points !repeat_connections);
          wrap "garbled" (fun _ -> Garbled.run points) ] ) ]

let () =
  Sys.catch_break true ;
  try main () with _ -> ()
src/lib_p2p/test/test_p2p_pool.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Inductive message : Type :=
| Ping : message.

Definition msg_config : Tezos_p2p.P2p_connect_handler.message_config message :=
  {|
    encoding :=
      cons
        (Tezos_p2p.P2p_message.Encoding
          {| tag := 16; title := "Ping" % string;
            encoding := Data_encoding.empty;
            wrap :=
              fun function_parameter =>
                let 'tt := function_parameter in
                Ping;
            unwrap :=
              fun function_parameter =>
                let 'Ping := function_parameter in
                Some tt; max_length := None |}) [];
    chain_name := Distributed_db_version.sandboxed_chain_name;
    distributed_db_versions := cons Distributed_db_version.zero [] |}.

Definition metadata := unit.

Definition peer_meta_config : Tezos_p2p.P2p_pool.peer_meta_config metadata :=
  {| peer_meta_encoding := Data_encoding.empty;
    peer_meta_initial :=
      fun function_parameter =>
        let '_ := function_parameter in
        tt;
    score :=
      fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Float constant 0. is approximated by the integer 0 *)
        0 |}.

Definition conn_meta_config : Tezos_p2p.P2p_socket.metadata_config metadata :=
  {| conn_meta_encoding := Data_encoding.empty;
    conn_meta_value :=
      fun function_parameter =>
        let '_ := function_parameter in
        tt;
    private_node :=
      fun function_parameter =>
        let '_ := function_parameter in
        false |}.

Definition sync {A : Type} (ch : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (op_startypeminuserrorstar ch tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar ch)
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Fixpoint sync_nodes {A B : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  op_gtgteqquestion
    (iter_p
      (fun function_parameter =>
        let '_ := function_parameter in
        op_startypeminuserrorstar op_startypeminuserrorstar) nodes)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (iter_p
          (fun function_parameter =>
            let '_ := function_parameter in
            op_startypeminuserrorstar op_startypeminuserrorstar tt) nodes)
        (fun function_parameter =>
          let 'tt := function_parameter in
          sync_nodes nodes)).

Definition sync_nodes {A : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (sync_nodes nodes)
    (fun function_parameter =>
      match function_parameter with
      |
        Stdlib.Ok tt |
          Stdlib.Error (cons (Tezos_base__TzPervasives.Exn OCaml.End_of_file) _)
        => return_unit
      | (Stdlib.Error _) as err => Lwt._return err
      end).

Definition detach_node {A B : Type}
  (f :
    A ->
      (Tezos_p2p.P2p_connect_handler.t message metadata metadata) ->
        (Tezos_p2p.P2p_pool.t message metadata metadata) ->
          (list Tezos_base__TzPervasives.P2p_point.Id.t) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (points : list Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z) : B :=
  let '((addr, port), points) := List.select n points in
  let proof_of_work_target :=
    Crypto_box.make_target
      (* ❌ Float constant 0. is approximated by the integer 0 *)
      0 in
  let identity := P2p_identity.generate proof_of_work_target in
  let private_mode := true in
  let nb_points := List.length points in
  let connect_handler_cfg :=
    {| incoming_app_message_queue_size := None; private_mode := private_mode;
      min_connections := nb_points; max_connections := nb_points;
      max_incoming_connections := nb_points;
      incoming_message_queue_size := None; outgoing_message_queue_size := None;
      binary_chunks_size := None; identity := identity;
      connection_timeout :=
        Time.System.Span.of_seconds_exn
          (* ❌ Float constant 10. is approximated by the integer 10 *)
          10;
      authentication_timeout :=
        Time.System.Span.of_seconds_exn
          (* ❌ Float constant 2. is approximated by the integer 2 *)
          2;
      greylisting_config := P2p_point_state.Info.default_greylisting_config;
      proof_of_work_target := proof_of_work_target; listening_port := Some port
      |} in
  let pool_config :=
    {| identity := identity; trusted_points := points;
      peers_file := "/dev/null" % string; private_mode := private_mode;
      max_known_points := None; max_known_peer_ids := None |} in
  op_startypeminuserrorstar
    (Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal ": " % string
            CamlinternalFormatBasics.End_of_format)) "%a: " % string)
      P2p_peer.Id.pp_short (peer_id identity))
    (fun channel =>
      let sched :=
        P2p_io_scheduler.create None None None None (Z.shiftl 1 12) tt in
      let triggers := P2p_trigger.create tt in
      let log {C : Type} (function_parameter : C) : unit :=
        let '_ := function_parameter in
        tt in
      op_gtgteq (P2p_pool.create pool_config peer_meta_config triggers log)
        (fun pool =>
          let answerer :=
            (* ❌ Lazy expressions are not handled *)
            lazy (P2p_protocol.create_private tt) in
          let connect_handler :=
            P2p_connect_handler.create None connect_handler_cfg pool msg_config
              conn_meta_config sched triggers log answerer in
          op_gtgteq (P2p_welcome.create (Some addr) 10 connect_handler port)
            (fun welcome =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_welcome.activate welcome in
              op_gtgteq
                (lwt_log_info
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Node ready (port: " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "Node ready (port: %d)" % string) port)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion (sync channel)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion (f channel connect_handler pool points)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (lwt_log_info
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Shutting down..." % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Shutting down..." % string))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq (P2p_welcome.shutdown welcome)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq (P2p_pool.destroy pool)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (P2p_connect_handler.destroy
                                          connect_handler)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (P2p_io_scheduler.shutdown None
                                              sched)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                (lwt_log_info
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Bye." % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "Bye." % string))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  return_unit)))))))))))).

Definition detach_nodes {A B : Type}
  (run_node :
    A ->
      (Tezos_p2p.P2p_connect_handler.t message metadata metadata) ->
        (Tezos_p2p.P2p_pool.t message metadata metadata) ->
          (list Tezos_base__TzPervasives.P2p_point.Id.t) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t B :=
  let clients := List.length points in
  op_gtgteq
    (Lwt_list.map_p (detach_node run_node points)
      (op_minusminus 0 (Z.sub clients 1)))
    (fun nodes =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Lwt.ignore_result (sync_nodes nodes) in
      op_startypeminuserrorstar nodes).

(* ❌ Structure item `typext` not handled. *)
type_extension

Module Simple.
  Fixpoint connect {A B C : Type}
    (timeout : Tezos_base__TzPervasives.Time.System.Span.t)
    (connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
    (pool : Tezos_p2p__P2p_pool.t A B C)
    (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (Tezos_p2p.P2p_conn.t A B C)) :=
    op_gtgteq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Connect to " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "Connect to %a" % string)
        P2p_point.Id.pp point)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (P2p_connect_handler.connect (Some timeout) connect_handler point)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error (cons Tezos_base__TzPervasives.Connected _) =>
              match P2p_pool.Connection.find_by_point pool point with
              | Some conn => _return conn
              | None =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "Woops..." % string
                      CamlinternalFormatBasics.End_of_format)
                    "Woops..." % string)
              end
            |
              Stdlib.Error
                (cons
                  ((Tezos_base__TzPervasives.Connection_refused |
                    Tezos_base__TzPervasives.Pending_connection |
                    Tezos_base__TzPervasives.Rejected_socket_connection |
                    Tezos_base__TzPervasives.Canceled |
                    Tezos_base__TzPervasives.Timeout |
                    Tezos_base__TzPervasives.Rejected _) as head_err) _) =>
              op_gtgteq
                (lwt_log_info
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Connection to " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " failed (" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))))
                    "Connection to %a failed (%a)" % string) P2p_point.Id.pp
                  point
                  (fun ppf =>
                    fun err =>
                      match err with
                      | Tezos_base__TzPervasives.Connection_refused =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "connection refused" % string
                              CamlinternalFormatBasics.End_of_format)
                            "connection refused" % string)
                      | Tezos_base__TzPervasives.Pending_connection =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "pending connection" % string
                              CamlinternalFormatBasics.End_of_format)
                            "pending connection" % string)
                      | Tezos_base__TzPervasives.Rejected_socket_connection =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "rejected" % string
                              CamlinternalFormatBasics.End_of_format)
                            "rejected" % string)
                      | Tezos_base__TzPervasives.Canceled =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "canceled" % string
                              CamlinternalFormatBasics.End_of_format)
                            "canceled" % string)
                      | Tezos_base__TzPervasives.Timeout =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "timeout" % string
                              CamlinternalFormatBasics.End_of_format)
                            "timeout" % string)
                      | Tezos_base__TzPervasives.Rejected peer =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "rejected (" % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  ")" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "rejected (%a)" % string) P2p_peer.Id.pp peer
                      | _ =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end) head_err)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Lwt_unix.sleep
                      (Stdlib.op_pluspoint
                        (* ❌ Float constant 0.5 is approximated by the integer 0 *)
                        0
                        (Random.float
                          (* ❌ Float constant 2. is approximated by the integer 2 *)
                          2)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      connect timeout connect_handler pool point))
            | (Stdlib.Ok _ | Stdlib.Error _) as res => Lwt._return res
            end)).
  
  Definition connect_all {A B C : Type}
    (timeout : Tezos_base__TzPervasives.Time.System.Span.t)
    (connect_handler : Tezos_p2p.P2p_connect_handler.t A B C)
    (pool : Tezos_p2p__P2p_pool.t A B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult (list (Tezos_p2p.P2p_conn.t A B C))) :=
    map_p (connect timeout connect_handler pool) points.
  
  Definition write_all {A B C : Type}
    (conns : list (Tezos_p2p.P2p_conn.t A B C)) (msg : A)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    iter_p
      (fun conn =>
        apply (trace Tezos_base__TzPervasives.Write)
          (P2p_conn.write_sync conn msg)) conns.
  
  Definition read_all {A B : Type}
    (conns : list (Tezos_p2p.P2p_conn.t message A B))
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    iter_p
      (fun conn =>
        op_gtgteqquestion
          (apply (trace Tezos_base__TzPervasives.Read) (P2p_conn.read conn))
          (fun function_parameter =>
            let 'Ping := function_parameter in
            return_unit)) conns.
  
  Definition close_all {A B C : Type}
    (conns : list (Tezos_p2p.P2p_conn.t A B C)) : Lwt.t unit :=
    Lwt_list.iter_p
      (let arg := P2p_conn.disconnect in
      fun eta => arg None eta) conns.
  
  Definition node {A B C : Type}
    (channel : A)
    (connect_handler : Tezos_p2p.P2p_connect_handler.t message B C)
    (pool : Tezos_p2p__P2p_pool.t message B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion
      (connect_all
        (Time.System.Span.of_seconds_exn
          (* ❌ Float constant 2. is approximated by the integer 2 *)
          2) connect_handler pool points)
      (fun conns =>
        op_gtgteq
          (lwt_log_info
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Bootstrap OK" % string
                CamlinternalFormatBasics.End_of_format) "Bootstrap OK" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (sync channel)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (write_all conns Ping)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      (lwt_log_info
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Sent all messages." % string
                            CamlinternalFormatBasics.End_of_format)
                          "Sent all messages." % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync channel)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion (read_all conns)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  (lwt_log_info
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Read all messages." % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "Read all messages." % string))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion (sync channel)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq (close_all conns)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_gtgteq
                                              (lwt_log_info
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "All connections successfully closed."
                                                      % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "All connections successfully closed."
                                                    % string))
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                return_unit))))))))))).
  
  Definition run {A : Type}
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t A :=
    detach_nodes node points.
End Simple.

Module Random_connections.
  Fixpoint connect_random {A B : Type}
    (connect_handler : Tezos_p2p.P2p_connect_handler.t message A B)
    (pool : Tezos_p2p__P2p_pool.t message A B) (total : Z) (rem : Stdlib.ref Z)
    (point : Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq
      (Lwt_unix.sleep
        (Stdlib.op_pluspoint
          (* ❌ Float constant 0.2 is approximated by the integer 0 *)
          0
          (Random.float
            (* ❌ Float constant 1.0 is approximated by the integer 1 *)
            1)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (apply (trace Tezos_base__TzPervasives.Connect)
            (Simple.connect
              (Time.System.Span.of_seconds_exn
                (* ❌ Float constant 2. is approximated by the integer 2 *)
                2) connect_handler pool point))
          (fun conn =>
            op_gtgteq
              (apply (trace Tezos_base__TzPervasives.Write)
                (P2p_conn.write conn Ping))
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteqquestion
                  (apply (trace Tezos_base__TzPervasives.Read)
                    (P2p_conn.read conn))
                  (fun function_parameter =>
                    let 'Ping := function_parameter in
                    op_gtgteq
                      (Lwt_unix.sleep
                        (Stdlib.op_pluspoint
                          (* ❌ Float constant 0.2 is approximated by the integer 0 *)
                          0
                          (Random.float
                            (* ❌ Float constant 1.0 is approximated by the integer 1 *)
                            1)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (P2p_conn.disconnect None conn)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              (let _ := Stdlib.decr rem in
                              if
                                equiv_decb
                                  (Z.modulo (Stdlib.op_exclamation rem) total) 0
                                then
                                lwt_log_info
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Remaining: " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.Char_literal
                                          "." % char
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Remaining: %d." % string)
                                  (Z.div (Stdlib.op_exclamation rem) total)
                              else
                                Lwt.return_unit)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                if OCaml.Stdlib.gt n 1 then
                                  connect_random connect_handler pool total rem
                                    point (Z.pred n)
                                else
                                  return_unit))))))).
  
  Definition connect_random_all {A B : Type}
    (connect_handler : Tezos_p2p.P2p_connect_handler.t message A B)
    (pool : Tezos_p2p__P2p_pool.t message A B)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) (n : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let total := List.length points in
    let rem := Stdlib.ref (Z.mul n total) in
    iter_p (fun point => connect_random connect_handler pool total rem point n)
      points.
  
  Definition node {A B C : Type}
    (repeat : Z) (_channel : A)
    (connect_handler : Tezos_p2p.P2p_connect_handler.t message B C)
    (pool : Tezos_p2p__P2p_pool.t message B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq
      (lwt_log_info
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Begin random connections." % string
            CamlinternalFormatBasics.End_of_format)
          "Begin random connections." % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (connect_random_all connect_handler pool points repeat)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (lwt_log_info
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Random connections OK." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Random connections OK." % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit))).
  
  Definition run {A : Type}
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) (repeat : Z)
    : Lwt.t A := detach_nodes (node repeat) points.
End Random_connections.

Module Garbled.
  Definition is_connection_closed {A : Type}
    (function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
    match function_parameter with
    |
      Stdlib.Error
        (cons (Tezos_base__TzPervasives.Write | Tezos_base__TzPervasives.Read)
          (cons Tezos_base__TzPervasives.Connection_closed _)) => true
    | Stdlib.Ok _ => false
    | Stdlib.Error err =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        log_info
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unexpected error: " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Unexpected error: %a" % string) pp_print_error err in
      false
    end.
  
  Definition write_bad_all {A B C : Type}
    (conns : list (Tezos_p2p.P2p_conn.t A B C))
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let bad_msg := Stdlib.Bytes.of_string (String.make 16 "000" % char) in
    iter_p
      (fun conn =>
        apply (trace Tezos_base__TzPervasives.Write)
          (P2p_conn.raw_write_sync conn bad_msg)) conns.
  
  Definition node {A B C : Type}
    (ch : A) (connect_handler : Tezos_p2p.P2p_connect_handler.t message B C)
    (pool : Tezos_p2p__P2p_pool.t message B C)
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion
      (Simple.connect_all
        (Time.System.Span.of_seconds_exn
          (* ❌ Float constant 2. is approximated by the integer 2 *)
          2) connect_handler pool points)
      (fun conns =>
        op_gtgteqquestion (sync ch)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (op_gtgteqquestion (write_bad_all conns)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Simple.read_all conns))
              (fun err =>
                _assert (is_connection_closed err) Stdlib.__LOC__
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string)))).
  
  Definition run {A : Type}
    (points : list Tezos_base__TzPervasives.P2p_point.Id.t) : Lwt.t A :=
    detach_nodes node points.
End Garbled.



Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.

Definition port : Stdlib.ref Z := Stdlib.ref (Z.add 1024 (Random.int 8192)).

Definition clients : Stdlib.ref Z := Stdlib.ref 10.

Definition repeat_connections : Stdlib.ref Z := Stdlib.ref 5.

Definition log_config
  : Stdlib.ref (option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) :=
  Stdlib.ref None.

Definition spec : list (string * Stdlib.Arg.spec * string) :=
  cons
    ("--port" % string, (Stdlib.Arg.Int (fun p => Stdlib.op_coloneq port p)),
      " Listening port of the first peer." % string)
    (cons
      ("--addr" % string,
        (Stdlib.Arg.String
          (fun p => Stdlib.op_coloneq addr (Ipaddr.V6.of_string_exn p))),
        " Listening addr" % string)
      (cons
        ("--clients" % string, (Stdlib.Arg.Set_int clients),
          " Number of concurrent clients." % string)
        (cons
          ("--repeat" % string, (Stdlib.Arg.Set_int repeat_connections),
            " Number of connections/disconnections." % string)
          (cons
            ("-v" % string,
              (Stdlib.Arg.Unit
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Stdlib.op_coloneq log_config
                    (Some
                      (Lwt_log_sink_unix.create_cfg None None
                        (Some
                          "test.p2p.connection-pool -> info; p2p.connection-pool -> info"
                            % string) None tt)))),
              " Log up to info msgs" % string)
            (cons
              ("-vv" % string,
                (Stdlib.Arg.Unit
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Stdlib.op_coloneq log_config
                      (Some
                        (Lwt_log_sink_unix.create_cfg None None
                          (Some
                            "test.p2p.connection-pool -> debug; p2p.connection-pool -> debug"
                              % string) None tt)))),
                " Log up to debug msgs" % string) []))))).

Definition init_logs : lazy_t (Lwt.t unit) :=
  (* ❌ Lazy expressions are not handled *)
  lazy (Internal_event_unix.init (Stdlib.op_exclamation log_config) None tt).

Definition wrap {A B : Type}
  (n : A) (f : unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Lazy.force init_logs)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (f tt)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => Lwt.return_unit
                | Stdlib.Error error =>
                  Format.kasprintf Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    pp_print_error error
                end))).

Definition main {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  let anon_fun {B C : Type} (_num_peers : B) : C :=
    Stdlib.raise (Bad "No anonymous argument." % string) in
  let usage_msg := "Usage: %s <num_peers>.
Arguments are:" % string in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Arg.parse spec anon_fun usage_msg in
  let ports :=
    op_minusminus (Stdlib.op_exclamation port)
      (Z.sub
        (Z.add (Stdlib.op_exclamation port) (Stdlib.op_exclamation clients)) 1)
    in
  let points :=
    List.map (fun port => ((Stdlib.op_exclamation addr), port)) ports in
  op_startypeminuserrorstar
    (* ❌ Arrays not handled. *)
    [ "" % string ] "tezos-p2p" % string
    (cons
      ("p2p-connection-pool" % string,
        (cons
          (wrap "simple" % string
            (fun function_parameter =>
              let '_ := function_parameter in
              Simple.run points))
          (cons
            (wrap "random" % string
              (fun function_parameter =>
                let '_ := function_parameter in
                Random_connections.run points
                  (Stdlib.op_exclamation repeat_connections)))
            (cons
              (wrap "garbled" % string
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Garbled.run points)) [])))) []).



src/lib_p2p/test/test_p2p_socket.ml 44 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "test.p2p.connection"
end)

let addr = ref Ipaddr.V6.localhost

let canceler = Lwt_canceler.create () (* unused *)

let proof_of_work_target = Crypto_box.make_target 16.

let id1 = P2p_identity.generate proof_of_work_target

let id2 = P2p_identity.generate proof_of_work_target

let id0 =
  (* Luckilly, this will be an insuficient proof of work! *)
  P2p_identity.generate (Crypto_box.make_target 0.)

let version =
  {
    Network_version.chain_name = Distributed_db_version.sandboxed_chain_name;
    distributed_db_version = Distributed_db_version.zero;
    p2p_version = P2p_version.zero;
  }

type metadata = unit

let conn_meta_config : metadata P2p_socket.metadata_config =
  {
    conn_meta_encoding = Data_encoding.empty;
    conn_meta_value = (fun _ -> ());
    private_node = (fun _ -> false);
  }

let rec listen ?port addr =
  let tentative_port =
    match port with None -> 1024 + Random.int 8192 | Some port -> port
  in
  let uaddr = Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket = Lwt_unix.(socket PF_INET6 SOCK_STREAM 0) in
  Lwt_unix.(setsockopt main_socket SO_REUSEADDR true) ;
  Lwt.catch
    (fun () ->
      Lwt_unix.bind main_socket (ADDR_INET (uaddr, tentative_port))
      >>= fun () ->
      Lwt_unix.listen main_socket 1 ;
      Lwt.return (main_socket, tentative_port))
    (function
      | Unix.Unix_error ((Unix.EADDRINUSE | Unix.EADDRNOTAVAIL), _, _)
        when port = None ->
          listen addr
      | exn ->
          Lwt.fail exn)

let sync ch =
  Process.Channel.push ch ()
  >>=? fun () -> Process.Channel.pop ch >>=? fun () -> return_unit

let rec sync_nodes nodes =
  iter_p (fun {Process.channel; _} -> Process.Channel.pop channel) nodes
  >>=? fun () ->
  iter_p (fun {Process.channel; _} -> Process.Channel.push channel ()) nodes
  >>=? fun () -> sync_nodes nodes

let sync_nodes nodes =
  sync_nodes nodes
  >>= function
  | Ok () | Error (Exn End_of_file :: _) ->
      return_unit
  | Error _ as err ->
      Lwt.return err

let run_nodes client server =
  listen !addr
  >>= fun (main_socket, port) ->
  Process.detach ~prefix:"server: " (fun channel ->
      let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
      server channel sched main_socket
      >>=? fun () -> P2p_io_scheduler.shutdown sched >>= fun () -> return_unit)
  >>= fun server_node ->
  Process.detach ~prefix:"client: " (fun channel ->
      Lwt_utils_unix.safe_close main_socket
      >>= fun () ->
      let sched = P2p_io_scheduler.create ~read_buffer_size:(1 lsl 12) () in
      client channel sched !addr port
      >>=? fun () -> P2p_io_scheduler.shutdown sched >>= fun () -> return_unit)
  >>= fun client_node ->
  let nodes = [server_node; client_node] in
  Lwt.ignore_result (sync_nodes nodes) ;
  Process.wait_all nodes

let raw_accept sched main_socket =
  P2p_fd.accept main_socket
  >>= fun (fd, sockaddr) ->
  let fd = P2p_io_scheduler.register sched fd in
  let point =
    match sockaddr with
    | Lwt_unix.ADDR_UNIX _ ->
        assert false
    | Lwt_unix.ADDR_INET (addr, port) ->
        (Ipaddr_unix.V6.of_inet_addr_exn addr, port)
  in
  Lwt.return (fd, point)

let accept sched main_socket =
  raw_accept sched main_socket
  >>= fun (fd, point) ->
  P2p_socket.authenticate
    ~canceler
    ~proof_of_work_target
    ~incoming:true
    fd
    point
    id1
    version
    conn_meta_config

let raw_connect sched addr port =
  let fd = P2p_fd.socket PF_INET6 SOCK_STREAM 0 in
  let uaddr = Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr, port) in
  P2p_fd.connect fd uaddr
  >>= fun () ->
  let fd = P2p_io_scheduler.register sched fd in
  Lwt.return fd

let connect sched addr port id =
  raw_connect sched addr port
  >>= fun fd ->
  P2p_socket.authenticate
    ~canceler
    ~proof_of_work_target
    ~incoming:false
    fd
    (addr, port)
    id
    version
    conn_meta_config
  >>=? fun (info, auth_fd) ->
  _assert (not info.incoming) __LOC__ ""
  >>=? fun () ->
  _assert (P2p_peer.Id.compare info.peer_id id1.peer_id = 0) __LOC__ ""
  >>=? fun () -> return auth_fd

let is_connection_closed = function
  | Error (P2p_errors.Connection_closed :: _) ->
      true
  | Ok _ ->
      false
  | Error err ->
      log_notice "Error: %a" pp_print_error err ;
      false

let is_decoding_error = function
  | Error (P2p_errors.Decoding_error :: _) ->
      true
  | Ok _ ->
      false
  | Error err ->
      log_notice "Error: %a" pp_print_error err ;
      false

module Crypto_test = struct
  (* maximal size of the buffer *)
  let bufsize = (1 lsl 16) - 1

  let header_length = 2

  let max_content_length = bufsize - Crypto_box.zerobytes

  (* The size of extra data added by encryption. *)
  let boxextrabytes = Crypto_box.zerobytes - Crypto_box.boxzerobytes

  (* The number of bytes added by encryption + header *)
  let extrabytes = header_length + boxextrabytes

  type data = {
    channel_key : Crypto_box.channel_key;
    mutable local_nonce : Crypto_box.nonce;
    mutable remote_nonce : Crypto_box.nonce;
  }

  let () = assert (Crypto_box.boxzerobytes >= header_length)

  let write_chunk fd cryptobox_data msg =
    let msglen = Bytes.length msg in
    fail_unless (msglen <= max_content_length) P2p_errors.Invalid_message_size
    >>=? fun () ->
    let buf_length = msglen + Crypto_box.zerobytes in
    let buf = Bytes.make buf_length '\x00' in
    Bytes.blit msg 0 buf Crypto_box.zerobytes msglen ;
    let local_nonce = cryptobox_data.local_nonce in
    cryptobox_data.local_nonce <- Crypto_box.increment_nonce local_nonce ;
    Crypto_box.fast_box_noalloc cryptobox_data.channel_key local_nonce buf ;
    let encrypted_length = buf_length - Crypto_box.boxzerobytes in
    let header_pos = Crypto_box.boxzerobytes - header_length in
    TzEndian.set_int16 buf header_pos encrypted_length ;
    let payload = Bytes.sub buf header_pos (buf_length - header_pos) in
    return (Unix.write fd payload 0 (buf_length - header_pos))
    >>=? fun i ->
    _assert (buf_length - header_pos = i) __LOC__ "" >>=? fun () -> return_unit

  let read_chunk fd cryptobox_data =
    let header_buf = Bytes.create header_length in
    return (Unix.read fd header_buf 0 header_length)
    >>=? fun i ->
    _assert (header_length = i) __LOC__ ""
    >>=? fun () ->
    let encrypted_length = TzEndian.get_uint16 header_buf 0 in
    let buf_length = encrypted_length + Crypto_box.boxzerobytes in
    let buf = Bytes.make buf_length '\x00' in
    return (Unix.read fd buf Crypto_box.boxzerobytes encrypted_length)
    >>=? fun i ->
    _assert (encrypted_length = i) __LOC__ ""
    >>=? fun () ->
    let remote_nonce = cryptobox_data.remote_nonce in
    cryptobox_data.remote_nonce <- Crypto_box.increment_nonce remote_nonce ;
    match
      Crypto_box.fast_box_open_noalloc
        cryptobox_data.channel_key
        remote_nonce
        buf
    with
    | false ->
        fail P2p_errors.Decipher_error
    | true ->
        return
          (Bytes.sub
             buf
             Crypto_box.zerobytes
             (buf_length - Crypto_box.zerobytes))

  let (sk, pk, pkh) = Crypto_box.random_keypair ()

  let zero_nonce = Crypto_box.zero_nonce

  let channel_key = Crypto_box.precompute sk pk

  let (in_fd, out_fd) = Unix.pipe ()

  let data = {channel_key; local_nonce = zero_nonce; remote_nonce = zero_nonce}

  let wrap () =
    Alcotest_lwt.test_case "ACK" `Quick (fun _ () ->
        let msg = Bytes.of_string "test" in
        write_chunk out_fd data msg
        >>= fun _ ->
        read_chunk in_fd data
        >>= function
        | Ok res when Bytes.equal msg res ->
            Lwt.return_unit
        | Ok res ->
            Format.kasprintf
              Pervasives.failwith
              "Error : %s <> %s"
              (Bytes.to_string res)
              (Bytes.to_string msg)
        | Error error ->
            Format.kasprintf Pervasives.failwith "%a" pp_print_error error)
end

module Low_level = struct
  let simple_msg = Rand.generate (1 lsl 4)

  let client _ch sched addr port =
    let msg = Bytes.create (Bytes.length simple_msg) in
    raw_connect sched addr port
    >>= fun fd ->
    P2p_io_scheduler.read_full fd msg
    >>=? fun () ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () -> P2p_io_scheduler.close fd >>=? fun () -> return_unit

  let server _ch sched socket =
    raw_accept sched socket
    >>= fun (fd, _point) ->
    P2p_io_scheduler.write fd simple_msg
    >>=? fun () -> P2p_io_scheduler.close fd >>=? fun _ -> return_unit

  let run _dir = run_nodes client server
end

module Kick = struct
  let encoding = Data_encoding.bytes

  let is_rejected = function
    | Error (P2p_errors.Rejected_socket_connection :: _) ->
        true
    | Ok _ ->
        false
    | Error err ->
        log_notice "Error: %a" pp_print_error err ;
        false

  let server _ch sched socket =
    accept sched socket
    >>=? fun (info, auth_fd) ->
    _assert info.incoming __LOC__ ""
    >>=? fun () ->
    _assert (P2p_peer.Id.compare info.peer_id id2.peer_id = 0) __LOC__ ""
    >>=? fun () -> P2p_socket.kick auth_fd >>= fun () -> return_unit

  let client _ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>= fun conn ->
    _assert (is_rejected conn) __LOC__ "" >>=? fun () -> return_unit

  let run _dir = run_nodes client server
end

module Kicked = struct
  let encoding = Data_encoding.bytes

  let server _ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>= fun conn ->
    _assert (Kick.is_rejected conn) __LOC__ "" >>=? fun () -> return_unit

  let client _ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd -> P2p_socket.kick auth_fd >>= fun () -> return_unit

  let run _dir = run_nodes client server
end

module Simple_message = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 4)

  let simple_msg2 = Rand.generate (1 lsl 4)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg2
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Chunked_message = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 8)

  let simple_msg2 = Rand.generate (1 lsl 8)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler ~binary_chunks_size:21 auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg2
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Oversized_message = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 17)

  let simple_msg2 = Rand.generate (1 lsl 17)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg2 msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.write_sync conn simple_msg2
    >>=? fun () ->
    P2p_socket.read conn
    >>=? fun (_msg_size, msg) ->
    _assert (Bytes.compare simple_msg msg = 0) __LOC__ ""
    >>=? fun () ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Close_on_read = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 4)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    sync ch >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    sync ch
    >>=? fun () ->
    P2p_socket.read conn
    >>= fun err ->
    _assert (is_connection_closed err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Close_on_write = struct
  let encoding = Data_encoding.bytes

  let simple_msg = Rand.generate (1 lsl 4)

  let server ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.close conn >>= fun _stat -> sync ch >>=? fun () -> return_unit

  let client ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    sync ch
    >>=? fun () ->
    Lwt_unix.sleep 0.1
    >>= fun () ->
    P2p_socket.write_sync conn simple_msg
    >>= fun err ->
    _assert (is_connection_closed err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

module Garbled_data = struct
  let encoding =
    let open Data_encoding in
    dynamic_size @@ option @@ string

  (* generate a fixed garbled_msg to avoid 'Data_encoding.Binary.Await
     _', which blocks 'make test' *)
  let garbled_msg =
    let buf = Bytes.create (1 lsl 4) in
    TzEndian.set_int32 buf 0 (Int32.of_int 4) ;
    TzEndian.set_int32 buf 4 (Int32.of_int (-1)) ;
    TzEndian.set_int32 buf 8 (Int32.of_int (-1)) ;
    TzEndian.set_int32 buf 12 (Int32.of_int (-1)) ;
    buf

  let server _ch sched socket =
    accept sched socket
    >>=? fun (_info, auth_fd) ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.raw_write_sync conn garbled_msg
    >>=? fun () ->
    P2p_socket.read conn
    >>= fun err ->
    _assert (is_connection_closed err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let client _ch sched addr port =
    connect sched addr port id2
    >>=? fun auth_fd ->
    P2p_socket.accept ~canceler auth_fd encoding
    >>=? fun conn ->
    P2p_socket.read conn
    >>= fun err ->
    _assert (is_decoding_error err) __LOC__ ""
    >>=? fun () -> P2p_socket.close conn >>= fun _stat -> return_unit

  let run _dir = run_nodes client server
end

let log_config = ref None

let spec =
  Arg.
    [ ( "--addr",
        String (fun p -> addr := Ipaddr.V6.of_string_exn p),
        " Listening addr" );
      ( "-v",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:"test.p2p.connection -> info; p2p.connection -> info"
                   ())),
        " Log up to info msgs" );
      ( "-vv",
        Unit
          (fun () ->
            log_config :=
              Some
                (Lwt_log_sink_unix.create_cfg
                   ~rules:
                     "test.p2p.connection -> debug; p2p.connection -> debug"
                   ())),
        " Log up to debug msgs" ) ]

let init_logs = lazy (Internal_event_unix.init ?lwt_log_sink:!log_config ())

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lazy.force init_logs
      >>= fun () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let main () =
  let anon_fun _num_peers = raise (Arg.Bad "No anonymous argument.") in
  let usage_msg = "Usage: %s.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg ;
  Alcotest.run
    ~argv:[|""|]
    "tezos-p2p"
    [ ( "p2p-connection.",
        [ wrap "low-level" Low_level.run;
          wrap "kick" Kick.run;
          wrap "kicked" Kicked.run;
          wrap "simple-message" Simple_message.run;
          wrap "chunked-message" Chunked_message.run;
          wrap "oversized-message" Oversized_message.run;
          wrap "close-on-read" Close_on_read.run;
          wrap "close-on-write" Close_on_write.run;
          wrap "garbled-data" Garbled_data.run;
          Crypto_test.wrap () ] ) ]

let () =
  Sys.catch_break true ;
  try main () with _ -> ()
src/lib_p2p/test/test_p2p_socket.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition addr : Stdlib.ref Ipaddr.V6.t := Stdlib.ref Ipaddr.V6.localhost.

Definition canceler : Tezos_stdlib.Lwt_canceler.t := Lwt_canceler.create tt.

Definition proof_of_work_target : Tezos_base__TzPervasives.Crypto_box.target :=
  Crypto_box.make_target
    (* ❌ Float constant 16. is approximated by the integer 16 *)
    16.

Definition id1 : Tezos_base__TzPervasives.P2p_identity.t :=
  P2p_identity.generate proof_of_work_target.

Definition id2 : Tezos_base__TzPervasives.P2p_identity.t :=
  P2p_identity.generate proof_of_work_target.

Definition id0 : Tezos_base__TzPervasives.P2p_identity.t :=
  P2p_identity.generate
    (Crypto_box.make_target
      (* ❌ Float constant 0. is approximated by the integer 0 *)
      0).

Definition version : Tezos_base__TzPervasives.Network_version.t :=
  {| Network_version.chain_name := Distributed_db_version.sandboxed_chain_name;
    Network_version.distributed_db_version := Distributed_db_version.zero;
    Network_version.p2p_version := P2p_version.zero |}.

Definition metadata := unit.

Definition conn_meta_config : Tezos_p2p.P2p_socket.metadata_config metadata :=
  {| conn_meta_encoding := Data_encoding.empty;
    conn_meta_value :=
      fun function_parameter =>
        let '_ := function_parameter in
        tt;
    private_node :=
      fun function_parameter =>
        let '_ := function_parameter in
        false |}.

Fixpoint listen (port : option Z) (addr : Ipaddr.V6.t)
  : Lwt.t (Lwt_unix.file_descr * Z) :=
  let tentative_port :=
    match port with
    | None => Z.add 1024 (Random.int 8192)
    | Some port => port
    end in
  let uaddr := Ipaddr_unix.V6.to_inet_addr addr in
  let main_socket := socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := setsockopt main_socket Lwt_unix.SO_REUSEADDR true in
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (Lwt_unix.bind main_socket (Lwt_unix.ADDR_INET uaddr tentative_port))
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_unix.listen main_socket 1 in
          Lwt._return (main_socket, tentative_port)))
    (fun function_parameter =>
      match function_parameter with
      | Unix_error (Unix.EADDRINUSE | Unix.EADDRNOTAVAIL) _ _ =>
        listen None addr
      | exn => Lwt.fail exn
      end).

Definition sync {A : Type} (ch : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (op_startypeminuserrorstar ch tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar ch)
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Fixpoint sync_nodes {A B : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  op_gtgteqquestion
    (iter_p
      (fun function_parameter =>
        let '_ := function_parameter in
        op_startypeminuserrorstar op_startypeminuserrorstar) nodes)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (iter_p
          (fun function_parameter =>
            let '_ := function_parameter in
            op_startypeminuserrorstar op_startypeminuserrorstar tt) nodes)
        (fun function_parameter =>
          let 'tt := function_parameter in
          sync_nodes nodes)).

Definition sync_nodes {A : Type} (nodes : list A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (sync_nodes nodes)
    (fun function_parameter =>
      match function_parameter with
      |
        Stdlib.Ok tt |
          Stdlib.Error (cons (Tezos_base__TzPervasives.Exn OCaml.End_of_file) _)
        => return_unit
      | (Stdlib.Error _) as err => Lwt._return err
      end).

Definition run_nodes {A B C : Type}
  (client :
    A ->
      Tezos_p2p.P2p_io_scheduler.t ->
        Ipaddr.V6.t -> Z -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (server :
    B ->
      Tezos_p2p.P2p_io_scheduler.t ->
        Lwt_unix.file_descr -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t C :=
  op_gtgteq (listen None (Stdlib.op_exclamation addr))
    (fun function_parameter =>
      let '(main_socket, port) := function_parameter in
      op_gtgteq
        (op_startypeminuserrorstar "server: " % string
          (fun channel =>
            let sched :=
              P2p_io_scheduler.create None None None None (Z.shiftl 1 12) tt in
            op_gtgteqquestion (server channel sched main_socket)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_io_scheduler.shutdown None sched)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit))))
        (fun server_node =>
          op_gtgteq
            (op_startypeminuserrorstar "client: " % string
              (fun channel =>
                op_gtgteq (Lwt_utils_unix.safe_close main_socket)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let sched :=
                      P2p_io_scheduler.create None None None None
                        (Z.shiftl 1 12) tt in
                    op_gtgteqquestion
                      (client channel sched (Stdlib.op_exclamation addr) port)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (P2p_io_scheduler.shutdown None sched)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)))))
            (fun client_node =>
              let nodes := cons server_node (cons client_node []) in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Lwt.ignore_result (sync_nodes nodes) in
              op_startypeminuserrorstar nodes))).

Definition raw_accept
  (sched : Tezos_p2p.P2p_io_scheduler.t) (main_socket : Lwt_unix.file_descr)
  : Lwt.t (Tezos_p2p.P2p_io_scheduler.connection * (Ipaddr.V6.t * Z)) :=
  op_gtgteq (P2p_fd.accept main_socket)
    (fun function_parameter =>
      let '(fd, sockaddr) := function_parameter in
      let fd := P2p_io_scheduler.register sched fd in
      let point :=
        match sockaddr with
        | Lwt_unix.ADDR_UNIX _ =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Lwt_unix.ADDR_INET addr port =>
          ((Ipaddr_unix.V6.of_inet_addr_exn addr), port)
        end in
      Lwt._return (fd, point)).

Definition accept
  (sched : Tezos_p2p.P2p_io_scheduler.t) (main_socket : Lwt_unix.file_descr)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_base__TzPervasives.P2p_connection.Info.t metadata) *
        (Tezos_p2p.P2p_socket.authenticated_connection metadata))) :=
  op_gtgteq (raw_accept sched main_socket)
    (fun function_parameter =>
      let '(fd, point) := function_parameter in
      P2p_socket.authenticate canceler proof_of_work_target true fd point None
        id1 version conn_meta_config).

Definition raw_connect
  (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Ipaddr.V6.t) (port : Z)
  : Lwt.t Tezos_p2p.P2p_io_scheduler.connection :=
  let fd := P2p_fd.socket Lwt_unix.PF_INET6 Lwt_unix.SOCK_STREAM 0 in
  let uaddr := Lwt_unix.ADDR_INET (Ipaddr_unix.V6.to_inet_addr addr) port in
  op_gtgteq (P2p_fd.connect fd uaddr)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let fd := P2p_io_scheduler.register sched fd in
      Lwt._return fd).

Definition connect
  (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Tezos_base.P2p_addr.t)
  (port : Tezos_base.P2p_addr.port)
  (id : Tezos_base__TzPervasives.P2p_identity.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_p2p.P2p_socket.authenticated_connection metadata)) :=
  op_gtgteq (raw_connect sched addr port)
    (fun fd =>
      op_gtgteqquestion
        (P2p_socket.authenticate canceler proof_of_work_target false fd
          (addr, port) None id version conn_meta_config)
        (fun function_parameter =>
          let '(info, auth_fd) := function_parameter in
          op_gtgteqquestion
            (_assert (negb (incoming info)) Stdlib.__LOC__
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (_assert
                  (equiv_decb (P2p_peer.Id.compare (peer_id info) (peer_id id1))
                    0) Stdlib.__LOC__
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return auth_fd)))).

Definition is_connection_closed {A : Type}
  (function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
  match function_parameter with
  | Stdlib.Error (cons Tezos_base__TzPervasives.Connection_closed _) => true
  | Stdlib.Ok _ => false
  | Stdlib.Error err =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Error: " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
        pp_print_error err in
    false
  end.

Definition is_decoding_error {A : Type}
  (function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
  match function_parameter with
  | Stdlib.Error (cons Tezos_base__TzPervasives.Decoding_error _) => true
  | Stdlib.Ok _ => false
  | Stdlib.Error err =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Error: " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
        pp_print_error err in
    false
  end.

Module Crypto_test.
  Definition bufsize : Z := Z.sub (Z.shiftl 1 16) 1.
  
  Definition header_length : Z := 2.
  
  Definition max_content_length : Z := Z.sub bufsize Crypto_box.zerobytes.
  
  Definition boxextrabytes : Z :=
    Z.sub Crypto_box.zerobytes Crypto_box.boxzerobytes.
  
  Definition extrabytes : Z := Z.add header_length boxextrabytes.
  
  Record data := {
    channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key;
    local_nonce : Tezos_base__TzPervasives.Crypto_box.nonce;
    remote_nonce : Tezos_base__TzPervasives.Crypto_box.nonce }.
  
  
  
  Definition write_chunk
    (fd : Unix.file_descr) (cryptobox_data : data) (msg : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let msglen := String.length msg in
    op_gtgteqquestion
      (fail_unless (OCaml.Stdlib.le msglen max_content_length)
        Tezos_base__TzPervasives.Invalid_message_size)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let buf_length := Z.add msglen Crypto_box.zerobytes in
        let buf := Stdlib.Bytes.make buf_length "000" % char in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Stdlib.Bytes.blit msg 0 buf Crypto_box.zerobytes msglen in
        let local_nonce := local_nonce cryptobox_data in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field cryptobox_data "local_nonce" % string
            (Crypto_box.increment_nonce None local_nonce) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Crypto_box.fast_box_noalloc (channel_key cryptobox_data) local_nonce
            buf in
        let encrypted_length := Z.sub buf_length Crypto_box.boxzerobytes in
        let header_pos := Z.sub Crypto_box.boxzerobytes header_length in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := TzEndian.set_int16 buf header_pos encrypted_length in
        let payload := String.sub buf header_pos (Z.sub buf_length header_pos)
          in
        op_gtgteqquestion
          (_return (Unix.write fd payload 0 (Z.sub buf_length header_pos)))
          (fun i =>
            op_gtgteqquestion
              (_assert (equiv_decb (Z.sub buf_length header_pos) i)
                Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit))).
  
  Definition read_chunk (fd : Unix.file_descr) (cryptobox_data : data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    let header_buf := Stdlib.Bytes.create header_length in
    op_gtgteqquestion (_return (Unix.read fd header_buf 0 header_length))
      (fun i =>
        op_gtgteqquestion
          (_assert (equiv_decb header_length i) Stdlib.__LOC__
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            let encrypted_length := TzEndian.get_uint16 header_buf 0 in
            let buf_length := Z.add encrypted_length Crypto_box.boxzerobytes in
            let buf := Stdlib.Bytes.make buf_length "000" % char in
            op_gtgteqquestion
              (_return
                (Unix.read fd buf Crypto_box.boxzerobytes encrypted_length))
              (fun i =>
                op_gtgteqquestion
                  (_assert (equiv_decb encrypted_length i) Stdlib.__LOC__
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let remote_nonce := remote_nonce cryptobox_data in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      (* ❌ Set record field not handled. *)
                      set_record_field cryptobox_data "remote_nonce" % string
                        (Crypto_box.increment_nonce None remote_nonce) in
                    match
                      Crypto_box.fast_box_open_noalloc
                        (channel_key cryptobox_data) remote_nonce buf with
                    | false => fail Tezos_base__TzPervasives.Decipher_error
                    | true =>
                      _return
                        (String.sub buf Crypto_box.zerobytes
                          (Z.sub buf_length Crypto_box.zerobytes))
                    end)))).
  
  
  
  Definition zero_nonce : Tezos_base__TzPervasives.Crypto_box.nonce :=
    Crypto_box.zero_nonce.
  
  Definition channel_key : Tezos_base__TzPervasives.Crypto_box.channel_key :=
    Crypto_box.precompute sk pk.
  
  
  
  Definition data : data :=
    {| channel_key := channel_key; local_nonce := zero_nonce;
      remote_nonce := zero_nonce |}.
  
  Definition wrap {A : Type} (function_parameter : unit) : A :=
    let 'tt := function_parameter in
    op_startypeminuserrorstar "ACK" % string
      (* ❌ Variants not supported *)
      variant
      (fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let msg := Stdlib.Bytes.of_string "test" % string in
          op_gtgteq (write_chunk out_fd data msg)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteq (read_chunk in_fd data)
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok res => Lwt.return_unit
                  | Stdlib.Ok res =>
                    Format.kasprintf Pervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Error : " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              " <> " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format))))
                        "Error : %s <> %s" % string)
                      (Stdlib.Bytes.to_string res) (Stdlib.Bytes.to_string msg)
                  | Stdlib.Error error =>
                    Format.kasprintf Pervasives.failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format) "%a" % string)
                      pp_print_error error
                  end))).
End Crypto_test.

Module Low_level.
  Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t) (addr : Ipaddr.V6.t)
    (port : Z) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let msg := Stdlib.Bytes.create (String.length simple_msg) in
    op_gtgteq (raw_connect sched addr port)
      (fun fd =>
        op_gtgteqquestion (P2p_io_scheduler.read_full None fd None None msg)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (_assert (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_io_scheduler.close None fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))).
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq (raw_accept sched socket)
      (fun function_parameter =>
        let '(fd, _point) := function_parameter in
        op_gtgteqquestion (P2p_io_scheduler.write None fd simple_msg)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (P2p_io_scheduler.close None fd)
              (fun function_parameter =>
                let '_ := function_parameter in
                return_unit))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Low_level.

Module Kick.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition is_rejected {A : Type}
    (function_parameter : sum A Tezos_base__TzPervasives.trace) : bool :=
    match function_parameter with
    | Stdlib.Error (cons Tezos_base__TzPervasives.Rejected_socket_connection _)
      => true
    | Stdlib.Ok _ => false
    | Stdlib.Error err =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        log_notice
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Error: " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)) "Error: %a" % string)
          pp_print_error err in
      false
    end.
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (_assert (incoming info) Stdlib.__LOC__
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (_assert
                (equiv_decb (P2p_peer.Id.compare (peer_id info) (peer_id id2)) 0)
                Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_socket.kick auth_fd)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteq (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion
              (_assert (is_rejected conn) Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Kick.

Module Kicked.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteq (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion
              (_assert (Kick.is_rejected conn) Stdlib.__LOC__
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit))).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteq (P2p_socket.kick auth_fd)
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_unit)).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Kicked.

Module Simple_message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
  
  Definition simple_msg2 : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.write_sync conn simple_msg)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_socket.read conn)
                  (fun function_parameter =>
                    let '(_msg_size, msg) := function_parameter in
                    op_gtgteqquestion
                      (_assert
                        (equiv_decb (Stdlib.Bytes.compare simple_msg2 msg) 0)
                        Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync ch)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.write_sync conn simple_msg2)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_socket.read conn)
                  (fun function_parameter =>
                    let '(_msg_size, msg) := function_parameter in
                    op_gtgteqquestion
                      (_assert
                        (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                        Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync ch)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Simple_message.

Module Chunked_message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 8).
  
  Definition simple_msg2 : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 8).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (P2p_socket.accept None None (Some 21) canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.write_sync conn simple_msg)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_socket.read conn)
                  (fun function_parameter =>
                    let '(_msg_size, msg) := function_parameter in
                    op_gtgteqquestion
                      (_assert
                        (equiv_decb (Stdlib.Bytes.compare simple_msg2 msg) 0)
                        Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync ch)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteqquestion
          (P2p_socket.accept None None (Some 21) canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.write_sync conn simple_msg2)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_socket.read conn)
                  (fun function_parameter =>
                    let '(_msg_size, msg) := function_parameter in
                    op_gtgteqquestion
                      (_assert
                        (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                        Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync ch)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Chunked_message.

Module Oversized_message.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 17).
  
  Definition simple_msg2 : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 17).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.write_sync conn simple_msg)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_socket.read conn)
                  (fun function_parameter =>
                    let '(_msg_size, msg) := function_parameter in
                    op_gtgteqquestion
                      (_assert
                        (equiv_decb (Stdlib.Bytes.compare simple_msg2 msg) 0)
                        Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync ch)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.write_sync conn simple_msg2)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (P2p_socket.read conn)
                  (fun function_parameter =>
                    let '(_msg_size, msg) := function_parameter in
                    op_gtgteqquestion
                      (_assert
                        (equiv_decb (Stdlib.Bytes.compare simple_msg msg) 0)
                        Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion (sync ch)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Oversized_message.

Module Close_on_read.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (sync ch)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_socket.close None conn)
                  (fun _stat => return_unit)))).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (sync ch)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_socket.read conn)
                  (fun err =>
                    op_gtgteqquestion
                      (_assert (is_connection_closed err) Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (P2p_socket.close None conn)
                          (fun _stat => return_unit)))))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Close_on_read.

Module Close_on_write.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
    Data_encoding.bytes.
  
  Definition simple_msg : Stdlib.Bytes.t := Rand.generate (Z.shiftl 1 4).
  
  Definition server {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteq (P2p_socket.close None conn)
              (fun _stat =>
                op_gtgteqquestion (sync ch)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))).
  
  Definition client {A : Type}
    (ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (sync ch)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Lwt_unix.sleep
                    (* ❌ Float constant 0.1 is approximated by the integer 0 *)
                    0)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (P2p_socket.write_sync conn simple_msg)
                      (fun err =>
                        op_gtgteqquestion
                          (_assert (is_connection_closed err) Stdlib.__LOC__
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (P2p_socket.close None conn)
                              (fun _stat => return_unit))))))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Close_on_write.

Module Garbled_data.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding (option string) :=
    apply
      (let arg := dynamic_size in
      fun eta => arg None eta) (apply option string).
  
  Definition garbled_msg : string :=
    let buf := Stdlib.Bytes.create (Z.shiftl 1 4) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := TzEndian.set_int32 buf 0 (Int32.of_int 4) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := TzEndian.set_int32 buf 4 (Int32.of_int (-1)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := TzEndian.set_int32 buf 8 (Int32.of_int (-1)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := TzEndian.set_int32 buf 12 (Int32.of_int (-1)) in
    buf.
  
  Definition server {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (socket : Lwt_unix.file_descr)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (accept sched socket)
      (fun function_parameter =>
        let '(_info, auth_fd) := function_parameter in
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteqquestion (P2p_socket.raw_write_sync conn garbled_msg)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (P2p_socket.read conn)
                  (fun err =>
                    op_gtgteqquestion
                      (_assert (is_connection_closed err) Stdlib.__LOC__
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (P2p_socket.close None conn)
                          (fun _stat => return_unit)))))).
  
  Definition client {A : Type}
    (_ch : A) (sched : Tezos_p2p.P2p_io_scheduler.t)
    (addr : Tezos_base.P2p_addr.t) (port : Tezos_base.P2p_addr.port)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (connect sched addr port id2)
      (fun auth_fd =>
        op_gtgteqquestion
          (P2p_socket.accept None None None canceler auth_fd encoding)
          (fun conn =>
            op_gtgteq (P2p_socket.read conn)
              (fun err =>
                op_gtgteqquestion
                  (_assert (is_decoding_error err) Stdlib.__LOC__
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (P2p_socket.close None conn)
                      (fun _stat => return_unit))))).
  
  Definition run {A B : Type} (_dir : A) : Lwt.t B := run_nodes client server.
End Garbled_data.

Definition log_config
  : Stdlib.ref (option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg) :=
  Stdlib.ref None.

Definition spec : list (string * Stdlib.Arg.spec * string) :=
  cons
    ("--addr" % string,
      (Stdlib.Arg.String
        (fun p => Stdlib.op_coloneq addr (Ipaddr.V6.of_string_exn p))),
      " Listening addr" % string)
    (cons
      ("-v" % string,
        (Stdlib.Arg.Unit
          (fun function_parameter =>
            let 'tt := function_parameter in
            Stdlib.op_coloneq log_config
              (Some
                (Lwt_log_sink_unix.create_cfg None None
                  (Some
                    "test.p2p.connection -> info; p2p.connection -> info" %
                      string) None tt)))), " Log up to info msgs" % string)
      (cons
        ("-vv" % string,
          (Stdlib.Arg.Unit
            (fun function_parameter =>
              let 'tt := function_parameter in
              Stdlib.op_coloneq log_config
                (Some
                  (Lwt_log_sink_unix.create_cfg None None
                    (Some
                      "test.p2p.connection -> debug; p2p.connection -> debug" %
                        string) None tt)))), " Log up to debug msgs" % string)
        [])).

Definition init_logs : lazy_t (Lwt.t unit) :=
  (* ❌ Lazy expressions are not handled *)
  lazy (Internal_event_unix.init (Stdlib.op_exclamation log_config) None tt).

Definition wrap {A B : Type}
  (n : A) (f : unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Lazy.force init_logs)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (f tt)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => Lwt.return_unit
                | Stdlib.Error error =>
                  Format.kasprintf Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    pp_print_error error
                end))).

Definition main {A : Type} (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  let anon_fun {B C : Type} (_num_peers : B) : C :=
    Stdlib.raise (Bad "No anonymous argument." % string) in
  let usage_msg := "Usage: %s.
Arguments are:" % string in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Arg.parse spec anon_fun usage_msg in
  op_startypeminuserrorstar
    (* ❌ Arrays not handled. *)
    [ "" % string ] "tezos-p2p" % string
    (cons
      ("p2p-connection." % string,
        (cons (wrap "low-level" % string Low_level.run)
          (cons (wrap "kick" % string Kick.run)
            (cons (wrap "kicked" % string Kicked.run)
              (cons (wrap "simple-message" % string Simple_message.run)
                (cons (wrap "chunked-message" % string Chunked_message.run)
                  (cons
                    (wrap "oversized-message" % string Oversized_message.run)
                    (cons (wrap "close-on-read" % string Close_on_read.run)
                      (cons (wrap "close-on-write" % string Close_on_write.run)
                        (cons (wrap "garbled-data" % string Garbled_data.run)
                          (cons (Crypto_test.wrap tt) []))))))))))) []).



src/lib_protocol_compiler/byte.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The OCaml compiler not being implemented with Lwt, the compilation
    take place in a separated process (by using [Lwt_process.exec]).

    The [main] function is the entry point for the forked process.
    While [Updater.compile] is the 'forking' function to be called by
    the [tezos-node] process.

*)

(** Semi-generic compilation functions *)

let pack_objects output objects =
  let output = output ^ ".cmo" in
  Compmisc.init_path true ;
  Bytepackager.package_files
    Format.err_formatter
    Env.initial_safe_string
    objects
    output ;
  Warnings.check_fatal () ;
  output

let link_shared output objects =
  Compenv.(readenv Format.err_formatter Before_link) ;
  Compmisc.init_path true ;
  Bytelink.link Format.err_formatter objects output ;
  Warnings.check_fatal ()

let compile_ml ?for_pack ml =
  let target = Filename.chop_extension ml in
  Clflags.for_package := for_pack ;
  Compenv.(readenv Format.err_formatter (Before_compile ml)) ;
  Compile.implementation Format.err_formatter ml target ;
  Clflags.for_package := None ;
  target ^ ".cmo"

let () = Clflags.native_code := false

let driver = Compiler.{compile_ml; link_shared; pack_objects}
src/lib_protocol_compiler/byte.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition pack_objects (output : string) (objects : list string) : string :=
  let output := String.append output ".cmo" % string in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Compmisc.init_path None true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Bytepackager.package_files Format.err_formatter Env.initial_safe_string
      objects output in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Warnings.check_fatal tt in
  output.

Definition link_shared (output : string) (objects : list string) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := readenv Format.err_formatter Compenv.Before_link in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Compmisc.init_path None true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Bytelink.link Format.err_formatter objects output in
  Warnings.check_fatal tt.

Definition compile_ml (for_pack : option string) (ml : Compenv.filename)
  : string :=
  let target := Filename.chop_extension ml in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.op_coloneq Clflags.for_package for_pack in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := readenv Format.err_formatter (Compenv.Before_compile ml) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Compile.implementation Format.err_formatter ml target in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.op_coloneq Clflags.for_package None in
  String.append target ".cmo" % string.



Definition driver : Tezos_protocol_compiler.Compiler.driver :=
  {| compile_ml := compile_ml; pack_objects := pack_objects;
    link_shared := link_shared |}.

src/lib_protocol_compiler/compiler.ml 38 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let warnings = "+a-4-6-7-9-29-40..42-44-45-48"

let warn_error = "-a+8"

let () = Clflags.unsafe_string := false

(** Override the default 'Env.Persistent_signature.load'
    with a lookup in locally defined hashtable.
*)

let preloaded_cmis : (string, Env.Persistent_signature.t) Hashtbl.t =
  Hashtbl.create ~random:true 42

(* Set hook *)
let () =
  Env.Persistent_signature.load :=
    fun ~unit_name ->
      try
        Some (Hashtbl.find preloaded_cmis (String.capitalize_ascii unit_name))
      with Not_found -> None

let load_cmi_from_file file =
  Hashtbl.add
    preloaded_cmis
    (String.capitalize_ascii Filename.(basename (chop_extension file)))
    {filename = file; cmi = Cmi_format.read_cmi file}

let load_embeded_cmi (unit_name, content) =
  let content = Bytes.of_string content in
  (* Read cmi magic *)
  let magic_len = String.length Config.cmi_magic_number in
  let magic = Bytes.sub content 0 magic_len in
  assert (magic = Bytes.of_string Config.cmi_magic_number) ;
  (* Read cmi_name and cmi_sign *)
  let pos = magic_len in
  let (cmi_name, cmi_sign) = Marshal.from_bytes content pos in
  let pos = pos + Marshal.total_size content pos in
  (* Read cmi_crcs *)
  let cmi_crcs = Marshal.from_bytes content pos in
  let pos = pos + Marshal.total_size content pos in
  (* Read cmi_flags *)
  let cmi_flags = Marshal.from_bytes content pos in
  (* TODO check crcrs... *)
  Hashtbl.add
    preloaded_cmis
    (String.capitalize_ascii unit_name)
    {
      filename = unit_name ^ ".cmi";
      cmi = {cmi_name; cmi_sign; cmi_crcs; cmi_flags};
    }

let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis

(** Compilation environment.

    [tezos_protocol_env] defines the list of [cmi] available while compiling
    the protocol version. The [cmi] are packed into the [tezos-node]
    binary by using [ocp-ocamlres], see the Makefile.

    [register_env] defines a complementary list of [cmi] available
    while compiling the generated [register.ml] file (that register
    the protocol first-class module into the [Updater.versions]
    hashtable).

*)

let tezos_protocol_env =
  let open Embedded_cmis in
  [ ("CamlinternalFormatBasics", camlinternalFormatBasics_cmi);
    ("Tezos_protocol_environment_sigs", tezos_protocol_environment_sigs_cmi);
    ( "Tezos_protocol_environment_sigs__V1",
      tezos_protocol_environment_sigs__V1_cmi ) ]

let register_env =
  let open Embedded_cmis in
  [ ( "tezos_protocol_registerer__Registerer",
      tezos_protocol_registerer__Registerer_cmi ) ]

(** Helpers *)

let ( // ) = Filename.concat

let create_file ?(perm = 0o644) name content =
  let open Unix in
  let fd = openfile name [O_TRUNC; O_CREAT; O_WRONLY] perm in
  ignore (write_substring fd content 0 (String.length content)) ;
  close fd

let safe_unlink file =
  try Unix.unlink file with Unix.Unix_error (Unix.ENOENT, _, _) -> ()

let unlink_cmi dir (file, _) = safe_unlink ((dir // file) ^ ".cmi")

let unlink_object obj =
  safe_unlink obj ;
  safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".cmi") ;
  safe_unlink (Filename.chop_suffix obj ".cmx" ^ ".o")

let debug_flag = ref false

let debug fmt =
  if !debug_flag then Format.eprintf fmt
  else Format.ifprintf Format.err_formatter fmt

let mktemp_dir () =
  Filename.get_temp_dir_name ()
  // Printf.sprintf "tezos-protocol-build-%06X" (Random.int 0xFFFFFF)

(** Main *)

type driver = {
  compile_ml : ?for_pack:string -> string -> string;
  pack_objects : string -> string list -> string;
  link_shared : string -> string list -> unit;
}

let main {compile_ml; pack_objects; link_shared} =
  Random.self_init () ;
  let anonymous = ref []
  and static = ref false
  and register = ref false
  and build_dir = ref None
  and output_file = ref None
  and output_dep = ref false
  and hash_only = ref false
  and check_protocol_hash = ref true in
  let args_spec =
    [ ("-o", Arg.String (fun s -> output_file := Some s), "");
      ( "-hash-only",
        Arg.Set hash_only,
        " Only display the hash of the protocol and don't compile" );
      ( "-no-hash-check",
        Arg.Clear check_protocol_hash,
        " Don't check that TEZOS_PROTOCOL declares the expected protocol hash \
         (if existent)" );
      ("-static", Arg.Set static, " Only build the static library (no .cmxs)");
      ("-register", Arg.Set register, " Generate the `Registerer` module");
      ("-bin-annot", Arg.Set Clflags.binary_annotations, " (see ocamlopt)");
      ("-g", Arg.Set Clflags.debug, " (see ocamlopt)");
      ("-output-dep", Arg.Set output_dep, " ...");
      ( "-build-dir",
        Arg.String (fun s -> build_dir := Some s),
        "use custom build directory and preserve build artifacts" ) ]
  in
  let usage_msg =
    Printf.sprintf "Usage: %s [options] <srcdir>\nOptions are:" Sys.argv.(0)
  in
  Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
  let source_dir =
    match List.rev !anonymous with
    | [protocol_dir] ->
        protocol_dir
    | _ ->
        Arg.usage args_spec usage_msg ;
        Pervasives.exit 1
  in
  let (announced_hash, protocol) =
    match
      Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
    with
    | Ok (hash, proto) ->
        (hash, proto)
    | Error err ->
        Format.eprintf "Failed to read TEZOS_PROTOCOL: %a" pp_print_error err ;
        exit 2
  in
  let real_hash = Protocol.hash protocol in
  if !hash_only then (
    Format.printf "%a@." Protocol_hash.pp real_hash ;
    exit 0 ) ;
  let hash =
    match announced_hash with
    | None ->
        real_hash
    | Some hash
      when !check_protocol_hash && not (Protocol_hash.equal real_hash hash) ->
        Format.eprintf
          "Inconsistent hash for protocol in TEZOS_PROTOCOL.@\n\
           Found: %a@\n\
           Expected: %a@."
          Protocol_hash.pp
          hash
          Protocol_hash.pp
          real_hash ;
        exit 2
    | Some hash ->
        hash
  in
  let build_dir =
    match !build_dir with
    | None ->
        let dir = mktemp_dir () in
        at_exit (fun () -> Lwt_main.run (Lwt_utils_unix.remove_dir dir)) ;
        dir
    | Some dir ->
        dir
  in
  let output =
    match !output_file with
    | Some output ->
        output
    | None ->
        Format.asprintf "proto_%a" Protocol_hash.pp hash
  in
  Lwt_main.run (Lwt_utils_unix.create_dir ~perm:0o755 build_dir) ;
  Lwt_main.run
    (Lwt_utils_unix.create_dir ~perm:0o755 (Filename.dirname output)) ;
  (* Generate the 'functor' *)
  let functor_file = build_dir // "functor.ml" in
  let oc = open_out functor_file in
  Packer.dump
    oc
    hash
    (Array.map
       (fun {Protocol.name; _} ->
         let name_lowercase = String.uncapitalize_ascii name in
         (source_dir // name_lowercase) ^ ".ml")
       (Array.of_list protocol.components)) ;
  close_out oc ;
  (* Compile the protocol *)
  let proto_cmi = Filename.chop_extension functor_file ^ ".cmi" in
  let functor_unit =
    String.capitalize_ascii Filename.(basename (chop_extension functor_file))
  in
  let for_pack = String.capitalize_ascii (Filename.basename output) in
  (* Initialize the compilers *)
  Compenv.(readenv Format.err_formatter Before_args) ;
  Clflags.nopervasives := true ;
  Clflags.no_std_include := true ;
  Clflags.include_dirs := [Filename.dirname functor_file] ;
  Warnings.parse_options false warnings ;
  Warnings.parse_options true warn_error ;
  load_embeded_cmis tezos_protocol_env ;
  let packed_protocol_object = compile_ml ~for_pack functor_file in
  let register_objects =
    if not !register then []
    else (
      load_embeded_cmis register_env ;
      load_cmi_from_file proto_cmi ;
      (* Compiler the 'registering module' *)
      let register_file = Filename.dirname functor_file // "register.ml" in
      create_file
        register_file
        (Printf.sprintf
           "module Name = struct let name = %S end\n\
           \ let () = Tezos_protocol_registerer__Registerer.register \
            Name.name (module %s.Make)"
           (Protocol_hash.to_b58check hash)
           functor_unit) ;
      let register_object = compile_ml ~for_pack register_file in
      [register_object] )
  in
  let resulting_object =
    pack_objects output (packed_protocol_object :: register_objects)
  in
  (* Create the final [cmxs] *)
  if not !static then (
    Clflags.link_everything := true ;
    link_shared (output ^ ".cmxs") [resulting_object] ) ;
  if !output_dep then (
    let dsrc = Digest.file functor_file in
    let dimpl = Digest.file resulting_object in
    let dintf =
      Digest.file (Filename.chop_extension resulting_object ^ ".cmi")
    in
    Format.printf "module Toto = struct include %s end ;; \n" for_pack ;
    Format.printf "let src_digest = %S ;;\n" (Digest.to_hex dsrc) ;
    Format.printf "let impl_digest = %S ;;\n" (Digest.to_hex dimpl) ;
    Format.printf "let intf_digest = %S ;;\n" (Digest.to_hex dintf) ) ;
  Format.printf "Success: %a.@." Protocol_hash.pp hash
src/lib_protocol_compiler/compiler.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition warnings : string := "+a-4-6-7-9-29-40..42-44-45-48" % string.

Definition warn_error : string := "-a+8" % string.



Definition preloaded_cmis
  : Stdlib.Hashtbl.t string Env.Persistent_signature.t :=
  Hashtbl.create (Some true) 42.



Definition load_cmi_from_file (file : string) : unit :=
  Hashtbl.add preloaded_cmis
    (String.capitalize_ascii (basename (chop_extension file)))
    {| filename := file; cmi := Cmi_format.read_cmi file |}.

Definition load_embeded_cmi (function_parameter : string * string) : unit :=
  let '(unit_name, content) := function_parameter in
  let content := Stdlib.Bytes.of_string content in
  let magic_len := String.length Config.cmi_magic_number in
  let magic := String.sub content 0 magic_len in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (equiv_decb magic (Stdlib.Bytes.of_string Config.cmi_magic_number))
    in
  let pos := magic_len in
  let '(cmi_name, cmi_sign) := Marshal.from_bytes content pos in
  let pos := Z.add pos (Marshal.total_size content pos) in
  let cmi_crcs := Marshal.from_bytes content pos in
  let pos := Z.add pos (Marshal.total_size content pos) in
  let cmi_flags := Marshal.from_bytes content pos in
  Hashtbl.add preloaded_cmis (String.capitalize_ascii unit_name)
    {| filename := String.append unit_name ".cmi" % string;
      cmi :=
        {| cmi_name := cmi_name; cmi_sign := cmi_sign; cmi_crcs := cmi_crcs;
          cmi_flags := cmi_flags |} |}.

Definition load_embeded_cmis (cmis : list (string * string)) : unit :=
  List.iter load_embeded_cmi cmis.

Definition tezos_protocol_env : list (string * string) :=
  cons ("CamlinternalFormatBasics" % string, camlinternalFormatBasics_cmi)
    (cons
      ("Tezos_protocol_environment_sigs" % string,
        tezos_protocol_environment_sigs_cmi)
      (cons
        ("Tezos_protocol_environment_sigs__V1" % string,
          tezos_protocol_environment_sigs__V1_cmi) [])).

Definition register_env : list (string * string) :=
  cons
    ("tezos_protocol_registerer__Registerer" % string,
      tezos_protocol_registerer__Registerer_cmi) [].

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition create_file (op_staroptstar : option Unix.file_perm)
  : string -> string -> unit :=
  let perm :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 420
    end in
  fun name =>
    fun content =>
      let fd :=
        openfile name
          (cons Unix.O_TRUNC (cons Unix.O_CREAT (cons Unix.O_WRONLY []))) perm
        in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        OCaml.Stdlib.ignore
          (write_substring fd content 0 (String.length content)) in
      close fd.

Definition safe_unlink (file : string) : unit :=
  (* ❌ Try-with are not handled *)
  try (Unix.unlink file).

Definition unlink_cmi {A : Type}
  (dir : string) (function_parameter : string * A) : unit :=
  let '(file, _) := function_parameter in
  safe_unlink (String.append (op_divdiv dir file) ".cmi" % string).

Definition unlink_object (obj : string) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := safe_unlink obj in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    safe_unlink
      (String.append (Filename.chop_suffix obj ".cmx" % string) ".cmi" % string)
    in
  safe_unlink
    (String.append (Filename.chop_suffix obj ".cmx" % string) ".o" % string).

Definition debug_flag : Stdlib.ref bool := Stdlib.ref false.

Definition debug {A : Type} (fmt : Stdlib.format A Stdlib.Format.formatter unit)
  : A :=
  if Stdlib.op_exclamation debug_flag then
    Format.eprintf fmt
  else
    Format.ifprintf Format.err_formatter fmt.

Definition mktemp_dir (function_parameter : unit) : string :=
  let 'tt := function_parameter in
  op_divdiv (Filename.get_temp_dir_name tt)
    (Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "tezos-protocol-build-" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_X
            (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
              6) CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "tezos-protocol-build-%06X" % string) (Random.int 16777215)).

Record driver := {
  compile_ml : (option string) -> string -> string;
  pack_objects : string -> (list string) -> string;
  link_shared : string -> (list string) -> unit }.

Definition main (function_parameter : driver) : unit :=
  let '{|
    compile_ml := compile_ml;
      pack_objects := pack_objects;
      link_shared := link_shared
      |} := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Random.self_init tt in
  let anonymous : Stdlib.ref (list string) :=
    Stdlib.ref []
  with static : Stdlib.ref bool :=
    Stdlib.ref false
  with register : Stdlib.ref bool :=
    Stdlib.ref false
  with build_dir : Stdlib.ref (option string) :=
    Stdlib.ref None
  with output_file : Stdlib.ref (option string) :=
    Stdlib.ref None
  with output_dep : Stdlib.ref bool :=
    Stdlib.ref false
  with hash_only : Stdlib.ref bool :=
    Stdlib.ref false
  with check_protocol_hash : Stdlib.ref bool :=
    Stdlib.ref true in
  let args_spec :=
    cons
      ("-o" % string,
        (Stdlib.Arg.String (fun s => Stdlib.op_coloneq output_file (Some s))),
        "" % string)
      (cons
        ("-hash-only" % string, (Stdlib.Arg.Set hash_only),
          " Only display the hash of the protocol and don't compile" % string)
        (cons
          ("-no-hash-check" % string, (Stdlib.Arg.Clear check_protocol_hash),
            " Don't check that TEZOS_PROTOCOL declares the expected protocol hash (if existent)"
              % string)
          (cons
            ("-static" % string, (Stdlib.Arg.Set static),
              " Only build the static library (no .cmxs)" % string)
            (cons
              ("-register" % string, (Stdlib.Arg.Set register),
                " Generate the `Registerer` module" % string)
              (cons
                ("-bin-annot" % string,
                  (Stdlib.Arg.Set Clflags.binary_annotations),
                  " (see ocamlopt)" % string)
                (cons
                  ("-g" % string, (Stdlib.Arg.Set Clflags.debug),
                    " (see ocamlopt)" % string)
                  (cons
                    ("-output-dep" % string, (Stdlib.Arg.Set output_dep),
                      " ..." % string)
                    (cons
                      ("-build-dir" % string,
                        (Stdlib.Arg.String
                          (fun s => Stdlib.op_coloneq build_dir (Some s))),
                        "use custom build directory and preserve build artifacts"
                          % string) [])))))))) in
  let usage_msg :=
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Usage: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              " [options] <srcdir>
Options are:" % string
              CamlinternalFormatBasics.End_of_format)))
        "Usage: %s [options] <srcdir>
Options are:" % string)
      (Array.get Sys.argv 0) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Arg.parse args_spec
      (fun s =>
        Stdlib.op_coloneq anonymous (cons s (Stdlib.op_exclamation anonymous)))
      usage_msg in
  let source_dir :=
    match List.rev (Stdlib.op_exclamation anonymous) with
    | cons protocol_dir [] => protocol_dir
    | _ =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Arg.usage args_spec usage_msg in
      Pervasives.exit 1
    end in
  let '(announced_hash, protocol) :=
    match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
    | Stdlib.Ok (hash, proto) => (hash, proto)
    | Stdlib.Error err =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Failed to read TEZOS_PROTOCOL: " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Failed to read TEZOS_PROTOCOL: %a" % string) pp_print_error err in
      Stdlib.exit 2
    end in
  let real_hash := Protocol.hash protocol in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if Stdlib.op_exclamation hash_only then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Flush_newline
                CamlinternalFormatBasics.End_of_format)) "%a@." % string)
          Protocol_hash.pp real_hash in
      Stdlib.exit 0
    else
      tt in
  let hash :=
    match announced_hash with
    | None => real_hash
    | Some hash =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.eprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Inconsistent hash for protocol in TEZOS_PROTOCOL." % string
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Force_newline
                (CamlinternalFormatBasics.String_literal "Found: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Force_newline
                      (CamlinternalFormatBasics.String_literal
                        "Expected: " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Flush_newline
                            CamlinternalFormatBasics.End_of_format))))))))
            "Inconsistent hash for protocol in TEZOS_PROTOCOL.@
Found: %a@
Expected: %a@."
              % string) Protocol_hash.pp hash Protocol_hash.pp real_hash in
      Stdlib.exit 2
    | Some hash => hash
    end in
  let build_dir :=
    match Stdlib.op_exclamation build_dir with
    | None =>
      let dir := mktemp_dir tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.at_exit
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_main.run (Lwt_utils_unix.remove_dir dir)) in
      dir
    | Some dir => dir
    end in
  let output :=
    match Stdlib.op_exclamation output_file with
    | Some output => output
    | None =>
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "proto_" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "proto_%a" % string)
        Protocol_hash.pp hash
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Lwt_main.run (Lwt_utils_unix.create_dir (Some 493) build_dir) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Lwt_main.run
      (Lwt_utils_unix.create_dir (Some 493) (Filename.dirname output)) in
  let functor_file := op_divdiv build_dir "functor.ml" % string in
  let oc := Stdlib.open_out functor_file in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Packer.dump oc hash
      (Array.map
        (fun function_parameter =>
          let '{| Protocol.name := name |} := function_parameter in
          let name_lowercase := String.uncapitalize_ascii name in
          String.append (op_divdiv source_dir name_lowercase) ".ml" % string)
        (Array.of_list (components protocol))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.close_out oc in
  let proto_cmi :=
    String.append (Filename.chop_extension functor_file) ".cmi" % string in
  let functor_unit :=
    String.capitalize_ascii (basename (chop_extension functor_file)) in
  let for_pack := String.capitalize_ascii (Filename.basename output) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := readenv Format.err_formatter Compenv.Before_args in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.op_coloneq Clflags.nopervasives true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.op_coloneq Clflags.no_std_include true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Stdlib.op_coloneq Clflags.include_dirs
      (cons (Filename.dirname functor_file) []) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Warnings.parse_options false warnings in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Warnings.parse_options true warn_error in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := load_embeded_cmis tezos_protocol_env in
  let packed_protocol_object := compile_ml (Some for_pack) functor_file in
  let register_objects :=
    if negb (Stdlib.op_exclamation register) then
      []
    else
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := load_embeded_cmis register_env in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := load_cmi_from_file proto_cmi in
      let register_file :=
        op_divdiv (Filename.dirname functor_file) "register.ml" % string in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        create_file None register_file
          (Printf.sprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "module Name = struct let name = " % string
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " end
 let () = Tezos_protocol_registerer__Registerer.register Name.name (module "
                      % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal ".Make)" % string
                        CamlinternalFormatBasics.End_of_format)))))
              "module Name = struct let name = %S end
 let () = Tezos_protocol_registerer__Registerer.register Name.name (module %s.Make)"
                % string) (Protocol_hash.to_b58check hash) functor_unit) in
      let register_object := compile_ml (Some for_pack) register_file in
      cons register_object [] in
  let resulting_object :=
    pack_objects output (cons packed_protocol_object register_objects) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if negb (Stdlib.op_exclamation static) then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq Clflags.link_everything true in
      link_shared (String.append output ".cmxs" % string)
        (cons resulting_object [])
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if Stdlib.op_exclamation output_dep then
      let dsrc := Digest.file functor_file in
      let dimpl := Digest.file resulting_object in
      let dintf :=
        Digest.file
          (String.append (Filename.chop_extension resulting_object)
            ".cmi" % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "module Toto = struct include " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " end ;; 
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "module Toto = struct include %s end ;; 
" % string) for_pack in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "let src_digest = " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;;
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "let src_digest = %S ;;
" % string) (Digest.to_hex dsrc) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "let impl_digest = " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal " ;;
" % string
                  CamlinternalFormatBasics.End_of_format)))
            "let impl_digest = %S ;;
" % string) (Digest.to_hex dimpl) in
      Format.printf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "let intf_digest = " % string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal " ;;
" % string
                CamlinternalFormatBasics.End_of_format)))
          "let intf_digest = %S ;;
" % string) (Digest.to_hex dintf)
    else
      tt in
  Format.printf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "Success: " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Char_literal "." % char
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Flush_newline
              CamlinternalFormatBasics.End_of_format))))
      "Success: %a.@." % string) Protocol_hash.pp hash.

src/lib_protocol_compiler/main_byte.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  try
    Tezos_protocol_compiler.Compiler.main
      Tezos_protocol_compiler_byte.Byte.driver ;
    Pervasives.exit 0
  with exn ->
    Format.eprintf "%a\n%!" Errors.report_error exn ;
    Pervasives.exit 1
src/lib_protocol_compiler/main_byte.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/lib_protocol_compiler/main_embedded_packer.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let srcdir = Sys.argv.(1)

let version = Sys.argv.(2)

let srcdir =
  if Filename.basename srcdir = "TEZOS_PROTOCOL" then Filename.dirname srcdir
  else srcdir

let (hash, sources) =
  match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir srcdir) with
  | Ok (None, proto) ->
      (Protocol.hash proto, proto)
  | Ok (Some hash, proto) ->
      (hash, proto)
  | Error err ->
      Format.kasprintf
        Pervasives.failwith
        "Failed to read TEZOS_PROTOCOL: %a"
        pp_print_error
        err

let () =
  Format.printf
    {|
module Source = struct
  let hash =
    Some (Tezos_crypto.Protocol_hash.of_b58check_exn %S)
  let sources = Tezos_base.Protocol.%a
end
@.|}
    (Protocol_hash.to_b58check hash)
    Protocol.pp_ocaml
    sources

let () =
  Format.printf
    {|
module Registered =
  Tezos_protocol_updater.Registered_protocol.Register_embedded
    (Tezos_protocol_environment_%s.Environment)
    (Tezos_raw_protocol_%s.Main)
    (Source)
@.|}
    version
    version
src/lib_protocol_compiler/main_embedded_packer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition srcdir : string := Array.get Sys.argv 1.

Definition version : string := Array.get Sys.argv 2.

Definition srcdir : string :=
  if equiv_decb (Filename.basename srcdir) "TEZOS_PROTOCOL" % string then
    Filename.dirname srcdir
  else
    srcdir.







src/lib_protocol_compiler/main_native.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  try
    Tezos_protocol_compiler.Compiler.main
      Tezos_protocol_compiler_native.Native.driver ;
    Pervasives.exit 0
  with exn ->
    Format.eprintf "%a\n%!" Opterrors.report_error exn ;
    Pervasives.exit 1
src/lib_protocol_compiler/main_native.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/lib_protocol_compiler/main_packer.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

let () =
  Random.self_init () ;
  let anonymous = ref [] in
  let args_spec = [] in
  let usage_msg = Printf.sprintf "Usage: %s [options] <srcdir>" Sys.argv.(0) in
  Arg.parse args_spec (fun s -> anonymous := s :: !anonymous) usage_msg ;
  let source_dir =
    match List.rev !anonymous with
    | [source_dir] when Filename.basename source_dir = "TEZOS_PROTOCOL" ->
        Filename.dirname source_dir
    | [source_dir] ->
        source_dir
    | _ ->
        Arg.usage args_spec usage_msg ;
        Pervasives.exit 1
  in
  let (hash, protocol) =
    match
      Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir)
    with
    | Ok (None, proto) ->
        (Protocol.hash proto, proto)
    | Ok (Some hash, proto) ->
        (hash, proto)
    | Error err ->
        Format.kasprintf
          Pervasives.failwith
          "Failed to read TEZOS_PROTOCOL: %a"
          pp_print_error
          err
  in
  (* Generate the 'functor' *)
  Packer.dump
    stdout
    hash
    (Array.map
       (fun {Protocol.name; _} ->
         let name_lowercase = String.uncapitalize_ascii name in
         (source_dir // name_lowercase) ^ ".ml")
       (Array.of_list protocol.components))
src/lib_protocol_compiler/main_packer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.



src/lib_protocol_compiler/native.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The OCaml compiler not being implemented with Lwt, the compilation
    take place in a separated process (by using [Lwt_process.exec]).

    The [main] function is the entry point for the forked process.
    While [Updater.compile] is the 'forking' function to be called by
    the [tezos-node] process.

*)

open Compiler

(* TODO: fail in the presence of "external" *)

module Backend = struct
  (* See backend_intf.mli. *)

  let symbol_for_global' = Compilenv.symbol_for_global'

  let closure_symbol = Compilenv.closure_symbol

  let really_import_approx = Import_approx.really_import_approx

  let import_symbol = Import_approx.import_symbol

  let size_int = Arch.size_int

  let big_endian = Arch.big_endian

  let max_sensible_number_of_arguments =
    (* The "-1" is to allow for a potential closure environment parameter. *)
    Proc.max_arguments_for_tailcalls - 1
end

let backend = (module Backend : Backend_intf.S)

(** Semi-generic compilation functions *)

let pack_objects output objects =
  let output = output ^ ".cmx" in
  Compmisc.init_path true ;
  Asmpackager.package_files
    ~backend
    Format.err_formatter
    Env.initial_safe_string
    objects
    output ;
  Warnings.check_fatal () ;
  output

let link_shared output objects =
  Compenv.(readenv Format.err_formatter Before_link) ;
  Compmisc.init_path true ;
  Asmlink.link_shared Format.err_formatter objects output ;
  Warnings.check_fatal ()

let compile_ml ?for_pack ml =
  let target = Filename.chop_extension ml in
  Clflags.for_package := for_pack ;
  Compenv.(readenv Format.err_formatter (Before_compile ml)) ;
  Optcompile.implementation ~backend Format.err_formatter ml target ;
  Clflags.for_package := None ;
  target ^ ".cmx"

let () = Clflags.native_code := true

let driver = {compile_ml; link_shared; pack_objects}
src/lib_protocol_compiler/native.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Compiler.

Module Backend.
  Definition symbol_for_global' : Ident.t -> Symbol.t :=
    Compilenv.symbol_for_global'.
  
  Definition closure_symbol : Closure_id.t -> Symbol.t :=
    Compilenv.closure_symbol.
  
  Definition really_import_approx
    : Simple_value_approx.t -> Simple_value_approx.t :=
    Import_approx.really_import_approx.
  
  Definition import_symbol : Symbol.t -> Simple_value_approx.t :=
    Import_approx.import_symbol.
  
  Definition size_int : Z := Arch.size_int.
  
  Definition big_endian : bool := Arch.big_endian.
  
  Definition max_sensible_number_of_arguments : Z :=
    Z.sub Proc.max_arguments_for_tailcalls 1.
End Backend.

Definition backend : {_ : unit & Backend_intf.S.signature } := Backend.

Definition pack_objects (output : string) (objects : list string) : string :=
  let output := String.append output ".cmx" % string in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Compmisc.init_path None true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Asmpackager.package_files Format.err_formatter Env.initial_safe_string
      objects output backend in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Warnings.check_fatal tt in
  output.

Definition link_shared (output : string) (objects : list string) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := readenv Format.err_formatter Compenv.Before_link in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Compmisc.init_path None true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Asmlink.link_shared Format.err_formatter objects output in
  Warnings.check_fatal tt.

Definition compile_ml (for_pack : option string) (ml : Compenv.filename)
  : string :=
  let target := Filename.chop_extension ml in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.op_coloneq Clflags.for_package for_pack in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := readenv Format.err_formatter (Compenv.Before_compile ml) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Optcompile.implementation backend Format.err_formatter ml target in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.op_coloneq Clflags.for_package None in
  String.append target ".cmx" % string.



Definition driver : Tezos_protocol_compiler.Compiler.driver :=
  {| compile_ml := compile_ml; pack_objects := pack_objects;
    link_shared := link_shared |}.

src/lib_protocol_compiler/packer.ml 19 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let dump_file oc file =
  let ic = open_in file in
  let buflen = 8096 in
  let buf = Bytes.create buflen in
  let rec loop () =
    let len = input ic buf 0 buflen in
    if len <> 0 then (
      Printf.fprintf
        oc
        "%s"
        ( if len = buflen then Bytes.unsafe_to_string buf
        else Bytes.sub_string buf 0 len ) ;
      loop () )
  in
  loop () ; close_in ic

let include_ml oc file =
  let unit =
    String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
  in
  (* FIXME insert .mli... *)
  Printf.fprintf oc "module %s " unit ;
  if Sys.file_exists (file ^ "i") then (
    Printf.fprintf oc ": sig\n" ;
    Printf.fprintf oc "# 1 %S\n" (file ^ "i") ;
    dump_file oc (file ^ "i") ;
    Printf.fprintf oc "end " ) ;
  Printf.fprintf oc "= struct\n" ;
  Printf.fprintf oc "# 1 %S\n" file ;
  dump_file oc file ;
  Printf.fprintf oc "end\n%!"

let opened_modules =
  ["Tezos_protocol_environment"; "Pervasives"; "Error_monad"; "Logging"]

let dump oc hash files =
  Printf.fprintf
    oc
    "module Make (Tezos_protocol_environment : \
     Tezos_protocol_environment_sigs__V1.T) = struct\n" ;
  Printf.fprintf oc "[@@@ocaml.warning \"-33\"]\n" ;
  List.iter (Printf.fprintf oc "open %s\n") opened_modules ;
  Printf.fprintf oc "[@@@ocaml.warning \"+33\"]\n" ;
  Printf.fprintf
    oc
    "let hash = Protocol_hash.of_b58check_exn %S;;\n"
    (Protocol_hash.to_b58check hash) ;
  for i = 0 to Array.length files - 1 do
    include_ml oc files.(i)
  done ;
  Printf.fprintf
    oc
    "  include %s\n"
    (String.capitalize_ascii
       (Filename.basename
          (Filename.chop_extension files.(Array.length files - 1)))) ;
  Printf.fprintf oc "end\n%!"
src/lib_protocol_compiler/packer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition dump_file (oc : Stdlib.out_channel) (file : string) : unit :=
  let ic := Stdlib.open_in file in
  let buflen := 8096 in
  let buf := Stdlib.Bytes.create buflen in
  let fix loop (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    let len := Stdlib.input ic buf 0 buflen in
    if nequiv_decb len 0 then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Printf.fprintf oc
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format) "%s" % string)
          (if equiv_decb len buflen then
            Stdlib.Bytes.unsafe_to_string buf
          else
            Stdlib.Bytes.sub_string buf 0 len) in
      loop tt
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := loop tt in
  Stdlib.close_in ic.

Definition include_ml (oc : Stdlib.out_channel) (file : string) : unit :=
  let unit :=
    String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "module " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal " " % char
              CamlinternalFormatBasics.End_of_format))) "module %s " % string)
      unit in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if Sys.file_exists (String.append file "i" % string) then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Printf.fprintf oc
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal ": sig
" % string
              CamlinternalFormatBasics.End_of_format) ": sig
" % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Printf.fprintf oc
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "# 1 " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "010" % char
                  CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string)
          (String.append file "i" % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := dump_file oc (String.append file "i" % string) in
      Printf.fprintf oc
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "end " % string
            CamlinternalFormatBasics.End_of_format) "end " % string)
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "= struct
" % string
          CamlinternalFormatBasics.End_of_format) "= struct
" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "# 1 " % string
          (CamlinternalFormatBasics.Caml_string
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string) file
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := dump_file oc file in
  Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "end
" % string
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
      "end
%!" % string).

Definition opened_modules : list string :=
  cons "Tezos_protocol_environment" % string
    (cons "Pervasives" % string
      (cons "Error_monad" % string (cons "Logging" % string []))).

Definition dump
  (oc : Stdlib.out_channel) (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (files : array string) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "module Make (Tezos_protocol_environment : Tezos_protocol_environment_sigs__V1.T) = struct
"
            % string CamlinternalFormatBasics.End_of_format)
        "module Make (Tezos_protocol_environment : Tezos_protocol_environment_sigs__V1.T) = struct
"
          % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Escaped_at
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Scan_indic "o" % char)
              (CamlinternalFormatBasics.String_literal
                "caml.warning ""-33""]
" % string
                CamlinternalFormatBasics.End_of_format))))
        "[@@@ocaml.warning ""-33""]
" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (Printf.fprintf oc
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "open " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "010" % char
                CamlinternalFormatBasics.End_of_format))) "open %s
" % string))
      opened_modules in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Escaped_at
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Scan_indic "o" % char)
              (CamlinternalFormatBasics.String_literal
                "caml.warning ""+33""]
" % string
                CamlinternalFormatBasics.End_of_format))))
        "[@@@ocaml.warning ""+33""]
" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "let hash = Protocol_hash.of_b58check_exn " % string
          (CamlinternalFormatBasics.Caml_string
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ";;
" % string
              CamlinternalFormatBasics.End_of_format)))
        "let hash = Protocol_hash.of_b58check_exn %S;;
" % string)
      (Protocol_hash.to_b58check hash) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ For loops not handled. *)
    for in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "  include " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "  include %s
" % string)
      (String.capitalize_ascii
        (Filename.basename
          (Filename.chop_extension
            (Array.get files (Z.sub (Array.length files) 1))))) in
  Printf.fprintf oc
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "end
" % string
        (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
      "end
%!" % string).

src/lib_protocol_compiler/registerer.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type PROTOCOL_V1 = functor
  (Env : Tezos_protocol_environment_sigs.V1.T)
  -> Env.Updater.PROTOCOL

module VersionTable = Protocol_hash.Table

let versions : (module PROTOCOL_V1) VersionTable.t = VersionTable.create 20

let register hash proto =
  let hash = Protocol_hash.of_b58check_exn hash in
  VersionTable.add versions hash proto

let mem hash = VersionTable.mem versions hash

let get hash =
  try Some (VersionTable.find versions hash) with Not_found -> None
src/lib_protocol_compiler/registerer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of signature is not handled. *)
unhandled_module_type

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition versions : VersionTable.t {_ : unit & PROTOCOL_V1.signature } :=
  VersionTable.create 20.

Definition register
  (hash : string) (proto : {_ : unit & PROTOCOL_V1.signature }) : unit :=
  let hash := Protocol_hash.of_b58check_exn hash in
  VersionTable.add versions hash proto.

Definition mem (hash : VersionTable.key) : bool :=
  VersionTable.mem versions hash.

Definition get (hash : VersionTable.key)
  : option {_ : unit & PROTOCOL_V1.signature } :=
  (* ❌ Try-with are not handled *)
  try (Some (VersionTable.find versions hash)).

src/lib_protocol_compiler/replace.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module StringMap = Map.Make (String)
open Re

let regexp = Str.regexp "%%[^%]*%%"

let current_dir = Sys.getcwd ()

let guess_version () =
  let prefix = "proto_" in
  let rec loop dir =
    let dirname = Filename.basename dir in
    let x = String.length prefix in
    let n = String.length dirname in
    if n >= x && String.sub dirname 0 x = prefix then
      String.sub dirname x (n - x)
    else
      let updir = Filename.dirname dir in
      if updir = dir then (
        Format.eprintf
          "Cannot guess protocol version in path!@.Looking for `%s*` in `%s`@."
          prefix
          current_dir ;
        exit 1 ) ;
      loop updir
  in
  loop (Sys.getcwd ())

let warning_message =
  {|

;
;        /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;

|}

let replace ~template ~destination vars =
  let inch = open_in template in
  let outch = open_out destination in
  output_string outch warning_message ;
  try
    while true do
      let line = input_line inch in
      let line =
        Str.global_substitute
          regexp
          (fun s ->
            let matched = Str.matched_string s in
            let var = String.sub matched 2 (String.length matched - 4) in
            match StringMap.find_opt var vars with
            | Some value ->
                value
            | None ->
                prerr_endline ("Unknown variable: " ^ var) ;
                exit 1)
          line
      in
      output_string outch line ; output_string outch "\n"
    done
  with End_of_file -> flush outch ; close_out outch ; ()

let module_name (c : Protocol.component) = String.capitalize_ascii c.name

let sources_name (c : Protocol.component) =
  let name = String.lowercase_ascii c.name in
  match c.interface with
  | None ->
      Printf.sprintf "%s.ml" name
  | Some _ ->
      Printf.sprintf "%s.mli %s.ml" name name

let process ~template ~destination (protocol : Protocol.t) lib_version hash =
  let version = String.concat "-" (String.split_on_char '_' lib_version) in
  let vars =
    StringMap.empty
    |> StringMap.add "VERSION" version
    |> StringMap.add "LIB_VERSION" lib_version
    |> StringMap.add "HASH" (Protocol_hash.to_b58check hash)
    |> StringMap.add
         "MODULES"
         (String.concat " " (List.map module_name protocol.components))
    |> StringMap.add
         "SOURCES"
         (String.concat " " (List.map sources_name protocol.components))
  in
  replace ~template ~destination vars

let read_proto destination =
  let source_dir =
    if Filename.is_relative destination then
      Filename.concat current_dir (Filename.dirname destination)
    else Filename.dirname destination
  in
  match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
  | Ok (None, proto) ->
      (Protocol.hash proto, proto)
  | Ok (Some hash, proto) ->
      (hash, proto)
  | Error err ->
      Format.kasprintf
        Pervasives.failwith
        "Failed to read TEZOS_PROTOCOL in %s:@ %a"
        source_dir
        pp_print_error
        err

let main () =
  let template = Sys.argv.(1) in
  let destination = Sys.argv.(2) in
  let version = try Sys.argv.(3) with _ -> guess_version () in
  let (hash, proto) = read_proto destination in
  process ~template ~destination proto version hash

let () = main ()
src/lib_protocol_compiler/replace.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

Import Re.

Definition regexp : Re.Str.regexp := Str.regexp "%%[^%]*%%" % string.

Definition current_dir : string := Sys.getcwd tt.

Definition guess_version (function_parameter : unit) : string :=
  let 'tt := function_parameter in
  let prefix := "proto_" % string in
  let fix loop (dir : string) : string :=
    let dirname := Filename.basename dir in
    let x := String.length prefix in
    let n := String.length dirname in
    if andb (OCaml.Stdlib.ge n x) (equiv_decb (String.sub dirname 0 x) prefix)
      then
      String.sub dirname x (Z.sub n x)
    else
      let updir := Filename.dirname dir in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if equiv_decb updir dir then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.eprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Cannot guess protocol version in path!" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Flush_newline
                    (CamlinternalFormatBasics.String_literal
                      "Looking for `" % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          "*` in `" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.Char_literal "`" % char
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))))))
                "Cannot guess protocol version in path!@.Looking for `%s*` in `%s`@."
                  % string) prefix current_dir in
          Stdlib.exit 1
        else
          tt in
      loop updir in
  loop (Sys.getcwd tt).

Definition warning_message : string :=
  "

;
;        /!\ /!\ Do not modify this file /!\ /!\
;
; but the original template in `tezos-protocol-compiler`
;

"
    % string.

Definition replace
  (template : string) (destination : string) (vars : StringMap.t string)
  : unit :=
  let inch := Stdlib.open_in template in
  let outch := Stdlib.open_out destination in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.output_string outch warning_message in
  (* ❌ Try-with are not handled *)
  try
    (* ❌ While loops not handled. *)
    while.

Definition module_name (c : Tezos_base__TzPervasives.Protocol.component)
  : string := String.capitalize_ascii (name c).

Definition sources_name (c : Tezos_base__TzPervasives.Protocol.component)
  : string :=
  let name := String.lowercase_ascii (name c) in
  match interface c with
  | None =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal ".ml" % string
            CamlinternalFormatBasics.End_of_format)) "%s.ml" % string) name
  | Some _ =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal ".mli " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal ".ml" % string
                CamlinternalFormatBasics.End_of_format))))
        "%s.mli %s.ml" % string) name name
  end.

Definition process
  (template : string) (destination : string)
  (protocol : Tezos_base__TzPervasives.Protocol.t) (lib_version : string)
  (hash : Tezos_base__TzPervasives.Protocol_hash.t) : unit :=
  let version :=
    String.concat "-" % string (String.split_on_char "_" % char lib_version) in
  let vars :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply StringMap.empty
              (StringMap.add "VERSION" % string version))
            (StringMap.add "LIB_VERSION" % string lib_version))
          (StringMap.add "HASH" % string (Protocol_hash.to_b58check hash)))
        (StringMap.add "MODULES" % string
          (String.concat " " % string
            (List.map module_name (components protocol)))))
      (StringMap.add "SOURCES" % string
        (String.concat " " % string
          (List.map sources_name (components protocol)))) in
  replace template destination vars.

Definition read_proto (destination : string)
  : Tezos_crypto.Protocol_hash.t * Tezos_base.Protocol.t :=
  let source_dir :=
    if Filename.is_relative destination then
      Filename.concat current_dir (Filename.dirname destination)
    else
      Filename.dirname destination in
  match Lwt_main.run (Tezos_base_unix.Protocol_files.read_dir source_dir) with
  | Stdlib.Ok (None, proto) => ((Protocol.hash proto), proto)
  | Stdlib.Ok (Some hash, proto) => (hash, proto)
  | Stdlib.Error err =>
    Format.kasprintf Pervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to read TEZOS_PROTOCOL in " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ":" % char
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))))
        "Failed to read TEZOS_PROTOCOL in %s:@ %a" % string) source_dir
      pp_print_error err
  end.

Definition main (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let template := Array.get Sys.argv 1 in
  let destination := Array.get Sys.argv 2 in
  let version :=
    (* ❌ Try-with are not handled *)
    try (Array.get Sys.argv 3) in
  let '(hash, proto) := read_proto destination in
  process template destination proto version hash.



src/lib_protocol_environment/dummy_context.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module M = struct
  type t = unit

  type key = string list

  type value = MBytes.t

  let mem _ _ = assert false

  let dir_mem _ _ = assert false

  let get _ _ = assert false

  let set _ _ _ = assert false

  let copy _ ~from:_ ~to_:_ = assert false

  let del _ _ = assert false

  let remove_rec _ _ = assert false

  let fold _ _ ~init:_ ~f:_ = assert false

  let set_protocol _ _ = assert false

  let fork_test_chain _ ~protocol:_ ~expiration:_ = assert false
end

open Tezos_protocol_environment

type _ Context.kind += Faked : unit Context.kind

let ops = (module M : CONTEXT with type t = 'ctxt)

let empty = Context.Context {ops; ctxt = (); kind = Faked}
src/lib_protocol_environment/dummy_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module M.
  Definition t := unit.
  
  Definition key := list string.
  
  Definition value := Tezos_base__TzPervasives.MBytes.t.
  
  Definition mem {A B C : Type} (function_parameter : A) : B -> C :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      (* ❌ Assert instruction is not handled. *)
      assert false.
  
  Definition dir_mem {A B C : Type} (function_parameter : A) : B -> C :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      (* ❌ Assert instruction is not handled. *)
      assert false.
  
  Definition get {A B C : Type} (function_parameter : A) : B -> C :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      (* ❌ Assert instruction is not handled. *)
      assert false.
  
  Definition set {A B C D : Type} (function_parameter : A) : B -> C -> D :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        (* ❌ Assert instruction is not handled. *)
        assert false.
  
  Definition copy {A B C D : Type} (function_parameter : A) : B -> C -> D :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        (* ❌ Assert instruction is not handled. *)
        assert false.
  
  Definition del {A B C : Type} (function_parameter : A) : B -> C :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      (* ❌ Assert instruction is not handled. *)
      assert false.
  
  Definition remove_rec {A B C : Type} (function_parameter : A) : B -> C :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      (* ❌ Assert instruction is not handled. *)
      assert false.
  
  Definition fold {A B C D E : Type} (function_parameter : A)
    : B -> C -> D -> E :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          (* ❌ Assert instruction is not handled. *)
          assert false.
  
  Definition set_protocol {A B C : Type} (function_parameter : A) : B -> C :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      (* ❌ Assert instruction is not handled. *)
      assert false.
  
  Definition fork_test_chain {A B C D : Type} (function_parameter : A)
    : B -> C -> D :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        (* ❌ Assert instruction is not handled. *)
        assert false.
End M.

Import Tezos_protocol_environment.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition ops
  : {_ : unit &
    Tezos_protocol_environment.CONTEXT.signature
      M.(Tezos_protocol_environment.CONTEXT.t)} := M.

Definition empty : Tezos_protocol_environment.Context.t :=
  Tezos_protocol_environment.Context.Context
    {| kind := Tezos_protocol_environment.Context.Faked; ctxt := tt; ops := ops
      |}.

src/lib_protocol_environment/memory_context.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module M = struct
  module StringMap = Map.Make (String)

  type key = string list

  type value = MBytes.t

  type t = Dir of t StringMap.t | Key of value

  let empty = Dir StringMap.empty

  let rec raw_get m k =
    match (k, m) with
    | ([], m) ->
        Some m
    | (n :: k, Dir m) -> (
      match StringMap.find_opt n m with
      | Some res ->
          raw_get res k
      | None ->
          None )
    | (_ :: _, Key _) ->
        None

  let rec raw_set m k v =
    match (k, m, v) with
    | ([], (Key _ as m), Some v) ->
        if m = v then None else Some v
    | ([], (Dir _ as m), Some v) ->
        if m == v then None else Some v
    | ([], (Key _ | Dir _), None) ->
        Some empty
    | (n :: k, Dir m, _) -> (
      match
        raw_set (Option.unopt ~default:empty (StringMap.find_opt n m)) k v
      with
      | None ->
          None
      | Some rm when rm = empty ->
          Some (Dir (StringMap.remove n m))
      | Some rm ->
          Some (Dir (StringMap.add n rm m)) )
    | (_ :: _, Key _, None) ->
        None
    | (_ :: _, Key _, Some _) ->
        Pervasives.failwith "Mem_context.set"

  let mem m k =
    match raw_get m k with
    | Some (Key _) ->
        Lwt.return_true
    | Some (Dir _) | None ->
        Lwt.return_false

  let dir_mem m k =
    match raw_get m k with
    | Some (Dir _) ->
        Lwt.return_true
    | Some (Key _) | None ->
        Lwt.return_false

  let get m k =
    match raw_get m k with
    | Some (Key v) ->
        Lwt.return_some v
    | Some (Dir _) | None ->
        Lwt.return_none

  let set m k v =
    match raw_set m k (Some (Key v)) with
    | None ->
        Lwt.return m
    | Some m ->
        Lwt.return m

  let del m k =
    (* TODO assert key *)
    match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m

  let remove_rec m k =
    match raw_set m k None with None -> Lwt.return m | Some m -> Lwt.return m

  let copy m ~from ~to_ =
    match raw_get m from with
    | None ->
        Lwt.return_none
    | Some v ->
        Lwt.return (raw_set m to_ (Some v))

  let fold m k ~init ~f =
    match raw_get m k with
    | None ->
        Lwt.return init
    | Some (Key _) ->
        Lwt.return init
    | Some (Dir m) ->
        StringMap.fold
          (fun n m acc ->
            acc
            >>= fun acc ->
            match m with
            | Key _ ->
                f (`Key (k @ [n])) acc
            | Dir _ ->
                f (`Dir (k @ [n])) acc)
          m
          (Lwt.return init)

  let current_protocol_key = ["protocol"]

  let set_protocol v key =
    raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key)))
    |> function Some m -> Lwt.return m | None -> assert false

  let fork_test_chain c ~protocol:_ ~expiration:_ = Lwt.return c
end

open Tezos_protocol_environment

type t = M.t

type _ Context.kind += Memory : t Context.kind

let ops = (module M : CONTEXT with type t = 'ctxt)

let empty =
  let ctxt = M.empty in
  Context.Context {ops; ctxt; kind = Memory}
src/lib_protocol_environment/memory_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module M.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition key := list string.
  
  Definition value := Tezos_base__TzPervasives.MBytes.t.
  
  Inductive t : Type :=
  | Dir : (StringMap.(Stdlib__map.S.t) t) -> t
  | Key : value -> t.
  
  Definition empty : t := Dir StringMap.(Stdlib__map.S.empty).
  
  Fixpoint raw_get (m : t) (k : list StringMap.(Stdlib__map.S.key))
    : option t :=
    match (k, m) with
    | ([], m) => Some m
    | (cons n k, Dir m) =>
      match StringMap.(Stdlib__map.S.find_opt) n m with
      | Some res => raw_get res k
      | None => None
      end
    | (cons _ _, Key _) => None
    end.
  
  Fixpoint raw_set
    (m : t) (k : list StringMap.(Stdlib__map.S.key)) (v : option t)
    : option t :=
    match (k, m, v) with
    | ([], (Key _) as m, Some v) =>
      if equiv_decb m v then
        None
      else
        Some v
    | ([], (Dir _) as m, Some v) =>
      if Stdlib.op_eqeq m v then
        None
      else
        Some v
    | ([], Key _ | Dir _, None) => Some empty
    | (cons n k, Dir m, _) =>
      match
        raw_set (Option.unopt empty (StringMap.(Stdlib__map.S.find_opt) n m)) k
          v with
      | None => None
      | Some rm => Some (Dir (StringMap.(Stdlib__map.S.remove) n m))
      | Some rm => Some (Dir (StringMap.(Stdlib__map.S.add) n rm m))
      end
    | (cons _ _, Key _, None) => None
    | (cons _ _, Key _, Some _) =>
      Pervasives.failwith "Mem_context.set" % string
    end.
  
  Definition mem (m : t) (k : list StringMap.(Stdlib__map.S.key))
    : Lwt.t bool :=
    match raw_get m k with
    | Some (Key _) => Lwt.return_true
    | Some (Dir _) | None => Lwt.return_false
    end.
  
  Definition dir_mem (m : t) (k : list StringMap.(Stdlib__map.S.key))
    : Lwt.t bool :=
    match raw_get m k with
    | Some (Dir _) => Lwt.return_true
    | Some (Key _) | None => Lwt.return_false
    end.
  
  Definition get (m : t) (k : list StringMap.(Stdlib__map.S.key))
    : Lwt.t (option value) :=
    match raw_get m k with
    | Some (Key v) => Lwt.return_some v
    | Some (Dir _) | None => Lwt.return_none
    end.
  
  Definition set (m : t) (k : list StringMap.(Stdlib__map.S.key)) (v : value)
    : Lwt.t t :=
    match raw_set m k (Some (Key v)) with
    | None => Lwt._return m
    | Some m => Lwt._return m
    end.
  
  Definition del (m : t) (k : list StringMap.(Stdlib__map.S.key)) : Lwt.t t :=
    match raw_set m k None with
    | None => Lwt._return m
    | Some m => Lwt._return m
    end.
  
  Definition remove_rec (m : t) (k : list StringMap.(Stdlib__map.S.key))
    : Lwt.t t :=
    match raw_set m k None with
    | None => Lwt._return m
    | Some m => Lwt._return m
    end.
  
  Definition copy
    (m : t) (from : list StringMap.(Stdlib__map.S.key))
    (to_ : list StringMap.(Stdlib__map.S.key)) : Lwt.t (option t) :=
    match raw_get m from with
    | None => Lwt.return_none
    | Some v => Lwt._return (raw_set m to_ (Some v))
    end.
  
  Definition fold {A : Type}
    (m : t) (k : list StringMap.(Stdlib__map.S.key)) (init : A)
    (f : variant -> A -> Lwt.t A) : Lwt.t A :=
    match raw_get m k with
    | None => Lwt._return init
    | Some (Key _) => Lwt._return init
    | Some (Dir m) =>
      StringMap.(Stdlib__map.S.fold)
        (fun n =>
          fun m =>
            fun acc =>
              op_gtgteq acc
                (fun acc =>
                  match m with
                  | Key _ =>
                    f
                      (* ❌ Variants not supported *)
                      variant acc
                  | Dir _ =>
                    f
                      (* ❌ Variants not supported *)
                      variant acc
                  end)) m (Lwt._return init)
    end.
  
  Definition current_protocol_key : list string := cons "protocol" % string [].
  
  Definition set_protocol
    (v : t) (key : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t t :=
    OCaml.Stdlib.reverse_apply
      (raw_set v current_protocol_key (Some (Key (Protocol_hash.to_bytes key))))
      (fun function_parameter =>
        match function_parameter with
        | Some m => Lwt._return m
        | None =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        end).
  
  Definition fork_test_chain {A B C : Type} (c : A) (function_parameter : B)
    : C -> Lwt.t A :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      Lwt._return c.
End M.

Import Tezos_protocol_environment.

Definition t := M.t.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition ops
  : {_ : unit & Tezos_protocol_environment.CONTEXT.signature M.t} := M.

Definition empty : Tezos_protocol_environment.Context.t :=
  let ctxt := M.empty in
  Tezos_protocol_environment.Context.Context
    {| kind := Tezos_protocol_environment.Context.Memory; ctxt := ctxt;
      ops := ops |}.

src/lib_protocol_environment/shell_context.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Tezos_protocol_environment
open Context

let ( >>= ) = Lwt.( >>= )

type _ Context.kind += Shell : Tezos_storage.Context.t Context.kind

let ops = (module Tezos_storage.Context : CONTEXT with type t = 'ctxt)

let checkout index context_hash =
  Tezos_storage.Context.checkout index context_hash
  >>= function
  | Some ctxt ->
      Lwt.return_some (Context.Context {ops; ctxt; kind = Shell})
  | None ->
      Lwt.return_none

let checkout_exn index context_hash =
  Tezos_storage.Context.checkout_exn index context_hash
  >>= fun ctxt -> Lwt.return (Context.Context {ops; ctxt; kind = Shell})

let wrap_disk_context ctxt = Context.Context {ops; ctxt; kind = Shell}

let unwrap_disk_context : t -> Tezos_storage.Context.t = function
  | Context.Context {ctxt; kind = Shell; _} ->
      ctxt
  | _ ->
      assert false
src/lib_protocol_environment/shell_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Tezos_protocol_environment.

Import Context.

Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.op_gtgteq.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition ops
  : {_ : unit &
    Tezos_protocol_environment.CONTEXT.signature Tezos_storage.Context.t} :=
  Tezos_storage.Context.

Definition checkout
  (index : Tezos_storage.Context.index)
  (context_hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (option Tezos_protocol_environment.Context.t) :=
  op_gtgteq (Tezos_storage.Context.checkout index context_hash)
    (fun function_parameter =>
      match function_parameter with
      | Some ctxt =>
        Lwt.return_some
          (Tezos_protocol_environment.Context.Context
            {| kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt;
              ops := ops |})
      | None => Lwt.return_none
      end).

Definition checkout_exn
  (index : Tezos_storage.Context.index)
  (context_hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_protocol_environment.Context.t :=
  op_gtgteq (Tezos_storage.Context.checkout_exn index context_hash)
    (fun ctxt =>
      Lwt._return
        (Tezos_protocol_environment.Context.Context
          {| kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt;
            ops := ops |})).

Definition wrap_disk_context (ctxt : Tezos_storage.Context.t)
  : Tezos_protocol_environment.Context.t :=
  Tezos_protocol_environment.Context.Context
    {| kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt;
      ops := ops |}.

Definition unwrap_disk_context
  (function_parameter : Tezos_protocol_environment.Context.t)
  : Tezos_storage.Context.t :=
  match function_parameter with
  |
    Tezos_protocol_environment.Context.Context {|
      kind := Tezos_protocol_environment.Context.Shell; ctxt := ctxt |} =>
    ctxt
  | _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

src/lib_protocol_environment/sigs_packer/sigs_packer.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let dump_file oc file =
  let ic = open_in file in
  let buflen = 8096 in
  let buf = Bytes.create buflen in
  let rec loop () =
    let len = input ic buf 0 buflen in
    if len <> 0 then (
      Printf.fprintf
        oc
        "%s"
        (Bytes.to_string (if len = buflen then buf else Bytes.sub buf 0 len)) ;
      loop () )
  in
  loop () ; close_in ic

let opened_modules = ["Pervasives"; "Error_monad"]

let include_mli oc file =
  let unit =
    String.capitalize_ascii (Filename.chop_extension (Filename.basename file))
  in
  Printf.fprintf oc "module %s : sig\n" unit ;
  Printf.fprintf oc "# 1 %S\n" file ;
  dump_file oc file ;
  Printf.fprintf oc "end\n" ;
  if unit = "Result" then
    Printf.fprintf
      oc
      "type ('a, 'b) result = ('a, 'b) Result.result =  Ok of 'a | Error of 'b\n" ;
  if List.mem unit opened_modules then Printf.fprintf oc "open %s\n" unit

let () =
  Printf.fprintf stdout "module type T = sig\n" ;
  for i = 1 to Array.length Sys.argv - 1 do
    let file = Sys.argv.(i) in
    include_mli stdout file
  done ;
  Printf.fprintf stdout "end\n%!"
src/lib_protocol_environment/sigs_packer/sigs_packer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition dump_file (oc : Stdlib.out_channel) (file : string) : unit :=
  let ic := Stdlib.open_in file in
  let buflen := 8096 in
  let buf := Stdlib.Bytes.create buflen in
  let fix loop (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    let len := Stdlib.input ic buf 0 buflen in
    if nequiv_decb len 0 then
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Printf.fprintf oc
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format) "%s" % string)
          (Stdlib.Bytes.to_string
            (if equiv_decb len buflen then
              buf
            else
              String.sub buf 0 len)) in
      loop tt
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := loop tt in
  Stdlib.close_in ic.

Definition opened_modules : list string :=
  cons "Pervasives" % string (cons "Error_monad" % string []).

Definition include_mli (oc : Stdlib.out_channel) (file : string) : unit :=
  let unit :=
    Stdlib.String.capitalize_ascii
      (Filename.chop_extension (Filename.basename file)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "module " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal " : sig
" % string
              CamlinternalFormatBasics.End_of_format)))
        "module %s : sig
" % string) unit in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "# 1 " % string
          (CamlinternalFormatBasics.Caml_string
            CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "# 1 %S
" % string) file
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := dump_file oc file in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "end
" % string
          CamlinternalFormatBasics.End_of_format) "end
" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if equiv_decb unit "Result" % string then
      Printf.fprintf oc
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "type ('a, 'b) result = ('a, 'b) Result.result =  Ok of 'a | Error of 'b
"
              % string CamlinternalFormatBasics.End_of_format)
          "type ('a, 'b) result = ('a, 'b) Result.result =  Ok of 'a | Error of 'b
"
            % string)
    else
      tt in
  if Stdlib.List.mem unit opened_modules then
    Printf.fprintf oc
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "open " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "open %s
" % string)
      unit
  else
    tt.



src/lib_protocol_environment/test/assert.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let equal_string_option ?msg o1 o2 =
  let prn = function None -> "None" | Some s -> s in
  equal ?msg ~prn o1 o2

let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg

let make_equal_list eq prn ?(msg = "") x y =
  let rec iter i x y =
    match (x, y) with
    | (hd_x :: tl_x, hd_y :: tl_y) ->
        if eq hd_x hd_y then iter (succ i) tl_x tl_y
        else
          let fm = Printf.sprintf "%s (at index %d)" msg i in
          fail (prn hd_x) (prn hd_y) fm
    | (_ :: _, []) | ([], _ :: _) ->
        let fm = Printf.sprintf "%s (lists of different sizes)" msg in
        fail_msg "%s" fm
    | ([], []) ->
        ()
  in
  iter 0 x y

let equal_string_list_list ?msg l1 l2 =
  let pr_persist l =
    let res =
      String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
    in
    Printf.sprintf "[%s]" res
  in
  make_equal_list ?msg ( = ) pr_persist l1 l2
src/lib_protocol_environment/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let prn :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition equal_string_option
  (msg : option string) (o1 : option string) (o2 : option string) : unit :=
  let prn (function_parameter : option string) : string :=
    match function_parameter with
    | None => "None" % string
    | Some s => s
    end in
  equal None (Some prn) msg o1 o2.

Definition is_none {A : Type} (op_staroptstar : option string)
  : (option A) -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    if nequiv_decb x None then
      fail "None" % string "Some _" % string msg
    else
      tt.

Definition make_equal_list {A : Type}
  (eq : A -> A -> bool) (prn : A -> string) (op_staroptstar : option string)
  : (list A) -> (list A) -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    fun y =>
      let fix iter (i : Z) (x : list A) (y : list A) : unit :=
        match (x, y) with
        | (cons hd_x tl_x, cons hd_y tl_y) =>
          if eq hd_x hd_y then
            iter (Z.succ i) tl_x tl_y
          else
            let fm :=
              Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " (at index " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))
                  "%s (at index %d)" % string) msg i in
            fail (prn hd_x) (prn hd_y) fm
        | (cons _ _, []) | ([], cons _ _) =>
          let fm :=
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (lists of different sizes)" % string
                    CamlinternalFormatBasics.End_of_format))
                "%s (lists of different sizes)" % string) msg in
          fail_msg
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) fm
        | ([], []) => tt
        end in
      iter 0 x y.

Definition equal_string_list_list
  (msg : option string) (l1 : list (list string)) (l2 : list (list string))
  : unit :=
  let pr_persist (l : list string) : string :=
    let res :=
      String.concat ";" % string
        (List.map
          (fun s =>
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
      in
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
  make_equal_list equiv_decb pr_persist msg l1 l2.

src/lib_protocol_environment/test/test.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run "tezos-shell-context" [("mem_context", Test_mem_context.tests)]
src/lib_protocol_environment/test/test.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/lib_protocol_environment/test/test_mem_context.ml 104 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Context creation *)

let create_block2 ctxt =
  Context.set ctxt ["a"; "b"] (MBytes.of_string "Novembre")
  >>= fun ctxt ->
  Context.set ctxt ["a"; "c"] (MBytes.of_string "Juin")
  >>= fun ctxt ->
  Context.set ctxt ["version"] (MBytes.of_string "0.0")
  >>= fun ctxt -> Lwt.return ctxt

let create_block3a ctxt =
  Context.del ctxt ["a"; "b"]
  >>= fun ctxt ->
  Context.set ctxt ["a"; "d"] (MBytes.of_string "Mars")
  >>= fun ctxt -> Lwt.return ctxt

let create_block3b ctxt =
  Context.del ctxt ["a"; "c"]
  >>= fun ctxt ->
  Context.set ctxt ["a"; "d"] (MBytes.of_string "Février")
  >>= fun ctxt -> Lwt.return ctxt

type t = {
  genesis : Context.t;
  block2 : Context.t;
  block3a : Context.t;
  block3b : Context.t;
}

let wrap_context_init f _ () =
  let genesis = Memory_context.empty in
  create_block2 genesis
  >>= fun block2 ->
  create_block3a block2
  >>= fun block3a ->
  create_block3b block2
  >>= fun block3b ->
  f {genesis; block2; block3a; block3b} >>= fun result -> Lwt.return result

(** Simple test *)

let c = function None -> None | Some s -> Some (MBytes.to_string s)

let test_simple {block2 = ctxt; _} =
  Context.get ctxt ["version"]
  >>= fun version ->
  Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
  Context.get ctxt ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option (Some "Novembre") (c novembre) ;
  Context.get ctxt ["a"; "c"]
  >>= fun juin ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
  Lwt.return_unit

let test_continuation {block3a = ctxt; _} =
  Context.get ctxt ["version"]
  >>= fun version ->
  Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
  Context.get ctxt ["a"; "b"]
  >>= fun novembre ->
  Assert.is_none ~msg:__LOC__ (c novembre) ;
  Context.get ctxt ["a"; "c"]
  >>= fun juin ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
  Context.get ctxt ["a"; "d"]
  >>= fun mars ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
  Lwt.return_unit

let test_fork {block3b = ctxt; _} =
  Context.get ctxt ["version"]
  >>= fun version ->
  Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
  Context.get ctxt ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
  Context.get ctxt ["a"; "c"]
  >>= fun juin ->
  Assert.is_none ~msg:__LOC__ (c juin) ;
  Context.get ctxt ["a"; "d"]
  >>= fun mars ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
  Lwt.return_unit

let test_replay {genesis = ctxt0; _} =
  Context.set ctxt0 ["version"] (MBytes.of_string "0.0")
  >>= fun ctxt1 ->
  Context.set ctxt1 ["a"; "b"] (MBytes.of_string "Novembre")
  >>= fun ctxt2 ->
  Context.set ctxt2 ["a"; "c"] (MBytes.of_string "Juin")
  >>= fun ctxt3 ->
  Context.set ctxt3 ["a"; "d"] (MBytes.of_string "July")
  >>= fun ctxt4a ->
  Context.set ctxt3 ["a"; "d"] (MBytes.of_string "Juillet")
  >>= fun ctxt4b ->
  Context.set ctxt4a ["a"; "b"] (MBytes.of_string "November")
  >>= fun ctxt5a ->
  Context.get ctxt4a ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
  Context.get ctxt5a ["a"; "b"]
  >>= fun november ->
  Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
  Context.get ctxt5a ["a"; "d"]
  >>= fun july ->
  Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
  Context.get ctxt4b ["a"; "b"]
  >>= fun novembre ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
  Context.get ctxt4b ["a"; "d"]
  >>= fun juillet ->
  Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
  Lwt.return_unit

let fold_keys s k ~init ~f =
  let rec loop k acc =
    Context.fold s k ~init:acc ~f:(fun file acc ->
        match file with `Key k -> f k acc | `Dir k -> loop k acc)
  in
  loop k init

let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

let test_fold {genesis = ctxt; _} =
  Context.set ctxt ["a"; "b"] (MBytes.of_string "Novembre")
  >>= fun ctxt ->
  Context.set ctxt ["a"; "c"] (MBytes.of_string "Juin")
  >>= fun ctxt ->
  Context.set ctxt ["a"; "d"; "e"] (MBytes.of_string "Septembre")
  >>= fun ctxt ->
  Context.set ctxt ["f"] (MBytes.of_string "Avril")
  >>= fun ctxt ->
  Context.set ctxt ["g"; "h"] (MBytes.of_string "Avril")
  >>= fun ctxt ->
  keys ctxt []
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
    (List.sort compare l) ;
  keys ctxt ["a"]
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
    (List.sort compare l) ;
  keys ctxt ["f"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  keys ctxt ["g"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] l ;
  keys ctxt ["i"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  Lwt.return_unit

(******************************************************************************)

let tests =
  [ ("simple", test_simple);
    ("continuation", test_continuation);
    ("fork", test_fork);
    ("replay", test_replay);
    ("fold", test_fold) ]

let tests =
  List.map
    (fun (n, f) -> Alcotest_lwt.test_case n `Quick (wrap_context_init f))
    tests
src/lib_protocol_environment/test/test_mem_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition create_block2 {A B : Type} (ctxt : A) : Lwt.t B :=
  op_gtgteq
    (op_startypeminuserrorstar ctxt (cons "a" % string (cons "b" % string []))
      (MBytes.of_string "Novembre" % string))
    (fun ctxt =>
      op_gtgteq
        (op_startypeminuserrorstar ctxt
          (cons "a" % string (cons "c" % string []))
          (MBytes.of_string "Juin" % string))
        (fun ctxt =>
          op_gtgteq
            (op_startypeminuserrorstar ctxt (cons "version" % string [])
              (MBytes.of_string "0.0" % string)) (fun ctxt => Lwt._return ctxt))).

Definition create_block3a {A B : Type} (ctxt : A) : Lwt.t B :=
  op_gtgteq
    (op_startypeminuserrorstar ctxt (cons "a" % string (cons "b" % string [])))
    (fun ctxt =>
      op_gtgteq
        (op_startypeminuserrorstar ctxt
          (cons "a" % string (cons "d" % string []))
          (MBytes.of_string "Mars" % string)) (fun ctxt => Lwt._return ctxt)).

Definition create_block3b {A B : Type} (ctxt : A) : Lwt.t B :=
  op_gtgteq
    (op_startypeminuserrorstar ctxt (cons "a" % string (cons "c" % string [])))
    (fun ctxt =>
      op_gtgteq
        (op_startypeminuserrorstar ctxt
          (cons "a" % string (cons "d" % string []))
          (MBytes.of_string "Février" % string)) (fun ctxt => Lwt._return ctxt)).

Definition wrap_context_init {A B C : Type}
  (f : A -> Lwt.t B) (function_parameter : C) : unit -> Lwt.t B :=
  let '_ := function_parameter in
  fun function_parameter =>
    let 'tt := function_parameter in
    let genesis := Memory_context.empty in
    op_gtgteq (create_block2 genesis)
      (fun block2 =>
        op_gtgteq (create_block3a block2)
          (fun block3a =>
            op_gtgteq (create_block3b block2)
              (fun block3b =>
                op_gtgteq (f op_startypeminuserrorstar)
                  (fun result => Lwt._return result)))).

Definition c (function_parameter : option Tezos_base__TzPervasives.MBytes.t)
  : option string :=
  match function_parameter with
  | None => None
  | Some s => Some (MBytes.to_string s)
  end.

Definition test_simple {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  op_gtgteq
    (op_startypeminuserrorstar op_startypeminuserrorstar
      (cons "version" % string []))
    (fun version =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar Stdlib.__LOC__ (c version)
          (Some "0.0" % string) in
      op_gtgteq
        (op_startypeminuserrorstar op_startypeminuserrorstar
          (cons "a" % string (cons "b" % string [])))
        (fun novembre =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            op_startypeminuserrorstar (Some "Novembre" % string) (c novembre) in
          op_gtgteq
            (op_startypeminuserrorstar op_startypeminuserrorstar
              (cons "a" % string (cons "c" % string [])))
            (fun juin =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                op_startypeminuserrorstar Stdlib.__LOC__ (Some "Juin" % string)
                  (c juin) in
              Lwt.return_unit))).

Definition test_continuation {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  op_gtgteq
    (op_startypeminuserrorstar op_startypeminuserrorstar
      (cons "version" % string []))
    (fun version =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
          (c version) in
      op_gtgteq
        (op_startypeminuserrorstar op_startypeminuserrorstar
          (cons "a" % string (cons "b" % string [])))
        (fun novembre =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c novembre) in
          op_gtgteq
            (op_startypeminuserrorstar op_startypeminuserrorstar
              (cons "a" % string (cons "c" % string [])))
            (fun juin =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                op_startypeminuserrorstar Stdlib.__LOC__ (Some "Juin" % string)
                  (c juin) in
              op_gtgteq
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (cons "a" % string (cons "d" % string [])))
                (fun mars =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    op_startypeminuserrorstar Stdlib.__LOC__
                      (Some "Mars" % string) (c mars) in
                  Lwt.return_unit)))).

Definition test_fork {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  op_gtgteq
    (op_startypeminuserrorstar op_startypeminuserrorstar
      (cons "version" % string []))
    (fun version =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
          (c version) in
      op_gtgteq
        (op_startypeminuserrorstar op_startypeminuserrorstar
          (cons "a" % string (cons "b" % string [])))
        (fun novembre =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            op_startypeminuserrorstar Stdlib.__LOC__ (Some "Novembre" % string)
              (c novembre) in
          op_gtgteq
            (op_startypeminuserrorstar op_startypeminuserrorstar
              (cons "a" % string (cons "c" % string [])))
            (fun juin =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c juin) in
              op_gtgteq
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (cons "a" % string (cons "d" % string [])))
                (fun mars =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    op_startypeminuserrorstar Stdlib.__LOC__
                      (Some "Février" % string) (c mars) in
                  Lwt.return_unit)))).

Definition test_replay {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  op_gtgteq
    (op_startypeminuserrorstar op_startypeminuserrorstar
      (cons "version" % string []) (MBytes.of_string "0.0" % string))
    (fun ctxt1 =>
      op_gtgteq
        (op_startypeminuserrorstar ctxt1
          (cons "a" % string (cons "b" % string []))
          (MBytes.of_string "Novembre" % string))
        (fun ctxt2 =>
          op_gtgteq
            (op_startypeminuserrorstar ctxt2
              (cons "a" % string (cons "c" % string []))
              (MBytes.of_string "Juin" % string))
            (fun ctxt3 =>
              op_gtgteq
                (op_startypeminuserrorstar ctxt3
                  (cons "a" % string (cons "d" % string []))
                  (MBytes.of_string "July" % string))
                (fun ctxt4a =>
                  op_gtgteq
                    (op_startypeminuserrorstar ctxt3
                      (cons "a" % string (cons "d" % string []))
                      (MBytes.of_string "Juillet" % string))
                    (fun ctxt4b =>
                      op_gtgteq
                        (op_startypeminuserrorstar ctxt4a
                          (cons "a" % string (cons "b" % string []))
                          (MBytes.of_string "November" % string))
                        (fun ctxt5a =>
                          op_gtgteq
                            (op_startypeminuserrorstar ctxt4a
                              (cons "a" % string (cons "b" % string [])))
                            (fun novembre =>
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                op_startypeminuserrorstar Stdlib.__LOC__
                                  (Some "Novembre" % string) (c novembre) in
                              op_gtgteq
                                (op_startypeminuserrorstar ctxt5a
                                  (cons "a" % string (cons "b" % string [])))
                                (fun november =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    op_startypeminuserrorstar Stdlib.__LOC__
                                      (Some "November" % string) (c november) in
                                  op_gtgteq
                                    (op_startypeminuserrorstar ctxt5a
                                      (cons "a" % string (cons "d" % string [])))
                                    (fun july =>
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        op_startypeminuserrorstar Stdlib.__LOC__
                                          (Some "July" % string) (c july) in
                                      op_gtgteq
                                        (op_startypeminuserrorstar ctxt4b
                                          (cons "a" % string
                                            (cons "b" % string [])))
                                        (fun novembre =>
                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                          let _ :=
                                            op_startypeminuserrorstar
                                              Stdlib.__LOC__
                                              (Some "Novembre" % string)
                                              (c novembre) in
                                          op_gtgteq
                                            (op_startypeminuserrorstar ctxt4b
                                              (cons "a" % string
                                                (cons "d" % string [])))
                                            (fun juillet =>
                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                              let _ :=
                                                op_startypeminuserrorstar
                                                  Stdlib.__LOC__
                                                  (Some "Juillet" % string)
                                                  (c juillet) in
                                              Lwt.return_unit))))))))))).

Definition fold_keys {A B C D E : Type}
  (s : A) (k : B) (init : C) (f : D -> C -> E) : E :=
  let fix loop {F : Type} (k : F) (acc : C) : E :=
    op_startypeminuserrorstar s k acc
      (fun file =>
        fun acc =>
          match file with
          | Key k => f k acc
          | Dir k => loop k acc
          end) in
  loop k init.

Definition keys {A B C : Type} (t : A) : B -> Lwt.t (list C) :=
  fold_keys t
    (* ❌ expected an argument *)
    expected_argument [] (fun k => fun acc => Lwt._return (cons k acc)).

Definition test_fold {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  op_gtgteq
    (op_startypeminuserrorstar op_startypeminuserrorstar
      (cons "a" % string (cons "b" % string []))
      (MBytes.of_string "Novembre" % string))
    (fun ctxt =>
      op_gtgteq
        (op_startypeminuserrorstar ctxt
          (cons "a" % string (cons "c" % string []))
          (MBytes.of_string "Juin" % string))
        (fun ctxt =>
          op_gtgteq
            (op_startypeminuserrorstar ctxt
              (cons "a" % string (cons "d" % string (cons "e" % string [])))
              (MBytes.of_string "Septembre" % string))
            (fun ctxt =>
              op_gtgteq
                (op_startypeminuserrorstar ctxt (cons "f" % string [])
                  (MBytes.of_string "Avril" % string))
                (fun ctxt =>
                  op_gtgteq
                    (op_startypeminuserrorstar ctxt
                      (cons "g" % string (cons "h" % string []))
                      (MBytes.of_string "Avril" % string))
                    (fun ctxt =>
                      op_gtgteq (keys ctxt [])
                        (fun l =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            op_startypeminuserrorstar Stdlib.__LOC__
                              (cons (cons "a" % string (cons "b" % string []))
                                (cons (cons "a" % string (cons "c" % string []))
                                  (cons
                                    (cons "a" % string
                                      (cons "d" % string (cons "e" % string [])))
                                    (cons (cons "f" % string [])
                                      (cons
                                        (cons "g" % string
                                          (cons "h" % string [])) [])))))
                              (List.sort OCaml.Stdlib.compare l) in
                          op_gtgteq (keys ctxt (cons "a" % string []))
                            (fun l =>
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                op_startypeminuserrorstar Stdlib.__LOC__
                                  (cons
                                    (cons "a" % string (cons "b" % string []))
                                    (cons
                                      (cons "a" % string (cons "c" % string []))
                                      (cons
                                        (cons "a" % string
                                          (cons "d" % string
                                            (cons "e" % string []))) [])))
                                  (List.sort OCaml.Stdlib.compare l) in
                              op_gtgteq (keys ctxt (cons "f" % string []))
                                (fun l =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    op_startypeminuserrorstar Stdlib.__LOC__ []
                                      l in
                                  op_gtgteq (keys ctxt (cons "g" % string []))
                                    (fun l =>
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        op_startypeminuserrorstar Stdlib.__LOC__
                                          (cons
                                            (cons "g" % string
                                              (cons "h" % string [])) []) l in
                                      op_gtgteq
                                        (keys ctxt (cons "i" % string []))
                                        (fun l =>
                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                          let _ :=
                                            op_startypeminuserrorstar
                                              Stdlib.__LOC__ [] l in
                                          Lwt.return_unit)))))))))).

Definition tests {A : Type} : list (string * (A -> Lwt.t unit)) :=
  cons ("simple" % string, test_simple)
    (cons ("continuation" % string, test_continuation)
      (cons ("fork" % string, test_fork)
        (cons ("replay" % string, test_replay)
          (cons ("fold" % string, test_fold) [])))).

Definition tests {A : Type} : list A :=
  List.map
    (fun function_parameter =>
      let '(n, f) := function_parameter in
      op_startypeminuserrorstar n
        (* ❌ Variants not supported *)
        variant (wrap_context_init f)) tests.

src/lib_protocol_environment/tezos_protocol_environment.ml 80 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module type CONTEXT = sig
  type t

  type key = string list

  type value = MBytes.t

  val mem : t -> key -> bool Lwt.t

  val dir_mem : t -> key -> bool Lwt.t

  val get : t -> key -> value option Lwt.t

  val set : t -> key -> value -> t Lwt.t

  val copy : t -> from:key -> to_:key -> t option Lwt.t

  val del : t -> key -> t Lwt.t

  val remove_rec : t -> key -> t Lwt.t

  val fold :
    t ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val set_protocol : t -> Protocol_hash.t -> t Lwt.t

  val fork_test_chain :
    t -> protocol:Protocol_hash.t -> expiration:Time.Protocol.t -> t Lwt.t
end

module Context = struct
  type key = string list

  type value = MBytes.t

  type 'ctxt ops = (module CONTEXT with type t = 'ctxt)

  type _ kind = ..

  type t = Context : {kind : 'a kind; ctxt : 'a; ops : 'a ops} -> t

  let mem (Context {ops = (module Ops); ctxt; _}) key = Ops.mem ctxt key

  let set (Context {ops = (module Ops) as ops; ctxt; kind}) key value =
    Ops.set ctxt key value
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let dir_mem (Context {ops = (module Ops); ctxt; _}) key =
    Ops.dir_mem ctxt key

  let get (Context {ops = (module Ops); ctxt; _}) key = Ops.get ctxt key

  let copy (Context {ops = (module Ops) as ops; ctxt; kind}) ~from ~to_ =
    Ops.copy ctxt ~from ~to_
    >>= function
    | Some ctxt ->
        Lwt.return_some (Context {ops; ctxt; kind})
    | None ->
        Lwt.return_none

  let del (Context {ops = (module Ops) as ops; ctxt; kind}) key =
    Ops.del ctxt key >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let remove_rec (Context {ops = (module Ops) as ops; ctxt; kind}) key =
    Ops.remove_rec ctxt key
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let fold (Context {ops = (module Ops); ctxt; _}) key ~init ~f =
    Ops.fold ctxt key ~init ~f

  let set_protocol (Context {ops = (module Ops) as ops; ctxt; kind})
      protocol_hash =
    Ops.set_protocol ctxt protocol_hash
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})

  let fork_test_chain (Context {ops = (module Ops) as ops; ctxt; kind})
      ~protocol ~expiration =
    Ops.fork_test_chain ctxt ~protocol ~expiration
    >>= fun ctxt -> Lwt.return (Context {ops; ctxt; kind})
end

type validation_result = {
  context : Context.t;
  fitness : Fitness.t;
  message : string option;
  max_operations_ttl : int;
  last_allowed_fork_level : Int32.t;
}

type quota = {max_size : int; max_op : int option}

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Context.t;
}

module type T = sig
  type context

  type quota

  type validation_result

  type rpc_context

  type 'a tzresult

  val max_block_length : int

  val max_operation_data_length : int

  val validation_passes : quota list

  type block_header_data

  val block_header_data_encoding : block_header_data Data_encoding.t

  type block_header = {
    shell : Block_header.shell_header;
    protocol_data : block_header_data;
  }

  type block_header_metadata

  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  type operation_data

  type operation_receipt

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  val operation_data_encoding : operation_data Data_encoding.t

  val operation_receipt_encoding : operation_receipt Data_encoding.t

  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t

  val acceptable_passes : operation -> int list

  val compare_operations : operation -> operation -> int

  type validation_state

  val current_context : validation_state -> context tzresult Lwt.t

  val begin_partial_application :
    chain_id:Chain_id.t ->
    ancestor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  val begin_application :
    chain_id:Chain_id.t ->
    predecessor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_fitness:Fitness.t ->
    block_header ->
    validation_state tzresult Lwt.t

  val begin_construction :
    chain_id:Chain_id.t ->
    predecessor_context:context ->
    predecessor_timestamp:Time.Protocol.t ->
    predecessor_level:Int32.t ->
    predecessor_fitness:Fitness.t ->
    predecessor:Block_hash.t ->
    timestamp:Time.Protocol.t ->
    ?protocol_data:block_header_data ->
    unit ->
    validation_state tzresult Lwt.t

  val apply_operation :
    validation_state ->
    operation ->
    (validation_state * operation_receipt) tzresult Lwt.t

  val finalize_block :
    validation_state ->
    (validation_result * block_header_metadata) tzresult Lwt.t

  val rpc_services : rpc_context RPC_directory.t

  val init :
    context -> Block_header.shell_header -> validation_result tzresult Lwt.t
end

module type PROTOCOL =
  T
    with type context := Context.t
     and type quota := quota
     and type validation_result := validation_result
     and type rpc_context := rpc_context
     and type 'a tzresult := 'a Error_monad.tzresult

module type V1 = sig
  include
    Tezos_protocol_environment_sigs.V1.T
      with type Format.formatter = Format.formatter
       and type 'a Data_encoding.t = 'a Data_encoding.t
       and type 'a Data_encoding.lazy_t = 'a Data_encoding.lazy_t
       and type 'a Lwt.t = 'a Lwt.t
       and type ('a, 'b) Pervasives.result = ('a, 'b) result
       and type Chain_id.t = Chain_id.t
       and type Block_hash.t = Block_hash.t
       and type Operation_hash.t = Operation_hash.t
       and type Operation_list_hash.t = Operation_list_hash.t
       and type Operation_list_list_hash.t = Operation_list_list_hash.t
       and type Context.t = Context.t
       and type Context_hash.t = Context_hash.t
       and type Protocol_hash.t = Protocol_hash.t
       and type Time.t = Time.Protocol.t
       and type MBytes.t = MBytes.t
       and type Operation.shell_header = Operation.shell_header
       and type Operation.t = Operation.t
       and type Block_header.shell_header = Block_header.shell_header
       and type Block_header.t = Block_header.t
       and type 'a RPC_directory.t = 'a RPC_directory.t
       and type Ed25519.Public_key_hash.t = Ed25519.Public_key_hash.t
       and type Ed25519.Public_key.t = Ed25519.Public_key.t
       and type Ed25519.t = Ed25519.t
       and type Secp256k1.Public_key_hash.t = Secp256k1.Public_key_hash.t
       and type Secp256k1.Public_key.t = Secp256k1.Public_key.t
       and type Secp256k1.t = Secp256k1.t
       and type P256.Public_key_hash.t = P256.Public_key_hash.t
       and type P256.Public_key.t = P256.Public_key.t
       and type P256.t = P256.t
       and type Signature.public_key_hash = Signature.public_key_hash
       and type Signature.public_key = Signature.public_key
       and type Signature.t = Signature.t
       and type Signature.watermark = Signature.watermark
       and type 'a Micheline.canonical = 'a Micheline.canonical
       and type ('a, 'b) RPC_path.t = ('a, 'b) RPC_path.t
       and type Z.t = Z.t
       and type ('a, 'b) Micheline.node = ('a, 'b) Micheline.node
       and type Data_encoding.json_schema = Data_encoding.json_schema
       and type RPC_service.meth = RPC_service.meth
       and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t =
            ('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t
       and type Error_monad.shell_error = Error_monad.error
       and type Z.t = Z.t

  type error += Ecoproto_error of Error_monad.error

  val wrap_error : 'a Error_monad.tzresult -> 'a tzresult

  module Lift (P : Updater.PROTOCOL) :
    PROTOCOL
      with type block_header_data = P.block_header_data
       and type block_header = P.block_header
       and type operation_data = P.operation_data
       and type operation_receipt = P.operation_receipt
       and type operation = P.operation
       and type validation_state = P.validation_state

  class ['chain, 'block] proto_rpc_context :
    Tezos_rpc.RPC_context.t
    -> (unit, (unit * 'chain) * 'block) RPC_path.t
    -> ['chain * 'block] RPC_context.simple

  class ['block] proto_rpc_context_of_directory :
    ('block -> RPC_context.t)
    -> RPC_context.t RPC_directory.t
    -> ['block] RPC_context.simple
end

module MakeV1 (Param : sig
  val name : string
end)
() =
struct
  include Pervasives
  module Pervasives = Pervasives
  module Compare = Compare
  module Array = Array
  module List = List

  module Bytes = struct
    include Bytes
    include EndianBytes.BigEndian
    module LE = EndianBytes.LittleEndian
  end

  module String = struct
    include String
    include EndianString.BigEndian
    module LE = EndianString.LittleEndian
  end

  module Set = Set
  module Map = Map
  module Int32 = Int32
  module Int64 = Int64
  module Nativeint = Nativeint
  module Buffer = Buffer
  module Format = Format
  module Option = Option
  module MBytes = MBytes

  module Raw_hashes = struct
    let conv f x = Bigstring.to_bytes (f (Bigstring.of_bytes x))

    let sha256 msg = conv Hacl.Hash.SHA256.digest msg

    let sha512 msg = conv Hacl.Hash.SHA512.digest msg

    let blake2b msg = Blake2B.to_bytes (Blake2B.hash_bytes [msg])
  end

  module Z = struct
    include Z

    let to_bits ?(pad_to = 0) z =
      let bits = to_bits z in
      let len = Pervasives.((numbits z + 7) / 8) in
      let full_len = Tezos_stdlib.Compare.Int.max pad_to len in
      if full_len = 0 then MBytes.create 0
      else
        let res = MBytes.create full_len in
        Bytes.fill res 0 full_len '\000' ;
        MBytes.blit_of_string bits 0 res 0 len ;
        res

    let of_bits bytes = of_bits (MBytes.to_string bytes)
  end

  module Lwt_sequence = Lwt_sequence
  module Lwt = Lwt
  module Lwt_list = Lwt_list
  module Uri = Uri
  module Data_encoding = Data_encoding
  module Time = Time.Protocol
  module Ed25519 = Ed25519
  module Secp256k1 = Secp256k1
  module P256 = P256
  module Signature = Signature

  module S = struct
    module type T = Tezos_base.S.T

    module type HASHABLE = Tezos_base.S.HASHABLE

    module type MINIMAL_HASH = S.MINIMAL_HASH

    module type B58_DATA = sig
      type t

      val to_b58check : t -> string

      val to_short_b58check : t -> string

      val of_b58check_exn : string -> t

      val of_b58check_opt : string -> t option

      type Base58.data += Data of t

      val b58check_encoding : t Base58.encoding
    end

    module type RAW_DATA = sig
      type t

      val size : int (* in bytes *)

      val to_bytes : t -> MBytes.t

      val of_bytes_opt : MBytes.t -> t option

      val of_bytes_exn : MBytes.t -> t
    end

    module type ENCODER = sig
      type t

      val encoding : t Data_encoding.t

      val rpc_arg : t RPC_arg.t
    end

    module type SET = Tezos_base.S.SET

    module type MAP = Tezos_base.S.MAP

    module type INDEXES = sig
      type t

      val to_path : t -> string list -> string list

      val of_path : string list -> t option

      val of_path_exn : string list -> t

      val prefix_path : string -> string list

      val path_length : int

      module Set : sig
        include Set.S with type elt = t

        val encoding : t Data_encoding.t
      end

      module Map : sig
        include Map.S with type key = t

        val encoding : 'a Data_encoding.t -> 'a t Data_encoding.t
      end
    end

    module type HASH = sig
      include MINIMAL_HASH

      include RAW_DATA with type t := t

      include B58_DATA with type t := t

      include ENCODER with type t := t

      include INDEXES with type t := t
    end

    module type MERKLE_TREE = sig
      type elt

      include HASH

      val compute : elt list -> t

      val empty : t

      type path = Left of path * t | Right of t * path | Op

      val compute_path : elt list -> int -> path

      val check_path : path -> elt -> t * int

      val path_encoding : path Data_encoding.t
    end

    module type SIGNATURE = sig
      module Public_key_hash : sig
        type t

        val pp : Format.formatter -> t -> unit

        val pp_short : Format.formatter -> t -> unit

        include Compare.S with type t := t

        include RAW_DATA with type t := t

        include B58_DATA with type t := t

        include ENCODER with type t := t

        include INDEXES with type t := t

        val zero : t
      end

      module Public_key : sig
        type t

        val pp : Format.formatter -> t -> unit

        include Compare.S with type t := t

        include B58_DATA with type t := t

        include ENCODER with type t := t

        val hash : t -> Public_key_hash.t
      end

      type t

      val pp : Format.formatter -> t -> unit

      include RAW_DATA with type t := t

      include Compare.S with type t := t

      include B58_DATA with type t := t

      include ENCODER with type t := t

      val zero : t

      type watermark

      (** Check a signature *)
      val check : ?watermark:watermark -> Public_key.t -> t -> MBytes.t -> bool
    end
  end

  module Error_core = struct
    include Tezos_error_monad.Core_maker.Make (struct
      let id = Format.asprintf "proto.%s." Param.name
    end)
  end

  type error += Ecoproto_error of Error_core.error

  module Wrapped_error_monad = struct
    type unwrapped = Error_core.error = ..

    include (
      Error_core :
        sig
          include Tezos_error_monad.Sig.CORE with type error := unwrapped

          include Tezos_error_monad.Sig.EXT with type error := unwrapped
        end )

    let unwrap = function
      | Ecoproto_error ecoerror ->
          Some ecoerror
      | _ ->
          None

    let wrap ecoerror = Ecoproto_error ecoerror
  end

  module Error_monad = struct
    type 'a shell_tzresult = 'a Error_monad.tzresult

    type shell_error = Error_monad.error = ..

    type error_category = [`Branch | `Temporary | `Permanent]

    include Error_core
    include Tezos_error_monad.Monad_maker.Make (Error_core)
  end

  let () =
    let id = Format.asprintf "proto.%s.wrapper" Param.name in
    register_wrapped_error_kind
      (module Wrapped_error_monad)
      ~id
      ~title:("Error returned by protocol " ^ Param.name)
      ~description:("Wrapped error for economic protocol " ^ Param.name ^ ".")

  let wrap_error = function
    | Ok _ as ok ->
        ok
    | Error errors ->
        Error (List.map (fun error -> Ecoproto_error error) errors)

  module Chain_id = Chain_id
  module Block_hash = Block_hash
  module Operation_hash = Operation_hash
  module Operation_list_hash = Operation_list_hash
  module Operation_list_list_hash = Operation_list_list_hash
  module Context_hash = Context_hash
  module Protocol_hash = Protocol_hash
  module Blake2B = Blake2B
  module Fitness = Fitness
  module Operation = Operation
  module Block_header = Block_header
  module Protocol = Protocol
  module RPC_arg = RPC_arg
  module RPC_path = RPC_path
  module RPC_query = RPC_query
  module RPC_service = RPC_service

  module RPC_answer = struct
    type 'o t =
      [ `Ok of 'o (* 200 *)
      | `OkStream of 'o stream (* 200 *)
      | `Created of string option (* 201 *)
      | `No_content (* 204 *)
      | `Unauthorized of Error_monad.error list option (* 401 *)
      | `Forbidden of Error_monad.error list option (* 403 *)
      | `Not_found of Error_monad.error list option (* 404 *)
      | `Conflict of Error_monad.error list option (* 409 *)
      | `Error of Error_monad.error list option (* 500 *) ]

    and 'a stream = 'a Resto_directory.Answer.stream = {
      next : unit -> 'a option Lwt.t;
      shutdown : unit -> unit;
    }

    let return x = Lwt.return (`Ok x)

    let return_stream x = Lwt.return (`OkStream x)

    let not_found = Lwt.return (`Not_found None)

    let fail err = Lwt.return (`Error (Some err))
  end

  module RPC_directory = struct
    include RPC_directory

    let gen_register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i
          >>= function
          | `Ok o ->
              RPC_answer.return o
          | `OkStream s ->
              RPC_answer.return_stream s
          | `Created s ->
              Lwt.return (`Created s)
          | `No_content ->
              Lwt.return `No_content
          | `Unauthorized e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Unauthorized e)
          | `Forbidden e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Forbidden e)
          | `Not_found e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Not_found e)
          | `Conflict e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Conflict e)
          | `Error e ->
              let e = Option.map e ~f:(List.map (fun e -> Ecoproto_error e)) in
              Lwt.return (`Error e))

    let register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i
          >>= function
          | Ok o -> RPC_answer.return o | Error e -> RPC_answer.fail e)

    let opt_register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i
          >>= function
          | Ok (Some o) ->
              RPC_answer.return o
          | Ok None ->
              RPC_answer.not_found
          | Error e ->
              RPC_answer.fail e)

    let lwt_register dir service handler =
      gen_register dir service (fun p q i ->
          handler p q i >>= fun o -> RPC_answer.return o)

    open Curry

    let register0 root s f = register root s (curry Z f)

    let register1 root s f = register root s (curry (S Z) f)

    let register2 root s f = register root s (curry (S (S Z)) f)

    let register3 root s f = register root s (curry (S (S (S Z))) f)

    let register4 root s f = register root s (curry (S (S (S (S Z)))) f)

    let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)

    let opt_register0 root s f = opt_register root s (curry Z f)

    let opt_register1 root s f = opt_register root s (curry (S Z) f)

    let opt_register2 root s f = opt_register root s (curry (S (S Z)) f)

    let opt_register3 root s f = opt_register root s (curry (S (S (S Z))) f)

    let opt_register4 root s f =
      opt_register root s (curry (S (S (S (S Z)))) f)

    let opt_register5 root s f =
      opt_register root s (curry (S (S (S (S (S Z))))) f)

    let gen_register0 root s f = gen_register root s (curry Z f)

    let gen_register1 root s f = gen_register root s (curry (S Z) f)

    let gen_register2 root s f = gen_register root s (curry (S (S Z)) f)

    let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f)

    let gen_register4 root s f =
      gen_register root s (curry (S (S (S (S Z)))) f)

    let gen_register5 root s f =
      gen_register root s (curry (S (S (S (S (S Z))))) f)

    let lwt_register0 root s f = lwt_register root s (curry Z f)

    let lwt_register1 root s f = lwt_register root s (curry (S Z) f)

    let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f)

    let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f)

    let lwt_register4 root s f =
      lwt_register root s (curry (S (S (S (S Z)))) f)

    let lwt_register5 root s f =
      lwt_register root s (curry (S (S (S (S (S Z))))) f)
  end

  module RPC_context = struct
    type t = rpc_context

    class type ['pr] simple =
      object
        method call_proto_service0 :
          'm 'q 'i 'o.
          (([< RPC_service.meth] as 'm), t, t, 'q, 'i, 'o) RPC_service.t ->
          'pr -> 'q -> 'i -> 'o Error_monad.shell_tzresult Lwt.t

        method call_proto_service1 :
          'm 'a 'q 'i 'o.
          (([< RPC_service.meth] as 'm), t, t * 'a, 'q, 'i, 'o) RPC_service.t ->
          'pr -> 'a -> 'q -> 'i -> 'o Error_monad.shell_tzresult Lwt.t

        method call_proto_service2 :
          'm 'a 'b 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            t,
            (t * 'a) * 'b,
            'q,
            'i,
            'o )
          RPC_service.t -> 'pr -> 'a -> 'b -> 'q -> 'i ->
          'o Error_monad.shell_tzresult Lwt.t

        method call_proto_service3 :
          'm 'a 'b 'c 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            t,
            ((t * 'a) * 'b) * 'c,
            'q,
            'i,
            'o )
          RPC_service.t -> 'pr -> 'a -> 'b -> 'c -> 'q -> 'i ->
          'o Error_monad.shell_tzresult Lwt.t
      end

    let make_call0 s (ctxt : _ simple) = ctxt#call_proto_service0 s

    let make_call0 = (make_call0 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_call1 s (ctxt : _ simple) = ctxt#call_proto_service1 s

    let make_call1 = (make_call1 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_call2 s (ctxt : _ simple) = ctxt#call_proto_service2 s

    let make_call2 = (make_call2 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_call3 s (ctxt : _ simple) = ctxt#call_proto_service3 s

    let make_call3 = (make_call3 : _ -> _ simple -> _ :> _ -> _ #simple -> _)

    let make_opt_call0 s ctxt block q i =
      make_call0 s ctxt block q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)

    let make_opt_call1 s ctxt block a1 q i =
      make_call1 s ctxt block a1 q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)

    let make_opt_call2 s ctxt block a1 a2 q i =
      make_call2 s ctxt block a1 a2 q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)

    let make_opt_call3 s ctxt block a1 a2 a3 q i =
      make_call3 s ctxt block a1 a2 a3 q i
      >>= function
      | Error [RPC_context.Not_found _] ->
          Lwt.return_ok None
      | Error _ as v ->
          Lwt.return v
      | Ok v ->
          Lwt.return_ok (Some v)
  end

  module Micheline = struct
    include Micheline

    let canonical_encoding_v1 = canonical_encoding_v1

    let canonical_encoding = canonical_encoding_v0
  end

  module Logging = Internal_event.Legacy_logging.Make (Param)

  module Updater = struct
    type nonrec validation_result = validation_result = {
      context : Context.t;
      fitness : Fitness.t;
      message : string option;
      max_operations_ttl : int;
      last_allowed_fork_level : Int32.t;
    }

    type nonrec quota = quota = {max_size : int; max_op : int option}

    type nonrec rpc_context = rpc_context = {
      block_hash : Block_hash.t;
      block_header : Block_header.shell_header;
      context : Context.t;
    }

    let activate = Context.set_protocol

    let fork_test_chain = Context.fork_test_chain

    module type PROTOCOL =
      T
        with type context := Context.t
         and type quota := quota
         and type validation_result := validation_result
         and type rpc_context := rpc_context
         and type 'a tzresult := 'a Error_monad.tzresult
  end

  module Base58 = struct
    include Tezos_crypto.Base58

    let simple_encode enc s = simple_encode enc s

    let simple_decode enc s = simple_decode enc s

    include Make (struct
      type context = Context.t
    end)

    let decode s = decode s
  end

  module Context = struct
    include Context

    let fold_keys s k ~init ~f =
      let rec loop k acc =
        fold s k ~init:acc ~f:(fun file acc ->
            match file with `Key k -> f k acc | `Dir k -> loop k acc)
      in
      loop k init

    let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

    let register_resolver = Base58.register_resolver

    let complete ctxt s = Base58.complete ctxt s
  end

  module Lift (P : Updater.PROTOCOL) = struct
    include P

    let begin_partial_application ~chain_id ~ancestor_context
        ~predecessor_timestamp ~predecessor_fitness raw_block =
      begin_partial_application
        ~chain_id
        ~ancestor_context
        ~predecessor_timestamp
        ~predecessor_fitness
        raw_block
      >|= wrap_error

    let begin_application ~chain_id ~predecessor_context ~predecessor_timestamp
        ~predecessor_fitness raw_block =
      begin_application
        ~chain_id
        ~predecessor_context
        ~predecessor_timestamp
        ~predecessor_fitness
        raw_block
      >|= wrap_error

    let begin_construction ~chain_id ~predecessor_context
        ~predecessor_timestamp ~predecessor_level ~predecessor_fitness
        ~predecessor ~timestamp ?protocol_data () =
      begin_construction
        ~chain_id
        ~predecessor_context
        ~predecessor_timestamp
        ~predecessor_level
        ~predecessor_fitness
        ~predecessor
        ~timestamp
        ?protocol_data
        ()
      >|= wrap_error

    let current_context c = current_context c >|= wrap_error

    let apply_operation c o = apply_operation c o >|= wrap_error

    let finalize_block c = finalize_block c >|= wrap_error

    let init c bh = init c bh >|= wrap_error
  end

  class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t)
    (prefix : (unit, (unit * 'chain) * 'block) RPC_path.t) =
    object
      method call_proto_service0
          : 'm 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun s (chain, block) q i ->
          let s = RPC_service.subst0 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s (((), chain), block) q i

      method call_proto_service1
          : 'm 'a 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t * 'a,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'a -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s (chain, block) a1 q i ->
          let s = RPC_service.subst1 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s ((((), chain), block), a1) q i

      method call_proto_service2
          : 'm 'a 'b 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              (RPC_context.t * 'a) * 'b,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'a -> 'b -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s (chain, block) a1 a2 q i ->
          let s = RPC_service.subst2 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s (((((), chain), block), a1), a2) q i

      method call_proto_service3
          : 'm 'a 'b 'c 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              ((RPC_context.t * 'a) * 'b) * 'c,
              'q,
              'i,
              'o )
            RPC_service.t -> 'chain * 'block -> 'a -> 'b -> 'c -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s (chain, block) a1 a2 a3 q i ->
          let s = RPC_service.subst3 s in
          let s = RPC_service.prefix prefix s in
          t#call_service s ((((((), chain), block), a1), a2), a3) q i
    end

  class ['block] proto_rpc_context_of_directory conv dir :
    ['block] RPC_context.simple =
    let lookup = new Tezos_rpc.RPC_context.of_directory dir in
    object
      method call_proto_service0
          : 'm 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun s block q i ->
          let rpc_context = conv block in
          lookup#call_service s rpc_context q i

      method call_proto_service1
          : 'm 'a 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              RPC_context.t * 'a,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun s block a1 q i ->
          let rpc_context = conv block in
          lookup#call_service s (rpc_context, a1) q i

      method call_proto_service2
          : 'm 'a 'b 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              (RPC_context.t * 'a) * 'b,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'a -> 'b -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s block a1 a2 q i ->
          let rpc_context = conv block in
          lookup#call_service s ((rpc_context, a1), a2) q i

      method call_proto_service3
          : 'm 'a 'b 'c 'q 'i 'o.
            ( ([< RPC_service.meth] as 'm),
              RPC_context.t,
              ((RPC_context.t * 'a) * 'b) * 'c,
              'q,
              'i,
              'o )
            RPC_service.t -> 'block -> 'a -> 'b -> 'c -> 'q -> 'i ->
            'o tzresult Lwt.t =
        fun s block a1 a2 a3 q i ->
          let rpc_context = conv block in
          lookup#call_service s (((rpc_context, a1), a2), a3) q i
    end
end
src/lib_protocol_environment/tezos_protocol_environment.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module CONTEXT.
  Record signature {t : Type} := {
    t := t;
    key := list string;
    value := Tezos_base__TzPervasives.MBytes.t;
    mem : t -> key -> Lwt.t bool;
    dir_mem : t -> key -> Lwt.t bool;
    get : t -> key -> Lwt.t (option value);
    set : t -> key -> value -> Lwt.t t;
    copy : t -> key -> key -> Lwt.t (option t);
    del : t -> key -> Lwt.t t;
    remove_rec : t -> key -> Lwt.t t;
    fold : forall {a variant : Type}, t ->
      key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a;
    set_protocol : t -> Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t t;
    fork_test_chain : t ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t t;
  }.
  Arguments signature : clear implicits.
End CONTEXT.

Module Context.
  Definition key := list string.
  
  Definition value := Tezos_base__TzPervasives.MBytes.t.
  
  Definition ops (ctxt : Type) := {_ : unit & CONTEXT.signature ctxt}.
  
  Definition kind := False.
  
  Inductive t : Type :=
  | Context : forall {a : Type}, (kind a) -> a -> (ops a) -> t.
  
  Definition mem (function_parameter : t) : (list string) -> Lwt.t bool :=
    let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
    let Ops := projT2 Ops in
    fun key => Ops.(CONTEXT.mem) ctxt key.
  
  Definition set (function_parameter : t)
    : (list string) -> Tezos_base__TzPervasives.MBytes.t -> Lwt.t t :=
    let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
      function_parameter in
    let Ops := projT2 Ops in
    fun key =>
      fun value =>
        op_gtgteq (Ops.(CONTEXT.set) ctxt key value)
          (fun ctxt =>
            Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
  
  Definition dir_mem (function_parameter : t) : (list string) -> Lwt.t bool :=
    let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
    let Ops := projT2 Ops in
    fun key => Ops.(CONTEXT.dir_mem) ctxt key.
  
  Definition get (function_parameter : t)
    : (list string) -> Lwt.t (option Tezos_base__TzPervasives.MBytes.t) :=
    let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
    let Ops := projT2 Ops in
    fun key => Ops.(CONTEXT.get) ctxt key.
  
  Definition copy (function_parameter : t)
    : (list string) -> (list string) -> Lwt.t (option t) :=
    let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
      function_parameter in
    let Ops := projT2 Ops in
    fun from =>
      fun to_ =>
        op_gtgteq (Ops.(CONTEXT.copy) ctxt from to_)
          (fun function_parameter =>
            match function_parameter with
            | Some ctxt =>
              Lwt.return_some
                (Context {| kind := kind; ctxt := ctxt; ops := ops |})
            | None => Lwt.return_none
            end).
  
  Definition del (function_parameter : t) : (list string) -> Lwt.t t :=
    let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
      function_parameter in
    let Ops := projT2 Ops in
    fun key =>
      op_gtgteq (Ops.(CONTEXT.del) ctxt key)
        (fun ctxt =>
          Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
  
  Definition remove_rec (function_parameter : t) : (list string) -> Lwt.t t :=
    let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
      function_parameter in
    let Ops := projT2 Ops in
    fun key =>
      op_gtgteq (Ops.(CONTEXT.remove_rec) ctxt key)
        (fun ctxt =>
          Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
  
  Definition fold {A : Type} (function_parameter : t)
    : (list string) -> A -> (variant -> A -> Lwt.t A) -> Lwt.t A :=
    let 'Context {| ctxt := ctxt; ops := Ops |} := function_parameter in
    let Ops := projT2 Ops in
    fun key => fun init => fun f => Ops.(CONTEXT.fold) ctxt key init f.
  
  Definition set_protocol (function_parameter : t)
    : Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t t :=
    let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
      function_parameter in
    let Ops := projT2 Ops in
    fun protocol_hash =>
      op_gtgteq (Ops.(CONTEXT.set_protocol) ctxt protocol_hash)
        (fun ctxt =>
          Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
  
  Definition fork_test_chain (function_parameter : t)
    : Tezos_base__TzPervasives.Protocol_hash.t ->
      Tezos_base__TzPervasives.Time.Protocol.t -> Lwt.t t :=
    let 'Context {| kind := kind; ctxt := ctxt; ops := Ops as ops |} :=
      function_parameter in
    let Ops := projT2 Ops in
    fun protocol =>
      fun expiration =>
        op_gtgteq (Ops.(CONTEXT.fork_test_chain) ctxt protocol expiration)
          (fun ctxt =>
            Lwt._return (Context {| kind := kind; ctxt := ctxt; ops := ops |})).
End Context.

Record validation_result := {
  context : Context.t;
  fitness : Tezos_base__TzPervasives.Fitness.t;
  message : option string;
  max_operations_ttl : Z;
  last_allowed_fork_level : Stdlib.Int32.t }.

Record quota := {
  max_size : Z;
  max_op : option Z }.

Record rpc_context := {
  block_hash : Tezos_base__TzPervasives.Block_hash.t;
  block_header : Tezos_base__TzPervasives.Block_header.shell_header;
  context : Context.t }.

Module T.
  Record signature {context quota validation_result rpc_context tzresult
    block_header_data block_header block_header_metadata operation_data
    operation_receipt operation validation_state : Type} := {
    context := context;
    quota := quota;
    validation_result := validation_result;
    rpc_context := rpc_context;
    polymorphic_abstract_type;
    max_block_length : Z;
    max_operation_data_length : Z;
    validation_passes : list quota;
    block_header_data := block_header_data;
    block_header_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_data;
    block_header := block_header;
    block_header_metadata := block_header_metadata;
    block_header_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_metadata;
    operation_data := operation_data;
    operation_receipt := operation_receipt;
    operation := operation;
    operation_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_data;
    operation_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_receipt;
    operation_data_and_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      (operation_data * operation_receipt);
    acceptable_passes : operation -> list Z;
    compare_operations : operation -> operation -> Z;
    validation_state := validation_state;
    current_context : validation_state -> Lwt.t (tzresult context);
    begin_partial_application : Tezos_base__TzPervasives.Chain_id.t ->
      context ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Fitness.t ->
            block_header -> Lwt.t (tzresult validation_state);
    begin_application : Tezos_base__TzPervasives.Chain_id.t ->
      context ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Fitness.t ->
            block_header -> Lwt.t (tzresult validation_state);
    begin_construction : Tezos_base__TzPervasives.Chain_id.t ->
      context ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Stdlib.Int32.t ->
            Tezos_base__TzPervasives.Fitness.t ->
              Tezos_base__TzPervasives.Block_hash.t ->
                Tezos_base__TzPervasives.Time.Protocol.t ->
                  (option block_header_data) ->
                    unit -> Lwt.t (tzresult validation_state);
    apply_operation : validation_state ->
      operation -> Lwt.t (tzresult (validation_state * operation_receipt));
    finalize_block : validation_state ->
      Lwt.t (tzresult (validation_result * block_header_metadata));
    rpc_services : Tezos_base__TzPervasives.RPC_directory.t rpc_context;
    init : context ->
      Tezos_base__TzPervasives.Block_header.shell_header ->
        Lwt.t (tzresult validation_result);
  }.
  Arguments signature : clear implicits.
End T.

(* ❌ This kind of signature is not handled. *)
unhandled_module_type

Module V1.
  Record signature {Pervasives_ref Data_encoding_field Data_encoding_case_tag
    Data_encoding_case Data_encoding_Binary_write_error Error_monad_error
    Error_monad_error_info RPC_arg_t RPC_arg_descr RPC_arg_eq RPC_query_t
    RPC_query_field RPC_query_open_query RPC_answer_stream RPC_directory_step
    RPC_directory_conflict Base58_encoding Base58_data
    Ed25519_Public_key_hash_Set_t Ed25519_Public_key_hash_Map_t
    Secp256k1_Public_key_hash_Set_t Secp256k1_Public_key_hash_Map_t
    P256_Public_key_hash_Set_t P256_Public_key_hash_Map_t Chain_id_Set_t
    Chain_id_Map_t Signature_Public_key_hash_Set_t
    Signature_Public_key_hash_Map_t Block_hash_Set_t Block_hash_Map_t
    Operation_hash_Set_t Operation_hash_Map_t Operation_list_hash_Set_t
    Operation_list_hash_Map_t Operation_list_hash_path
    Operation_list_list_hash_Set_t Operation_list_list_hash_Map_t
    Operation_list_list_hash_path Protocol_hash_Set_t Protocol_hash_Map_t
    Context_hash_Set_t Context_hash_Map_t Protocol_t Protocol_component
    Protocol_env_version Updater_validation_result Updater_quota
    Updater_rpc_context : Type} := {
    include;
    extensible_type;
    wrap_error : forall {a : Type}, (Error_monad.tzresult a) ->
      Tezos_base__TzPervasives.Error_monad.tzresult a;
    Lift : functor;
    class;
    class;
  }.
  Arguments signature : clear implicits.
End V1.

(* ❌ Functors are not handled. *)
functor

src/lib_protocol_updater/registered_protocol.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type T = sig
  module P : sig
    val hash : Protocol_hash.t

    include Tezos_protocol_environment.PROTOCOL
  end

  include module type of struct
    include P
  end

  module Block_services : module type of struct
    include Block_services.Make (P) (P)
  end

  val complete_b58prefix :
    Tezos_protocol_environment.Context.t -> string -> string list Lwt.t
end

type t = (module T)

let build_v1 hash =
  match Tezos_protocol_registerer.Registerer.get hash with
  | None ->
      None
  | Some protocol ->
      let (module F) = protocol in
      let module Name = struct
        let name = Protocol_hash.to_b58check hash
      end in
      let module Env = Tezos_protocol_environment.MakeV1 (Name) () in
      Some
        ( module struct
          module Raw = F (Env)

          module P = struct
            let hash = hash

            include Env.Lift (Raw)
          end

          include P
          module Block_services = Block_services.Make (P) (P)

          let complete_b58prefix = Env.Context.complete
        end : T )

module VersionTable = Protocol_hash.Table

let versions : (module T) VersionTable.t = VersionTable.create 20

let sources : Protocol.t VersionTable.t = VersionTable.create 20

let mem hash =
  VersionTable.mem versions hash
  || Tezos_protocol_registerer.Registerer.mem hash

let get hash =
  try Some (VersionTable.find versions hash)
  with Not_found -> (
    match build_v1 hash with
    | Some proto ->
        VersionTable.add versions hash proto ;
        Some proto
    | None ->
        None )

let list () = VersionTable.fold (fun _ p acc -> p :: acc) versions []

let list_embedded () = VersionTable.fold (fun k _ acc -> k :: acc) sources []

let get_embedded_sources_exn hash = VersionTable.find sources hash

let get_embedded_sources hash =
  try Some (get_embedded_sources_exn hash) with Not_found -> None

module Register_embedded
    (Env : Tezos_protocol_environment.V1)
    (Proto : Env.Updater.PROTOCOL) (Source : sig
      val hash : Protocol_hash.t option

      val sources : Protocol.t
    end) =
struct
  let hash =
    match Source.hash with
    | None ->
        Protocol.hash Source.sources
    | Some hash ->
        hash

  module Self = struct
    module P = struct
      let hash = hash

      include Env.Lift (Proto)
    end

    include P
    module Block_services = Block_services.Make (P) (P)

    let complete_b58prefix = Env.Context.complete
  end

  let () =
    VersionTable.add sources hash Source.sources ;
    VersionTable.add versions hash (module Self : T)

  include Self
end
src/lib_protocol_updater/registered_protocol.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module T.
  Record signature {P_block_header_data P_block_header P_block_header_metadata
    P_operation_data P_operation_receipt P_operation P_validation_state : Type}
    := {
    P : signature;
    include;
    Block_services : typeof;
    complete_b58prefix : Tezos_protocol_environment.Context.t ->
      string -> Lwt.t (list string);
  }.
  Arguments signature : clear implicits.
End T.

Definition t :=
  {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    T.signature P_block_header_data P_block_header P_block_header_metadata
      P_operation_data P_operation_receipt P_operation P_validation_state}.

Definition build_v1 (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : option
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  match Tezos_protocol_registerer.Registerer.get hash with
  | None => None
  | Some protocol =>
    let F := protocol in
    let F := projT2 F in
    let Name :=
      (* ❌ The signature name of this module could not be found *)
      existT _ _
        {|
          unknown_signature_name.name := Protocol_hash.to_b58check hash
          |} in
    let Env :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    Some
      (existT _ ((((((_, _), _), _), _), _), _)
        {|
          T.Raw :=
            (* ❌ Applications of functors are not supported for first-class module values *)
            unsupported_functor_application;
          T.P :=
            (* ❌ The signature name of this module could not be found *)
            existT _ _
              {|
                unknown_signature_name.hash := hash;
                (* ❌ Include is not handled inside first-class module values *)
                unknown_signature_name._ := include
                |};
          (* ❌ Include is not handled inside first-class module values *)
          T._ := include;
          T.Block_services :=
            (* ❌ Applications of functors are not supported for first-class module values *)
            unsupported_functor_application;
          T.complete_b58prefix := Env.Context.complete
          |})
  end.

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition versions
  : VersionTable.t
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  VersionTable.create 20.

Definition sources : VersionTable.t Tezos_base__TzPervasives.Protocol.t :=
  VersionTable.create 20.

Definition mem (hash : VersionTable.key) : bool :=
  orb (VersionTable.mem versions hash)
    (Tezos_protocol_registerer.Registerer.mem hash).

Definition get (hash : VersionTable.key)
  : option
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  (* ❌ Try-with are not handled *)
  try (Some (VersionTable.find versions hash)).

Definition list (function_parameter : unit)
  : list
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      T.signature P_block_header_data P_block_header P_block_header_metadata
        P_operation_data P_operation_receipt P_operation P_validation_state} :=
  let 'tt := function_parameter in
  VersionTable.fold
    (fun function_parameter =>
      let '_ := function_parameter in
      fun p => fun acc => cons p acc) versions [].

Definition list_embedded (function_parameter : unit) : list VersionTable.key :=
  let 'tt := function_parameter in
  VersionTable.fold
    (fun k =>
      fun function_parameter =>
        let '_ := function_parameter in
        fun acc => cons k acc) sources [].

Definition get_embedded_sources_exn (hash : VersionTable.key)
  : Tezos_base__TzPervasives.Protocol.t := VersionTable.find sources hash.

Definition get_embedded_sources (hash : VersionTable.key)
  : option Tezos_base__TzPervasives.Protocol.t :=
  (* ❌ Try-with are not handled *)
  try (Some (get_embedded_sources_exn hash)).

(* ❌ Functors are not handled. *)
functor

src/lib_protocol_updater/updater.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Updater_logging

let ( // ) = Filename.concat

(** Compiler *)

let datadir = ref None

let get_datadir () =
  match !datadir with
  | None ->
      fatal_error "Node not initialized" ;
      Lwt_exit.exit 1
  | Some m ->
      m

let init dir = datadir := Some dir

let compiler_name = "tezos-protocol-compiler"

let do_compile hash p =
  assert (p.Protocol.expected_env = V1) ;
  let datadir = get_datadir () in
  let source_dir = datadir // Protocol_hash.to_short_b58check hash // "src" in
  let log_file = datadir // Protocol_hash.to_short_b58check hash // "LOG" in
  let plugin_file =
    datadir
    // Protocol_hash.to_short_b58check hash
    // Format.asprintf "protocol_%a" Protocol_hash.pp hash
  in
  Tezos_base_unix.Protocol_files.write_dir source_dir ~hash p
  >>=? (fun () ->
         let compiler_command =
           ( Sys.executable_name,
             Array.of_list
               [compiler_name; "-register"; "-o"; plugin_file; source_dir] )
         in
         let fd =
           Unix.(openfile log_file [O_WRONLY; O_CREAT; O_TRUNC] 0o644)
         in
         Lwt_process.exec
           ~stdin:`Close
           ~stdout:(`FD_copy fd)
           ~stderr:(`FD_move fd)
           compiler_command
         >>= return)
  >>= function
  | Error err ->
      log_error "Error %a" pp_print_error err ;
      Lwt.return_false
  | Ok (Unix.WSIGNALED _ | Unix.WSTOPPED _) ->
      log_error "INTERRUPTED COMPILATION (%s)" log_file ;
      Lwt.return_false
  | Ok (Unix.WEXITED x) when x <> 0 ->
      log_error "COMPILATION ERROR (%s)" log_file ;
      Lwt.return_false
  | Ok (Unix.WEXITED _) -> (
    try
      Dynlink.loadfile_private (plugin_file ^ ".cmxs") ;
      Lwt.return_true
    with Dynlink.Error err ->
      log_error
        "Can't load plugin: %s (%s)"
        (Dynlink.error_message err)
        plugin_file ;
      Lwt.return_false )

let compile hash p =
  if Tezos_protocol_registerer.Registerer.mem hash then Lwt.return_true
  else
    do_compile hash p
    >>= fun success ->
    let loaded = Tezos_protocol_registerer.Registerer.mem hash in
    if success && not loaded then
      log_error "Internal error while compiling %a" Protocol_hash.pp hash ;
    Lwt.return loaded
src/lib_protocol_updater/updater.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Updater_logging.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition datadir : Stdlib.ref (option string) := Stdlib.ref None.

Definition get_datadir (function_parameter : unit) : string :=
  let 'tt := function_parameter in
  match Stdlib.op_exclamation datadir with
  | None =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      fatal_error
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Node not initialized" % string
            CamlinternalFormatBasics.End_of_format)
          "Node not initialized" % string) in
    Lwt_exit.exit 1
  | Some m => m
  end.

Definition init (dir : string) : unit := Stdlib.op_coloneq datadir (Some dir).

Definition compiler_name : string := "tezos-protocol-compiler" % string.

Definition do_compile
  (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (p : Tezos_base__TzPervasives.Protocol.t) : Lwt.t bool :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      (equiv_decb (Protocol.expected_env p) Tezos_base__TzPervasives.Protocol.V1)
    in
  let datadir := get_datadir tt in
  let source_dir :=
    op_divdiv (op_divdiv datadir (Protocol_hash.to_short_b58check hash))
      "src" % string in
  let log_file :=
    op_divdiv (op_divdiv datadir (Protocol_hash.to_short_b58check hash))
      "LOG" % string in
  let plugin_file :=
    op_divdiv (op_divdiv datadir (Protocol_hash.to_short_b58check hash))
      (Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "protocol_" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "protocol_%a" % string)
        Protocol_hash.pp hash) in
  op_gtgteq
    (op_gtgteqquestion
      (Tezos_base_unix.Protocol_files.write_dir source_dir (Some hash) p)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let compiler_command :=
          (Sys.executable_name,
            (Array.of_list
              (cons compiler_name
                (cons "-register" % string
                  (cons "-o" % string (cons plugin_file (cons source_dir [])))))))
          in
        let fd :=
          openfile log_file
            (cons Unix.O_WRONLY (cons Unix.O_CREAT (cons Unix.O_TRUNC []))) 420
          in
        op_gtgteq
          (Lwt_process.exec None None
            (Some
              (* ❌ Variants not supported *)
              variant)
            (Some
              (* ❌ Variants not supported *)
              variant)
            (Some
              (* ❌ Variants not supported *)
              variant) compiler_command) _return))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Error " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)) "Error %a" % string)
            pp_print_error err in
        Lwt.return_false
      | Stdlib.Ok (Unix.WSIGNALED _ | Unix.WSTOPPED _) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "INTERRUPTED COMPILATION (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "INTERRUPTED COMPILATION (%s)" % string) log_file in
        Lwt.return_false
      | Stdlib.Ok (Unix.WEXITED x) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          log_error
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "COMPILATION ERROR (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "COMPILATION ERROR (%s)" % string) log_file in
        Lwt.return_false
      | Stdlib.Ok (Unix.WEXITED _) =>
        (* ❌ Try-with are not handled *)
        try
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          (let _ :=
            Dynlink.loadfile_private
              (String.append plugin_file ".cmxs" % string) in
          Lwt.return_true)
      end).

Definition compile
  (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (p : Tezos_base__TzPervasives.Protocol.t) : Lwt.t bool :=
  if Tezos_protocol_registerer.Registerer.mem hash then
    Lwt.return_true
  else
    op_gtgteq (do_compile hash p)
      (fun success =>
        let loaded := Tezos_protocol_registerer.Registerer.mem hash in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if andb success (negb loaded) then
            log_error
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Internal error while compiling " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "Internal error while compiling %a" % string) Protocol_hash.pp
              hash
          else
            tt in
        Lwt._return loaded).

src/lib_protocol_updater/updater_logging.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "updater"
end)
src/lib_protocol_updater/updater_logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_rpc/RPC_answer.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Return type for service handler *)
type 'o t =
  [ `Ok of 'o (* 200 *)
  | `OkStream of 'o stream (* 200 *)
  | `Created of string option (* 201 *)
  | `No_content (* 204 *)
  | `Unauthorized of RPC_service.error option (* 401 *)
  | `Forbidden of RPC_service.error option (* 403 *)
  | `Not_found of RPC_service.error option (* 404 *)
  | `Conflict of RPC_service.error option (* 409 *)
  | `Error of RPC_service.error option (* 500 *) ]

and 'a stream = 'a Resto_directory.Answer.stream = {
  next : unit -> 'a option Lwt.t;
  shutdown : unit -> unit;
}

let return x = Lwt.return (`Ok x)

let return_unit = Lwt.return (`Ok ())

let return_stream x = Lwt.return (`OkStream x)

let not_found = Lwt.return (`Not_found None)

let fail err = Lwt.return (`Error (Some err))
src/lib_rpc/RPC_answer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Reserved Notation "'t".



where "'t" := (fun (o : Type) => variant).

Definition t := 't.

Definition _return {A : Type} (x : A) : Lwt.t variant :=
  Lwt._return
    (* ❌ Variants not supported *)
    variant.

Definition return_unit : Lwt.t variant :=
  Lwt._return
    (* ❌ Variants not supported *)
    variant.

Definition return_stream {A : Type} (x : A) : Lwt.t variant :=
  Lwt._return
    (* ❌ Variants not supported *)
    variant.

Definition not_found : Lwt.t variant :=
  Lwt._return
    (* ❌ Variants not supported *)
    variant.

Definition fail {A : Type} (err : A) : Lwt.t variant :=
  Lwt._return
    (* ❌ Variants not supported *)
    variant.

src/lib_rpc/RPC_arg.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type ('i, 'j) eq = ('i, 'j) Resto.eq = Eq : ('a, 'a) eq

include Resto.Arg
src/lib_rpc/RPC_arg.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive eq : forall (i j : Type), Type :=
| Eq : forall {a : Type}, eq a a.

(* ❌ Structure item `include` not handled. *)
include

src/lib_rpc/RPC_context.ml 40 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

class type ['pr] gen_simple =
  object
    method call_service :
      'm 'p 'q 'i 'o.
      (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
      'q -> 'i -> 'o tzresult Lwt.t
  end

class type ['pr] gen_streamed =
  object
    method call_streamed_service :
      'm 'p 'q 'i 'o.
      (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
      on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
      (unit -> unit) tzresult Lwt.t
  end

class type ['pr] gen =
  object
    inherit ['pr] gen_simple

    inherit ['pr] gen_streamed
  end

class type simple =
  object
    inherit [unit] gen_simple
  end

class type streamed =
  object
    inherit [unit] gen_streamed
  end

class type t =
  object
    inherit simple

    inherit streamed
  end

type ('o, 'e) rest_result =
  [ `Ok of 'o
  | `Conflict of 'e
  | `Error of 'e
  | `Forbidden of 'e
  | `Not_found of 'e
  | `Unauthorized of 'e ]
  tzresult

class type json =
  object
    inherit t

    method generic_json_call :
      RPC_service.meth ->
      ?body:Data_encoding.json ->
      Uri.t ->
      (Data_encoding.json, Data_encoding.json option) rest_result Lwt.t

    method base : Uri.t
  end

type error +=
  | Not_found of {meth : RPC_service.meth; uri : Uri.t}
  | Generic_error of {meth : RPC_service.meth; uri : Uri.t}

let base = Uri.make ~scheme:"ocaml" ()

let not_found s p q =
  let {RPC_service.meth; uri; _} =
    RPC_service.forge_partial_request s ~base p q
  in
  fail (Not_found {meth; uri})

let generic_error s p q =
  let {RPC_service.meth; uri; _} =
    RPC_service.forge_partial_request s ~base p q
  in
  fail (Generic_error {meth; uri})

class ['pr] of_directory (dir : 'pr RPC_directory.t) =
  object
    method call_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
          'q -> 'i -> 'o tzresult Lwt.t =
      fun s p q i ->
        RPC_directory.transparent_lookup dir s p q i
        >>= function
        | `Ok v ->
            return v
        | `OkStream {next; shutdown} -> (
            next ()
            >>= function
            | Some v ->
                shutdown () ; return v
            | None ->
                shutdown () ; not_found s p q )
        | `Not_found None ->
            not_found s p q
        | `Unauthorized (Some err)
        | `Forbidden (Some err)
        | `Not_found (Some err)
        | `Conflict (Some err)
        | `Error (Some err) ->
            Lwt.return_error err
        | `Unauthorized None
        | `Error None
        | `Forbidden None
        | `Created _
        | `Conflict None
        | `No_content ->
            generic_error s p q

    method call_streamed_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), 'pr, 'p, 'q, 'i, 'o) RPC_service.t ->
          on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
          (unit -> unit) tzresult Lwt.t =
      fun s ~on_chunk ~on_close p q i ->
        RPC_directory.transparent_lookup dir s p q i
        >>= function
        | `OkStream {next; shutdown} ->
            let rec loop () =
              next ()
              >>= function
              | None ->
                  on_close () ; Lwt.return_unit
              | Some v ->
                  on_chunk v ; loop ()
            in
            let _ = loop () in
            return shutdown
        | `Ok v ->
            on_chunk v ;
            on_close () ;
            return (fun () -> ())
        | `Not_found None ->
            not_found s p q
        | `Unauthorized (Some err)
        | `Forbidden (Some err)
        | `Not_found (Some err)
        | `Conflict (Some err)
        | `Error (Some err) ->
            Lwt.return_error err
        | `Unauthorized None
        | `Error None
        | `Forbidden None
        | `Created _
        | `Conflict None
        | `No_content ->
            generic_error s p q
  end

let make_call s (ctxt : #simple) = ctxt#call_service s

let make_call1 s ctxt x = make_call s ctxt ((), x)

let make_call2 s ctxt x y = make_call s ctxt (((), x), y)

let make_call3 s ctxt x y z = make_call s ctxt ((((), x), y), z)

type stopper = unit -> unit

let make_streamed_call s (ctxt : #streamed) p q i =
  let (stream, push) = Lwt_stream.create () in
  let on_chunk v = push (Some v) and on_close () = push None in
  ctxt#call_streamed_service s ~on_chunk ~on_close p q i
  >>=? fun close -> return (stream, close)

let () =
  let open Data_encoding in
  register_error_kind
    `Branch
    ~id:"RPC_context.Not_found"
    ~title:"RPC lookup failed"
    ~description:
      "RPC lookup failed. No RPC exists at the URL or the RPC tried to access \
       non-existent data."
    (obj2
       (req "method" RPC_service.meth_encoding)
       (req "uri" RPC_encoding.uri_encoding))
    ~pp:(fun ppf (meth, uri) ->
      Format.fprintf
        ppf
        "Did not find service: %s %a"
        (RPC_service.string_of_meth meth)
        Uri.pp_hum
        uri)
    (function Not_found {meth; uri} -> Some (meth, uri) | _ -> None)
    (fun (meth, uri) -> Not_found {meth; uri})
src/lib_rpc/RPC_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class_type` not handled. *)
class_type

Definition rest_result (o e : Type) :=
  Tezos_error_monad.Error_monad.tzresult variant.

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition base : Uri.t :=
  Uri.make (Some "ocaml" % string) None None None None None None tt.

Definition not_found {A B C D E F G : Type}
  (s : Tezos_rpc.RPC_service.raw variant A B C D E F) (p : B) (q : C)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult G) :=
  let '{| RPC_service.meth := meth; RPC_service.uri := uri |} :=
    RPC_service.forge_partial_request s (Some base) p q in
  fail (Tezos_error_monad.Error_monad.Not_found {| meth := meth; uri := uri |}).

Definition generic_error {A B C D E F G : Type}
  (s : Tezos_rpc.RPC_service.raw variant A B C D E F) (p : B) (q : C)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult G) :=
  let '{| RPC_service.meth := meth; RPC_service.uri := uri |} :=
    RPC_service.forge_partial_request s (Some base) p q in
  fail
    (Tezos_error_monad.Error_monad.Generic_error {| meth := meth; uri := uri |}).

(* ❌ Structure item `class` not handled. *)
class

Definition make_call {A B C D I J i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit A B C D)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (I * p * q * i * o)) * J) * J)
  : A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
  (* ❌ Sending method message is not handled *)
  send s.

Definition make_call1 {A B C D I J i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (I * p * q * i * o)) * J) * J) (x : A)
  : B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
  make_call s ctxt (tt, x).

Definition make_call2 {A B C D E J K i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit ((unit * A) * B) C D E)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (J * p * q * i * o)) * K) * K) (x : A) (y : B)
  : C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E) :=
  make_call s ctxt ((tt, x), y).

Definition make_call3 {A B C D E F K L i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit (((unit * A) * B) * C) D E F)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (K * p * q * i * o)) * L) * L) (x : A) (y : B) (z : C)
  : D -> E -> Lwt.t (Tezos_error_monad.Error_monad.tzresult F) :=
  make_call s ctxt (((tt, x), y), z).

Definition stopper := unit -> unit.

Definition make_streamed_call {A B C D I J i o p q : Type}
  (s : Tezos_rpc.RPC_service.t variant unit A B C D)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (I * p * q * i * o)) * J) * J) (p : A) (q : B) (i : C)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult ((Lwt_stream.t D) * (unit -> unit))) :=
  let '(stream, push) := Lwt_stream.create tt in
  let on_chunk (v : D) : unit :=
    push (Some v)
  with on_close (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    push None in
  op_gtgteqquestion
    ((* ❌ Sending method message is not handled *)
    send s on_chunk on_close p q i) (fun close => _return (stream, close)).



src/lib_rpc/RPC_description.ml 5 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto.Description

let describe ctxt ?(recurse = false) path =
  RPC_context.make_call1 RPC_service.description_service ctxt path {recurse} ()
src/lib_rpc/RPC_description.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition describe {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
  : (list string) ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Resto.Description.directory Tezos_rpc.RPC_encoding.schema)) :=
  let recurse :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun path =>
    RPC_context.make_call1 RPC_service.description_service ctxt path
      {| recurse := recurse |} tt.

src/lib_rpc/RPC_directory.ml 37 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad
include Resto_directory.Make (RPC_encoding)

let gen_register dir service handler =
  register dir service (fun p q i ->
      Lwt.catch
        (fun () -> handler p q i)
        (function
          | Not_found -> RPC_answer.not_found | exn -> RPC_answer.fail [Exn exn]))

let gen_register =
  ( gen_register
    : _ -> _ -> (_ -> _ -> _ -> _ RPC_answer.t Lwt.t) -> _
    :> _ -> _ -> (_ -> _ -> _ -> [< _ RPC_answer.t] Lwt.t) -> _ )

let register dir service handler =
  gen_register dir service (fun p q i ->
      handler p q i
      >>= function Ok o -> RPC_answer.return o | Error e -> RPC_answer.fail e)

let opt_register dir service handler =
  gen_register dir service (fun p q i ->
      handler p q i
      >>= function
      | Ok (Some o) ->
          RPC_answer.return o
      | Ok None ->
          RPC_answer.not_found
      | Error e ->
          RPC_answer.fail e)

let lwt_register dir service handler =
  gen_register dir service (fun p q i ->
      handler p q i >>= fun o -> RPC_answer.return o)

open Curry

let register0 root s f = register root s (curry Z f)

let register1 root s f = register root s (curry (S Z) f)

let register2 root s f = register root s (curry (S (S Z)) f)

let register3 root s f = register root s (curry (S (S (S Z))) f)

let register4 root s f = register root s (curry (S (S (S (S Z)))) f)

let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f)

let opt_register0 root s f = opt_register root s (curry Z f)

let opt_register1 root s f = opt_register root s (curry (S Z) f)

let opt_register2 root s f = opt_register root s (curry (S (S Z)) f)

let opt_register3 root s f = opt_register root s (curry (S (S (S Z))) f)

let opt_register4 root s f = opt_register root s (curry (S (S (S (S Z)))) f)

let opt_register5 root s f =
  opt_register root s (curry (S (S (S (S (S Z))))) f)

let gen_register0 root s f = gen_register root s (curry Z f)

let gen_register1 root s f = gen_register root s (curry (S Z) f)

let gen_register2 root s f = gen_register root s (curry (S (S Z)) f)

let gen_register3 root s f = gen_register root s (curry (S (S (S Z))) f)

let gen_register4 root s f = gen_register root s (curry (S (S (S (S Z)))) f)

let gen_register5 root s f =
  gen_register root s (curry (S (S (S (S (S Z))))) f)

let lwt_register0 root s f = lwt_register root s (curry Z f)

let lwt_register1 root s f = lwt_register root s (curry (S Z) f)

let lwt_register2 root s f = lwt_register root s (curry (S (S Z)) f)

let lwt_register3 root s f = lwt_register root s (curry (S (S (S Z))) f)

let lwt_register4 root s f = lwt_register root s (curry (S (S (S (S Z)))) f)

let lwt_register5 root s f =
  lwt_register root s (curry (S (S (S (S (S Z))))) f)
src/lib_rpc/RPC_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

(* ❌ Structure item `include` not handled. *)
include

Definition gen_register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler : B -> C -> D -> Lwt.t (Tezos_rpc.RPC_answer.t E)) : directory A :=
  register dir service
    (fun p =>
      fun q =>
        fun i =>
          Lwt.catch
            (fun function_parameter =>
              let 'tt := function_parameter in
              handler p q i)
            (fun function_parameter =>
              match function_parameter with
              | OCaml.Not_found => RPC_answer.not_found
              | exn =>
                RPC_answer.fail
                  (cons (Tezos_error_monad.Error_monad.Exn exn) [])
              end)).

Definition gen_register {A B C D E : Type}
  : (directory A) ->
    (Service.t variant A B C D E Tezos_rpc.RPC_service.error) ->
      (B -> C -> D -> Lwt.t variant) -> directory A := gen_register.

Definition register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler :
    B -> C -> D -> Lwt.t (sum E (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  gen_register dir service
    (fun p =>
      fun q =>
        fun i =>
          op_gtgteq (handler p q i)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok o => RPC_answer._return o
              | Stdlib.Error e => RPC_answer.fail e
              end)).

Definition opt_register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler :
    B ->
      C ->
        D -> Lwt.t (sum (option E) (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  gen_register dir service
    (fun p =>
      fun q =>
        fun i =>
          op_gtgteq (handler p q i)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok (Some o) => RPC_answer._return o
              | Stdlib.Ok None => RPC_answer.not_found
              | Stdlib.Error e => RPC_answer.fail e
              end)).

Definition lwt_register {A B C D E : Type}
  (dir : directory A)
  (service : Service.t variant A B C D E Tezos_rpc.RPC_service.error)
  (handler : B -> C -> D -> Lwt.t E) : directory A :=
  gen_register dir service
    (fun p =>
      fun q =>
        fun i => op_gtgteq (handler p q i) (fun o => RPC_answer._return o)).

Import Curry.

Definition register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f : B -> C -> Lwt.t (sum D (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (curry Curry.Z f).

Definition register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> Lwt.t (sum E (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (curry (Curry.S Curry.Z) f).

Definition register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f :
    B -> C -> D -> E -> Lwt.t (sum F (list Tezos_error_monad.Error_monad.error)))
  : directory A := register root s (curry (Curry.S (Curry.S Curry.Z)) f).

Definition register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D -> E -> F -> Lwt.t (sum G (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).

Definition register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F -> G -> Lwt.t (sum H (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).

Definition register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              G -> H -> Lwt.t (sum I (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  register root s
    (curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).

Definition opt_register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f :
    B -> C -> Lwt.t (sum (option D) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (curry Curry.Z f).

Definition opt_register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D -> Lwt.t (sum (option E) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (curry (Curry.S Curry.Z) f).

Definition opt_register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E -> Lwt.t (sum (option F) (list Tezos_error_monad.Error_monad.error)))
  : directory A := opt_register root s (curry (Curry.S (Curry.S Curry.Z)) f).

Definition opt_register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              Lwt.t (sum (option G) (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  opt_register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).

Definition opt_register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              G ->
                Lwt.t
                  (sum (option H) (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  opt_register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).

Definition opt_register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f :
    B ->
      C ->
        D ->
          E ->
            F ->
              G ->
                H ->
                  Lwt.t
                    (sum (option I) (list Tezos_error_monad.Error_monad.error)))
  : directory A :=
  opt_register root s
    (curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).

Definition gen_register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f : B -> C -> Lwt.t variant) : directory A :=
  gen_register root s (curry Curry.Z f).

Definition gen_register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> Lwt.t variant) : directory A :=
  gen_register root s (curry (Curry.S Curry.Z) f).

Definition gen_register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> Lwt.t variant) : directory A :=
  gen_register root s (curry (Curry.S (Curry.S Curry.Z)) f).

Definition gen_register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> Lwt.t variant) : directory A :=
  gen_register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).

Definition gen_register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> G -> Lwt.t variant) : directory A :=
  gen_register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).

Definition gen_register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> G -> H -> Lwt.t variant) : directory A :=
  gen_register root s
    (curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).

Definition lwt_register0 {A B C D : Type}
  (root : directory A)
  (s : Service.t variant A unit B C D Tezos_rpc.RPC_service.error)
  (f : B -> C -> Lwt.t D) : directory A := lwt_register root s (curry Curry.Z f).

Definition lwt_register1 {A B C D E : Type}
  (root : directory A)
  (s : Service.t variant A (unit * B) C D E Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> Lwt.t E) : directory A :=
  lwt_register root s (curry (Curry.S Curry.Z) f).

Definition lwt_register2 {A B C D E F : Type}
  (root : directory A)
  (s : Service.t variant A ((unit * B) * C) D E F Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> Lwt.t F) : directory A :=
  lwt_register root s (curry (Curry.S (Curry.S Curry.Z)) f).

Definition lwt_register3 {A B C D E F G : Type}
  (root : directory A)
  (s :
    Service.t variant A (((unit * B) * C) * D) E F G Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> Lwt.t G) : directory A :=
  lwt_register root s (curry (Curry.S (Curry.S (Curry.S Curry.Z))) f).

Definition lwt_register4 {A B C D E F G H : Type}
  (root : directory A)
  (s :
    Service.t variant A ((((unit * B) * C) * D) * E) F G H
      Tezos_rpc.RPC_service.error) (f : B -> C -> D -> E -> F -> G -> Lwt.t H)
  : directory A :=
  lwt_register root s (curry (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z)))) f).

Definition lwt_register5 {A B C D E F G H I : Type}
  (root : directory A)
  (s :
    Service.t variant A (((((unit * B) * C) * D) * E) * F) G H I
      Tezos_rpc.RPC_service.error)
  (f : B -> C -> D -> E -> F -> G -> H -> Lwt.t I) : directory A :=
  lwt_register root s
    (curry (Curry.S (Curry.S (Curry.S (Curry.S (Curry.S Curry.Z))))) f).

src/lib_rpc/RPC_encoding.ml 29 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a t = 'a Data_encoding.t

type schema = Data_encoding.json_schema * Data_encoding.Binary_schema.t

let unit = Data_encoding.empty

let untyped = Data_encoding.(obj1 (req "untyped" string))

let conv f g t = Data_encoding.conv ~schema:(Data_encoding.Json.schema t) f g t

let schema ?definitions_path t =
  ( Data_encoding.Json.schema ?definitions_path t,
    Data_encoding.Binary.describe t )

let schema_encoding =
  let open Data_encoding in
  obj2
    (req "json_schema" json_schema)
    (req "binary_schema" Data_encoding.Binary_schema.encoding)

module StringMap = Resto.StringMap

let arg_encoding =
  let open Data_encoding in
  conv
    (fun {Resto.Arg.name; descr} -> ((), name, descr))
    (fun ((), name, descr) -> {name; descr})
    (obj3
       (req "id" (constant "single"))
       (req "name" string)
       (opt "descr" string))

let multi_arg_encoding =
  let open Data_encoding in
  conv
    (fun {Resto.Arg.name; descr} -> ((), name, descr))
    (fun ((), name, descr) -> {name; descr})
    (obj3
       (req "id" (constant "multiple"))
       (req "name" string)
       (opt "descr" string))

open Resto.Description

let meth_encoding =
  Data_encoding.string_enum
    [ ("GET", `GET);
      ("POST", `POST);
      ("DELETE", `DELETE);
      ("PUT", `PUT);
      ("PATCH", `PATCH) ]

let path_item_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        string
        ~title:"PStatic"
        (function PStatic s -> Some s | _ -> None)
        (fun s -> PStatic s);
      case
        (Tag 1)
        arg_encoding
        ~title:"PDynamic"
        (function PDynamic s -> Some s | _ -> None)
        (fun s -> PDynamic s);
      case
        (Tag 2)
        multi_arg_encoding
        ~title:"PDynamicTail"
        (function PDynamicTail s -> Some s | _ -> None)
        (fun s -> PDynamicTail s) ]

let query_kind_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Single"
        (obj1 (req "single" arg_encoding))
        (function Single s -> Some s | _ -> None)
        (fun s -> Single s);
      case
        (Tag 1)
        ~title:"Optional"
        (obj1 (req "optional" arg_encoding))
        (function Optional s -> Some s | _ -> None)
        (fun s -> Optional s);
      case
        (Tag 2)
        ~title:"Flag"
        (obj1 (req "flag" empty))
        (function Flag -> Some () | _ -> None)
        (fun () -> Flag);
      case
        (Tag 3)
        ~title:"Multi"
        (obj1 (req "multi" arg_encoding))
        (function Multi s -> Some s | _ -> None)
        (fun s -> Multi s) ]

let query_item_encoding =
  let open Data_encoding in
  conv
    (fun {name; description; kind} -> (name, description, kind))
    (fun (name, description, kind) -> {name; description; kind})
    (obj3
       (req "name" string)
       (opt "description" string)
       (req "kind" query_kind_encoding))

let service_descr_encoding =
  let open Data_encoding in
  conv
    (fun {meth; path; description; query; input; output; error} ->
      (meth, path, description, query, input, output, error))
    (fun (meth, path, description, query, input, output, error) ->
      {meth; path; description; query; input; output; error})
    (obj7
       (req "meth" meth_encoding)
       (req "path" (list path_item_encoding))
       (opt "description" string)
       (req "query" (list query_item_encoding))
       (opt "input" schema_encoding)
       (req "output" schema_encoding)
       (req "error" schema_encoding))

let directory_descr_encoding =
  let open Data_encoding in
  mu "service_tree"
  @@ fun directory_descr_encoding ->
  let static_subdirectories_descr_encoding =
    union
      [ case
          (Tag 0)
          ~title:"Suffixes"
          (obj1
             (req
                "suffixes"
                (list
                   (obj2
                      (req "name" string)
                      (req "tree" directory_descr_encoding)))))
          (function
            | Suffixes map -> Some (StringMap.bindings map) | _ -> None)
          (fun m ->
            let add acc (n, t) = StringMap.add n t acc in
            Suffixes (List.fold_left add StringMap.empty m));
        case
          (Tag 1)
          ~title:"Arg"
          (obj1
             (req
                "dynamic_dispatch"
                (obj2
                   (req "arg" arg_encoding)
                   (req "tree" directory_descr_encoding))))
          (function Arg (ty, tree) -> Some (ty, tree) | _ -> None)
          (fun (ty, tree) -> Arg (ty, tree)) ]
  in
  let static_directory_descr_encoding =
    conv
      (fun {services; subdirs} ->
        let find s =
          try Some (Resto.MethMap.find s services) with Not_found -> None
        in
        (find `GET, find `POST, find `DELETE, find `PUT, find `PATCH, subdirs))
      (fun (get, post, delete, put, patch, subdirs) ->
        let add meth s services =
          match s with
          | None ->
              services
          | Some s ->
              Resto.MethMap.add meth s services
        in
        let services =
          Resto.MethMap.empty
          |> add `GET get
          |> add `POST post
          |> add `DELETE delete
          |> add `PUT put
          |> add `PATCH patch
        in
        {services; subdirs})
      (obj6
         (opt "get_service" service_descr_encoding)
         (opt "post_service" service_descr_encoding)
         (opt "delete_service" service_descr_encoding)
         (opt "put_service" service_descr_encoding)
         (opt "patch_service" service_descr_encoding)
         (opt "subdirs" static_subdirectories_descr_encoding))
  in
  union
    [ case
        (Tag 0)
        ~title:"Static"
        (obj1 (req "static" static_directory_descr_encoding))
        (function Static descr -> Some descr | _ -> None)
        (fun descr -> Static descr);
      case
        (Tag 1)
        ~title:"Dynamic"
        (obj1 (req "dynamic" (option string)))
        (function Dynamic descr -> Some descr | _ -> None)
        (fun descr -> Dynamic descr) ]

let description_request_encoding =
  let open Data_encoding in
  conv
    (fun {recurse} -> recurse)
    (function recurse -> {recurse})
    (obj1 (dft "recursive" bool false))

let description_answer_encoding = directory_descr_encoding

let uri_encoding =
  let open Data_encoding in
  conv Uri.to_string Uri.of_string string
src/lib_rpc/RPC_encoding.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t (a : Type) := Tezos_data_encoding.Data_encoding.t a.

Definition schema :=
  Tezos_data_encoding.Data_encoding.json_schema *
    Tezos_data_encoding.Data_encoding.Binary_schema.t.

Definition unit : Tezos_data_encoding.Data_encoding.encoding unit :=
  Data_encoding.empty.

Definition untyped : Tezos_data_encoding.Data_encoding.encoding string :=
  obj1 (req None None "untyped" % string string).

Definition conv {A B : Type}
  (f : A -> B) (g : B -> A)
  (t : Tezos_data_encoding__Data_encoding.Encoding.t B)
  : Tezos_data_encoding.Data_encoding.encoding A :=
  Data_encoding.conv f g (Some (Data_encoding.Json.schema None t)) t.

Definition schema {A : Type}
  (definitions_path : option string)
  (t : Tezos_data_encoding__Data_encoding.Encoding.t A)
  : Tezos_data_encoding.Data_encoding.Json.schema *
    Tezos_data_encoding__Data_encoding.Binary_schema.t :=
  ((Data_encoding.Json.schema definitions_path t),
    (Data_encoding.Binary.describe t)).

Definition schema_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Tezos_data_encoding.Data_encoding.json_schema *
      Tezos_data_encoding.Data_encoding.Binary_schema.t) :=
  obj2 (req None None "json_schema" % string json_schema)
    (req None None "binary_schema" % string Data_encoding.Binary_schema.encoding).

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition arg_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Arg.descr :=
  conv
    (fun function_parameter =>
      let '{| Resto.Arg.name := name; Resto.Arg.descr := descr |} :=
        function_parameter in
      (tt, name, descr))
    (fun function_parameter =>
      let '(tt, name, descr) := function_parameter in
      {| name := name; descr := descr |}) None
    (obj3 (req None None "id" % string (constant "single" % string))
      (req None None "name" % string string)
      (opt None None "descr" % string string)).

Definition multi_arg_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Arg.descr :=
  conv
    (fun function_parameter =>
      let '{| Resto.Arg.name := name; Resto.Arg.descr := descr |} :=
        function_parameter in
      (tt, name, descr))
    (fun function_parameter =>
      let '(tt, name, descr) := function_parameter in
      {| name := name; descr := descr |}) None
    (obj3 (req None None "id" % string (constant "multiple" % string))
      (req None None "name" % string string)
      (opt None None "descr" % string string)).

Import Resto.Description.

Definition meth_encoding : Tezos_data_encoding.Data_encoding.encoding variant :=
  Data_encoding.string_enum
    (cons
      ("GET" % string,
        (* ❌ Variants not supported *)
        variant)
      (cons
        ("POST" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("DELETE" % string,
            (* ❌ Variants not supported *)
            variant)
          (cons
            ("PUT" % string,
              (* ❌ Variants not supported *)
              variant)
            (cons
              ("PATCH" % string,
                (* ❌ Variants not supported *)
                variant) []))))).

Definition path_item_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.path_item :=
  union None
    (cons
      (case "PStatic" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
        string
        (fun function_parameter =>
          match function_parameter with
          | Resto.Description.PStatic s => Some s
          | _ => None
          end) (fun s => Resto.Description.PStatic s))
      (cons
        (case "PDynamic" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
          arg_encoding
          (fun function_parameter =>
            match function_parameter with
            | Resto.Description.PDynamic s => Some s
            | _ => None
            end) (fun s => Resto.Description.PDynamic s))
        (cons
          (case "PDynamicTail" % string None
            (Tezos_data_encoding.Data_encoding.Tag 2) multi_arg_encoding
            (fun function_parameter =>
              match function_parameter with
              | Resto.Description.PDynamicTail s => Some s
              | _ => None
              end) (fun s => Resto.Description.PDynamicTail s)) []))).

Definition query_kind_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.query_kind :=
  union None
    (cons
      (case "Single" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
        (obj1 (req None None "single" % string arg_encoding))
        (fun function_parameter =>
          match function_parameter with
          | Resto.Description.Single s => Some s
          | _ => None
          end) (fun s => Resto.Description.Single s))
      (cons
        (case "Optional" % string None (Tezos_data_encoding.Data_encoding.Tag 1)
          (obj1 (req None None "optional" % string arg_encoding))
          (fun function_parameter =>
            match function_parameter with
            | Resto.Description.Optional s => Some s
            | _ => None
            end) (fun s => Resto.Description.Optional s))
        (cons
          (case "Flag" % string None (Tezos_data_encoding.Data_encoding.Tag 2)
            (obj1 (req None None "flag" % string empty))
            (fun function_parameter =>
              match function_parameter with
              | Resto.Description.Flag => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Resto.Description.Flag))
          (cons
            (case "Multi" % string None
              (Tezos_data_encoding.Data_encoding.Tag 3)
              (obj1 (req None None "multi" % string arg_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Resto.Description.Multi s => Some s
                | _ => None
                end) (fun s => Resto.Description.Multi s)) [])))).

Definition query_item_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.query_item :=
  conv
    (fun function_parameter =>
      let '{| name := name; description := description; kind := kind |} :=
        function_parameter in
      (name, description, kind))
    (fun function_parameter =>
      let '(name, description, kind) := function_parameter in
      {| name := name; description := description; kind := kind |}) None
    (obj3 (req None None "name" % string string)
      (opt None None "description" % string string)
      (req None None "kind" % string query_kind_encoding)).

Definition service_descr_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Resto.Description.service
      (Tezos_data_encoding.Data_encoding.json_schema *
        Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
  conv
    (fun function_parameter =>
      let '{|
        description := description;
          path := path;
          meth := meth;
          query := query;
          input := input;
          output := output;
          error := error
          |} := function_parameter in
      (meth, path, description, query, input, output, error))
    (fun function_parameter =>
      let '(meth, path, description, query, input, output, error) :=
        function_parameter in
      {| description := description; path := path; meth := meth; query := query;
        input := input; output := output; error := error |}) None
    (obj7 (req None None "meth" % string meth_encoding)
      (req None None "path" % string (list None path_item_encoding))
      (opt None None "description" % string string)
      (req None None "query" % string (list None query_item_encoding))
      (opt None None "input" % string schema_encoding)
      (req None None "output" % string schema_encoding)
      (req None None "error" % string schema_encoding)).

Definition directory_descr_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Resto.Description.directory
      (Tezos_data_encoding.Data_encoding.json_schema *
        Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
  apply
    (let arg := mu "service_tree" % string in
    fun eta => arg None None eta)
    (fun directory_descr_encoding =>
      let static_subdirectories_descr_encoding :=
        union None
          (cons
            (case "Suffixes" % string None
              (Tezos_data_encoding.Data_encoding.Tag 0)
              (obj1
                (req None None "suffixes" % string
                  (list None
                    (obj2 (req None None "name" % string string)
                      (req None None "tree" % string directory_descr_encoding)))))
              (fun function_parameter =>
                match function_parameter with
                | Resto.Description.Suffixes map =>
                  Some (StringMap.bindings map)
                | _ => None
                end)
              (fun m =>
                let add {A : Type}
                  (acc : StringMap.t A) (function_parameter : StringMap.key * A)
                  : StringMap.t A :=
                  let '(n, t) := function_parameter in
                  StringMap.add n t acc in
                Resto.Description.Suffixes
                  (Stdlib.List.fold_left add StringMap.empty m)))
            (cons
              (case "Arg" % string None
                (Tezos_data_encoding.Data_encoding.Tag 1)
                (obj1
                  (req None None "dynamic_dispatch" % string
                    (obj2 (req None None "arg" % string arg_encoding)
                      (req None None "tree" % string directory_descr_encoding))))
                (fun function_parameter =>
                  match function_parameter with
                  | Resto.Description.Arg ty tree => Some (ty, tree)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(ty, tree) := function_parameter in
                  Resto.Description.Arg ty tree)) [])) in
      let static_directory_descr_encoding :=
        conv
          (fun function_parameter =>
            let '{| services := services; subdirs := subdirs |} :=
              function_parameter in
            let find (s : Resto.MethMap.(Stdlib__map.S.key))
              : option
                (Resto.Description.service
                  (Tezos_data_encoding.Data_encoding.json_schema *
                    Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
              (* ❌ Try-with are not handled *)
              try (Some (Resto.MethMap.(Stdlib__map.S.find) s services)) in
            ((find
              (* ❌ Variants not supported *)
              variant),
              (find
                (* ❌ Variants not supported *)
                variant),
              (find
                (* ❌ Variants not supported *)
                variant),
              (find
                (* ❌ Variants not supported *)
                variant),
              (find
                (* ❌ Variants not supported *)
                variant), subdirs))
          (fun function_parameter =>
            let '(get, post, delete, put, patch, subdirs) := function_parameter
              in
            let add {A : Type}
              (meth : Resto.MethMap.(Stdlib__map.S.key)) (s : option A)
              (services : Resto.MethMap.(Stdlib__map.S.t) A)
              : Resto.MethMap.(Stdlib__map.S.t) A :=
              match s with
              | None => services
              | Some s => Resto.MethMap.(Stdlib__map.S.add) meth s services
              end in
            let services :=
              OCaml.Stdlib.reverse_apply
                (OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        Resto.MethMap.(Stdlib__map.S.empty)
                        (add
                          (* ❌ Variants not supported *)
                          variant get))
                      (add
                        (* ❌ Variants not supported *)
                        variant post))
                    (add
                      (* ❌ Variants not supported *)
                      variant delete))
                  (add
                    (* ❌ Variants not supported *)
                    variant put))
                (add
                  (* ❌ Variants not supported *)
                  variant patch) in
            {| services := services; subdirs := subdirs |}) None
          (obj6 (opt None None "get_service" % string service_descr_encoding)
            (opt None None "post_service" % string service_descr_encoding)
            (opt None None "delete_service" % string service_descr_encoding)
            (opt None None "put_service" % string service_descr_encoding)
            (opt None None "patch_service" % string service_descr_encoding)
            (opt None None "subdirs" % string
              static_subdirectories_descr_encoding)) in
      union None
        (cons
          (case "Static" % string None (Tezos_data_encoding.Data_encoding.Tag 0)
            (obj1
              (req None None "static" % string static_directory_descr_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Resto.Description.Static descr => Some descr
              | _ => None
              end) (fun descr => Resto.Description.Static descr))
          (cons
            (case "Dynamic" % string None
              (Tezos_data_encoding.Data_encoding.Tag 1)
              (obj1 (req None None "dynamic" % string (option string)))
              (fun function_parameter =>
                match function_parameter with
                | Resto.Description.Dynamic descr => Some descr
                | _ => None
                end) (fun descr => Resto.Description.Dynamic descr)) []))).

Definition description_request_encoding
  : Tezos_data_encoding.Data_encoding.encoding Resto.Description.request :=
  conv
    (fun function_parameter =>
      let '{| recurse := recurse |} := function_parameter in
      recurse) (fun recurse => {| recurse := recurse |}) None
    (obj1 (dft None None "recursive" % string bool false)).

Definition description_answer_encoding
  : Tezos_data_encoding.Data_encoding.encoding
    (Resto.Description.directory
      (Tezos_data_encoding.Data_encoding.json_schema *
        Tezos_data_encoding.Data_encoding.Binary_schema.t)) :=
  directory_descr_encoding.

Definition uri_encoding : Tezos_data_encoding.Data_encoding.encoding Uri.t :=
  conv Uri.to_string Uri.of_string None string.

src/lib_rpc/RPC_error.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let list ctxt = RPC_context.make_call RPC_service.error_service ctxt () () ()

let encoding = RPC_service.error_encoding
src/lib_rpc/RPC_error.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition list {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Json_schema.schema) :=
  RPC_context.make_call RPC_service.error_service ctxt tt tt tt.

Definition encoding
  : Tezos_data_encoding.Data_encoding.t Tezos_rpc.RPC_service.error :=
  RPC_service.error_encoding.

src/lib_rpc/RPC_path.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto.Path
src/lib_rpc/RPC_path.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_rpc/RPC_query.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto.Query
src/lib_rpc/RPC_query.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_rpc_http/RPC_client.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type S = sig
  module type LOGGER = sig
    type request

    val log_empty_request : Uri.t -> request Lwt.t

    val log_request :
      ?media:Media_type.t ->
      'a Data_encoding.t ->
      Uri.t ->
      string ->
      request Lwt.t

    val log_response :
      request ->
      ?media:Media_type.t ->
      'a Data_encoding.t ->
      Cohttp.Code.status_code ->
      string Lwt.t Lazy.t ->
      unit Lwt.t
  end

  type logger = (module LOGGER)

  val null_logger : logger

  val timings_logger :
    gettimeofday:(unit -> float) -> Format.formatter -> logger

  val full_logger : Format.formatter -> logger

  type config = {host : string; port : int; tls : bool; logger : logger}

  val config_encoding : config Data_encoding.t

  val default_config : config

  class http_ctxt : config -> Media_type.t list -> RPC_context.json

  (**/**)

  val call_service :
    Media_type.t list ->
    ?logger:logger ->
    ?headers:(string * string) list ->
    base:Uri.t ->
    ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
    'p ->
    'q ->
    'i ->
    'o tzresult Lwt.t

  val call_streamed_service :
    Media_type.t list ->
    ?logger:logger ->
    ?headers:(string * string) list ->
    base:Uri.t ->
    ([< Resto.meth], unit, 'p, 'q, 'i, 'o) RPC_service.t ->
    on_chunk:('o -> unit) ->
    on_close:(unit -> unit) ->
    'p ->
    'q ->
    'i ->
    (unit -> unit) tzresult Lwt.t

  val generic_json_call :
    ?headers:(string * string) list ->
    ?body:Data_encoding.json ->
    [< RPC_service.meth] ->
    Uri.t ->
    (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
    Lwt.t

  type content_type = string * string

  type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option

  val generic_call :
    ?headers:(string * string) list ->
    ?accept:Media_type.t list ->
    ?body:Cohttp_lwt.Body.t ->
    ?media:Media_type.t ->
    [< RPC_service.meth] ->
    Uri.t ->
    (content, content) RPC_context.rest_result Lwt.t
end

module Make (Client : Cohttp_lwt.S.Client) = struct
  module Client = Resto_cohttp_client.Client.Make (RPC_encoding) (Client)

  module type LOGGER = Client.LOGGER

  type logger = (module LOGGER)

  let null_logger = Client.null_logger

  let timings_logger = Client.timings_logger

  let full_logger = Client.full_logger

  type content_type = string * string

  type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option

  let request_failed meth uri error =
    let meth = (meth : [< RPC_service.meth] :> RPC_service.meth) in
    fail (RPC_client_errors.Request_failed {meth; uri; error})

  let generic_call ?headers ?accept ?body ?media meth uri :
      (content, content) RPC_context.rest_result Lwt.t =
    Client.generic_call meth ?headers ?accept ?body ?media uri
    >>= function
    | `Ok (Some v) ->
        return (`Ok v)
    | `Ok None ->
        request_failed meth uri Empty_answer
    | (`Conflict _ | `Error _ | `Forbidden _ | `Unauthorized _ | `Not_found _)
      as v ->
        return v
    | `Unexpected_status_code (code, (content, _, media_type)) ->
        let media_type = Option.map media_type ~f:Media_type.name in
        Cohttp_lwt.Body.to_string content
        >>= fun content ->
        request_failed
          meth
          uri
          (Unexpected_status_code {code; content; media_type})
    | `Method_not_allowed allowed ->
        let allowed = List.filter_map RPC_service.meth_of_string allowed in
        request_failed meth uri (Method_not_allowed allowed)
    | `Unsupported_media_type ->
        let media = Option.map media ~f:Media_type.name in
        request_failed meth uri (Unsupported_media_type media)
    | `Not_acceptable acceptable ->
        let proposed =
          Option.unopt_map accept ~default:"" ~f:Media_type.accept_header
        in
        request_failed meth uri (Not_acceptable {proposed; acceptable})
    | `Bad_request msg ->
        request_failed meth uri (Bad_request msg)
    | `Connection_failed msg ->
        request_failed meth uri (Connection_failed msg)
    | `OCaml_exception msg ->
        request_failed meth uri (OCaml_exception msg)
    | `Unauthorized_host host ->
        request_failed meth uri (Unauthorized_host host)

  let handle_error meth uri (body, media, _) f =
    Cohttp_lwt.Body.is_empty body
    >>= fun empty ->
    if empty then return (f None)
    else
      match media with
      | Some ("application", "json") | None -> (
          Cohttp_lwt.Body.to_string body
          >>= fun body ->
          match Data_encoding.Json.from_string body with
          | Ok body ->
              return (f (Some body))
          | Error msg ->
              request_failed
                meth
                uri
                (Unexpected_content
                   {
                     content = body;
                     media_type = Media_type.(name json);
                     error = msg;
                   }) )
      | Some (l, r) ->
          Cohttp_lwt.Body.to_string body
          >>= fun body ->
          request_failed
            meth
            uri
            (Unexpected_content_type
               {
                 received = l ^ "/" ^ r;
                 acceptable = [Media_type.(name json)];
                 body;
               })

  let generic_json_call ?headers ?body meth uri :
      (Data_encoding.json, Data_encoding.json option) RPC_context.rest_result
      Lwt.t =
    let body =
      Option.map body ~f:(fun b ->
          Cohttp_lwt.Body.of_string (Data_encoding.Json.to_string b))
    in
    let media = Media_type.json in
    generic_call meth ?headers ~accept:Media_type.[bson; json] ?body ~media uri
    >>=? function
    | `Ok (body, (Some ("application", "json") | None), _) -> (
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        match Data_encoding.Json.from_string body with
        | Ok json ->
            return (`Ok json)
        | Error msg ->
            request_failed
              meth
              uri
              (Unexpected_content
                 {
                   content = body;
                   media_type = Media_type.(name json);
                   error = msg;
                 }) )
    | `Ok (body, Some ("application", "bson"), _) -> (
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.unsafe_of_string body)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
            let error = Format.asprintf "(at offset: %d) %s" pos msg in
            request_failed
              meth
              uri
              (Unexpected_content
                 {content = body; media_type = Media_type.(name bson); error})
        | bson ->
            return
              (`Ok
                (Json_repr.convert
                   (module Json_repr_bson.Repr)
                   (module Json_repr.Ezjsonm)
                   bson)) )
    | `Ok (body, Some (l, r), _) ->
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        request_failed
          meth
          uri
          (Unexpected_content_type
             {
               received = l ^ "/" ^ r;
               acceptable = [Media_type.(name json)];
               body;
             })
    | `Conflict body ->
        handle_error meth uri body (fun v -> `Conflict v)
    | `Error body ->
        handle_error meth uri body (fun v -> `Error v)
    | `Forbidden body ->
        handle_error meth uri body (fun v -> `Forbidden v)
    | `Not_found body ->
        handle_error meth uri body (fun v -> `Not_found v)
    | `Unauthorized body ->
        handle_error meth uri body (fun v -> `Unauthorized v)

  let handle accept (meth, uri, ans) =
    match ans with
    | `Ok (Some v) ->
        return v
    | `Ok None ->
        request_failed meth uri Empty_answer
    | `Not_found None ->
        fail (RPC_context.Not_found {meth; uri})
    | `Conflict (Some err)
    | `Error (Some err)
    | `Forbidden (Some err)
    | `Unauthorized (Some err)
    | `Not_found (Some err) ->
        Lwt.return_error err
    | `Conflict None | `Error None | `Forbidden None | `Unauthorized None ->
        fail (RPC_context.Generic_error {meth; uri})
    | `Unexpected_status_code (code, (content, _, media_type)) ->
        let media_type = Option.map media_type ~f:Media_type.name in
        Cohttp_lwt.Body.to_string content
        >>= fun content ->
        request_failed
          meth
          uri
          (Unexpected_status_code {code; content; media_type})
    | `Method_not_allowed allowed ->
        let allowed = List.filter_map RPC_service.meth_of_string allowed in
        request_failed meth uri (Method_not_allowed allowed)
    | `Unsupported_media_type ->
        let name =
          match Media_type.first_complete_media accept with
          | None ->
              None
          | Some ((l, r), _) ->
              Some (l ^ "/" ^ r)
        in
        request_failed meth uri (Unsupported_media_type name)
    | `Not_acceptable acceptable ->
        let proposed =
          Option.unopt_map
            (Some accept)
            ~default:""
            ~f:Media_type.accept_header
        in
        request_failed meth uri (Not_acceptable {proposed; acceptable})
    | `Bad_request msg ->
        request_failed meth uri (Bad_request msg)
    | `Unexpected_content ((content, media_type), error)
    | `Unexpected_error_content ((content, media_type), error) ->
        let media_type = Media_type.name media_type in
        request_failed
          meth
          uri
          (Unexpected_content {content; media_type; error})
    | `Unexpected_error_content_type (body, media)
    | `Unexpected_content_type (body, media) ->
        Cohttp_lwt.Body.to_string body
        >>= fun body ->
        let received =
          Option.unopt_map media ~default:"" ~f:(fun (l, r) -> l ^ "/" ^ r)
        in
        request_failed
          meth
          uri
          (Unexpected_content_type
             {received; acceptable = List.map Media_type.name accept; body})
    | `Connection_failed msg ->
        request_failed meth uri (Connection_failed msg)
    | `OCaml_exception msg ->
        request_failed meth uri (OCaml_exception msg)
    | `Unauthorized_host host ->
        request_failed meth uri (Unauthorized_host host)

  let call_streamed_service (type p q i o) accept ?logger ?headers ~base
      (service : (_, _, p, q, i, o) RPC_service.t) ~on_chunk ~on_close
      (params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t =
    Client.call_streamed_service
      accept
      ?logger
      ?headers
      ~base
      ~on_chunk
      ~on_close
      service
      params
      query
      body
    >>= fun ans -> handle accept ans

  let call_service (type p q i o) accept ?logger ?headers ~base
      (service : (_, _, p, q, i, o) RPC_service.t) (params : p) (query : q)
      (body : i) : o tzresult Lwt.t =
    Client.call_service ?logger ?headers ~base accept service params query body
    >>= fun ans -> handle accept ans

  type config = {host : string; port : int; tls : bool; logger : logger}

  let config_encoding =
    let open Data_encoding in
    conv
      (fun {host; port; tls; logger = _} -> (host, port, tls))
      (fun (host, port, tls) -> {host; port; tls; logger = null_logger})
      (obj3 (req "host" string) (req "port" uint16) (req "tls" bool))

  let default_config =
    {host = "localhost"; port = 8732; tls = false; logger = null_logger}

  class http_ctxt config media_types : RPC_context.json =
    let base =
      Uri.make
        ~scheme:(if config.tls then "https" else "http")
        ~host:config.host
        ~port:config.port
        ()
    in
    let logger = config.logger in
    object
      method generic_json_call meth ?body uri =
        let path = Uri.path uri and query = Uri.query uri in
        let uri = Uri.with_path base path in
        let uri = Uri.with_query uri query in
        generic_json_call meth ?body uri

      method call_service
          : 'm 'p 'q 'i 'o.
            (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
            'p -> 'q -> 'i -> 'o tzresult Lwt.t =
        fun service params query body ->
          call_service media_types ~logger ~base service params query body

      method call_streamed_service
          : 'm 'p 'q 'i 'o.
            (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
            on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q ->
            'i -> (unit -> unit) tzresult Lwt.t =
        fun service ~on_chunk ~on_close params query body ->
          call_streamed_service
            media_types
            service
            ~logger
            ~base
            ~on_chunk
            ~on_close
            params
            query
            body

      method base = base
    end
end
src/lib_rpc_http/RPC_client.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Record signature {config : Type} := {
    module_type;
    logger := {request : _ & LOGGER.signature request};
    null_logger : logger;
    timings_logger : (unit -> Z) -> Stdlib.Format.formatter -> logger;
    full_logger : Stdlib.Format.formatter -> logger;
    config := config;
    config_encoding : Tezos_base__TzPervasives.Data_encoding.t config;
    default_config : config;
    class;
    call_service : forall {i o p q variant : Type}, (list
      Tezos_rpc_http.Media_type.t) ->
      (option logger) ->
        (option (list (string * string))) ->
          Uri.t ->
            (Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o);
    call_streamed_service : forall {i o p q variant : Type}, (list
      Tezos_rpc_http.Media_type.t) ->
      (option logger) ->
        (option (list (string * string))) ->
          Uri.t ->
            (Tezos_rpc.RPC_service.t variant unit p q i o) ->
              (o -> unit) ->
                (unit -> unit) ->
                  p ->
                    q ->
                      i ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult (unit -> unit));
    generic_json_call : forall {variant : Type}, (option
      (list (string * string))) ->
      (option Tezos_base__TzPervasives.Data_encoding.json) ->
        variant ->
          Uri.t ->
            Lwt.t
              (Tezos_rpc.RPC_context.rest_result
                Tezos_base__TzPervasives.Data_encoding.json
                (option Tezos_base__TzPervasives.Data_encoding.json));
    content_type := string * string;
    content := Cohttp_lwt.Body.t * (option content_type) *
      (option Tezos_rpc_http.Media_type.t);
    generic_call : forall {variant : Type}, (option (list (string * string))) ->
      (option (list Tezos_rpc_http.Media_type.t)) ->
        (option Cohttp_lwt.Body.t) ->
          (option Tezos_rpc_http.Media_type.t) ->
            variant ->
              Uri.t -> Lwt.t (Tezos_rpc.RPC_context.rest_result content content);
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

src/lib_rpc_http/RPC_client_errors.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type rpc_error =
  | Empty_answer
  | Connection_failed of string
  | Bad_request of string
  | Method_not_allowed of RPC_service.meth list
  | Unsupported_media_type of string option
  | Not_acceptable of {proposed : string; acceptable : string}
  | Unexpected_status_code of {
      code : Cohttp.Code.status_code;
      content : string;
      media_type : string option;
    }
  | Unexpected_content_type of {
      received : string;
      acceptable : string list;
      body : string;
    }
  | Unexpected_content of {
      content : string;
      media_type : string;
      error : string;
    }
  | OCaml_exception of string
  | Unauthorized_host of string option

type error +=
  | Request_failed of {meth : RPC_service.meth; uri : Uri.t; error : rpc_error}

let rpc_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Empty_answer"
        (obj1 (req "kind" (constant "empty_answer")))
        (function Empty_answer -> Some () | _ -> None)
        (fun () -> Empty_answer);
      case
        (Tag 1)
        ~title:"Connection_failed"
        (obj2
           (req "kind" (constant "connection_failed"))
           (req "message" string))
        (function Connection_failed msg -> Some ((), msg) | _ -> None)
        (function ((), msg) -> Connection_failed msg);
      case
        (Tag 2)
        ~title:"Bad_request"
        (obj2 (req "kind" (constant "bad_request")) (req "message" string))
        (function Bad_request msg -> Some ((), msg) | _ -> None)
        (function ((), msg) -> Bad_request msg);
      case
        (Tag 3)
        ~title:"Method_not_allowed"
        (obj2
           (req "kind" (constant "method_not_allowed"))
           (req "allowed" (list RPC_service.meth_encoding)))
        (function Method_not_allowed meths -> Some ((), meths) | _ -> None)
        (function ((), meths) -> Method_not_allowed meths);
      case
        (Tag 4)
        ~title:"Unsupported_media_type"
        (obj2
           (req "kind" (constant "unsupported_media_type"))
           (opt "content_type" string))
        (function Unsupported_media_type m -> Some ((), m) | _ -> None)
        (function ((), m) -> Unsupported_media_type m);
      case
        (Tag 5)
        ~title:"Not_acceptable"
        (obj3
           (req "kind" (constant "not_acceptable"))
           (req "proposed" string)
           (req "acceptable" string))
        (function
          | Not_acceptable {proposed; acceptable} ->
              Some ((), proposed, acceptable)
          | _ ->
              None)
        (function
          | ((), proposed, acceptable) -> Not_acceptable {proposed; acceptable});
      case
        (Tag 6)
        ~title:"Unexpected_status_code"
        (obj4
           (req "kind" (constant "unexpected_status_code"))
           (req "code" uint16)
           (req "content" string)
           (opt "media_type" string))
        (function
          | Unexpected_status_code {code; content; media_type} ->
              Some ((), Cohttp.Code.code_of_status code, content, media_type)
          | _ ->
              None)
        (function
          | ((), code, content, media_type) ->
              let code = Cohttp.Code.status_of_code code in
              Unexpected_status_code {code; content; media_type});
      case
        (Tag 7)
        ~title:"Unexpected_content_type"
        (obj4
           (req "kind" (constant "unexpected_content_type"))
           (req "received" string)
           (req "acceptable" (list string))
           (req "body" string))
        (function
          | Unexpected_content_type {received; acceptable; body} ->
              Some ((), received, acceptable, body)
          | _ ->
              None)
        (function
          | ((), received, acceptable, body) ->
              Unexpected_content_type {received; acceptable; body});
      case
        (Tag 8)
        ~title:"Unexpected_content"
        (obj4
           (req "kind" (constant "unexpected_content"))
           (req "content" string)
           (req "media_type" string)
           (req "error" string))
        (function
          | Unexpected_content {content; media_type; error} ->
              Some ((), content, media_type, error)
          | _ ->
              None)
        (function
          | ((), content, media_type, error) ->
              Unexpected_content {content; media_type; error});
      case
        (Tag 9)
        ~title:"OCaml_exception"
        (obj2 (req "kind" (constant "ocaml_exception")) (req "content" string))
        (function OCaml_exception msg -> Some ((), msg) | _ -> None)
        (function ((), msg) -> OCaml_exception msg) ]

let pp_rpc_error ppf err =
  match err with
  | Empty_answer ->
      Format.fprintf ppf "The server answered with an empty response."
  | Connection_failed msg ->
      Format.fprintf ppf "Unable to connect to the node: \"%s\"" msg
  | Bad_request msg ->
      Format.fprintf
        ppf
        "@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]"
        msg
  | Method_not_allowed meths ->
      Format.fprintf
        ppf
        "@[<v 2>The requested service only accepts the following method:@ %a@]"
        (Format.pp_print_list (fun ppf m ->
             Format.pp_print_string ppf (RPC_service.string_of_meth m)))
        meths
  | Unsupported_media_type None ->
      Format.fprintf
        ppf
        "@[<v 2>The server wants to known the media type we used.@]"
  | Unsupported_media_type (Some media) ->
      Format.fprintf
        ppf
        "@[<v 2>The server does not support the media type we used: %s.@]"
        media
  | Not_acceptable {proposed; acceptable} ->
      Format.fprintf
        ppf
        "@[<v 2>No intersection between the media types we accept and  the \
         ones the server is able to send.@,\
        \ We proposed: %s@,\
        \ The server is only able to serve: %s."
        proposed
        acceptable
  | Unexpected_status_code {code; content; _} ->
      Format.fprintf
        ppf
        "@[<v 2>Unexpected error %d:@,%S"
        (Cohttp.Code.code_of_status code)
        content
  | Unexpected_content_type {received; acceptable = _; body} ->
      Format.fprintf
        ppf
        "@[<v 0>The server answered with a media type we do not understand: \
         %s.@,\
         The response body was:@,\
         %s@]"
        received
        body
  | Unexpected_content {content; media_type; error} ->
      Format.fprintf
        ppf
        "@[<v 2>Failed to parse the answer (%s):@,\
         @[<v 2>error:@ %s@]@,\
         @[<v 2>content:@ %S@]@]"
        media_type
        error
        content
  | OCaml_exception msg ->
      Format.fprintf
        ppf
        "@[<v 2>The server failed with an unexpected exception:@ %s@]"
        msg
  | Unauthorized_host host ->
      Format.fprintf
        ppf
        "@[<v 2>The server refused connection to host \"%s\", please check \
         the node settings for CORS allowed origins.@]"
        (Option.unopt ~default:"" host)

let () =
  register_error_kind
    `Permanent
    ~id:"rpc_client.request_failed"
    ~title:""
    ~description:""
    ~pp:(fun ppf (meth, uri, error) ->
      Format.fprintf
        ppf
        "@[<v 2>Rpc request failed:@  - meth: %s@  - uri: %s@  - error: %a@]"
        (RPC_service.string_of_meth meth)
        (Uri.to_string uri)
        pp_rpc_error
        error)
    Data_encoding.(
      obj3
        (req "meth" RPC_service.meth_encoding)
        (req "uri" RPC_encoding.uri_encoding)
        (req "error" rpc_error_encoding))
    (function
      | Request_failed {uri; error; meth} ->
          Some (meth, uri, error)
      | _ ->
          None)
    (fun (meth, uri, error) -> Request_failed {uri; meth; error})
src/lib_rpc_http/RPC_client_errors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive rpc_error : Type :=
| Empty_answer : rpc_error
| Connection_failed : string -> rpc_error
| Bad_request : string -> rpc_error
| Method_not_allowed : (list Tezos_rpc.RPC_service.meth) -> rpc_error
| Unsupported_media_type : (option string) -> rpc_error
| Not_acceptable : string -> string -> rpc_error
| Unexpected_status_code : Cohttp.Code.status_code -> string -> (option string)
  -> rpc_error
| Unexpected_content_type : string -> (list string) -> string -> rpc_error
| Unexpected_content : string -> string -> string -> rpc_error
| OCaml_exception : string -> rpc_error
| Unauthorized_host : (option string) -> rpc_error.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition rpc_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding rpc_error :=
  union None
    (cons
      (case "Empty_answer" % string None
        (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (obj1 (req None None "kind" % string (constant "empty_answer" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Empty_answer => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Empty_answer))
      (cons
        (case "Connection_failed" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj2
            (req None None "kind" % string
              (constant "connection_failed" % string))
            (req None None "message" % string string))
          (fun function_parameter =>
            match function_parameter with
            | Connection_failed msg => Some (tt, msg)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, msg) := function_parameter in
            Connection_failed msg))
        (cons
          (case "Bad_request" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 2)
            (obj2
              (req None None "kind" % string (constant "bad_request" % string))
              (req None None "message" % string string))
            (fun function_parameter =>
              match function_parameter with
              | Bad_request msg => Some (tt, msg)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, msg) := function_parameter in
              Bad_request msg))
          (cons
            (case "Method_not_allowed" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 3)
              (obj2
                (req None None "kind" % string
                  (constant "method_not_allowed" % string))
                (req None None "allowed" % string
                  (list None RPC_service.meth_encoding)))
              (fun function_parameter =>
                match function_parameter with
                | Method_not_allowed meths => Some (tt, meths)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, meths) := function_parameter in
                Method_not_allowed meths))
            (cons
              (case "Unsupported_media_type" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 4)
                (obj2
                  (req None None "kind" % string
                    (constant "unsupported_media_type" % string))
                  (opt None None "content_type" % string string))
                (fun function_parameter =>
                  match function_parameter with
                  | Unsupported_media_type m => Some (tt, m)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, m) := function_parameter in
                  Unsupported_media_type m))
              (cons
                (case "Not_acceptable" % string None
                  (Tezos_base__TzPervasives.Data_encoding.Tag 5)
                  (obj3
                    (req None None "kind" % string
                      (constant "not_acceptable" % string))
                    (req None None "proposed" % string string)
                    (req None None "acceptable" % string string))
                  (fun function_parameter =>
                    match function_parameter with
                    |
                      Not_acceptable {|
                        proposed := proposed; acceptable := acceptable |} =>
                      Some (tt, proposed, acceptable)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let '(tt, proposed, acceptable) := function_parameter in
                    Not_acceptable
                      {| proposed := proposed; acceptable := acceptable |}))
                (cons
                  (case "Unexpected_status_code" % string None
                    (Tezos_base__TzPervasives.Data_encoding.Tag 6)
                    (obj4
                      (req None None "kind" % string
                        (constant "unexpected_status_code" % string))
                      (req None None "code" % string uint16)
                      (req None None "content" % string string)
                      (opt None None "media_type" % string string))
                    (fun function_parameter =>
                      match function_parameter with
                      |
                        Unexpected_status_code {|
                          code := code;
                            content := content;
                            media_type := media_type
                            |} =>
                        Some
                          (tt, (Cohttp.Code.code_of_status code), content,
                            media_type)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let '(tt, code, content, media_type) := function_parameter
                        in
                      let code := Cohttp.Code.status_of_code code in
                      Unexpected_status_code
                        {| code := code; content := content;
                          media_type := media_type |}))
                  (cons
                    (case "Unexpected_content_type" % string None
                      (Tezos_base__TzPervasives.Data_encoding.Tag 7)
                      (obj4
                        (req None None "kind" % string
                          (constant "unexpected_content_type" % string))
                        (req None None "received" % string string)
                        (req None None "acceptable" % string (list None string))
                        (req None None "body" % string string))
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          Unexpected_content_type {|
                            received := received;
                              acceptable := acceptable;
                              body := body
                              |} => Some (tt, received, acceptable, body)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        let '(tt, received, acceptable, body) :=
                          function_parameter in
                        Unexpected_content_type
                          {| received := received; acceptable := acceptable;
                            body := body |}))
                    (cons
                      (case "Unexpected_content" % string None
                        (Tezos_base__TzPervasives.Data_encoding.Tag 8)
                        (obj4
                          (req None None "kind" % string
                            (constant "unexpected_content" % string))
                          (req None None "content" % string string)
                          (req None None "media_type" % string string)
                          (req None None "error" % string string))
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Unexpected_content {|
                              content := content;
                                media_type := media_type;
                                error := error
                                |} => Some (tt, content, media_type, error)
                          | _ => None
                          end)
                        (fun function_parameter =>
                          let '(tt, content, media_type, error) :=
                            function_parameter in
                          Unexpected_content
                            {| content := content; media_type := media_type;
                              error := error |}))
                      (cons
                        (case "OCaml_exception" % string None
                          (Tezos_base__TzPervasives.Data_encoding.Tag 9)
                          (obj2
                            (req None None "kind" % string
                              (constant "ocaml_exception" % string))
                            (req None None "content" % string string))
                          (fun function_parameter =>
                            match function_parameter with
                            | OCaml_exception msg => Some (tt, msg)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            let '(tt, msg) := function_parameter in
                            OCaml_exception msg)) [])))))))))).

Definition pp_rpc_error (ppf : Stdlib.Format.formatter) (err : rpc_error)
  : unit :=
  match err with
  | Empty_answer =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "The server answered with an empty response." % string
          CamlinternalFormatBasics.End_of_format)
        "The server answered with an empty response." % string)
  | Connection_failed msg =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Unable to connect to the node: """ % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal """" % char
              CamlinternalFormatBasics.End_of_format)))
        "Unable to connect to the node: ""%s""" % string) msg
  | Bad_request msg =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Oups! It looks like we forged an invalid HTTP request." % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]" %
          string) msg
  | Method_not_allowed meths =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The requested service only accepts the following method:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The requested service only accepts the following method:@ %a@]"
          % string)
      (Format.pp_print_list None
        (fun ppf =>
          fun m => Format.pp_print_string ppf (RPC_service.string_of_meth m)))
      meths
  | Unsupported_media_type None =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server wants to known the media type we used." % string
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format)))
        "@[<v 2>The server wants to known the media type we used.@]" % string)
  | Unsupported_media_type (Some media) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server does not support the media type we used: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The server does not support the media type we used: %s.@]" %
          string) media
  | Not_acceptable {| proposed := proposed; acceptable := acceptable |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "No intersection between the media types we accept and  the ones the server is able to send."
              % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal " We proposed: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      " The server is only able to serve: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Char_literal "." % char
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<v 2>No intersection between the media types we accept and  the ones the server is able to send.@, We proposed: %s@, The server is only able to serve: %s."
          % string) proposed acceptable
  | Unexpected_status_code {| code := code; content := content |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Unexpected error " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format))))))
        "@[<v 2>Unexpected error %d:@,%S" % string)
      (Cohttp.Code.code_of_status code) content
  |
    Unexpected_content_type {|
      received := received; acceptable := _; body := body |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server answered with a media type we do not understand: " %
              string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "." % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "The response body was:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<v 0>The server answered with a media type we do not understand: %s.@,The response body was:@,%s@]"
          % string) received body
  |
    Unexpected_content {|
      content := content; media_type := media_type; error := error |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Failed to parse the answer (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "):" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal "error:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "content:" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Caml_string
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))))))))))))
        "@[<v 2>Failed to parse the answer (%s):@,@[<v 2>error:@ %s@]@,@[<v 2>content:@ %S@]@]"
          % string) media_type error content
  | OCaml_exception msg =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server failed with an unexpected exception:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The server failed with an unexpected exception:@ %s@]" % string)
      msg
  | Unauthorized_host host =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "The server refused connection to host """ % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                """, please check the node settings for CORS allowed origins." %
                  string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<v 2>The server refused connection to host ""%s"", please check the node settings for CORS allowed origins.@]"
          % string) (Option.unopt "" % string host)
  end.



src/lib_rpc_http/RPC_client_unix.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type attempt_event = {attempt : int; delay : float; text : string}

module Attempt_logging = Internal_event.Make (struct
  type t = attempt_event

  let name = "rpc_http_attempt"

  let doc = "Error emmited when an HTTP request returned a 502 error."

  let encoding =
    Data_encoding.(
      conv
        (fun {attempt; delay; text} -> (attempt, delay, text))
        (fun (attempt, delay, text) -> {attempt; delay; text})
        (obj3 (req "attempt" int8) (req "delay" float) (req "text" string)))

  let pp f {attempt; delay; text} =
    Format.fprintf
      f
      "Attempt number %d/10, will retry after %g seconds.\n\
       Original body follows.\n\
       %s"
      attempt
      delay
      text

  let level _ = Internal_event.Error
end)

include RPC_client.Make (struct
  include Cohttp_lwt_unix.Client

  let clone_body = function
    | `Stream s ->
        `Stream (Lwt_stream.clone s)
    | x ->
        x

  let call ?ctx ?headers ?body ?chunked meth uri =
    let rec call_and_retry_on_502 attempt delay =
      call ?ctx ?headers ?body ?chunked meth uri
      >>= fun (response, ansbody) ->
      let status = Cohttp.Response.status response in
      match status with
      | `Bad_gateway ->
          let log_ansbody = clone_body ansbody in
          Cohttp_lwt.Body.to_string log_ansbody
          >>= fun text ->
          Attempt_logging.emit (fun () -> {attempt; delay; text})
          >>= fun _ ->
          if attempt >= 10 then Lwt.return (response, ansbody)
          else
            Lwt_unix.sleep delay
            >>= fun () -> call_and_retry_on_502 (attempt + 1) (delay +. 0.1)
      | _ ->
          Lwt.return (response, ansbody)
    in
    call_and_retry_on_502 1 0.
end)
src/lib_rpc_http/RPC_client_unix.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record attempt_event := {
  attempt : Z;
  delay : Z;
  text : string }.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Structure item `include` not handled. *)
include

src/lib_rpc_http/RPC_server.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type cors = Resto_cohttp.Cors.t = {
  allowed_headers : string list;
  allowed_origins : string list;
}

module RPC_logging = Internal_event.Legacy_logging.Make (struct
  let name = "rpc"
end)

include Resto_cohttp_server.Server.Make (RPC_encoding) (RPC_logging)
src/lib_rpc_http/RPC_server.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record cors := {
  allowed_headers : list string;
  allowed_origins : list string }.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Structure item `include` not handled. *)
include

src/lib_rpc_http/media_type.ml 19 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Resto_cohttp.Media_type.Make (RPC_encoding)

let json =
  {
    name = Cohttp.Accept.MediaType ("application", "json");
    q = Some 1000;
    pp =
      (fun _enc ppf raw ->
        match Data_encoding.Json.from_string raw with
        | Error err ->
            Format.fprintf
              ppf
              "@[Invalid JSON:@  - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ \
               %s@]@]"
              err
              raw
        | Ok json ->
            Data_encoding.Json.pp ppf json);
    construct =
      (fun enc v ->
        Data_encoding.Json.to_string ~newline:true ~minify:true
        @@ Data_encoding.Json.construct enc v);
    destruct =
      (fun enc body ->
        match Data_encoding.Json.from_string body with
        | Error _ as err ->
            err
        | Ok json -> (
          try Ok (Data_encoding.Json.destruct enc json)
          with Data_encoding.Json.Cannot_destruct (_, exn) ->
            Error
              (Format.asprintf
                 "%a"
                 (fun fmt -> Data_encoding.Json.print_error fmt)
                 exn) ));
  }

let bson =
  {
    name = Cohttp.Accept.MediaType ("application", "bson");
    q = Some 100;
    pp =
      (fun _enc ppf raw ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.unsafe_of_string raw)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, _) ->
            Format.fprintf ppf "@[Invalid BSON:@ %s@]" msg
        | bson ->
            let json =
              Json_repr.convert
                (module Json_repr_bson.Repr)
                (module Json_repr.Ezjsonm)
                bson
            in
            Data_encoding.Json.pp ppf json);
    construct =
      (fun enc v ->
        Bytes.unsafe_to_string @@ Json_repr_bson.bson_to_bytes
        @@ Data_encoding.Bson.construct enc v);
    destruct =
      (fun enc body ->
        match
          Json_repr_bson.bytes_to_bson
            ~laziness:false
            ~copy:false
            (Bytes.unsafe_of_string body)
        with
        | exception Json_repr_bson.Bson_decoding_error (msg, _, pos) ->
            Error (Format.asprintf "(at offset: %d) %s" pos msg)
        | bson -> (
          try Ok (Data_encoding.Bson.destruct enc bson)
          with Data_encoding.Json.Cannot_destruct (_, exn) ->
            Error
              (Format.asprintf
                 "%a"
                 (fun fmt -> Data_encoding.Json.print_error fmt)
                 exn) ));
  }

let octet_stream =
  {
    name = Cohttp.Accept.MediaType ("application", "octet-stream");
    q = Some 200;
    pp =
      (fun enc ppf raw ->
        match Data_encoding.Binary.of_bytes enc (Bytes.of_string raw) with
        | None ->
            Format.fprintf ppf "Invalid binary data."
        | Some v ->
            Format.fprintf
              ppf
              ";; binary equivalent of the following json@.%a"
              Data_encoding.Json.pp
              (Data_encoding.Json.construct enc v));
    construct =
      (fun enc v -> Bytes.to_string @@ Data_encoding.Binary.to_bytes_exn enc v);
    destruct =
      (fun enc s ->
        match Data_encoding.Binary.of_bytes enc (Bytes.of_string s) with
        | None ->
            Error "Failed to parse binary data."
        | Some data ->
            Ok data);
  }

let all_media_types = [json; bson; octet_stream]
src/lib_rpc_http/media_type.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition json : t :=
  {| name := Cohttp.Accept.MediaType "application" % string "json" % string;
    q := Some 1000;
    pp :=
      fun _enc =>
        fun ppf =>
          fun raw =>
            match Data_encoding.Json.from_string raw with
            | Stdlib.Error err =>
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Invalid JSON:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String_literal " - " % string
                          (CamlinternalFormatBasics.Formatting_gen
                            (CamlinternalFormatBasics.Open_box
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "<v 2>" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "<v 2>" % string))
                            (CamlinternalFormatBasics.String_literal
                              "Error:" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.String_literal
                                      " - " % string
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 2>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 2>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Raw data:" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  CamlinternalFormatBasics.End_of_format))))))))))))))))
                  "@[Invalid JSON:@  - @[<v 2>Error:@ %s@] - @[<v 2>Raw data:@ %s@]@]"
                    % string) err raw
            | Stdlib.Ok json => Data_encoding.Json.pp ppf json
            end;
    construct :=
      fun enc =>
        fun v =>
          apply (Data_encoding.Json.to_string (Some true) (Some true))
            (Data_encoding.Json.construct enc v);
    destruct :=
      fun enc =>
        fun body =>
          match Data_encoding.Json.from_string body with
          | (Stdlib.Error _) as err => err
          | Stdlib.Ok json =>
            (* ❌ Try-with are not handled *)
            try (Stdlib.Ok (Data_encoding.Json.destruct enc json))
          end |}.

Definition bson : t :=
  {| name := Cohttp.Accept.MediaType "application" % string "bson" % string;
    q := Some 100;
    pp :=
      fun _enc =>
        fun ppf =>
          fun raw =>
            let 'bson :=
              Json_repr_bson.bytes_to_bson (Some false) None None false
                (Stdlib.Bytes.unsafe_of_string raw) in
            let json :=
              Json_repr.convert Json_repr_bson.Repr Json_repr.Ezjsonm bson in
            Data_encoding.Json.pp ppf json;
    construct :=
      fun enc =>
        fun v =>
          apply Stdlib.Bytes.unsafe_to_string
            (apply
              (let arg := Json_repr_bson.bson_to_bytes in
              fun eta => arg None None eta) (Data_encoding.Bson.construct enc v));
    destruct :=
      fun enc =>
        fun body =>
          let 'bson :=
            Json_repr_bson.bytes_to_bson (Some false) None None false
              (Stdlib.Bytes.unsafe_of_string body) in
          (* ❌ Try-with are not handled *)
          try (Stdlib.Ok (Data_encoding.Bson.destruct enc bson)) |}.

Definition octet_stream : t :=
  {|
    name :=
      Cohttp.Accept.MediaType "application" % string "octet-stream" % string;
    q := Some 200;
    pp :=
      fun enc =>
        fun ppf =>
          fun raw =>
            match Data_encoding.Binary.of_bytes enc (Stdlib.Bytes.of_string raw)
              with
            | None =>
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Invalid binary data." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Invalid binary data." % string)
            | Some v =>
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    ";; binary equivalent of the following json" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Flush_newline
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format)))
                  ";; binary equivalent of the following json@.%a" % string)
                Data_encoding.Json.pp (Data_encoding.Json.construct enc v)
            end;
    construct :=
      fun enc =>
        fun v =>
          apply Stdlib.Bytes.to_string (Data_encoding.Binary.to_bytes_exn enc v);
    destruct :=
      fun enc =>
        fun s =>
          match Data_encoding.Binary.of_bytes enc (Stdlib.Bytes.of_string s)
            with
          | None => Stdlib.Error "Failed to parse binary data." % string
          | Some data => Stdlib.Ok data
          end |}.

Definition all_media_types : list t :=
  cons json (cons bson (cons octet_stream [])).

src/lib_shell/bench/bench_simple.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let make_simple blocks =
  let rec loop pred n =
    if n <= 0 then return pred
    else Block.bake pred >>=? fun block -> loop block (n - 1)
  in
  Context.init 5 >>=? fun (genesis, _) -> loop genesis blocks

type args = {blocks : int; accounts : int}

let default_args = {blocks = 1000; accounts = 5}

let set_blocks cf blocks = cf := {!cf with blocks}

let set_accounts cf accounts = cf := {!cf with accounts}

let read_args () =
  let args = ref default_args in
  let specific =
    [ ("--blocks", Arg.Int (set_blocks args), "number of blocks");
      ("--accounts", Arg.Int (set_accounts args), "number of acount") ]
  in
  let usage = "Usage: [--blocks n] [--accounts n] " in
  Arg.parse specific (fun _ -> ()) usage ;
  !args

let () =
  let args = read_args () in
  match Lwt_main.run (make_simple args.blocks) with
  | Ok _head ->
      Format.printf "Success.@." ; exit 0
  | Error err ->
      Format.eprintf "%a@." pp_print_error err ;
      exit 1
src/lib_shell/bench/bench_simple.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition make_simple {A : Type} (blocks : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  let fix loop {B : Type} (pred : B) (n : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
    if OCaml.Stdlib.le n 0 then
      _return pred
    else
      op_gtgteqquestion (op_startypeminuserrorstar pred)
        (fun block => loop block (Z.sub n 1)) in
  op_gtgteqquestion op_startypeminuserrorstar
    (fun function_parameter =>
      let '(genesis, _) := function_parameter in
      loop genesis blocks).

Record args := {
  blocks : Z;
  accounts : Z }.

Definition default_args : args := {| blocks := 1000; accounts := 5 |}.

Definition set_blocks (cf : Stdlib.ref args) (blocks : Z) : unit :=
  Stdlib.op_coloneq cf
    (* ❌ Record substitution not handled *)
    record_substitution.

Definition set_accounts (cf : Stdlib.ref args) (accounts : Z) : unit :=
  Stdlib.op_coloneq cf
    (* ❌ Record substitution not handled *)
    record_substitution.

Definition read_args (function_parameter : unit) : args :=
  let 'tt := function_parameter in
  let args := Stdlib.ref default_args in
  let specific :=
    cons
      ("--blocks" % string, (Stdlib.Arg.Int (set_blocks args)),
        "number of blocks" % string)
      (cons
        ("--accounts" % string, (Stdlib.Arg.Int (set_accounts args)),
          "number of acount" % string) []) in
  let usage := "Usage: [--blocks n] [--accounts n] " % string in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Arg.parse specific
      (fun function_parameter =>
        let '_ := function_parameter in
        tt) usage in
  Stdlib.op_exclamation args.



src/lib_shell/bench/bench_tool.ml 120 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Helpers_Nonce = Nonce
open Protocol
open Parameters_repr
open Constants_repr
open Alpha_context

(** Args *)

type args = {
  mutable length : int;
  mutable seed : int;
  mutable accounts : int;
  mutable nb_commitments : int;
  mutable params : Parameters_repr.t;
}

let default_args =
  {
    length = 100;
    seed = 0;
    accounts = 100;
    nb_commitments = 200;
    params =
      {
        bootstrap_accounts = [];
        commitments = [];
        bootstrap_contracts = [];
        constants = Default_parameters.constants_mainnet;
        security_deposit_ramp_up_cycles = None;
        no_reward_cycles = None;
      };
  }

let debug = ref false

let if_debug k = if !debug then k ()

let if_debug_s k = if !debug then k () else return_unit

let args = default_args

let parse_param_file name =
  if not (Sys.file_exists name) then
    failwith "Parameters : Inexistent JSON file"
  else
    Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name
    >>=? fun json ->
    match Data_encoding.Json.destruct Parameters_repr.encoding json with
    | exception exn ->
        failwith "Parameters : Invalid JSON file - %a" Error_monad.pp_exn exn
    | param ->
        return param

let read_args () =
  let parse_param name =
    parse_param_file name
    >>= (function
          | Ok p ->
              Lwt.return p
          | Error errs ->
              Format.printf
                "Parameters parsing error : %a ==> using default parameters\n\
                 %!"
                Error_monad.pp_print_error
                errs ;
              Lwt.return default_args.params)
    |> Lwt_main.run
  in
  let specific =
    [ ( "--length",
        Arg.Int (fun n -> args.length <- n),
        "Length of the chain (nb of blocks)" );
      ("--seed", Arg.Int (fun n -> args.seed <- n), "Used seed (default 0)");
      ( "--random-commitments",
        Arg.Int (fun n -> args.nb_commitments <- n),
        "Number of randomly generated commitments. Defaults to 200. If less \
         than 0, commitments in protocol parameter files are used." );
      ( "--accounts",
        Arg.Int (fun n -> args.accounts <- n),
        "Number of initial randomly generated accounts. Still adds bootstrap \
         account if present in the parameters file." );
      ( "--parameters",
        Arg.String (fun s -> args.params <- parse_param s),
        "JSON protocol parameters file" );
      ("--debug", Arg.Set debug, "Print more info") ]
  in
  let usage =
    "Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]"
  in
  Arg.parse specific (fun _ -> ()) usage

(** Utils *)

let choose_exp_nat n =
  (* seems fine *)
  let lambda = 1. /. log (float n) in
  let u = Random.float 1. in
  -.log u /. lambda |> int_of_float

let pi = 3.1415926502

let two_pi = 2. *. 3.1415926502

let round x = x +. 0.5 |> int_of_float

let rec choose_gaussian_nat (a, b) =
  assert (b >= a) ;
  let sigma = 4. in
  let mu = ((b - a) / 2) + a |> float in
  let gauss () =
    let u1 = Random.float 1. (* |> fun x -> 1. -. x *) in
    let u2 = Random.float 1. in
    let r = sqrt (-.(2. *. log u1)) in
    let theta = cos (two_pi *. u2) in
    r *. theta
  in
  let z = gauss () in
  let z = (z *. sigma) +. mu |> round in
  if z > a && z < b then z else choose_gaussian_nat (a, b)

let list_shuffle l =
  List.map (fun c -> (Random.bits (), c)) l
  |> List.sort compare |> List.map snd

(******************************************************************)

type gen_state = {
  mutable possible_transfers : (Account.t * Account.t) list;
  mutable remaining_transfers : (Account.t * Account.t) list;
  mutable remaining_activations : (Account.t * Commitment_repr.t) list;
  mutable nonce_to_reveal : (Cycle.t * Raw_level.t * Nonce.t) list;
}

let get_n_endorsements ctxt n =
  Context.get_endorsers ctxt
  >>=? fun endorsing_rights ->
  let endorsing_rights = List.sub endorsing_rights n in
  map_s
    (fun {Delegate_services.Endorsing_rights.delegate; level; _} ->
      Op.endorsement ~delegate ~level ctxt ())
    endorsing_rights

let generate_and_add_random_endorsements inc =
  let pred inc = Incremental.predecessor inc in
  let nb_endorsements =
    let n = args.params.constants.endorsers_per_block in
    n - choose_exp_nat n
  in
  if_debug (fun () ->
      Format.printf
        "[DEBUG] Generating up to %d endorsements...\n%!"
        nb_endorsements) ;
  get_n_endorsements (B (pred inc)) (nb_endorsements - 1)
  >>=? fun endorsements ->
  let compare op1 op2 =
    Operation_hash.compare (Operation.hash op1) (Operation.hash op2)
  in
  let endorsements = List.sort_uniq compare endorsements in
  let endorsements = List.map Operation.pack endorsements in
  fold_left_s Incremental.add_operation inc endorsements

let regenerate_transfers = ref false

let generate_random_activation ({remaining_activations; _} as gen_state) inc =
  regenerate_transfers := true ;
  let open Account in
  match remaining_activations with
  | [] ->
      assert false
  | (({pkh; _} as account), _) :: l ->
      if_debug (fun () ->
          Format.printf "[DEBUG] Generating an activation.\n%!") ;
      gen_state.remaining_activations <- l ;
      add_account account ;
      Op.activation inc pkh Account.commitment_secret

exception No_transfer_left

let rec generate_random_transfer ({remaining_transfers; _} as gen_state) ctxt =
  if remaining_transfers = [] then raise No_transfer_left ;
  let (a1, a2) = List.hd remaining_transfers in
  gen_state.remaining_transfers <- List.tl remaining_transfers ;
  let open Account in
  let c1 = Alpha_context.Contract.implicit_contract a1.pkh in
  let c2 = Alpha_context.Contract.implicit_contract a2.pkh in
  Context.Contract.balance ctxt c1
  >>=? fun b1 ->
  if Tez.(b1 < Tez.one) then generate_random_transfer gen_state ctxt
  else Op.transaction ctxt c1 c2 Tez.one

let generate_random_operation (inc : Incremental.t) gen_state =
  let rnd = Random.int 100 in
  match rnd with
  | x when x < 2 && gen_state.remaining_activations <> [] ->
      generate_random_activation gen_state (I inc)
  | _ ->
      generate_random_transfer gen_state (I inc)

(* Build a random block *)
let step gen_state blk : Block.t tzresult Lwt.t =
  let priority = choose_exp_nat 5 in
  (* let nb_operations_per_block = choose_gaussian_nat (10, List.length (Account.get_known_accounts ())) in *)
  let nb_operations_per_block = choose_gaussian_nat (10, 100) in
  if !regenerate_transfers then (
    let l =
      Signature.Public_key_hash.Table.fold
        (fun _ v acc -> v :: acc)
        Account.known_accounts
        []
    in
    (* TODO : make possible transfer computations efficient.. *)
    gen_state.possible_transfers <-
      List.product l l |> List.filter (fun (a, b) -> a <> b) ;
    regenerate_transfers := false ) ;
  gen_state.remaining_transfers <- list_shuffle gen_state.possible_transfers ;
  let nb_operations =
    min nb_operations_per_block (List.length gen_state.remaining_transfers)
  in
  (* Nonce *)
  Alpha_services.Helpers.current_level ~offset:1l Block.rpc_ctxt blk
  >>|? (function
         | Level.{expected_commitment = true; cycle; level; _} ->
             if_debug (fun () -> Format.printf "[DEBUG] Commiting a nonce\n%!") ;
             let (hash, nonce) = Helpers_Nonce.generate () in
             gen_state.nonce_to_reveal <-
               (cycle, level, nonce) :: gen_state.nonce_to_reveal ;
             Some hash
         | _ ->
             None)
  >>=? fun seed_nonce_hash ->
  Incremental.begin_construction ~priority ?seed_nonce_hash blk
  >>=? fun inc ->
  let open Cycle in
  if_debug (fun () ->
      Format.printf
        "[DEBUG] Generating %d random operations...\n%!"
        nb_operations) ;
  (* Generate random operations *)
  fold_left_s
    (fun inc _ ->
      try
        generate_random_operation inc gen_state
        >>=? fun op -> Incremental.add_operation inc op
      with No_transfer_left -> return inc)
    inc
    (1 -- nb_operations)
  >>=? fun inc ->
  (* Endorsements *)
  generate_and_add_random_endorsements inc
  >>=? fun inc ->
  (* Revelations *)
  (* TODO debug cycle *)
  Alpha_services.Helpers.current_level ~offset:1l Incremental.rpc_ctxt inc
  >>|? (function
         | {cycle; level; _} -> (
             if_debug (fun () ->
                 Format.printf "[DEBUG] Current cycle : %a\n%!" Cycle.pp cycle) ;
             if_debug (fun () ->
                 Format.printf
                   "[DEBUG] Current level : %a\n%!"
                   Raw_level.pp
                   level) ;
             match gen_state.nonce_to_reveal with
             | (pred_cycle, _, _) :: _ as l when succ pred_cycle = cycle ->
                 if_debug (fun () ->
                     Format.printf
                       "[DEBUG] Seed nonce revelation : %d nonces to reveal.\n\
                        %!"
                     @@ List.length l) ;
                 gen_state.nonce_to_reveal <- [] ;
                 (* fold_left_s (fun inc (_, level, nonce) -> *)
                 (* Op.seed_nonce_revelation inc level nonce >>=? fun op ->
                  * Incremental.add_operation inc op *)
                 (* return *)
                 inc
             (* TODO reactivate the seeds *)
             (* ) inc l *)
             | _ ->
                 inc ))
  >>=? fun inc ->
  (* (\* Shuffle the operations a bit (why not) *\)
   * let operations = endorsements @ operations |> list_shuffle in *)
  Incremental.finalize_block inc

let init () =
  Random.init args.seed ;
  let parameters = args.params in
  (* keys randomness is delegated to module Signature's bindings *)
  (* TODO : distribute the tokens randomly *)
  (* Right now, we split half of 80.000 rolls between generated accounts *)
  (* TODO : ensure we don't overflow with the underlying commitments *)
  Tez_repr.(
    Lwt.return @@ Environment.wrap_error
    @@ args.params.Parameters_repr.constants.Constants_repr.tokens_per_roll
       *? 80_000L
    >>=? fun total_amount ->
    Lwt.return @@ Environment.wrap_error @@ (total_amount /? 2L)
    >>=? fun amount ->
    Lwt.return @@ Environment.wrap_error
    @@ (amount /? Int64.of_int args.accounts))
  >>=? fun initial_amount ->
  (* Ensure a deterministic run *)
  let new_seed () : Bytes.t =
    Bytes.(make 32 '\000' |> map (fun _ -> Random.int 0x100 |> char_of_int))
  in
  map_s
    (fun _ ->
      return (Account.new_account ~seed:(new_seed ()) (), initial_amount))
    (1 -- args.accounts)
  >>=? fun initial_accounts ->
  if_debug (fun () ->
      List.iter
        (fun (Account.{pkh; _}, _) ->
          Format.printf
            "[DEBUG] Account %a created\n%!"
            Signature.Public_key_hash.pp_short
            pkh)
        initial_accounts) ;
  let possible_transfers =
    let l = List.map fst initial_accounts in
    List.product l l |> List.filter (fun (a, b) -> a <> b)
  in
  ( match args.nb_commitments with
  | x when x < 0 ->
      return ([], parameters)
  | x ->
      map_s (fun _ -> Account.new_commitment ~seed:(new_seed ()) ()) (1 -- x)
      >>=? fun commitments ->
      return
        (commitments, {parameters with commitments = List.map snd commitments})
  )
  >>=? fun ( remaining_activations,
             { bootstrap_accounts = _;
               commitments;
               constants;
               security_deposit_ramp_up_cycles;
               no_reward_cycles;
               _ } ) ->
  let gen_state =
    {
      possible_transfers;
      remaining_transfers = [];
      nonce_to_reveal = [];
      remaining_activations;
    }
  in
  let bootstrap_accounts =
    List.map
      (fun (Account.{pk; pkh; _}, amount) ->
        Default_parameters.make_bootstrap_account (pkh, pk, amount))
      initial_accounts
  in
  let parameters =
    {
      Parameters_repr.bootstrap_accounts;
      bootstrap_contracts = [];
      commitments;
      constants;
      security_deposit_ramp_up_cycles;
      no_reward_cycles;
    }
  in
  Block.genesis_with_parameters parameters
  >>=? fun genesis ->
  if_debug_s (fun () ->
      iter_s
        (let open Account in
        fun (({pkh; _} as acc), _) ->
          let contract = Alpha_context.Contract.implicit_contract acc.pkh in
          Context.Contract.manager (B genesis) contract
          >>=? fun {pkh = pkh'; _} ->
          Context.Contract.balance (B genesis) contract
          >>=? fun balance ->
          return
          @@ Format.printf
               "[DEBUG] %a's manager is %a with a balance of %a\n%!"
               Signature.Public_key_hash.pp_short
               pkh
               Signature.Public_key_hash.pp_short
               pkh'
               Tez.pp
               balance)
        initial_accounts)
  >>=? fun () ->
  if_debug (fun () ->
      Format.printf
        "[DEBUG] Constants : %a\n%!"
        Data_encoding.Json.pp
        (Data_encoding.Json.construct
           Constants_repr.parametric_encoding
           parameters.Parameters_repr.constants)) ;
  let print_block block =
    let open Block in
    Format.printf
      "@[%6i %s@]\n%!"
      (Int32.to_int block.header.shell.level)
      (Block_hash.to_b58check block.hash)
  in
  Format.printf
    "@[<v 2>Starting generation with :@ @[length    = %d@]@ @[seed      = \
     %d@]@ @[nb_commi. = %d@]@ @[#accounts = %d@]@ @]@."
    args.length
    args.seed
    args.nb_commitments
    args.accounts ;
  let rec loop gen_state blk = function
    | 0 ->
        return (gen_state, blk)
    | n ->
        print_block blk ;
        step gen_state blk >>=? fun blk' -> loop gen_state blk' (n - 1)
  in
  return (loop gen_state genesis args.length)

let () =
  Lwt_main.run (read_args () ; init ())
  |> function
  | Ok _head ->
      Format.printf "Success.@." ; exit 0
  | Error err ->
      Format.eprintf "%a@." pp_print_error err ;
      exit 1
src/lib_shell/bench/bench_tool.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of module is not handled. *)
unhandled_module

Import Protocol.

Definition default_args {A : Type} : A := op_startypeminuserrorstar.

Definition debug : Stdlib.ref bool := Stdlib.ref false.

Definition if_debug (k : unit -> unit) : unit :=
  if Stdlib.op_exclamation debug then
    k tt
  else
    tt.

Definition if_debug_s
  (k : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if Stdlib.op_exclamation debug then
    k tt
  else
    return_unit.

Definition args {A : Type} : A := default_args.

Definition parse_param_file {A : Type} (name : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  if negb (Sys.file_exists name) then
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Parameters : Inexistent JSON file" % string
          CamlinternalFormatBasics.End_of_format)
        "Parameters : Inexistent JSON file" % string)
  else
    op_gtgteqquestion (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file name)
      (fun json =>
        let 'param := Data_encoding.Json.destruct op_startypeminuserrorstar json
          in
        _return param).

Definition read_args (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let parse_param {A : Type} (name : string) : A :=
    OCaml.Stdlib.reverse_apply
      (op_gtgteq (parse_param_file name)
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok p => Lwt._return p
          | Stdlib.Error errs =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Format.printf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Parameters parsing error : " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        " ==> using default parameters
" % string
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format))))
                  "Parameters parsing error : %a ==> using default parameters
%!"
                    % string) Error_monad.pp_print_error errs in
            Lwt._return (params default_args)
          end)) Lwt_main.run in
  let specific :=
    cons
      ("--length" % string,
        (Stdlib.Arg.Int
          (fun n =>
            (* ❌ Set record field not handled. *)
            set_record_field args "" % string n)),
        "Length of the chain (nb of blocks)" % string)
      (cons
        ("--seed" % string,
          (Stdlib.Arg.Int
            (fun n =>
              (* ❌ Set record field not handled. *)
              set_record_field args "" % string n)),
          "Used seed (default 0)" % string)
        (cons
          ("--random-commitments" % string,
            (Stdlib.Arg.Int
              (fun n =>
                (* ❌ Set record field not handled. *)
                set_record_field args "" % string n)),
            "Number of randomly generated commitments. Defaults to 200. If less than 0, commitments in protocol parameter files are used."
              % string)
          (cons
            ("--accounts" % string,
              (Stdlib.Arg.Int
                (fun n =>
                  (* ❌ Set record field not handled. *)
                  set_record_field args "" % string n)),
              "Number of initial randomly generated accounts. Still adds bootstrap account if present in the parameters file."
                % string)
            (cons
              ("--parameters" % string,
                (Stdlib.Arg.String
                  (fun s =>
                    (* ❌ Set record field not handled. *)
                    set_record_field args "" % string (parse_param s))),
                "JSON protocol parameters file" % string)
              (cons
                ("--debug" % string, (Stdlib.Arg.Set debug),
                  "Print more info" % string) []))))) in
  let usage :=
    "Usage: [--length n] [--seed n] [--accounts n] [--parameters json_file]" %
      string in
  Arg.parse specific
    (fun function_parameter =>
      let '_ := function_parameter in
      tt) usage.

Definition choose_exp_nat (n : Z) : Z :=
  let lambda :=
    Stdlib.op_divpoint
      (* ❌ Float constant 1. is approximated by the integer 1 *)
      1 (Stdlib.log (Stdlib.float n)) in
  let u :=
    Random.float
      (* ❌ Float constant 1. is approximated by the integer 1 *)
      1 in
  OCaml.Stdlib.reverse_apply
    (Stdlib.op_divpoint (Stdlib.op_tildeminuspoint (Stdlib.log u)) lambda)
    Stdlib.int_of_float.

Definition pi : Z :=
  (* ❌ Float constant 3.1415926502 is approximated by the integer 3 *)
  3.

Definition two_pi : Z :=
  Stdlib.op_starpoint
    (* ❌ Float constant 2. is approximated by the integer 2 *)
    2
    (* ❌ Float constant 3.1415926502 is approximated by the integer 3 *)
    3.

Definition round (x : Z) : Z :=
  OCaml.Stdlib.reverse_apply
    (Stdlib.op_pluspoint x
      (* ❌ Float constant 0.5 is approximated by the integer 0 *)
      0) Stdlib.int_of_float.

Fixpoint choose_gaussian_nat
  (function_parameter :
    Tezos_base__TzPervasives.Protocol.t * Tezos_base__TzPervasives.Protocol.t)
  : Z :=
  let '(a, b) := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (op_gteq b a) in
  let sigma :=
    (* ❌ Float constant 4. is approximated by the integer 4 *)
    4 in
  let mu :=
    OCaml.Stdlib.reverse_apply
      (Z.add
        (Z.div (Z.sub op_startypeminuserrorstar op_startypeminuserrorstar) 2)
        op_startypeminuserrorstar) Stdlib.float in
  let gauss (function_parameter : unit) : Z :=
    let 'tt := function_parameter in
    let u1 :=
      Random.float
        (* ❌ Float constant 1. is approximated by the integer 1 *)
        1 in
    let u2 :=
      Random.float
        (* ❌ Float constant 1. is approximated by the integer 1 *)
        1 in
    let r :=
      Stdlib.sqrt
        (Stdlib.op_tildeminuspoint
          (Stdlib.op_starpoint
            (* ❌ Float constant 2. is approximated by the integer 2 *)
            2 (Stdlib.log u1))) in
    let theta := Stdlib.cos (Stdlib.op_starpoint two_pi u2) in
    Stdlib.op_starpoint r theta in
  let z := gauss tt in
  let z :=
    OCaml.Stdlib.reverse_apply
      (Stdlib.op_pluspoint (Stdlib.op_starpoint z sigma) mu) round in
  if
    andb (op_gt op_startypeminuserrorstar a) (op_lt op_startypeminuserrorstar b)
    then
    z
  else
    choose_gaussian_nat (a, b).

Definition list_shuffle {A B : Type} (l : list A) : list B :=
  OCaml.Stdlib.reverse_apply op_startypeminuserrorstar (List.map snd).

Definition get_n_endorsements {A B : Type} (ctxt : A) (n : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (list B)) :=
  op_gtgteqquestion (op_startypeminuserrorstar ctxt)
    (fun endorsing_rights =>
      let endorsing_rights := List.sub endorsing_rights n in
      map_s
        (fun function_parameter =>
          let '_ := function_parameter in
          op_startypeminuserrorstar op_startypeminuserrorstar
            op_startypeminuserrorstar ctxt tt) endorsing_rights).

Definition generate_and_add_random_endorsements {A : Type} (inc : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  let pred {B C : Type} (inc : B) : C :=
    op_startypeminuserrorstar inc in
  let nb_endorsements :=
    let n := endorsers_per_block (constants (params args)) in
    Z.sub n (choose_exp_nat n) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if_debug
      (fun function_parameter =>
        let 'tt := function_parameter in
        Format.printf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "[DEBUG] Generating up to " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  " endorsements...
" % string
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format))))
            "[DEBUG] Generating up to %d endorsements...
%!" % string)
          nb_endorsements) in
  op_gtgteqquestion
    (get_n_endorsements op_startypeminuserrorstar (Z.sub nb_endorsements 1))
    (fun endorsements =>
      let compare
        (op1 : Tezos_base__TzPervasives.Operation.t) (op2 :
        Tezos_base__TzPervasives.Operation.t) : Z :=
        Operation_hash.compare (Operation.hash op1) (Operation.hash op2) in
      let endorsements := List.sort_uniq compare endorsements in
      let endorsements := List.map op_startypeminuserrorstar endorsements in
      fold_left_s op_startypeminuserrorstar inc endorsements).

Definition regenerate_transfers : Stdlib.ref bool := Stdlib.ref false.

Definition generate_random_activation {A B C : Type} (function_parameter : A)
  : B -> C :=
  let '_ := function_parameter in
  fun inc =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.op_coloneq regenerate_transfers true in
    op_startypeminuserrorstar.

(* ❌ The definition of exceptions is not handled. *)
exception

Fixpoint generate_random_transfer {A B C : Type} (function_parameter : A)
  : B -> C :=
  let '_ := function_parameter in
  fun ctxt =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if op_eq op_startypeminuserrorstar op_startypeminuserrorstar then
        Stdlib.raise No_transfer_left
      else
        tt in
    let '(a1, a2) := List.hd op_startypeminuserrorstar in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field op_startypeminuserrorstar "" % string
        (List.tl op_startypeminuserrorstar) in
    op_startypeminuserrorstar.

Definition generate_random_operation {A B C : Type} (function_parameter : A)
  : B -> C :=
  let '_ := function_parameter in
  fun gen_state =>
    let rnd := Random.int 100 in
    match rnd with
    | x => generate_random_activation gen_state op_startypeminuserrorstar
    | _ => generate_random_transfer gen_state op_startypeminuserrorstar
    end.

Definition step {A B : Type} (gen_state : A) (blk : B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) := op_startypeminuserrorstar.

Definition init {A B : Type} (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Lwt.t (Tezos_base__TzPervasives.tzresult (A * B)))) :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Random.init (seed args) in
  let parameters := params args in
  op_gtgteqquestion op_startypeminuserrorstar
    (fun initial_amount =>
      let new_seed (function_parameter : unit) : Stdlib.Bytes.t :=
        let 'tt := function_parameter in
        OCaml.Stdlib.reverse_apply (Stdlib.Bytes.make 32 "000" % char)
          (Stdlib.Bytes.map
            (fun function_parameter =>
              let '_ := function_parameter in
              OCaml.Stdlib.reverse_apply (Random.int 256)
                OCaml.Stdlib.char_of_int)) in
      op_gtgteqquestion
        (map_s
          (fun function_parameter =>
            let '_ := function_parameter in
            _return
              ((op_startypeminuserrorstar (new_seed tt) tt), initial_amount))
          (op_minusminus 1 (accounts args)))
        (fun initial_accounts =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if_debug
              (fun function_parameter =>
                let 'tt := function_parameter in
                List.iter
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Format.printf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "[DEBUG] Account " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " created
" % string
                              (CamlinternalFormatBasics.Flush
                                CamlinternalFormatBasics.End_of_format))))
                        "[DEBUG] Account %a created
%!" % string)
                      Signature.Public_key_hash.pp_short
                      op_startypeminuserrorstar) initial_accounts) in
          let possible_transfers :=
            let l := List.map fst initial_accounts in
            OCaml.Stdlib.reverse_apply (List.product l l)
              (List.filter
                (fun function_parameter =>
                  let '(a, b) := function_parameter in
                  op_ltgt a b)) in
          op_gtgteqquestion
            match nb_commitments args with
            | x => _return ([], parameters)
            | x =>
              op_gtgteqquestion
                (map_s
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    op_startypeminuserrorstar (new_seed tt) tt)
                  (op_minusminus 1 x))
                (fun commitments =>
                  _return (commitments, op_startypeminuserrorstar))
            end
            (fun function_parameter =>
              let '_ := function_parameter in
              let gen_state := op_startypeminuserrorstar in
              let bootstrap_accounts :=
                List.map
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    op_startypeminuserrorstar
                      (op_startypeminuserrorstar, op_startypeminuserrorstar,
                        op_startypeminuserrorstar)) initial_accounts in
              let parameters := op_startypeminuserrorstar in
              op_gtgteqquestion (op_startypeminuserrorstar parameters)
                (fun genesis =>
                  op_gtgteqquestion
                    (if_debug_s
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        iter_s op_startypeminuserrorstar initial_accounts))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        if_debug
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            Format.printf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "[DEBUG] Constants : " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "010" % char
                                      (CamlinternalFormatBasics.Flush
                                        CamlinternalFormatBasics.End_of_format))))
                                "[DEBUG] Constants : %a
%!" % string)
                              Data_encoding.Json.pp
                              (Data_encoding.Json.construct
                                op_startypeminuserrorstar
                                (Parameters_repr.constants parameters))) in
                      let print_block {C D : Type} (block : C) : D :=
                        op_startypeminuserrorstar in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Format.printf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<v 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<v 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Starting generation with :" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        CamlinternalFormatBasics.End_of_format
                                        "" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "length    = " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_box
                                                (CamlinternalFormatBasics.Format
                                                  CamlinternalFormatBasics.End_of_format
                                                  "" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "seed      = " % string
                                                (CamlinternalFormatBasics.Int
                                                  CamlinternalFormatBasics.Int_d
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.No_precision
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@ " % string 1 0)
                                                      (CamlinternalFormatBasics.Formatting_gen
                                                        (CamlinternalFormatBasics.Open_box
                                                          (CamlinternalFormatBasics.Format
                                                            CamlinternalFormatBasics.End_of_format
                                                            "" % string))
                                                        (CamlinternalFormatBasics.String_literal
                                                          "nb_commi. = " %
                                                            string
                                                          (CamlinternalFormatBasics.Int
                                                            CamlinternalFormatBasics.Int_d
                                                            CamlinternalFormatBasics.No_padding
                                                            CamlinternalFormatBasics.No_precision
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Close_box
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@ " % string
                                                                  1 0)
                                                                (CamlinternalFormatBasics.Formatting_gen
                                                                  (CamlinternalFormatBasics.Open_box
                                                                    (CamlinternalFormatBasics.Format
                                                                      CamlinternalFormatBasics.End_of_format
                                                                      "" %
                                                                        string))
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "#accounts = "
                                                                      % string
                                                                    (CamlinternalFormatBasics.Int
                                                                      CamlinternalFormatBasics.Int_d
                                                                      CamlinternalFormatBasics.No_padding
                                                                      CamlinternalFormatBasics.No_precision
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Close_box
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          (CamlinternalFormatBasics.Break
                                                                            "@ "
                                                                              %
                                                                              string
                                                                            1 0)
                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                            CamlinternalFormatBasics.Close_box
                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                              CamlinternalFormatBasics.Flush_newline
                                                                              CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))
                            "@[<v 2>Starting generation with :@ @[length    = %d@]@ @[seed      = %d@]@ @[nb_commi. = %d@]@ @[#accounts = %d@]@ @]@."
                              % string) (length args) (seed args)
                          (nb_commitments args) (accounts args) in
                      let fix loop
                        (gen_state : A) (blk : B) (function_parameter : Z)
                        : Lwt.t (Tezos_base__TzPervasives.tzresult (A * B)) :=
                        match function_parameter with
                        | 0 => _return (gen_state, blk)
                        | n =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ := print_block blk in
                          op_gtgteqquestion (step gen_state blk)
                            (fun blk' => loop gen_state blk' (Z.sub n 1))
                        end in
                      _return (loop gen_state genesis (length args))))))).



src/lib_shell/block_directory.ml 167 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rec read_partial_context context path depth =
  (* non tail-recursive *)
  if depth = 0 then Lwt.return Block_services.Cut
  else
    (* try to read as file *)
    Context.get context path
    >>= function
    | Some v ->
        Lwt.return (Block_services.Key v)
    | None ->
        (* try to read as directory *)
        Context.fold context path ~init:[] ~f:(fun k acc ->
            match k with
            | `Key k | `Dir k ->
                read_partial_context context k (depth - 1)
                >>= fun v ->
                let k = List.nth k (List.length k - 1) in
                Lwt.return ((k, v) :: acc))
        >>= fun l -> Lwt.return (Block_services.Dir (List.rev l))

let build_raw_header_rpc_directory (module Proto : Block_services.PROTO) =
  let dir : (State.Chain.t * Block_hash.t * Block_header.t) RPC_directory.t ref
      =
    ref RPC_directory.empty
  in
  let register0 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst0 s) (fun block p q ->
          f block p q)
  in
  let module Block_services = Block_services.Make (Proto) (Proto) in
  let module S = Block_services.S in
  register0 S.hash (fun (_, hash, _) () () -> return hash) ;
  (* block header *)
  register0 S.header (fun (chain_state, hash, header) () () ->
      let protocol_data =
        Data_encoding.Binary.of_bytes_exn
          Proto.block_header_data_encoding
          header.protocol_data
      in
      return
        {
          Block_services.hash;
          chain_id = State.Chain.id chain_state;
          shell = header.shell;
          protocol_data;
        }) ;
  register0 S.raw_header (fun (_, _, header) () () ->
      return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header)) ;
  register0 S.Header.shell_header (fun (_, _, header) () () ->
      return header.shell) ;
  register0 S.Header.protocol_data (fun (_, _, header) () () ->
      return
        (Data_encoding.Binary.of_bytes_exn
           Proto.block_header_data_encoding
           header.protocol_data)) ;
  register0 S.Header.raw_protocol_data (fun (_, _, header) () () ->
      return header.protocol_data) ;
  (* helpers *)
  register0 S.Helpers.Forge.block_header (fun _block () header ->
      return (Data_encoding.Binary.to_bytes_exn Block_header.encoding header)) ;
  (* protocols *)
  register0 S.protocols (fun (chain_state, _hash, header) () () ->
      State.Chain.get_level_indexed_protocol chain_state header
      >>= fun next_protocol_hash ->
      State.Block.header_of_hash chain_state header.shell.predecessor
      >>= function
      | None ->
          return
            {
              Tezos_shell_services.Block_services.current_protocol =
                next_protocol_hash;
              next_protocol = next_protocol_hash;
            }
      | Some pred_header ->
          State.Chain.get_level_indexed_protocol chain_state pred_header
          >>= fun protocol_hash ->
          return
            {
              Tezos_shell_services.Block_services.current_protocol =
                protocol_hash;
              next_protocol = next_protocol_hash;
            }) ;
  !dir

let build_raw_rpc_directory (module Proto : Block_services.PROTO)
    (module Next_proto : Registered_protocol.T) =
  let dir : State.Block.block RPC_directory.t ref = ref RPC_directory.empty in
  let merge d = dir := RPC_directory.merge d !dir in
  let register0 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst0 s) (fun block p q ->
          f block p q)
  in
  let register1 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst1 s) (fun (block, a) p q ->
          f block a p q)
  in
  let register2 s f =
    dir :=
      RPC_directory.register
        !dir
        (RPC_service.subst2 s)
        (fun ((block, a), b) p q -> f block a b p q)
  in
  let module Block_services = Block_services.Make (Proto) (Next_proto) in
  let module S = Block_services.S in
  register0 S.live_blocks (fun block () () ->
      State.Block.max_operations_ttl block
      >>=? fun max_op_ttl ->
      Chain_traversal.live_blocks block max_op_ttl
      >>=? fun (live_blocks, _) -> return live_blocks) ;
  (* block metadata *)
  let metadata block =
    State.Block.metadata block
    >>=? fun metadata ->
    let protocol_data =
      Data_encoding.Binary.of_bytes_exn
        Proto.block_header_metadata_encoding
        metadata
    in
    State.Block.test_chain block
    >>= fun (test_chain_status, _) ->
    State.Block.max_operations_ttl block
    >>=? fun max_operations_ttl ->
    return
      {
        Block_services.protocol_data;
        test_chain_status;
        max_operations_ttl;
        max_operation_data_length = Next_proto.max_operation_data_length;
        max_block_header_length = Next_proto.max_block_length;
        operation_list_quota =
          List.map
            (fun {Tezos_protocol_environment.max_size; max_op} ->
              {Tezos_shell_services.Block_services.max_size; max_op})
            Next_proto.validation_passes;
      }
  in
  register0 S.metadata (fun block () () -> metadata block) ;
  (* operations *)
  let convert chain_id (op : Operation.t) metadata : Block_services.operation =
    let protocol_data =
      Data_encoding.Binary.of_bytes_exn Proto.operation_data_encoding op.proto
    in
    let receipt =
      Data_encoding.Binary.of_bytes_exn
        Proto.operation_receipt_encoding
        metadata
    in
    {
      Block_services.chain_id;
      hash = Operation.hash op;
      shell = op.shell;
      protocol_data;
      receipt;
    }
  in
  let operations block =
    State.Block.all_operations block
    >>= fun ops ->
    State.Block.all_operations_metadata block
    >>= fun metadata ->
    let chain_id = State.Block.chain_id block in
    return (List.map2 (List.map2 (convert chain_id)) ops metadata)
  in
  register0 S.Operations.operations (fun block () () -> operations block) ;
  register1 S.Operations.operations_in_pass (fun block i () () ->
      let chain_id = State.Block.chain_id block in
      try
        State.Block.operations block i
        >>= fun (ops, _path) ->
        State.Block.operations_metadata block i
        >>= fun metadata -> return (List.map2 (convert chain_id) ops metadata)
      with _ -> Lwt.fail Not_found) ;
  register2 S.Operations.operation (fun block i j () () ->
      let chain_id = State.Block.chain_id block in
      ( try
          State.Block.operations block i
          >>= fun (ops, _path) ->
          State.Block.operations_metadata block i
          >>= fun metadata -> Lwt.return (List.nth ops j, List.nth metadata j)
        with _ -> Lwt.fail Not_found )
      >>= fun (op, md) -> return (convert chain_id op md)) ;
  (* operation_hashes *)
  register0 S.Operation_hashes.operation_hashes (fun block () () ->
      State.Block.all_operation_hashes block >>= return) ;
  register1 S.Operation_hashes.operation_hashes_in_pass (fun block i () () ->
      State.Block.operation_hashes block i >>= fun (ops, _) -> return ops) ;
  register2 S.Operation_hashes.operation_hash (fun block i j () () ->
      ( try
          State.Block.operation_hashes block i
          >>= fun (ops, _) -> Lwt.return (List.nth ops j)
        with _ -> Lwt.fail Not_found )
      >>= fun op -> return op) ;
  (* context *)
  register1 S.Context.read (fun block path q () ->
      let depth = Option.unopt ~default:max_int q#depth in
      fail_unless
        (depth >= 0)
        (Tezos_shell_services.Block_services.Invalid_depth_arg depth)
      >>=? fun () ->
      State.Block.context_exn block
      >>= fun context ->
      Context.mem context path
      >>= fun mem ->
      Context.dir_mem context path
      >>= fun dir_mem ->
      if not (mem || dir_mem) then Lwt.fail Not_found
      else read_partial_context context path depth >>= fun dir -> return dir) ;
  (* info *)
  register0 S.info (fun block () () ->
      let chain_id = State.Block.chain_id block in
      let hash = State.Block.hash block in
      let header = State.Block.header block in
      let shell = header.shell in
      let protocol_data =
        Data_encoding.Binary.of_bytes_exn
          Proto.block_header_data_encoding
          header.protocol_data
      in
      metadata block
      >>=? fun metadata ->
      operations block
      >>=? fun operations ->
      return
        {
          Block_services.hash;
          chain_id;
          header = {shell; protocol_data};
          metadata;
          operations;
        }) ;
  (* helpers *)
  register0 S.Helpers.Preapply.block (fun block q p ->
      let timestamp =
        match q#timestamp with
        | None ->
            Time.System.to_protocol (Systime_os.now ())
        | Some time ->
            time
      in
      let protocol_data =
        Data_encoding.Binary.to_bytes_exn
          Next_proto.block_header_data_encoding
          p.protocol_data
      in
      let operations =
        List.map
          (List.map (fun op ->
               let proto =
                 Data_encoding.Binary.to_bytes_exn
                   Next_proto.operation_data_encoding
                   op.Next_proto.protocol_data
               in
               {Operation.shell = op.shell; proto}))
          p.operations
      in
      Prevalidation.preapply
        ~predecessor:block
        ~timestamp
        ~protocol_data
        operations) ;
  register0 S.Helpers.Preapply.operations (fun block () ops ->
      State.Block.context_exn block
      >>= fun ctxt ->
      let predecessor = State.Block.hash block in
      let header = State.Block.shell_header block in
      let predecessor_context = Shell_context.wrap_disk_context ctxt in
      Next_proto.begin_construction
        ~chain_id:(State.Block.chain_id block)
        ~predecessor_context
        ~predecessor_timestamp:header.timestamp
        ~predecessor_level:header.level
        ~predecessor_fitness:header.fitness
        ~predecessor
        ~timestamp:(Time.System.to_protocol (Systime_os.now ()))
        ()
      >>=? fun state ->
      fold_left_s
        (fun (state, acc) op ->
          Next_proto.apply_operation state op
          >>=? fun (state, result) ->
          return (state, (op.protocol_data, result) :: acc))
        (state, [])
        ops
      >>=? fun (state, acc) ->
      Next_proto.finalize_block state >>=? fun _ -> return (List.rev acc)) ;
  register1 S.Helpers.complete (fun block prefix () () ->
      State.Block.context_exn block
      >>= fun ctxt ->
      Base58.complete prefix
      >>= fun l1 ->
      let ctxt = Shell_context.wrap_disk_context ctxt in
      Next_proto.complete_b58prefix ctxt prefix >>= fun l2 -> return (l1 @ l2)) ;
  (* merge protocol rpcs... *)
  merge
    (RPC_directory.map
       (fun block ->
         let chain_state = State.Block.chain_state block in
         let hash = State.Block.hash block in
         let header = State.Block.header block in
         Lwt.return (chain_state, hash, header))
       (build_raw_header_rpc_directory (module Proto))) ;
  merge
    (RPC_directory.map
       (fun block ->
         State.Block.context_exn block
         >|= fun context ->
         let context = Shell_context.wrap_disk_context context in
         {
           Tezos_protocol_environment.block_hash = State.Block.hash block;
           block_header = State.Block.shell_header block;
           context;
         })
       Next_proto.rpc_services) ;
  !dir

let get_protocol hash =
  match Registered_protocol.get hash with
  | None ->
      raise Not_found
  | Some protocol ->
      protocol

let get_directory chain_state block =
  State.Block.get_rpc_directory block
  >>= function
  | Some dir ->
      Lwt.return dir
  | None -> (
      State.Block.protocol_hash_exn block
      >>= fun next_protocol_hash ->
      let next_protocol = get_protocol next_protocol_hash in
      State.Block.predecessor block
      >>= function
      | None ->
          Lwt.return
            (build_raw_rpc_directory
               (module Block_services.Fake_protocol)
               next_protocol)
      | Some pred -> (
          State.Chain.save_point chain_state
          >>= fun (save_point_level, _) ->
          ( if Compare.Int32.(State.Block.level pred < save_point_level) then
            State.Chain.get_level_indexed_protocol
              chain_state
              (State.Block.header pred)
          else State.Block.protocol_hash_exn pred )
          >>= fun protocol_hash ->
          let (module Proto) = get_protocol protocol_hash in
          State.Block.get_rpc_directory block
          >>= function
          | Some dir ->
              Lwt.return dir
          | None ->
              let dir = build_raw_rpc_directory (module Proto) next_protocol in
              State.Block.set_rpc_directory block dir
              >>= fun () -> Lwt.return dir ) )

let get_header_directory chain_state header =
  State.Block.header_of_hash chain_state header.Block_header.shell.predecessor
  >>= function
  | None ->
      (* should not happen *)
      Lwt.fail Not_found
  | Some pred -> (
      State.Chain.get_level_indexed_protocol chain_state pred
      >>= fun protocol_hash ->
      let (module Proto) = get_protocol protocol_hash in
      State.Block.get_header_rpc_directory chain_state header
      >>= function
      | Some dir ->
          Lwt.return dir
      | None ->
          let dir = build_raw_header_rpc_directory (module Proto) in
          State.Block.set_header_rpc_directory chain_state header dir
          >>= fun () -> Lwt.return dir )

let get_block chain_state = function
  | `Genesis ->
      Chain.genesis chain_state >>= fun genesis -> Lwt.return_some genesis
  | `Head n ->
      Chain.head chain_state
      >>= fun head ->
      if n < 0 then Lwt.return_none
      else if n = 0 then Lwt.return_some head
      else
        State.Block.read_predecessor
          chain_state
          ~pred:n
          ~below_save_point:true
          (State.Block.hash head)
  | (`Alias (_, n) | `Hash (_, n)) as b ->
      ( match b with
      | `Alias (`Checkpoint, _) ->
          State.Chain.checkpoint chain_state
          >>= fun checkpoint -> Lwt.return (Block_header.hash checkpoint)
      | `Alias (`Save_point, _) ->
          State.Chain.save_point chain_state
          >>= fun (_, save_point) -> Lwt.return save_point
      | `Alias (`Caboose, _) ->
          State.Chain.caboose chain_state
          >>= fun (_, caboose) -> Lwt.return caboose
      | `Hash (h, _) ->
          Lwt.return h )
      >>= fun hash ->
      if n < 0 then
        State.Block.read_opt chain_state hash
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun block ->
        Chain.head chain_state
        >>= fun head ->
        let head_level = State.Block.level head in
        let block_level = State.Block.level block in
        let target =
          Int32.(to_int (sub head_level (sub block_level (of_int n))))
        in
        if target < 0 then Lwt.return_none
        else
          State.Block.read_predecessor
            chain_state
            ~pred:target
            ~below_save_point:true
            (State.Block.hash head)
      else if n = 0 then
        Chain.genesis chain_state
        >>= fun genesis ->
        let genesis_hash = State.Block.hash genesis in
        if Block_hash.equal hash genesis_hash then Lwt.return_some genesis
        else
          State.Block.read_predecessor
            chain_state
            ~pred:0
            ~below_save_point:true
            hash
      else
        State.Block.read_predecessor
          chain_state
          ~pred:n
          ~below_save_point:true
          hash
  | `Level i ->
      Chain.head chain_state
      >>= fun head ->
      let target = Int32.(to_int (sub (State.Block.level head) i)) in
      if target < 0 then Lwt.fail Not_found
      else
        State.Block.read_predecessor
          chain_state
          ~pred:target
          ~below_save_point:true
          (State.Block.hash head)

let build_rpc_directory chain_state block =
  get_block chain_state block
  >>= function
  | None ->
      Lwt.fail Not_found
  | Some b ->
      State.Chain.save_point chain_state
      >>= fun (save_point_level, _) ->
      let block_level = State.Block.level b in
      let block_hash = State.Block.hash b in
      let genesis = State.Chain.genesis chain_state in
      if
        block_level >= save_point_level
        || Block_hash.equal block_hash genesis.block
      then
        get_directory chain_state b
        >>= fun dir ->
        Lwt.return (RPC_directory.map (fun _ -> Lwt.return b) dir)
      else
        let header = State.Block.header b in
        let hash = State.Block.hash b in
        get_header_directory chain_state header
        >>= fun dir ->
        Lwt.return
          (RPC_directory.map
             (fun _ -> Lwt.return (chain_state, hash, header))
             dir)
src/lib_shell/block_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint read_partial_context
  (context : Tezos_storage.Context.context) (path : Tezos_storage.Context.key)
  (depth : Z) : Lwt.t Tezos_shell_services.Block_services.raw_context :=
  if equiv_decb depth 0 then
    Lwt._return Tezos_shell_services.Block_services.Cut
  else
    op_gtgteq (Context.get context path)
      (fun function_parameter =>
        match function_parameter with
        | Some v => Lwt._return (Tezos_shell_services.Block_services.Key v)
        | None =>
          op_gtgteq
            (Context.fold context path []
              (fun k =>
                fun acc =>
                  let 'Key k | Dir k := k in
                  op_gtgteq (read_partial_context context k (Z.sub depth 1))
                    (fun v =>
                      let k := List.nth k (Z.sub (List.length k) 1) in
                      Lwt._return (cons (k, v) acc))))
            (fun l =>
              Lwt._return (Tezos_shell_services.Block_services.Dir (List.rev l)))
        end).

Definition build_raw_header_rpc_directory
  (Proto :
    {'(block_header_data, block_header_metadata, operation_data,
      operation_receipt, operation) : _ &
      Tezos_shell_services.Block_services.PROTO.signature block_header_data
        block_header_metadata operation_data operation_receipt operation})
  : Tezos_base__TzPervasives.RPC_directory.t
    (Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t) :=
  let Proto := projT2 Proto in
  let dir := Stdlib.ref RPC_directory.empty in
  let register0 {A B C D : Type}
    (s :
    Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
      Tezos_rpc.RPC_service.error) (f :
    (Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t) ->
      B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) (RPC_service.subst0 s)
        (fun block => fun p => fun q => f block p q)) in
  let Block_services :=
    (* ❌ Applications of functors are not supported for first-class module values *)
    unsupported_functor_application in
  let S := Block_services.S in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.hash
      (fun function_parameter =>
        let '(_, hash, _) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            _return hash) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.header
      (fun function_parameter =>
        let '(chain_state, hash, header) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            let protocol_data :=
              Data_encoding.Binary.of_bytes_exn
                Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
                (protocol_data header) in
            _return
              {| Block_services.chain_id := State.Chain.id chain_state;
                Block_services.hash := hash;
                Block_services.shell := shell header;
                Block_services.protocol_data := protocol_data |}) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.raw_header
      (fun function_parameter =>
        let '(_, _, header) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            _return
              (Data_encoding.Binary.to_bytes_exn Block_header.encoding header))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.Header.shell_header
      (fun function_parameter =>
        let '(_, _, header) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            _return (shell header)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.Header.protocol_data
      (fun function_parameter =>
        let '(_, _, header) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            _return
              (Data_encoding.Binary.of_bytes_exn
                Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
                (protocol_data header))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.Header.raw_protocol_data
      (fun function_parameter =>
        let '(_, _, header) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            _return (protocol_data header)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.Helpers.Forge.block_header
      (fun _block =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun header =>
            _return
              (Data_encoding.Binary.to_bytes_exn Block_header.encoding header))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.protocols
      (fun function_parameter =>
        let '(chain_state, _hash, header) := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (State.Chain.get_level_indexed_protocol chain_state header)
              (fun next_protocol_hash =>
                op_gtgteq
                  (State.Block.header_of_hash chain_state
                    (predecessor (shell header)))
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      _return
                        {|
                          Tezos_shell_services.Block_services.current_protocol :=
                            next_protocol_hash;
                          Tezos_shell_services.Block_services.next_protocol :=
                            next_protocol_hash |}
                    | Some pred_header =>
                      op_gtgteq
                        (State.Chain.get_level_indexed_protocol chain_state
                          pred_header)
                        (fun protocol_hash =>
                          _return
                            {|
                              Tezos_shell_services.Block_services.current_protocol :=
                                protocol_hash;
                              Tezos_shell_services.Block_services.next_protocol :=
                                next_protocol_hash |})
                    end))) in
  Stdlib.op_exclamation dir.

Definition build_raw_rpc_directory
  (Proto :
    {'(block_header_data, block_header_metadata, operation_data,
      operation_receipt, operation) : _ &
      Tezos_shell_services.Block_services.PROTO.signature block_header_data
        block_header_metadata operation_data operation_receipt operation})
  : {'(P_block_header_data, P_block_header, P_block_header_metadata,
    P_operation_data, P_operation_receipt, P_operation, P_validation_state) : _
    &
    Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
      P_block_header P_block_header_metadata P_operation_data
      P_operation_receipt P_operation P_validation_state} ->
    Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Block.block :=
  let Proto := projT2 Proto in
  fun Next_proto =>
    let Next_proto := projT2 Next_proto in
    let dir := Stdlib.ref RPC_directory.empty in
    let merge
      (d :
      Tezos_base__TzPervasives.RPC_directory.directory
        Tezos_shell.State.Block.block) : unit :=
      Stdlib.op_coloneq dir (RPC_directory.merge d (Stdlib.op_exclamation dir))
      in
    let register0 {A B C D : Type}
      (s :
      Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
        Tezos_rpc.RPC_service.error) (f :
      Tezos_shell.State.Block.block ->
        B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
      Stdlib.op_coloneq dir
        (RPC_directory.register (Stdlib.op_exclamation dir)
          (RPC_service.subst0 s) (fun block => fun p => fun q => f block p q))
      in
    let register1 {A B C D E : Type}
      (s :
      Tezos_base__TzPervasives.RPC_service.raw variant A (A * B) C D E
        Tezos_rpc.RPC_service.error) (f :
      Tezos_shell.State.Block.block ->
        B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E))
      : unit :=
      Stdlib.op_coloneq dir
        (RPC_directory.register (Stdlib.op_exclamation dir)
          (RPC_service.subst1 s)
          (fun function_parameter =>
            let '(block, a) := function_parameter in
            fun p => fun q => f block a p q)) in
    let register2 {A B C D E F : Type}
      (s :
      Tezos_base__TzPervasives.RPC_service.raw variant A ((A * B) * C) D E F
        Tezos_rpc.RPC_service.error) (f :
      Tezos_shell.State.Block.block ->
        B -> C -> D -> E -> Lwt.t (Tezos_error_monad.Error_monad.tzresult F))
      : unit :=
      Stdlib.op_coloneq dir
        (RPC_directory.register (Stdlib.op_exclamation dir)
          (RPC_service.subst2 s)
          (fun function_parameter =>
            let '((block, a), b) := function_parameter in
            fun p => fun q => f block a b p q)) in
    let Block_services :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    let S := Block_services.S in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.live_blocks
        (fun block =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (State.Block.max_operations_ttl block)
                (fun max_op_ttl =>
                  op_gtgteqquestion
                    (Chain_traversal.live_blocks block max_op_ttl)
                    (fun function_parameter =>
                      let '(live_blocks, _) := function_parameter in
                      _return live_blocks))) in
    let metadata (block : Tezos_shell.State.Block.t)
      : Lwt.t (Tezos_base__TzPervasives.tzresult Block_services.block_metadata) :=
      op_gtgteqquestion (State.Block.metadata block)
        (fun metadata =>
          let protocol_data :=
            Data_encoding.Binary.of_bytes_exn
              Proto.(Tezos_shell_services__Block_services.PROTO.block_header_metadata_encoding)
              metadata in
          op_gtgteq (State.Block.test_chain block)
            (fun function_parameter =>
              let '(test_chain_status, _) := function_parameter in
              op_gtgteqquestion (State.Block.max_operations_ttl block)
                (fun max_operations_ttl =>
                  _return
                    {| Block_services.protocol_data := protocol_data;
                      Block_services.test_chain_status := test_chain_status;
                      Block_services.max_operations_ttl := max_operations_ttl;
                      Block_services.max_operation_data_length :=
                        Next_proto.(Tezos_protocol_updater__Registered_protocol.T.max_operation_data_length);
                      Block_services.max_block_header_length :=
                        Next_proto.(Tezos_protocol_updater__Registered_protocol.T.max_block_length);
                      Block_services.operation_list_quota :=
                        List.map
                          (fun function_parameter =>
                            let '{|
                              Tezos_protocol_environment.max_size := max_size;
                                Tezos_protocol_environment.max_op := max_op
                                |} := function_parameter in
                            {|
                              Tezos_shell_services.Block_services.max_size :=
                                max_size;
                              Tezos_shell_services.Block_services.max_op :=
                                max_op |})
                          Next_proto.(Tezos_protocol_updater__Registered_protocol.T.validation_passes)
                      |}))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.metadata
        (fun block =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              metadata block) in
    let convert
      (chain_id : Tezos_base__TzPervasives.Chain_id.t) (op :
      Tezos_base__TzPervasives.Operation.t) (metadata : Stdlib.Bytes.t)
      : Block_services.operation :=
      let protocol_data :=
        Data_encoding.Binary.of_bytes_exn
          Proto.(Tezos_shell_services__Block_services.PROTO.operation_data_encoding)
          (proto op) in
      let receipt :=
        Data_encoding.Binary.of_bytes_exn
          Proto.(Tezos_shell_services__Block_services.PROTO.operation_receipt_encoding)
          metadata in
      {| Block_services.chain_id := chain_id;
        Block_services.hash := Operation.hash op;
        Block_services.shell := shell op;
        Block_services.protocol_data := protocol_data;
        Block_services.receipt := receipt |} in
    let operations (block : Tezos_shell.State.Block.t)
      : Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list (list Block_services.operation))) :=
      op_gtgteq (State.Block.all_operations block)
        (fun ops =>
          op_gtgteq (State.Block.all_operations_metadata block)
            (fun metadata =>
              let chain_id := State.Block.chain_id block in
              _return (List.map2 (List.map2 (convert chain_id)) ops metadata)))
      in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.Operations.operations
        (fun block =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              operations block) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register1 S.Operations.operations_in_pass
        (fun block =>
          fun i =>
            fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let 'tt := function_parameter in
                let chain_id := State.Block.chain_id block in
                (* ❌ Try-with are not handled *)
                try
                  (op_gtgteq (State.Block.operations block i)
                    (fun function_parameter =>
                      let '(ops, _path) := function_parameter in
                      op_gtgteq (State.Block.operations_metadata block i)
                        (fun metadata =>
                          _return (List.map2 (convert chain_id) ops metadata)))))
      in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register2 S.Operations.operation
        (fun block =>
          fun i =>
            fun j =>
              fun function_parameter =>
                let 'tt := function_parameter in
                fun function_parameter =>
                  let 'tt := function_parameter in
                  let chain_id := State.Block.chain_id block in
                  op_gtgteq
                    (* ❌ Try-with are not handled *)
                    (try
                      (op_gtgteq (State.Block.operations block i)
                        (fun function_parameter =>
                          let '(ops, _path) := function_parameter in
                          op_gtgteq (State.Block.operations_metadata block i)
                            (fun metadata =>
                              Lwt._return
                                ((List.nth ops j), (List.nth metadata j))))))
                    (fun function_parameter =>
                      let '(op, md) := function_parameter in
                      _return (convert chain_id op md))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.Operation_hashes.operation_hashes
        (fun block =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (State.Block.all_operation_hashes block) _return) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register1 S.Operation_hashes.operation_hashes_in_pass
        (fun block =>
          fun i =>
            fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (State.Block.operation_hashes block i)
                  (fun function_parameter =>
                    let '(ops, _) := function_parameter in
                    _return ops)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register2 S.Operation_hashes.operation_hash
        (fun block =>
          fun i =>
            fun j =>
              fun function_parameter =>
                let 'tt := function_parameter in
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (* ❌ Try-with are not handled *)
                    (try
                      (op_gtgteq (State.Block.operation_hashes block i)
                        (fun function_parameter =>
                          let '(ops, _) := function_parameter in
                          Lwt._return (List.nth ops j)))) (fun op => _return op))
      in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register1 S.Context.read
        (fun block =>
          fun path =>
            fun q =>
              fun function_parameter =>
                let 'tt := function_parameter in
                let depth :=
                  Option.unopt Stdlib.max_int
                    (* ❌ Sending method message is not handled *)
                    send in
                op_gtgteqquestion
                  (fail_unless (OCaml.Stdlib.ge depth 0)
                    (Tezos_base__TzPervasives.Invalid_depth_arg depth))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (State.Block.context_exn block)
                      (fun context =>
                        op_gtgteq (Context.mem context path)
                          (fun mem =>
                            op_gtgteq (Context.dir_mem context path)
                              (fun dir_mem =>
                                if negb (orb mem dir_mem) then
                                  Lwt.fail OCaml.Not_found
                                else
                                  op_gtgteq
                                    (read_partial_context context path depth)
                                    (fun dir => _return dir)))))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.info
        (fun block =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              let chain_id := State.Block.chain_id block in
              let hash := State.Block.hash block in
              let header := State.Block.header block in
              let shell := shell header in
              let protocol_data :=
                Data_encoding.Binary.of_bytes_exn
                  Proto.(Tezos_shell_services__Block_services.PROTO.block_header_data_encoding)
                  (protocol_data header) in
              op_gtgteqquestion (metadata block)
                (fun metadata =>
                  op_gtgteqquestion (operations block)
                    (fun operations =>
                      _return
                        {| Block_services.chain_id := chain_id;
                          Block_services.hash := hash;
                          Block_services.header :=
                            {| shell := shell; protocol_data := protocol_data |};
                          Block_services.metadata := metadata;
                          Block_services.operations := operations |}))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.Helpers.Preapply.block
        (fun block =>
          fun q =>
            fun p =>
              let timestamp :=
                match
                  (* ❌ Sending method message is not handled *)
                  send with
                | None => Time.System.to_protocol (Systime_os.now tt)
                | Some time => time
                end in
              let protocol_data :=
                Data_encoding.Binary.to_bytes_exn
                  Next_proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
                  (protocol_data p) in
              let operations :=
                List.map
                  (List.map
                    (fun op =>
                      let proto :=
                        Data_encoding.Binary.to_bytes_exn
                          Next_proto.(Tezos_protocol_updater__Registered_protocol.T.operation_data_encoding)
                          (Next_proto.protocol_data op) in
                      {| Operation.shell := shell op; Operation.proto := proto
                        |})) (operations p) in
              Prevalidation.preapply block timestamp protocol_data operations)
      in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.Helpers.Preapply.operations
        (fun block =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun ops =>
              op_gtgteq (State.Block.context_exn block)
                (fun ctxt =>
                  let predecessor := State.Block.hash block in
                  let header := State.Block.shell_header block in
                  let predecessor_context :=
                    Shell_context.wrap_disk_context ctxt in
                  op_gtgteqquestion
                    (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.begin_construction)
                      (State.Block.chain_id block) predecessor_context
                      (timestamp header) (level header) (fitness header)
                      predecessor (Time.System.to_protocol (Systime_os.now tt))
                      None tt)
                    (fun state =>
                      op_gtgteqquestion
                        (fold_left_s
                          (fun function_parameter =>
                            let '(state, acc) := function_parameter in
                            fun op =>
                              op_gtgteqquestion
                                (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.apply_operation)
                                  state op)
                                (fun function_parameter =>
                                  let '(state, result) := function_parameter in
                                  _return
                                    (state,
                                      (cons ((protocol_data op), result) acc))))
                          (state, []) ops)
                        (fun function_parameter =>
                          let '(state, acc) := function_parameter in
                          op_gtgteqquestion
                            (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
                              state)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              _return (List.rev acc)))))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register1 S.Helpers.complete
        (fun block =>
          fun prefix =>
            fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (State.Block.context_exn block)
                  (fun ctxt =>
                    op_gtgteq (Base58.complete None prefix)
                      (fun l1 =>
                        let ctxt := Shell_context.wrap_disk_context ctxt in
                        op_gtgteq
                          (Next_proto.(Tezos_protocol_updater__Registered_protocol.T.complete_b58prefix)
                            ctxt prefix)
                          (fun l2 => _return (OCaml.Stdlib.app l1 l2))))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      merge
        (RPC_directory.map
          (fun block =>
            let chain_state := State.Block.chain_state block in
            let hash := State.Block.hash block in
            let header := State.Block.header block in
            Lwt._return (chain_state, hash, header))
          (build_raw_header_rpc_directory Proto)) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      merge
        (RPC_directory.map
          (fun block =>
            op_gtpipeeq (State.Block.context_exn block)
              (fun context =>
                let context := Shell_context.wrap_disk_context context in
                {|
                  Tezos_protocol_environment.block_hash :=
                    State.Block.hash block;
                  Tezos_protocol_environment.block_header :=
                    State.Block.shell_header block;
                  Tezos_protocol_environment.context := context |}))
          Next_proto.(Tezos_protocol_updater__Registered_protocol.T.rpc_services))
      in
    Stdlib.op_exclamation dir.

Definition get_protocol (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : Tezos_protocol_updater.Registered_protocol.t :=
  match Registered_protocol.get hash with
  | None => Stdlib.raise OCaml.Not_found
  | Some protocol => protocol
  end.

Definition get_directory
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Block.t) :=
  op_gtgteq (State.Block.get_rpc_directory block)
    (fun function_parameter =>
      match function_parameter with
      | Some dir => Lwt._return dir
      | None =>
        op_gtgteq (State.Block.protocol_hash_exn block)
          (fun next_protocol_hash =>
            let next_protocol := get_protocol next_protocol_hash in
            op_gtgteq (State.Block.predecessor block)
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  Lwt._return
                    (build_raw_rpc_directory Block_services.Fake_protocol
                      next_protocol)
                | Some pred =>
                  op_gtgteq (State.Chain.save_point chain_state)
                    (fun function_parameter =>
                      let '(save_point_level, _) := function_parameter in
                      op_gtgteq
                        (if op_lt (State.Block.level pred) save_point_level then
                          State.Chain.get_level_indexed_protocol chain_state
                            (State.Block.header pred)
                        else
                          State.Block.protocol_hash_exn pred)
                        (fun protocol_hash =>
                          let Proto := get_protocol protocol_hash in
                          let Proto := projT2 Proto in
                          op_gtgteq (State.Block.get_rpc_directory block)
                            (fun function_parameter =>
                              match function_parameter with
                              | Some dir => Lwt._return dir
                              | None =>
                                let dir :=
                                  build_raw_rpc_directory Proto next_protocol in
                                op_gtgteq
                                  (State.Block.set_rpc_directory block dir)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    Lwt._return dir)
                              end)))
                end))
      end).

Definition get_header_directory
  (chain_state : Tezos_shell__State.Chain.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.RPC_directory.t
      (Tezos_shell.State.Chain.t * Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) :=
  op_gtgteq
    (State.Block.header_of_hash chain_state
      (predecessor (Block_header.shell header)))
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some pred =>
        op_gtgteq (State.Chain.get_level_indexed_protocol chain_state pred)
          (fun protocol_hash =>
            let Proto := get_protocol protocol_hash in
            let Proto := projT2 Proto in
            op_gtgteq (State.Block.get_header_rpc_directory chain_state header)
              (fun function_parameter =>
                match function_parameter with
                | Some dir => Lwt._return dir
                | None =>
                  let dir := build_raw_header_rpc_directory Proto in
                  op_gtgteq
                    (State.Block.set_header_rpc_directory chain_state header dir)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Lwt._return dir)
                end))
      end).

Definition get_block
  (chain_state : Tezos_shell.State.Chain.t) (function_parameter : variant)
  : Lwt.t (option Tezos_shell.State.Block.t) :=
  match function_parameter with
  | Genesis =>
    op_gtgteq (Chain.genesis chain_state)
      (fun genesis => Lwt.return_some genesis)
  | Head n =>
    op_gtgteq (Chain.head chain_state)
      (fun head =>
        if OCaml.Stdlib.lt n 0 then
          Lwt.return_none
        else
          if equiv_decb n 0 then
            Lwt.return_some head
          else
            State.Block.read_predecessor chain_state n (Some true)
              (State.Block.hash head))
  | (Alias (_, n) | Hash (_, n)) as b =>
    op_gtgteq
      match b with
      | Alias (Checkpoint, _) =>
        op_gtgteq (State.Chain.checkpoint chain_state)
          (fun checkpoint => Lwt._return (Block_header.hash checkpoint))
      | Alias (Save_point, _) =>
        op_gtgteq (State.Chain.save_point chain_state)
          (fun function_parameter =>
            let '(_, save_point) := function_parameter in
            Lwt._return save_point)
      | Alias (Caboose, _) =>
        op_gtgteq (State.Chain.caboose chain_state)
          (fun function_parameter =>
            let '(_, caboose) := function_parameter in
            Lwt._return caboose)
      | Hash (h, _) => Lwt._return h
      end
      (fun hash =>
        if OCaml.Stdlib.lt n 0 then
          op_gtgteq
            (op_gtpipeeq (State.Block.read_opt chain_state hash)
              (Option.unopt_assert Stdlib.__POS__))
            (fun block =>
              op_gtgteq (Chain.head chain_state)
                (fun head =>
                  let head_level := State.Block.level head in
                  let block_level := State.Block.level block in
                  let target :=
                    to_int (sub head_level (sub block_level (of_int n))) in
                  if OCaml.Stdlib.lt target 0 then
                    Lwt.return_none
                  else
                    State.Block.read_predecessor chain_state target (Some true)
                      (State.Block.hash head)))
        else
          if equiv_decb n 0 then
            op_gtgteq (Chain.genesis chain_state)
              (fun genesis =>
                let genesis_hash := State.Block.hash genesis in
                if Block_hash.equal hash genesis_hash then
                  Lwt.return_some genesis
                else
                  State.Block.read_predecessor chain_state 0 (Some true) hash)
          else
            State.Block.read_predecessor chain_state n (Some true) hash)
  | Level i =>
    op_gtgteq (Chain.head chain_state)
      (fun head =>
        let target := to_int (sub (State.Block.level head) i) in
        if OCaml.Stdlib.lt target 0 then
          Lwt.fail OCaml.Not_found
        else
          State.Block.read_predecessor chain_state target (Some true)
            (State.Block.hash head))
  end.

Definition build_rpc_directory {A : Type}
  (chain_state : Tezos_shell.State.Chain.t) (block : variant)
  : Lwt.t (Tezos_base__TzPervasives.RPC_directory.directory A) :=
  op_gtgteq (get_block chain_state block)
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some b =>
        op_gtgteq (State.Chain.save_point chain_state)
          (fun function_parameter =>
            let '(save_point_level, _) := function_parameter in
            let block_level := State.Block.level b in
            let block_hash := State.Block.hash b in
            let genesis := State.Chain.genesis chain_state in
            if
              orb (OCaml.Stdlib.ge block_level save_point_level)
                (Block_hash.equal block_hash (block genesis)) then
              op_gtgteq (get_directory chain_state b)
                (fun dir =>
                  Lwt._return
                    (RPC_directory.map
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        Lwt._return b) dir))
            else
              let header := State.Block.header b in
              let hash := State.Block.hash b in
              op_gtgteq (get_header_directory chain_state header)
                (fun dir =>
                  Lwt._return
                    (RPC_directory.map
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        Lwt._return (chain_state, hash, header)) dir)))
      end).

src/lib_shell/block_validator.ml 45 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Block_validator_worker_state
open Block_validator_errors

type limits = {
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

module Name = struct
  type t = unit

  let encoding = Data_encoding.empty

  let base = ["validator"; "block"]

  let pp _ () = ()
end

module Types = struct
  include Worker_state

  type state = {
    protocol_validator : Protocol_validator.t;
    validation_process : Block_validator_process.t;
    limits : limits;
    start_testchain : bool;
  }

  type parameters =
    limits * bool * Distributed_db.t * Block_validator_process.t

  let view _state _parameters = ()
end

module Request = struct
  include Request

  type 'a t =
    | Request_validation : {
        chain_db : Distributed_db.chain_db;
        notify_new_block : State.Block.t -> unit;
        canceler : Lwt_canceler.t option;
        peer : P2p_peer.Id.t option;
        hash : Block_hash.t;
        header : Block_header.t;
        operations : Operation.t list list;
      }
        -> State.Block.t option tzresult t

  let view : type a. a t -> view =
   fun (Request_validation {chain_db; peer; hash; _}) ->
    let chain_id = chain_db |> Distributed_db.chain_state |> State.Chain.id in
    {chain_id; block = hash; peer}
end

module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)

type t = Worker.infinite Worker.queue Worker.t

let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))

let check_chain_liveness chain_db hash (header : Block_header.t) =
  let chain_state = Distributed_db.chain_state chain_db in
  match State.Chain.expiration chain_state with
  | Some eol when Time.Protocol.(eol <= header.shell.timestamp) ->
      fail @@ invalid_block hash
      @@ Expired_chain
           {
             chain_id = State.Chain.id chain_state;
             expiration = eol;
             timestamp = header.shell.timestamp;
           }
  | None | Some _ ->
      return_unit

let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
 fun w
     (Request.Request_validation
       {chain_db; notify_new_block; canceler; peer; hash; header; operations}) ->
  let bv = Worker.state w in
  let chain_state = Distributed_db.chain_state chain_db in
  State.Block.read_opt chain_state hash
  >>= function
  | Some block ->
      debug
        w
        "previously validated block %a (after pipe)"
        Block_hash.pp_short
        hash ;
      Protocol_validator.prefetch_and_compile_protocols
        bv.protocol_validator
        ?peer
        ~timeout:bv.limits.protocol_timeout
        block ;
      return (Ok None)
  | None -> (
      State.Block.read_invalid chain_state hash
      >>= function
      | Some {errors; _} ->
          return (Error errors)
      | None -> (
          State.Chain.save_point chain_state
          >>= fun (save_point_lvl, _) ->
          (* Safety and late workers in partial mode. *)
          if Compare.Int32.(header.shell.level < save_point_lvl) then
            return (Ok None)
          else
            ( debug w "validating block %a" Block_hash.pp_short hash ;
              State.Block.read chain_state header.shell.predecessor
              >>=? fun pred ->
              Worker.protect w (fun () ->
                  protect ?canceler (fun () ->
                      Block_validator_process.apply_block
                        bv.validation_process
                        ~predecessor:pred
                        header
                        operations
                      >>= function
                      | Ok x ->
                          return x
                      | Error (Missing_test_protocol protocol :: _) ->
                          Protocol_validator.fetch_and_compile_protocol
                            bv.protocol_validator
                            ?peer
                            ~timeout:bv.limits.protocol_timeout
                            protocol
                          >>=? fun _ ->
                          Block_validator_process.apply_block
                            bv.validation_process
                            ~predecessor:pred
                            header
                            operations
                      | Error _ as x ->
                          Lwt.return x)
                  >>=? fun { validation_store;
                             block_metadata;
                             ops_metadata;
                             forking_testchain } ->
                  let validation_store =
                    ( {
                        context_hash = validation_store.context_hash;
                        message = validation_store.message;
                        max_operations_ttl =
                          validation_store.max_operations_ttl;
                        last_allowed_fork_level =
                          validation_store.last_allowed_fork_level;
                      }
                      : Block_validation.validation_store )
                  in
                  Distributed_db.commit_block
                    chain_db
                    hash
                    header
                    block_metadata
                    operations
                    ops_metadata
                    validation_store
                    ~forking_testchain
                  >>=? function
                  | None ->
                      assert false (* should not happen *)
                  | Some block ->
                      return block) )
            >>= function
            | Ok block ->
                Protocol_validator.prefetch_and_compile_protocols
                  bv.protocol_validator
                  ?peer
                  ~timeout:bv.limits.protocol_timeout
                  block ;
                notify_new_block block ;
                return (Ok (Some block))
            | Error err as error ->
                if
                  List.exists
                    (function Invalid_block _ -> true | _ -> false)
                    err
                then (
                  Worker.protect w (fun () ->
                      Distributed_db.commit_invalid_block
                        chain_db
                        hash
                        header
                        err)
                  >>=? fun commited ->
                  assert commited ;
                  return error )
                else (
                  debug
                    w
                    "Error during %a block validation: %a"
                    Block_hash.pp_short
                    hash
                    Error_monad.pp_print_error
                    err ;
                  return error ) ) )

let on_launch _ _ (limits, start_testchain, db, validation_process) =
  let protocol_validator = Protocol_validator.create db in
  return
    {Types.protocol_validator; validation_process; limits; start_testchain}

let on_error w r st errs =
  Worker.record_event w (Validation_failure (r, st, errs)) ;
  Lwt.return_error errs

let on_completion :
    type a. t -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t
    =
 fun w (Request.Request_validation _ as r) v st ->
  match v with
  | Ok (Some _) ->
      Worker.record_event w (Event.Validation_success (Request.view r, st)) ;
      Lwt.return_unit
  | Ok None ->
      Lwt.return_unit
  | Error errs ->
      Worker.record_event
        w
        (Event.Validation_failure (Request.view r, st, errs)) ;
      Lwt.return_unit

let on_close w =
  let bv = Worker.state w in
  Block_validator_process.close bv.validation_process

let table = Worker.create_table Queue

let create limits db validation_process ~start_testchain =
  let module Handlers = struct
    type self = t

    let on_launch = on_launch

    let on_request = on_request

    let on_close = on_close

    let on_error = on_error

    let on_completion = on_completion

    let on_no_request _ = return_unit
  end in
  Worker.launch
    table
    limits.worker_limits
    ()
    (limits, start_testchain, db, validation_process)
    (module Handlers)

let shutdown = Worker.shutdown

let validate w ?canceler ?peer ?(notify_new_block = fun _ -> ()) chain_db hash
    (header : Block_header.t) operations =
  let bv = Worker.state w in
  let chain_state = Distributed_db.chain_state chain_db in
  State.Block.read_opt chain_state hash
  >>= function
  | Some block ->
      debug
        w
        "previously validated block %a (before pipe)"
        Block_hash.pp_short
        hash ;
      Protocol_validator.prefetch_and_compile_protocols
        bv.protocol_validator
        ?peer
        ~timeout:bv.limits.protocol_timeout
        block ;
      return_none
  | None ->
      map_p
        (map_p (fun op ->
             let op_hash = Operation.hash op in
             return op_hash))
        operations
      >>=? fun hashes ->
      let computed_hash =
        Operation_list_list_hash.compute
          (List.map Operation_list_hash.compute hashes)
      in
      fail_when
        ( Operation_list_list_hash.compare
            computed_hash
            header.shell.operations_hash
        <> 0 )
        (Inconsistent_operations_hash
           {
             block = hash;
             expected = header.shell.operations_hash;
             found = computed_hash;
           })
      >>=? fun () ->
      check_chain_liveness chain_db hash header
      >>=? fun () ->
      Worker.Queue.push_request_and_wait
        w
        (Request_validation
           {
             chain_db;
             notify_new_block;
             canceler;
             peer;
             hash;
             header;
             operations;
           })
      >>=? fun result -> Lwt.return result

let fetch_and_compile_protocol w =
  let bv = Worker.state w in
  Protocol_validator.fetch_and_compile_protocol bv.protocol_validator

let status = Worker.status

let running_worker () =
  match Worker.list table with
  | [(_, single)] ->
      single
  | [] ->
      raise Not_found
  | _ :: _ :: _ ->
      (* NOTE: names of workers must be unique, [Name.t = unit] which has only
         one inhabitant. *)
      assert false

let pending_requests t = Worker.Queue.pending_requests t

let current_request t = Worker.current_request t

let last_events = Worker.last_events
src/lib_shell/block_validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Block_validator_worker_state.

Import Block_validator_errors.

Record limits := {
  protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module Name.
  Definition t := unit.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Data_encoding.empty.
  
  Definition base : list string :=
    cons "validator" % string (cons "block" % string []).
  
  Definition pp {A : Type} (function_parameter : A) : unit -> unit :=
    let '_ := function_parameter in
    fun function_parameter =>
      let 'tt := function_parameter in
      tt.
End Name.

Module Types.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Record state := {
    protocol_validator : Tezos_shell.Protocol_validator.t;
    validation_process : Tezos_shell.Block_validator_process.t;
    limits : limits;
    start_testchain : bool }.
  
  Definition parameters :=
    limits * bool * Tezos_shell.Distributed_db.t *
      Tezos_shell.Block_validator_process.t.
  
  Definition view {A B : Type} (_state : A) (_parameters : B) : unit := tt.
End Types.

Module Request.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Inductive t : forall (a : Type), Type :=
  | Request_validation : Tezos_shell.Distributed_db.chain_db ->
    (Tezos_shell.State.Block.t -> unit) ->
    (option Tezos_base__TzPervasives.Lwt_canceler.t) ->
    (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_header.t ->
    (list (list Tezos_base__TzPervasives.Operation.t)) ->
    t (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.t)).
  
  Definition view {a : Type} (function_parameter : t a) : view :=
    let
      'Request_validation {| chain_db := chain_db; peer := peer; hash := hash |} :=
      function_parameter in
    let chain_id :=
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply chain_db Distributed_db.chain_state)
        State.Chain.id in
    {| chain_id := chain_id; block := hash; peer := peer |}.
End Request.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Definition t := Worker.t (Worker.queue Worker.infinite).

Definition debug {A B : Type} (w : Worker.t A)
  : (Stdlib.format4 B Stdlib.Format.formatter unit unit) -> B :=
  Format.kasprintf
    (fun msg =>
      Worker.record_event w
        (Tezos_shell_services.Block_validator_worker_state.Event.Debug msg)).

Definition check_chain_liveness
  (chain_db : Tezos_shell.Distributed_db.chain_db)
  (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let chain_state := Distributed_db.chain_state chain_db in
  match State.Chain.expiration chain_state with
  | Some eol =>
    apply fail
      (apply (invalid_block hash)
        (Tezos_shell_services.Block_validator_errors.Expired_chain
          {| chain_id := State.Chain.id chain_state; expiration := eol;
            timestamp := timestamp (shell header) |}))
  | None | Some _ => return_unit
  end.

Definition on_request {r : Type}
  (w : t) (function_parameter : Request.(Tezos_shell__Worker.REQUEST.t) r)
  : Lwt.t (Tezos_base__TzPervasives.tzresult r) :=
  let
    'Request.Request_validation {|
      chain_db := chain_db;
        notify_new_block := notify_new_block;
        canceler := canceler;
        peer := peer;
        hash := hash;
        header := header;
        operations := operations
        |} := function_parameter in
  let bv := Worker.state w in
  let chain_state := Distributed_db.chain_state chain_db in
  op_gtgteq (State.Block.read_opt chain_state hash)
    (fun function_parameter =>
      match function_parameter with
      | Some block =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "previously validated block " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " (after pipe)" % string
                    CamlinternalFormatBasics.End_of_format)))
              "previously validated block %a (after pipe)" % string)
            Block_hash.pp_short hash in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Protocol_validator.prefetch_and_compile_protocols
            (protocol_validator bv) peer (Some (protocol_timeout (limits bv)))
            block in
        _return (Stdlib.Ok None)
      | None =>
        op_gtgteq (State.Block.read_invalid chain_state hash)
          (fun function_parameter =>
            match function_parameter with
            | Some {| errors := errors |} => _return (Stdlib.Error errors)
            | None =>
              op_gtgteq (State.Chain.save_point chain_state)
                (fun function_parameter =>
                  let '(save_point_lvl, _) := function_parameter in
                  if op_lt (level (shell header)) save_point_lvl then
                    _return (Stdlib.Ok None)
                  else
                    op_gtgteq
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      (let _ :=
                        debug w
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "validating block " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            "validating block %a" % string) Block_hash.pp_short
                          hash in
                      op_gtgteqquestion
                        (State.Block.read chain_state
                          (predecessor (shell header)))
                        (fun pred =>
                          Worker.protect w None
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (protect None canceler
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      (Block_validator_process.apply_block
                                        (validation_process bv) pred header
                                        operations)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | Stdlib.Ok x => _return x
                                        |
                                          Stdlib.Error
                                            (cons
                                              (Tezos_base__TzPervasives.Missing_test_protocol
                                                protocol) _) =>
                                          op_gtgteqquestion
                                            (Protocol_validator.fetch_and_compile_protocol
                                              (protocol_validator bv) peer
                                              (Some
                                                (protocol_timeout (limits bv)))
                                              protocol)
                                            (fun function_parameter =>
                                              let '_ := function_parameter in
                                              Block_validator_process.apply_block
                                                (validation_process bv) pred
                                                header operations)
                                        | (Stdlib.Error _) as x => Lwt._return x
                                        end)))
                                (fun function_parameter =>
                                  let '{|
                                    validation_store := validation_store;
                                      block_metadata := block_metadata;
                                      ops_metadata := ops_metadata;
                                      forking_testchain := forking_testchain
                                      |} := function_parameter in
                                  let validation_store :=
                                    {|
                                      context_hash :=
                                        context_hash validation_store;
                                      message := message validation_store;
                                      max_operations_ttl :=
                                        max_operations_ttl validation_store;
                                      last_allowed_fork_level :=
                                        last_allowed_fork_level validation_store
                                      |} in
                                  op_gtgteqquestion
                                    (Distributed_db.commit_block chain_db hash
                                      header block_metadata operations
                                      ops_metadata validation_store
                                      forking_testchain)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | None =>
                                        (* ❌ Assert instruction is not handled. *)
                                        assert false
                                      | Some block => _return block
                                      end)))))
                      (fun function_parameter =>
                        match function_parameter with
                        | Stdlib.Ok block =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            Protocol_validator.prefetch_and_compile_protocols
                              (protocol_validator bv) peer
                              (Some (protocol_timeout (limits bv))) block in
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ := notify_new_block block in
                          _return (Stdlib.Ok (Some block))
                        | (Stdlib.Error err) as error =>
                          if
                            List._exists
                              (fun function_parameter =>
                                match function_parameter with
                                | Tezos_base__TzPervasives.Invalid_block _ =>
                                  true
                                | _ => false
                                end) err then
                            op_gtgteqquestion
                              (Worker.protect w None
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  Distributed_db.commit_invalid_block chain_db
                                    hash header err))
                              (fun commited =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  (* ❌ Assert instruction is not handled. *)
                                  assert commited in
                                _return error)
                          else
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              debug w
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Error during " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " block validation: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format))))
                                  "Error during %a block validation: %a" %
                                    string) Block_hash.pp_short hash
                                Error_monad.pp_print_error err in
                            _return error
                        end))
            end)
      end).

Definition on_launch {A B : Type} (function_parameter : A)
  : B ->
    (limits * bool * Tezos_shell.Distributed_db.t *
      Tezos_shell.Block_validator_process.t) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Types.(Tezos_shell__Worker.TYPES.state)) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    fun function_parameter =>
      let '(limits, start_testchain, db, validation_process) :=
        function_parameter in
      let protocol_validator := Protocol_validator.create db in
      _return
        {| Types.protocol_validator := protocol_validator;
          Types.validation_process := validation_process;
          Types.limits := limits; Types.start_testchain := start_testchain |}.

Definition on_error {A B : Type}
  (w : Worker.t A)
  (r : Tezos_shell_services__Block_validator_worker_state.Request.view)
  (st : Tezos_shell_services.Worker_types.request_status)
  (errs : list Tezos_base__TzPervasives.error)
  : Lwt.t (Result.result B (list Tezos_base__TzPervasives.error)) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Worker.record_event w
      (Tezos_shell_services.Block_validator_worker_state.Event.Validation_failure
        r st errs) in
  Lwt.return_error errs.

Definition on_completion {a : Type}
  (w : t) (function_parameter : Request.(Tezos_shell__Worker.REQUEST.t) a)
  : a -> Tezos_shell_services.Worker_types.request_status -> Lwt.t unit :=
  let '(Request.Request_validation _) as r := function_parameter in
  fun v =>
    fun st =>
      match v with
      | Stdlib.Ok (Some _) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Worker.record_event w
            (Tezos_shell_services.Block_validator_worker_state.Event.Validation_success
              (Request.(Tezos_shell__Worker.REQUEST.view) r) st) in
        Lwt.return_unit
      | Stdlib.Ok None => Lwt.return_unit
      | Stdlib.Error errs =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Worker.record_event w
            (Tezos_shell_services.Block_validator_worker_state.Event.Validation_failure
              (Request.(Tezos_shell__Worker.REQUEST.view) r) st errs) in
        Lwt.return_unit
      end.

Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let bv := Worker.state w in
  Block_validator_process.close (validation_process bv).

Definition table : Worker.table (Worker.queue Worker.infinite) :=
  Worker.create_table Worker.Queue.

Definition create
  (limits : limits) (db : Tezos_shell.Distributed_db.t)
  (validation_process : Tezos_shell.Block_validator_process.t)
  (start_testchain : bool)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
  let Handlers :=
    existT _ unit
      {|
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_launch := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_request := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_close := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_error := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_completion := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_no_request := unhandled
        |} in
  Worker.launch table None (worker_limits limits) tt
    (limits, start_testchain, db, validation_process) Handlers.

Definition shutdown {A : Type} : (Worker.t A) -> Lwt.t unit := Worker.shutdown.

Definition validate {A : Type}
  (w : Worker.t (Worker.queue A))
  (canceler : option Tezos_base__TzPervasives.Lwt_canceler.t)
  (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
  (op_staroptstar : option (Tezos_shell.State.Block.t -> unit))
  : Tezos_shell.Distributed_db.chain_db ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (option Tezos_shell.State.Block.t)) :=
  let notify_new_block :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        tt
    end in
  fun chain_db =>
    fun hash =>
      fun header =>
        fun operations =>
          let bv := Worker.state w in
          let chain_state := Distributed_db.chain_state chain_db in
          op_gtgteq (State.Block.read_opt chain_state hash)
            (fun function_parameter =>
              match function_parameter with
              | Some block =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  debug w
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "previously validated block " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " (before pipe)" % string
                            CamlinternalFormatBasics.End_of_format)))
                      "previously validated block %a (before pipe)" % string)
                    Block_hash.pp_short hash in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Protocol_validator.prefetch_and_compile_protocols
                    (protocol_validator bv) peer
                    (Some (protocol_timeout (limits bv))) block in
                return_none
              | None =>
                op_gtgteqquestion
                  (map_p
                    (map_p
                      (fun op =>
                        let op_hash := Operation.hash op in
                        _return op_hash)) operations)
                  (fun hashes =>
                    let computed_hash :=
                      Operation_list_list_hash.compute
                        (List.map Operation_list_hash.compute hashes) in
                    op_gtgteqquestion
                      (fail_when
                        (nequiv_decb
                          (Operation_list_list_hash.compare computed_hash
                            (operations_hash (shell header))) 0)
                        (Tezos_base__TzPervasives.Inconsistent_operations_hash
                          {| block := hash;
                            expected := operations_hash (shell header);
                            found := computed_hash |}))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (check_chain_liveness chain_db hash header)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Worker.Queue.push_request_and_wait w
                                (Request.Request_validation
                                  {| chain_db := chain_db;
                                    notify_new_block := notify_new_block;
                                    canceler := canceler; peer := peer;
                                    hash := hash; header := header;
                                    operations := operations |}))
                              (fun result => Lwt._return result))))
              end).

Definition fetch_and_compile_protocol {A : Type} (w : Worker.t A)
  : (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    (option Ptime.Span.t) ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t) :=
  let bv := Worker.state w in
  Protocol_validator.fetch_and_compile_protocol (protocol_validator bv).

Definition status {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
  Worker.status.

Definition running_worker (function_parameter : unit)
  : Worker.t (Worker.queue Worker.infinite) :=
  let 'tt := function_parameter in
  match Worker.list table with
  | cons (_, single) [] => single
  | [] => Stdlib.raise OCaml.Not_found
  | cons _ (cons _ _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition pending_requests {A : Type} (t : Worker.t (Worker.queue A))
  : list
    (Tezos_base__TzPervasives.Time.System.t *
      Worker.Request.(Tezos_shell__Worker.REQUEST.view)) :=
  Worker.Queue.pending_requests t.

Definition current_request {A : Type} (t : Worker.t A)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Worker.Request.(Tezos_shell__Worker.REQUEST.view)) :=
  Worker.current_request t.

Definition last_events {A : Type}
  : (Worker.t A) ->
    list
      (Tezos_base__TzPervasives.Internal_event.level *
        (list Worker.Event.(Tezos_shell__Worker.EVENT.t))) := Worker.last_events.

src/lib_shell/block_validator_process.ml 49 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let get_context index hash =
  Context.checkout index hash
  >>= function
  | None ->
      fail (Block_validator_errors.Failed_to_checkout_context hash)
  | Some ctx ->
      return ctx

(** The standard block validation method *)
module Seq_validator = struct
  include Internal_event.Legacy_logging.Make (struct
    let name = "validation_process.sequential"
  end)

  type validation_context = {context_index : Context.index}

  type t = validation_context

  let init context_index =
    lwt_log_notice "Initialized" >>= fun () -> Lwt.return {context_index}

  let close _ = lwt_log_notice "Shutting down..."

  let apply_block validator_process chain_state ~max_operations_ttl
      ~(predecessor_block_header : Block_header.t) ~block_header operations =
    let chain_id = State.Chain.id chain_state in
    get_context
      validator_process.context_index
      predecessor_block_header.shell.context
    >>=? fun predecessor_context ->
    Block_validation.apply
      chain_id
      ~max_operations_ttl
      ~predecessor_block_header
      ~predecessor_context
      ~block_header
      operations
end

(* Block validation using an external processes *)
module External_validator = struct
  include Internal_event.Legacy_logging.Make_semantic (struct
    let name = "shell.validation_process.external"
  end)

  type validation_context = {
    context_root : string;
    protocol_root : string;
    process_path : string;
    mutable validator_process : Lwt_process.process_full option;
    lock : Lwt_mutex.t;
    sandbox_parameters : Data_encoding.json option;
  }

  type t = validation_context

  let init ?sandbox_parameters ~context_root ~protocol_root ~process_path =
    lwt_log_notice (fun f -> f "Initialized")
    >>= fun () ->
    Lwt.return
      {
        context_root;
        protocol_root;
        process_path;
        validator_process = None;
        lock = Lwt_mutex.create ();
        sandbox_parameters;
      }

  let check_process_status =
    let open Unix in
    let int_tag = Tag.def "int" Format.pp_print_int in
    function
    | WEXITED 0 ->
        lwt_log_notice (fun f -> f "The process terminated normally")
    | WEXITED i ->
        lwt_fatal_error
          Tag.DSL.(
            fun f ->
              f "The process terminated abnormally with value %a"
              -% a int_tag i)
    | WSIGNALED i ->
        lwt_fatal_error
          Tag.DSL.(
            fun f -> f "The process was killed by signal %a" -% a int_tag i)
    | WSTOPPED i ->
        lwt_fatal_error
          Tag.DSL.(
            fun f -> f "The process was stopped by signal %a" -% a int_tag i)

  let close vp =
    lwt_log_notice (fun f -> f "Shutting down ...")
    >>= fun () ->
    match vp.validator_process with
    | Some process ->
        External_validation.send
          process#stdin
          External_validation.request_encoding
          External_validation.Terminate
        >>= fun () ->
        process#status
        >>= (function
              | Unix.WEXITED 0 ->
                  Lwt.return_unit
              | _ ->
                  process#terminate ; Lwt.return_unit)
        >>= fun () ->
        vp.validator_process <- None ;
        Lwt.return_unit
    | None ->
        Lwt.return_unit

  let send_request vp request result_encoding =
    let start_process () =
      let process =
        Lwt_process.open_process_full (vp.process_path, [|"tezos-validator"|])
      in
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Block validation started on pid %a"
            -% a (Tag.def "int" Format.pp_print_int) process#pid)
      >>= fun () ->
      let parameters =
        {
          External_validation.context_root = vp.context_root;
          protocol_root = vp.protocol_root;
          sandbox_parameters = vp.sandbox_parameters;
        }
      in
      vp.validator_process <- Some process ;
      External_validation.send
        process#stdin
        Data_encoding.Variable.bytes
        External_validation.magic
      >>= fun () ->
      External_validation.send
        process#stdin
        External_validation.parameters_encoding
        parameters
      >>= fun () -> Lwt.return process
    in
    ( match vp.validator_process with
    | Some process -> (
      match process#state with
      | Running ->
          Lwt.return process
      | Exited status ->
          vp.validator_process <- None ;
          check_process_status status
          >>= fun () ->
          vp.validator_process <- None ;
          lwt_log_notice (fun f -> f "restarting validation process...")
          >>= fun () -> start_process () )
    | None ->
        start_process () )
    >>= fun process ->
    Lwt.catch
      (fun () ->
        (* Make sure that the promise is not canceled between a send and recv *)
        Lwt.protected
          (Lwt_mutex.with_lock vp.lock (fun () ->
               External_validation.send
                 process#stdin
                 External_validation.request_encoding
                 request
               >>= fun () ->
               External_validation.recv_result process#stdout result_encoding))
        >>=? fun res ->
        match process#state with
        | Running ->
            return res
        | Exited status ->
            vp.validator_process <- None ;
            check_process_status status >>= fun () -> return res)
      (function
        | errors ->
            process#status
            >>= fun status ->
            check_process_status status
            >>= fun () ->
            vp.validator_process <- None ;
            Lwt.return (error_exn errors))
end

type validator_kind =
  | Internal of Context.index
  | External of {
      context_root : string;
      protocol_root : string;
      process_path : string;
      sandbox_parameters : Data_encoding.json option;
    }

type t = Sequential of Seq_validator.t | External of External_validator.t

let init = function
  | Internal index ->
      Seq_validator.init index >>= fun v -> return (Sequential v)
  | External {context_root; protocol_root; process_path; sandbox_parameters} ->
      External_validator.init
        ?sandbox_parameters
        ~context_root
        ~protocol_root
        ~process_path
      >>= fun v ->
      External_validator.send_request
        v
        External_validation.Init
        Data_encoding.empty
      >>=? fun () -> return (External v)

let close = function
  | Sequential vp ->
      Seq_validator.close vp
  | External vp ->
      External_validator.close vp

let apply_block bvp ~predecessor block_header operations =
  let chain_state = State.Block.chain_state predecessor in
  let predecessor_block_header = State.Block.header predecessor in
  State.Block.max_operations_ttl predecessor
  >>=? fun max_operations_ttl ->
  let block_hash = Block_header.hash block_header in
  Chain.data chain_state
  >>= (fun chain_data ->
        if State.Block.equal chain_data.current_head predecessor then
          return (chain_data.live_blocks, chain_data.live_operations)
        else Chain_traversal.live_blocks predecessor max_operations_ttl)
  >>=? fun (live_blocks, live_operations) ->
  Block_validation.check_liveness
    ~live_operations
    ~live_blocks
    block_hash
    operations
  >>=? fun () ->
  match bvp with
  | Sequential vp ->
      Seq_validator.apply_block
        vp
        ~max_operations_ttl
        chain_state
        ~predecessor_block_header
        ~block_header
        operations
  | External vp ->
      let chain_id = State.Chain.id chain_state in
      let request =
        External_validation.Validate
          {
            chain_id;
            block_header;
            predecessor_block_header;
            operations;
            max_operations_ttl;
          }
      in
      External_validator.send_request
        vp
        request
        Block_validation.result_encoding

let commit_genesis bvp ~genesis_hash ~chain_id ~time ~protocol =
  match bvp with
  | Sequential {context_index} ->
      Context.commit_genesis context_index ~chain_id ~time ~protocol
      >>= fun res -> return res
  | External vp ->
      let request =
        External_validation.Commit_genesis
          {genesis_hash; chain_id; time; protocol}
      in
      External_validator.send_request vp request Context_hash.encoding

let init_test_chain bvp forking_block =
  let forked_header = State.Block.header forking_block in
  match bvp with
  | Sequential _ ->
      State.Block.context forking_block
      >>=? fun context ->
      Block_validation.init_test_chain context forked_header
  | External vp ->
      let context_hash = forked_header.shell.context in
      let request =
        External_validation.Fork_test_chain {context_hash; forked_header}
      in
      External_validator.send_request vp request Block_header.encoding
src/lib_shell/block_validator_process.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition get_context
  (index : Tezos_storage.Context.index)
  (hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
  op_gtgteq (Context.checkout index hash)
    (fun function_parameter =>
      match function_parameter with
      | None => fail (Tezos_base__TzPervasives.Failed_to_checkout_context hash)
      | Some ctx => _return ctx
      end).

Module Seq_validator.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Record validation_context := {
    context_index : Tezos_storage.Context.index }.
  
  Definition t := validation_context.
  
  Definition init (context_index : Tezos_storage.Context.index)
    : Lwt.t validation_context :=
    op_gtgteq
      (lwt_log_notice
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Initialized" % string
            CamlinternalFormatBasics.End_of_format) "Initialized" % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt._return {| context_index := context_index |}).
  
  Definition close {A : Type} (function_parameter : A) : Lwt.t unit :=
    let '_ := function_parameter in
    lwt_log_notice
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Shutting down..." % string
          CamlinternalFormatBasics.End_of_format) "Shutting down..." % string).
  
  Definition apply_block
    (validator_process : validation_context)
    (chain_state : Tezos_shell.State.Chain.chain_state) (max_operations_ttl : Z)
    (predecessor_block_header : Tezos_base__TzPervasives.Block_header.t)
    (block_header : Tezos_base__TzPervasives.Block_header.t)
    (operations : list (list Tezos_base__TzPervasives.Operation.t))
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_validation.Block_validation.result) :=
    let chain_id := State.Chain.id chain_state in
    op_gtgteqquestion
      (get_context (context_index validator_process)
        (context (shell predecessor_block_header)))
      (fun predecessor_context =>
        Block_validation.apply chain_id max_operations_ttl
          predecessor_block_header predecessor_context block_header operations).
End Seq_validator.

Module External_validator.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Record validation_context := {
    context_root : string;
    protocol_root : string;
    process_path : string;
    validator_process : option Lwt_process.process_full;
    lock : Lwt_mutex.t;
    sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.
  
  Definition t := validation_context.
  
  Definition init
    (sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json)
    (context_root : string) (protocol_root : string) (process_path : string)
    : Lwt.t validation_context :=
    op_gtgteq
      (lwt_log_notice
        (fun f =>
          f
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Initialized" % string
                CamlinternalFormatBasics.End_of_format) "Initialized" % string)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt._return
          {| context_root := context_root; protocol_root := protocol_root;
            process_path := process_path; validator_process := None;
            lock := Lwt_mutex.create tt;
            sandbox_parameters := sandbox_parameters |}).
  
  Definition check_process_status : Unix.process_status -> Lwt.t unit :=
    let int_tag := Tag.def None "int" % string Format.pp_print_int in
    fun function_parameter =>
      match function_parameter with
      | Unix.WEXITED 0 =>
        lwt_log_notice
          (fun f =>
            f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "The process terminated normally" % string
                  CamlinternalFormatBasics.End_of_format)
                "The process terminated normally" % string))
      | Unix.WEXITED i =>
        lwt_fatal_error
          (fun f =>
            op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The process terminated abnormally with value " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "The process terminated abnormally with value %a" % string))
              (a int_tag i))
      | Unix.WSIGNALED i =>
        lwt_fatal_error
          (fun f =>
            op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The process was killed by signal " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "The process was killed by signal %a" % string)) (a int_tag i))
      | Unix.WSTOPPED i =>
        lwt_fatal_error
          (fun f =>
            op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The process was stopped by signal " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "The process was stopped by signal %a" % string))
              (a int_tag i))
      end.
  
  Definition close (vp : validation_context) : Lwt.t unit :=
    op_gtgteq
      (lwt_log_notice
        (fun f =>
          f
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Shutting down ..." % string
                CamlinternalFormatBasics.End_of_format)
              "Shutting down ..." % string)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        match validator_process vp with
        | Some process =>
          op_gtgteq
            (External_validation.send
              (* ❌ Sending method message is not handled *)
              send External_validation.request_encoding
              Tezos_validation.External_validation.Terminate)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (op_gtgteq
                  (* ❌ Sending method message is not handled *)
                  send
                  (fun function_parameter =>
                    match function_parameter with
                    | Unix.WEXITED 0 => Lwt.return_unit
                    | _ =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        (* ❌ Sending method message is not handled *)
                        send in
                      Lwt.return_unit
                    end))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    (* ❌ Set record field not handled. *)
                    set_record_field vp "validator_process" % string None in
                  Lwt.return_unit))
        | None => Lwt.return_unit
        end).
  
  Definition send_request {A : Type}
    (vp : validation_context)
    (request : Tezos_validation.External_validation.request)
    (result_encoding : Tezos_base__TzPervasives.Data_encoding.t A)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    let start_process (function_parameter : unit)
      : Lwt.t Lwt_process.process_full :=
      let 'tt := function_parameter in
      let process :=
        Lwt_process.open_process_full None None
          ((process_path vp),
            (* ❌ Arrays not handled. *)
            [ "tezos-validator" % string ]) in
      op_gtgteq
        (lwt_log_notice
          (fun f =>
            op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Block validation started on pid " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "Block validation started on pid %a" % string))
              (a (Tag.def None "int" % string Format.pp_print_int)
                (* ❌ Sending method message is not handled *)
                send)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          let parameters :=
            {| External_validation.context_root := context_root vp;
              External_validation.protocol_root := protocol_root vp;
              External_validation.sandbox_parameters := sandbox_parameters vp |}
            in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field vp "validator_process" % string (Some process) in
          op_gtgteq
            (External_validation.send
              (* ❌ Sending method message is not handled *)
              send Data_encoding.Variable.bytes External_validation.magic)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (External_validation.send
                  (* ❌ Sending method message is not handled *)
                  send External_validation.parameters_encoding parameters)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt._return process))) in
    op_gtgteq
      match validator_process vp with
      | Some process =>
        match
          (* ❌ Sending method message is not handled *)
          send with
        | Lwt_process.Running => Lwt._return process
        | Lwt_process.Exited status =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field vp "validator_process" % string None in
          op_gtgteq (check_process_status status)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field vp "validator_process" % string None in
              op_gtgteq
                (lwt_log_notice
                  (fun f =>
                    f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "restarting validation process..." % string
                          CamlinternalFormatBasics.End_of_format)
                        "restarting validation process..." % string)))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  start_process tt))
        end
      | None => start_process tt
      end
      (fun process =>
        Lwt.catch
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Lwt.protected
                (Lwt_mutex.with_lock (lock vp)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      (External_validation.send
                        (* ❌ Sending method message is not handled *)
                        send External_validation.request_encoding request)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        External_validation.recv_result
                          (* ❌ Sending method message is not handled *)
                          send result_encoding))))
              (fun res =>
                match
                  (* ❌ Sending method message is not handled *)
                  send with
                | Lwt_process.Running => _return res
                | Lwt_process.Exited status =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    (* ❌ Set record field not handled. *)
                    set_record_field vp "validator_process" % string None in
                  op_gtgteq (check_process_status status)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return res)
                end))
          (fun errors =>
            op_gtgteq
              (* ❌ Sending method message is not handled *)
              send
              (fun status =>
                op_gtgteq (check_process_status status)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      (* ❌ Set record field not handled. *)
                      set_record_field vp "validator_process" % string None in
                    Lwt._return (error_exn errors))))).
End External_validator.

Inductive validator_kind : Type :=
| Internal : Tezos_storage.Context.index -> validator_kind
| External : string -> string -> string ->
  (option Tezos_base__TzPervasives.Data_encoding.json) -> validator_kind.

Inductive t : Type :=
| Sequential : Seq_validator.t -> t
| External : External_validator.t -> t.

Definition init (function_parameter : validator_kind)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  match function_parameter with
  | Internal index =>
    op_gtgteq (Seq_validator.init index) (fun v => _return (Sequential v))
  |
    External {|
      context_root := context_root;
        protocol_root := protocol_root;
        process_path := process_path;
        sandbox_parameters := sandbox_parameters
        |} =>
    op_gtgteq
      (External_validator.init sandbox_parameters context_root protocol_root
        process_path)
      (fun v =>
        op_gtgteqquestion
          (External_validator.send_request v
            Tezos_validation.External_validation.Init Data_encoding.empty)
          (fun function_parameter =>
            let 'tt := function_parameter in
            _return (External v)))
  end.

Definition close (function_parameter : t) : Lwt.t unit :=
  match function_parameter with
  | Sequential vp => Seq_validator.close vp
  | External vp => External_validator.close vp
  end.

Definition apply_block
  (bvp : t) (predecessor : Tezos_shell.State.Block.t)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_validation.Block_validation.result) :=
  let chain_state := State.Block.chain_state predecessor in
  let predecessor_block_header := State.Block.header predecessor in
  op_gtgteqquestion (State.Block.max_operations_ttl predecessor)
    (fun max_operations_ttl =>
      let block_hash := Block_header.hash block_header in
      op_gtgteqquestion
        (op_gtgteq (Chain.data chain_state)
          (fun chain_data =>
            if State.Block.equal (current_head chain_data) predecessor then
              _return ((live_blocks chain_data), (live_operations chain_data))
            else
              Chain_traversal.live_blocks predecessor max_operations_ttl))
        (fun function_parameter =>
          let '(live_blocks, live_operations) := function_parameter in
          op_gtgteqquestion
            (Block_validation.check_liveness live_blocks live_operations
              block_hash operations)
            (fun function_parameter =>
              let 'tt := function_parameter in
              match bvp with
              | Sequential vp =>
                Seq_validator.apply_block vp chain_state max_operations_ttl
                  predecessor_block_header block_header operations
              | External vp =>
                let chain_id := State.Chain.id chain_state in
                let request :=
                  Tezos_validation.External_validation.Validate
                    {| chain_id := chain_id; block_header := block_header;
                      predecessor_block_header := predecessor_block_header;
                      operations := operations;
                      max_operations_ttl := max_operations_ttl |} in
                External_validator.send_request vp request
                  Block_validation.result_encoding
              end))).

Definition commit_genesis
  (bvp : t) (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (time : Tezos_base__TzPervasives.Time.Protocol.t)
  (protocol : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Context_hash.t) :=
  match bvp with
  | Sequential {| context_index := context_index |} =>
    op_gtgteq (Context.commit_genesis context_index chain_id time protocol)
      (fun res => _return res)
  | External vp =>
    let request :=
      Tezos_validation.External_validation.Commit_genesis
        {| chain_id := chain_id; genesis_hash := genesis_hash; time := time;
          protocol := protocol |} in
    External_validator.send_request vp request Context_hash.encoding
  end.

Definition init_test_chain (bvp : t) (forking_block : Tezos_shell.State.Block.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
  let forked_header := State.Block.header forking_block in
  match bvp with
  | Sequential _ =>
    op_gtgteqquestion (State.Block.context forking_block)
      (fun context => Block_validation.init_test_chain context forked_header)
  | External vp =>
    let context_hash := context (shell forked_header) in
    let request :=
      Tezos_validation.External_validation.Fork_test_chain
        {| context_hash := context_hash; forked_header := forked_header |} in
    External_validator.send_request vp request Block_header.encoding
  end.

src/lib_shell/bootstrap_pipeline.ml 187 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.validator.bootstrap_pipeline"
end)

let node_time_tag =
  Tag.def ~doc:"local time at this node" "node_time" Time.System.pp_hum

let block_time_tag =
  Tag.def
    ~doc:"claimed creation time of block"
    "block_time"
    (fun fmt prot_time -> Time.System.(pp_hum fmt (of_protocol_exn prot_time)))

open Validation_errors

type t = {
  canceler : Lwt_canceler.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  mutable headers_fetch_worker : unit Lwt.t;
  mutable operations_fetch_worker : unit Lwt.t;
  mutable validation_worker : unit Lwt.t;
  peer_id : P2p_peer.Id.t;
  chain_db : Distributed_db.chain_db;
  locator : Block_locator.t;
  block_validator : Block_validator.t;
  notify_new_block : State.Block.t -> unit;
  fetched_headers : (Block_hash.t * Block_header.t) list Lwt_pipe.t;
  fetched_blocks :
    (Block_hash.t * Block_header.t * Operation.t list list tzresult Lwt.t)
    Lwt_pipe.t;
  (* HACK, a worker should be able to return the 'error'. *)
  mutable errors : Error_monad.error list;
}

let operations_index_tag =
  Tag.def ~doc:"Operations index" "operations_index" Format.pp_print_int

let assert_acceptable_header pipeline hash (header : Block_header.t) =
  let chain_state = Distributed_db.chain_state pipeline.chain_db in
  let time_now = Systime_os.now () in
  fail_unless
    ( Time.Protocol.compare
        (Time.Protocol.add (Time.System.to_protocol (Systime_os.now ())) 15L)
        header.shell.timestamp
    >= 0 )
    (Future_block_header
       {block = hash; time = time_now; block_time = header.shell.timestamp})
  >>=? fun () ->
  State.Chain.checkpoint chain_state
  >>= fun checkpoint ->
  fail_when
    ( Int32.equal header.shell.level checkpoint.shell.level
    && not (Block_header.equal checkpoint header) )
    (Checkpoint_error (hash, Some pipeline.peer_id))
  >>=? fun () ->
  Chain.head chain_state
  >>= fun head ->
  let checkpoint_reached =
    (State.Block.header head).shell.level >= checkpoint.shell.level
  in
  if checkpoint_reached then
    (* If reached the checkpoint, every block before the checkpoint
       must be part of the chain. *)
    if header.shell.level <= checkpoint.shell.level then
      Chain.mem chain_state hash
      >>= fun in_chain ->
      fail_unless in_chain (Checkpoint_error (hash, Some pipeline.peer_id))
    else return_unit
  else return_unit

let fetch_step pipeline (step : Block_locator.step) =
  ( if step.step > 2000 then
    lwt_log_notice
      Tag.DSL.(
        fun f ->
          f
            "fetching a large bootstrap step (%a headers) from peer %a, this \
             may take a while."
          -% t event "fetching_large_step_from_peer"
          -% a (Tag.def ~doc:"" "length" Format.pp_print_int) step.step
          -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
  else
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "fetching step %a -> %a (%a) from peer %a."
          -% t event "fetching_step_from_peer"
          -% a Block_hash.Logging.tag step.block
          -% a Block_hash.Logging.predecessor_tag step.predecessor
          -% a (Tag.def ~doc:"" "" Block_locator.pp_step) step
          -% a P2p_peer.Id.Logging.tag pipeline.peer_id) )
  >>= fun () ->
  let rec fetch_loop acc hash cpt =
    Lwt_unix.yield ()
    >>= fun () ->
    ( if step.step > 2000 && step.step <> cpt && (step.step - cpt) mod 1000 = 0
    then
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "fetched %a/%a headers from peer %a, and continuing."
            -% t event "still_fetching_large_step_from_peer"
            -% a
                 (Tag.def ~doc:"" "fetched" Format.pp_print_int)
                 (step.step - cpt)
            -% a (Tag.def ~doc:"" "length" Format.pp_print_int) step.step
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
    else Lwt.return_unit )
    >>= fun () ->
    if cpt < 0 then
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "invalid step from peer %a (too long)."
            -% t event "step_too_long"
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () -> fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
    else if Block_hash.equal hash step.predecessor then
      if step.strict_step && cpt <> 0 then
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "invalid step from peer %a (too short)."
              -% t event "step_too_short"
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        fail (Invalid_locator (pipeline.peer_id, pipeline.locator))
      else return acc
    else
      let chain_state = Distributed_db.chain_state pipeline.chain_db in
      Chain.mem chain_state hash
      >>= fun in_chain ->
      if in_chain then return acc
      else
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "fetching block header %a from peer %a."
              -% t event "fetching_block_header_from_peer"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        protect ~canceler:pipeline.canceler (fun () ->
            Distributed_db.Block_header.fetch
              ~timeout:pipeline.block_header_timeout
              pipeline.chain_db
              ~peer:pipeline.peer_id
              hash
              ())
        >>=? fun header ->
        assert_acceptable_header pipeline hash header
        >>=? fun () ->
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "fetched block header %a from peer %a."
              -% t event "fetched_block_header_from_peer"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        fetch_loop ((hash, header) :: acc) header.shell.predecessor (cpt - 1)
  in
  fetch_loop [] step.block step.step

let headers_fetch_worker_loop pipeline =
  (let sender_id = Distributed_db.my_peer_id pipeline.chain_db in
   (* sender and receiver are inverted here because they are from
       the point of view of the node sending the locator *)
   let seed =
     {Block_locator.sender_id = pipeline.peer_id; receiver_id = sender_id}
   in
   let chain_state = Distributed_db.chain_state pipeline.chain_db in
   let state = State.Chain.global_state chain_state in
   State.history_mode state
   >>= fun history_mode ->
   ( match history_mode with
   | History_mode.Archive ->
       Lwt.return_none
   | Full | Rolling ->
       let chain_state = Distributed_db.chain_state pipeline.chain_db in
       State.Chain.save_point chain_state >>= Lwt.return_some )
   >>= fun save_point ->
   (* In Full and Rolling mode, we do not want to receive blocks
         that are past our save point's level, otherwise we would
         start validating them again. *)
   let steps =
     match save_point with
     | None ->
         Block_locator.to_steps seed pipeline.locator
     | Some (save_point_level, save_point) ->
         let (head, _) = (pipeline.locator : Block_locator.t :> _ * _) in
         let head_level = head.shell.level in
         let truncate_limit = Int32.(sub head_level save_point_level) in
         Block_locator.to_steps_truncate
           ~limit:(Int32.to_int truncate_limit)
           ~save_point
           seed
           pipeline.locator
   in
   match steps with
   | [] ->
       fail (Too_short_locator (sender_id, pipeline.locator))
   | {Block_locator.predecessor; _} :: _ ->
       State.Block.known chain_state predecessor
       >>= fun predecessor_known ->
       (* Check that the locator is anchored in a block locally known *)
       fail_unless
         predecessor_known
         (Too_short_locator (sender_id, pipeline.locator))
       >>=? fun () ->
       let rec process_headers headers =
         let (batch, remaining_headers) = List.split_n 20 headers in
         protect ~canceler:pipeline.canceler (fun () ->
             Lwt_pipe.push pipeline.fetched_headers batch
             >>= fun () -> return_unit)
         >>=? fun () ->
         match remaining_headers with
         | [] ->
             return_unit
         | _ ->
             process_headers remaining_headers
       in
       let rec pipe ?pred = function
         | [] ->
             return_unit
         | first :: (second :: _ as rest) ->
             let fetch =
               match pred with
               | None ->
                   fetch_step pipeline first
               | Some fetch ->
                   fetch
             in
             let pred = fetch_step pipeline second in
             fetch
             >>=? fun headers ->
             process_headers headers >>=? fun () -> pipe ~pred rest
         | [last] ->
             let fetch =
               match pred with
               | None ->
                   fetch_step pipeline last
               | Some fetch ->
                   fetch
             in
             fetch >>=? process_headers
       in
       pipe steps)
  >>= function
  | Ok () ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "fetched all steps from peer %a."
            -% t event "fetched_all_steps_from_peer"
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () ->
      Lwt_pipe.close pipeline.fetched_headers ;
      Lwt.return_unit
  | Error (Exn Lwt.Canceled :: _)
  | Error (Canceled :: _)
  | Error (Exn Lwt_pipe.Closed :: _) ->
      Lwt.return_unit
  | Error (Distributed_db.Block_header.Timeout bh :: _) ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "request for header %a from peer %a timed out."
            -% t event "header_request_timeout"
            -% a Block_hash.Logging.tag bh
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error (Future_block_header {block; block_time; time} :: _) ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f
              "Block locator %a from peer %a contains future blocks. local \
               time: %a, block time: %a"
            -% t event "locator_contains_future_blocks"
            -% a Block_hash.Logging.tag block
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id
            -% a node_time_tag time
            -% a block_time_tag block_time)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error (Too_short_locator _ :: _ as err) ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Too short locator received" -% t event "too_short_locator")
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error err ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (headers fetch):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler

let rec operations_fetch_worker_loop pipeline =
  Lwt_unix.yield ()
  >>= (fun () ->
        protect ~canceler:pipeline.canceler (fun () ->
            Lwt_pipe.pop pipeline.fetched_headers >>= return)
        >>=? fun batch ->
        map_p
          (fun (hash, header) ->
            lwt_log_info
              Tag.DSL.(
                fun f ->
                  f "fetching operations of block %a from peer %a."
                  -% t event "fetching_operations"
                  -% a Block_hash.Logging.tag hash
                  -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
            >>= fun () ->
            let operations =
              map_p
                (fun i ->
                  protect ~canceler:pipeline.canceler (fun () ->
                      Distributed_db.Operations.fetch
                        ~timeout:pipeline.block_operations_timeout
                        pipeline.chain_db
                        ~peer:pipeline.peer_id
                        (hash, i)
                        header.Block_header.shell.operations_hash
                      >>= fun res -> Lwt.return res))
                (0 -- (header.shell.validation_passes - 1))
              >>=? fun operations ->
              lwt_log_info
                Tag.DSL.(
                  fun f ->
                    f "fetched operations of block %a from peer %a."
                    -% t event "fetched_operations"
                    -% a Block_hash.Logging.tag hash
                    -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
              >>= fun () -> return operations
            in
            return (hash, header, operations))
          batch
        >>=? fun operationss ->
        iter_s
          (fun (hash, header, operations) ->
            protect ~canceler:pipeline.canceler (fun () ->
                Lwt_pipe.push pipeline.fetched_blocks (hash, header, operations)
                >>= fun () -> return_unit))
          operationss)
  >>= function
  | Ok () ->
      operations_fetch_worker_loop pipeline
  | Error (Exn Lwt.Canceled :: _)
  | Error (Canceled :: _)
  | Error (Exn Lwt_pipe.Closed :: _) ->
      Lwt_pipe.close pipeline.fetched_blocks ;
      Lwt.return_unit
  | Error (Distributed_db.Operations.Timeout (bh, n) :: _) ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "request for operations %a:%d from peer %a timed out."
            -% t event "request_operations_timeout"
            -% a Block_hash.Logging.tag bh
            -% s operations_index_tag n
            -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler
  | Error err ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (operations fetch):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler

let rec validation_worker_loop pipeline =
  Lwt_unix.yield ()
  >>= (fun () ->
        protect ~canceler:pipeline.canceler (fun () ->
            Lwt_pipe.pop pipeline.fetched_blocks >>= return)
        >>=? fun (hash, header, operations) ->
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "requesting validation for block %a from peer %a."
              -% t event "requesting_validation"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () ->
        operations
        >>=? fun operations ->
        protect ~canceler:pipeline.canceler (fun () ->
            Block_validator.validate
              ~canceler:pipeline.canceler
              ~notify_new_block:pipeline.notify_new_block
              pipeline.block_validator
              pipeline.chain_db
              hash
              header
              operations)
        >>=? fun _block ->
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "validated block %a from peer %a."
              -% t event "validated_block"
              -% a Block_hash.Logging.tag hash
              -% a P2p_peer.Id.Logging.tag pipeline.peer_id)
        >>= fun () -> return_unit)
  >>= function
  | Ok () ->
      validation_worker_loop pipeline
  | Error ((Exn Lwt.Canceled | Canceled | Exn Lwt_pipe.Closed) :: _) ->
      Lwt.return_unit
  | Error
      ( ( Block_validator_errors.Invalid_block _
        | Block_validator_errors.Unavailable_protocol _
        | Block_validator_errors.System_error _
        | Timeout )
        :: _ as err ) ->
      (* Propagate the error to the peer validator. *)
      pipeline.errors <- pipeline.errors @ err ;
      Lwt_canceler.cancel pipeline.canceler
  | Error err ->
      pipeline.errors <- pipeline.errors @ err ;
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (validator):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel pipeline.canceler

let create ?(notify_new_block = fun _ -> ()) ~block_header_timeout
    ~block_operations_timeout block_validator peer_id chain_db locator =
  let canceler = Lwt_canceler.create () in
  let fetched_headers = Lwt_pipe.create ~size:(1024, fun _ -> 1) () in
  let fetched_blocks = Lwt_pipe.create ~size:(128, fun _ -> 1) () in
  let pipeline =
    {
      canceler;
      block_header_timeout;
      block_operations_timeout;
      headers_fetch_worker = Lwt.return_unit;
      operations_fetch_worker = Lwt.return_unit;
      validation_worker = Lwt.return_unit;
      notify_new_block;
      peer_id;
      chain_db;
      locator;
      block_validator;
      fetched_headers;
      fetched_blocks;
      errors = [];
    }
  in
  Lwt_canceler.on_cancel pipeline.canceler (fun () ->
      Lwt_pipe.close fetched_blocks ;
      Lwt_pipe.close fetched_headers ;
      (* TODO proper cleanup of ressources... *)
      Lwt.return_unit) ;
  let (head, _) = (pipeline.locator : Block_locator.t :> _ * _) in
  let hash = Block_header.hash head in
  pipeline.headers_fetch_worker <-
    Lwt_utils.worker
      (Format.asprintf
         "bootstrap_pipeline-headers_fetch.%a.%a"
         P2p_peer.Id.pp_short
         peer_id
         Block_hash.pp_short
         hash)
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> headers_fetch_worker_loop pipeline)
      ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
  pipeline.operations_fetch_worker <-
    Lwt_utils.worker
      (Format.asprintf
         "bootstrap_pipeline-operations_fetch.%a.%a"
         P2p_peer.Id.pp_short
         peer_id
         Block_hash.pp_short
         hash)
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> operations_fetch_worker_loop pipeline)
      ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
  pipeline.validation_worker <-
    Lwt_utils.worker
      (Format.asprintf
         "bootstrap_pipeline-validation.%a.%a"
         P2p_peer.Id.pp_short
         peer_id
         Block_hash.pp_short
         hash)
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> validation_worker_loop pipeline)
      ~cancel:(fun () -> Lwt_canceler.cancel pipeline.canceler) ;
  pipeline

let wait_workers pipeline =
  pipeline.headers_fetch_worker
  >>= fun () ->
  pipeline.operations_fetch_worker >>= fun () -> pipeline.validation_worker

let wait pipeline =
  wait_workers pipeline
  >>= fun () ->
  match pipeline.errors with
  | [] ->
      return_unit
  | errors ->
      Lwt.return_error errors

let cancel pipeline =
  Lwt_canceler.cancel pipeline.canceler >>= fun () -> wait_workers pipeline

let length pipeline =
  Peer_validator_worker_state.Worker_state.
    {
      fetched_header_length = Lwt_pipe.length pipeline.fetched_headers;
      fetched_block_length = Lwt_pipe.length pipeline.fetched_blocks;
    }

let length_zero =
  Peer_validator_worker_state.Worker_state.
    {fetched_header_length = 0; fetched_block_length = 0}
src/lib_shell/bootstrap_pipeline.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition node_time_tag : Tag.def Tezos_base__TzPervasives.Time.System.t :=
  Tag.def (Some "local time at this node" % string) "node_time" % string
    Time.System.pp_hum.

Definition block_time_tag : Tag.def Tezos_base__Time.Protocol.t :=
  Tag.def (Some "claimed creation time of block" % string) "block_time" % string
    (fun fmt => fun prot_time => pp_hum fmt (of_protocol_exn prot_time)).

Import Validation_errors.

Record t := {
  canceler : Tezos_base__TzPervasives.Lwt_canceler.t;
  block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  headers_fetch_worker : Lwt.t unit;
  operations_fetch_worker : Lwt.t unit;
  validation_worker : Lwt.t unit;
  peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
  chain_db : Tezos_shell.Distributed_db.chain_db;
  locator : Tezos_base__TzPervasives.Block_locator.t;
  block_validator : Tezos_shell.Block_validator.t;
  notify_new_block : Tezos_shell.State.Block.t -> unit;
  fetched_headers :
    Tezos_base__TzPervasives.Lwt_pipe.t
      (list
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t));
  fetched_blocks :
    Tezos_base__TzPervasives.Lwt_pipe.t
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t *
        (Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list (list Tezos_base__TzPervasives.Operation.t)))));
  errors : list Tezos_base__TzPervasives.Error_monad.error }.

Definition operations_index_tag : Tag.def Z :=
  Tag.def (Some "Operations index" % string) "operations_index" % string
    Format.pp_print_int.

Definition assert_acceptable_header
  (pipeline : t) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let chain_state := Distributed_db.chain_state (chain_db pipeline) in
  let time_now := Systime_os.now tt in
  op_gtgteqquestion
    (fail_unless
      (OCaml.Stdlib.ge
        (Time.Protocol.compare
          (Time.Protocol.add (Time.System.to_protocol (Systime_os.now tt))
            (* ❌ Constant of type int64 is converted to int *)
            15) (timestamp (shell header))) 0)
      (Tezos_base__TzPervasives.Future_block_header
        {| block := hash; block_time := timestamp (shell header);
          time := time_now |}))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint chain_state)
        (fun checkpoint =>
          op_gtgteqquestion
            (fail_when
              (andb
                (Int32.equal (level (shell header)) (level (shell checkpoint)))
                (negb (Block_header.equal checkpoint header)))
              (Tezos_base__TzPervasives.Checkpoint_error hash
                (Some (peer_id pipeline))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Chain.head chain_state)
                (fun head =>
                  let checkpoint_reached :=
                    OCaml.Stdlib.ge (level (shell (State.Block.header head)))
                      (level (shell checkpoint)) in
                  if checkpoint_reached then
                    if
                      OCaml.Stdlib.le (level (shell header))
                        (level (shell checkpoint)) then
                      op_gtgteq (Chain.mem chain_state hash)
                        (fun in_chain =>
                          fail_unless in_chain
                            (Tezos_base__TzPervasives.Checkpoint_error hash
                              (Some (peer_id pipeline))))
                    else
                      return_unit
                  else
                    return_unit)))).

Definition fetch_step
  (pipeline : t) (step : Tezos_base__TzPervasives.Block_locator.step)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t))) :=
  op_gtgteq
    (if OCaml.Stdlib.gt (step step) 2000 then
      lwt_log_notice
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "fetching a large bootstrap step (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " headers) from peer " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              ", this may take a while." % string
                              CamlinternalFormatBasics.End_of_format)))))
                    "fetching a large bootstrap step (%a headers) from peer %a, this may take a while."
                      % string))
                (t event "fetching_large_step_from_peer" % string))
              (a
                (Tag.def (Some "" % string) "length" % string
                  Format.pp_print_int) (step step)))
            (a P2p_peer.Id.Logging.tag (peer_id pipeline)))
    else
      lwt_log_info
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "fetching step " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " -> " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " (" % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      ") from peer " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "." % char
                                          CamlinternalFormatBasics.End_of_format)))))))))
                        "fetching step %a -> %a (%a) from peer %a." % string))
                    (t event "fetching_step_from_peer" % string))
                  (a Block_hash.Logging.tag (block step)))
                (a Block_hash.Logging.predecessor_tag (predecessor step)))
              (a (Tag.def (Some "" % string) "" % string Block_locator.pp_step)
                step)) (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      let fix fetch_loop
        (acc :
        list
          (Tezos_base__TzPervasives.Block_hash.t *
            Tezos_base__TzPervasives.Block_header.t)) (hash :
        Tezos_base__TzPervasives.Block_hash.t) (cpt : Z)
        : Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list
              (Tezos_base__TzPervasives.Block_hash.t *
                Tezos_base__TzPervasives.Block_header.t))) :=
        op_gtgteq (Lwt_unix.yield tt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (if
                andb (OCaml.Stdlib.gt (step step) 2000)
                  (andb (nequiv_decb (step step) cpt)
                    (equiv_decb (Z.modulo (Z.sub (step step) cpt) 1000) 0)) then
                lwt_log_notice
                  (fun f =>
                    op_minuspercent
                      (op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "fetched " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "/" % char
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " headers from peer " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              ", and continuing." % string
                                              CamlinternalFormatBasics.End_of_format)))))))
                                "fetched %a/%a headers from peer %a, and continuing."
                                  % string))
                            (t event
                              "still_fetching_large_step_from_peer" % string))
                          (a
                            (Tag.def (Some "" % string) "fetched" % string
                              Format.pp_print_int) (Z.sub (step step) cpt)))
                        (a
                          (Tag.def (Some "" % string) "length" % string
                            Format.pp_print_int) (step step)))
                      (a P2p_peer.Id.Logging.tag (peer_id pipeline)))
              else
                Lwt.return_unit)
              (fun function_parameter =>
                let 'tt := function_parameter in
                if OCaml.Stdlib.lt cpt 0 then
                  op_gtgteq
                    (lwt_log_info
                      (fun f =>
                        op_minuspercent
                          (op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "invalid step from peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " (too long)." % string
                                      CamlinternalFormatBasics.End_of_format)))
                                "invalid step from peer %a (too long)." % string))
                            (t event "step_too_long" % string))
                          (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      fail
                        (Tezos_base__TzPervasives.Invalid_locator
                          (peer_id pipeline) (locator pipeline)))
                else
                  if Block_hash.equal hash (predecessor step) then
                    if andb (strict_step step) (nequiv_decb cpt 0) then
                      op_gtgteq
                        (lwt_log_info
                          (fun f =>
                            op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "invalid step from peer " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " (too short)." % string
                                          CamlinternalFormatBasics.End_of_format)))
                                    "invalid step from peer %a (too short)." %
                                      string))
                                (t event "step_too_short" % string))
                              (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          fail
                            (Tezos_base__TzPervasives.Invalid_locator
                              (peer_id pipeline) (locator pipeline)))
                    else
                      _return acc
                  else
                    let chain_state :=
                      Distributed_db.chain_state (chain_db pipeline) in
                    op_gtgteq (Chain.mem chain_state hash)
                      (fun in_chain =>
                        if in_chain then
                          _return acc
                        else
                          op_gtgteq
                            (lwt_log_info
                              (fun f =>
                                op_minuspercent
                                  (op_minuspercent
                                    (op_minuspercent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "fetching block header " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " from peer " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "." % char
                                                    CamlinternalFormatBasics.End_of_format)))))
                                          "fetching block header %a from peer %a."
                                            % string))
                                      (t event
                                        "fetching_block_header_from_peer" %
                                          string))
                                    (a Block_hash.Logging.tag hash))
                                  (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (protect None (Some (canceler pipeline))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    Distributed_db.Block_header.fetch
                                      (chain_db pipeline)
                                      (Some (peer_id pipeline))
                                      (Some (block_header_timeout pipeline))
                                      hash tt))
                                (fun header =>
                                  op_gtgteqquestion
                                    (assert_acceptable_header pipeline hash
                                      header)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (lwt_log_info
                                          (fun f =>
                                            op_minuspercent
                                              (op_minuspercent
                                                (op_minuspercent
                                                  (f
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "fetched block header "
                                                          % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.String_literal
                                                            " from peer " %
                                                              string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Char_literal
                                                                "." % char
                                                                CamlinternalFormatBasics.End_of_format)))))
                                                      "fetched block header %a from peer %a."
                                                        % string))
                                                  (t event
                                                    "fetched_block_header_from_peer"
                                                      % string))
                                                (a Block_hash.Logging.tag hash))
                                              (a P2p_peer.Id.Logging.tag
                                                (peer_id pipeline))))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          fetch_loop (cons (hash, header) acc)
                                            (predecessor (shell header))
                                            (Z.sub cpt 1)))))))) in
      fetch_loop [] (block step) (step step)).

Definition headers_fetch_worker_loop (pipeline : t) : Lwt.t unit :=
  op_gtgteq
    (let sender_id := Distributed_db.my_peer_id (chain_db pipeline) in
    let seed :=
      {| Block_locator.sender_id := peer_id pipeline;
        Block_locator.receiver_id := sender_id |} in
    let chain_state := Distributed_db.chain_state (chain_db pipeline) in
    let state := State.Chain.global_state chain_state in
    op_gtgteq (State.history_mode state)
      (fun history_mode =>
        op_gtgteq
          match history_mode with
          | Tezos_shell_services.History_mode.Archive => Lwt.return_none
          |
            Tezos_shell_services.History_mode.Full |
              Tezos_shell_services.History_mode.Rolling =>
            let chain_state := Distributed_db.chain_state (chain_db pipeline) in
            op_gtgteq (State.Chain.save_point chain_state) Lwt.return_some
          end
          (fun save_point =>
            let steps :=
              match save_point with
              | None => Block_locator.to_steps seed (locator pipeline)
              | Some (save_point_level, save_point) =>
                let '(head, _) := locator pipeline in
                let head_level := level (shell head) in
                let truncate_limit := sub head_level save_point_level in
                Block_locator.to_steps_truncate (Int32.to_int truncate_limit)
                  save_point seed (locator pipeline)
              end in
            match steps with
            | [] =>
              fail
                (Tezos_base__TzPervasives.Too_short_locator sender_id
                  (locator pipeline))
            | cons {| Block_locator.predecessor := predecessor |} _ =>
              op_gtgteq (State.Block.known chain_state predecessor)
                (fun predecessor_known =>
                  op_gtgteqquestion
                    (fail_unless predecessor_known
                      (Tezos_base__TzPervasives.Too_short_locator sender_id
                        (locator pipeline)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let fix process_headers
                        (headers :
                        list
                          (Tezos_base__TzPervasives.Block_hash.t *
                            Tezos_base__TzPervasives.Block_header.t))
                        : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                        let '(batch, remaining_headers) :=
                          List.split_n 20 headers in
                        op_gtgteqquestion
                          (protect None (Some (canceler pipeline))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (Lwt_pipe.push (fetched_headers pipeline) batch)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit)))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            match remaining_headers with
                            | [] => return_unit
                            | _ => process_headers remaining_headers
                            end) in
                      let fix pipe
                        (pred :
                        option
                          (Lwt.t
                            (Tezos_base__TzPervasives.tzresult
                              (list
                                (Tezos_base__TzPervasives.Block_hash.t *
                                  Tezos_base__TzPervasives.Block_header.t)))))
                        (function_parameter :
                        list Tezos_base__TzPervasives.Block_locator.step)
                        : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                        match function_parameter with
                        | [] => return_unit
                        | cons first ((cons second _) as rest) =>
                          let fetch :=
                            match pred with
                            | None => fetch_step pipeline first
                            | Some fetch => fetch
                            end in
                          let pred := fetch_step pipeline second in
                          op_gtgteqquestion fetch
                            (fun headers =>
                              op_gtgteqquestion (process_headers headers)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  pipe (Some pred) rest))
                        | cons last [] =>
                          let fetch :=
                            match pred with
                            | None => fetch_step pipeline last
                            | Some fetch => fetch
                            end in
                          op_gtgteqquestion fetch process_headers
                        end in
                      pipe None steps))
            end)))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt =>
        op_gtgteq
          (lwt_log_info
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "fetched all steps from peer " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "." % char
                            CamlinternalFormatBasics.End_of_format)))
                      "fetched all steps from peer %a." % string))
                  (t event "fetched_all_steps_from_peer" % string))
                (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Lwt_pipe.close (fetched_headers pipeline) in
            Lwt.return_unit)
      |
        Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Canceled) _) |
          Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
          Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
        Lwt.return_unit
      | Stdlib.Error (cons (Tezos_base__TzPervasives.Timeout bh) _) =>
        op_gtgteq
          (lwt_log_info
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "request for header " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " from peer " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " timed out." % string
                                  CamlinternalFormatBasics.End_of_format)))))
                        "request for header %a from peer %a timed out." % string))
                    (t event "header_request_timeout" % string))
                  (a Block_hash.Logging.tag bh))
                (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      |
        Stdlib.Error
          (cons
            (Tezos_base__TzPervasives.Future_block_header {|
              block := block; block_time := block_time; time := time |}) _)
        =>
        op_gtgteq
          (lwt_log_notice
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Block locator " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " from peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " contains future blocks. local time: " %
                                        string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          ", block time: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))))))))
                            "Block locator %a from peer %a contains future blocks. local time: %a, block time: %a"
                              % string))
                        (t event "locator_contains_future_blocks" % string))
                      (a Block_hash.Logging.tag block))
                    (a P2p_peer.Id.Logging.tag (peer_id pipeline)))
                  (a node_time_tag time)) (a block_time_tag block_time)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      |
        Stdlib.Error
          ((cons (Tezos_base__TzPervasives.Too_short_locator _ _) _) as err) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pipeline "errors" % string
            (OCaml.Stdlib.app (errors pipeline) err) in
        op_gtgteq
          (lwt_log_info
            (fun f =>
              op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Too short locator received" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Too short locator received" % string))
                (t event "too_short_locator" % string)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pipeline "errors" % string
            (OCaml.Stdlib.app (errors pipeline) err) in
        op_gtgteq
          (lwt_log_error
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (headers fetch):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (headers fetch):@ %a@]" % string))
                  (t event "unexpected_error" % string)) (a errs_tag err)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      end).

Fixpoint operations_fetch_worker_loop (pipeline : t) : Lwt.t unit :=
  op_gtgteq
    (op_gtgteq (Lwt_unix.yield tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (protect None (Some (canceler pipeline))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Lwt_pipe.pop (fetched_headers pipeline)) _return))
          (fun batch =>
            op_gtgteqquestion
              (map_p
                (fun function_parameter =>
                  let '(hash, header) := function_parameter in
                  op_gtgteq
                    (lwt_log_info
                      (fun f =>
                        op_minuspercent
                          (op_minuspercent
                            (op_minuspercent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "fetching operations of block " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " from peer " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Char_literal
                                            "." % char
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "fetching operations of block %a from peer %a."
                                    % string))
                              (t event "fetching_operations" % string))
                            (a Block_hash.Logging.tag hash))
                          (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let operations :=
                        op_gtgteqquestion
                          (map_p
                            (fun i =>
                              protect None (Some (canceler pipeline))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (Distributed_db.Operations.fetch
                                      (chain_db pipeline)
                                      (Some (peer_id pipeline))
                                      (Some (block_operations_timeout pipeline))
                                      (hash, i)
                                      (operations_hash
                                        (Block_header.shell header)))
                                    (fun res => Lwt._return res)))
                            (op_minusminus 0
                              (Z.sub (validation_passes (shell header)) 1)))
                          (fun operations =>
                            op_gtgteq
                              (lwt_log_info
                                (fun f =>
                                  op_minuspercent
                                    (op_minuspercent
                                      (op_minuspercent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "fetched operations of block " %
                                                string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " from peer " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "." % char
                                                      CamlinternalFormatBasics.End_of_format)))))
                                            "fetched operations of block %a from peer %a."
                                              % string))
                                        (t event "fetched_operations" % string))
                                      (a Block_hash.Logging.tag hash))
                                    (a P2p_peer.Id.Logging.tag
                                      (peer_id pipeline))))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                _return operations)) in
                      _return (hash, header, operations))) batch)
              (fun operationss =>
                iter_s
                  (fun function_parameter =>
                    let '(hash, header, operations) := function_parameter in
                    protect None (Some (canceler pipeline))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq
                          (Lwt_pipe.push (fetched_blocks pipeline)
                            (hash, header, operations))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit))) operationss))))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => operations_fetch_worker_loop pipeline
      |
        Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Canceled) _) |
          Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
          Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_pipe.close (fetched_blocks pipeline) in
        Lwt.return_unit
      | Stdlib.Error (cons (Tezos_base__TzPervasives.Timeout (bh, n)) _) =>
        op_gtgteq
          (lwt_log_info
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "request for operations " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal ":" % char
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " from peer " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " timed out." % string
                                        CamlinternalFormatBasics.End_of_format)))))))
                          "request for operations %a:%d from peer %a timed out."
                            % string))
                      (t event "request_operations_timeout" % string))
                    (a Block_hash.Logging.tag bh)) (s operations_index_tag n))
                (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pipeline "errors" % string
            (OCaml.Stdlib.app (errors pipeline) err) in
        op_gtgteq
          (lwt_log_error
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (operations fetch):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (operations fetch):@ %a@]" % string))
                  (t event "unexpected_error" % string)) (a errs_tag err)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      end).

Fixpoint validation_worker_loop (pipeline : t) : Lwt.t unit :=
  op_gtgteq
    (op_gtgteq (Lwt_unix.yield tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (protect None (Some (canceler pipeline))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Lwt_pipe.pop (fetched_blocks pipeline)) _return))
          (fun function_parameter =>
            let '(hash, header, operations) := function_parameter in
            op_gtgteq
              (lwt_log_info
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "requesting validation for block " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " from peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "." % char
                                      CamlinternalFormatBasics.End_of_format)))))
                            "requesting validation for block %a from peer %a." %
                              string))
                        (t event "requesting_validation" % string))
                      (a Block_hash.Logging.tag hash))
                    (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion operations
                  (fun operations =>
                    op_gtgteqquestion
                      (protect None (Some (canceler pipeline))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Block_validator.validate (block_validator pipeline)
                            (Some (canceler pipeline)) None
                            (Some (notify_new_block pipeline))
                            (chain_db pipeline) hash header operations))
                      (fun _block =>
                        op_gtgteq
                          (lwt_log_info
                            (fun f =>
                              op_minuspercent
                                (op_minuspercent
                                  (op_minuspercent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "validated block " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " from peer " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "." % char
                                                  CamlinternalFormatBasics.End_of_format)))))
                                        "validated block %a from peer %a." %
                                          string))
                                    (t event "validated_block" % string))
                                  (a Block_hash.Logging.tag hash))
                                (a P2p_peer.Id.Logging.tag (peer_id pipeline))))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)))))))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => validation_worker_loop pipeline
      |
        Stdlib.Error
          (cons
            (Tezos_base__TzPervasives.Exn Canceled |
              Tezos_base__TzPervasives.Canceled |
              Tezos_base__TzPervasives.Exn Closed) _) => Lwt.return_unit
      |
        Stdlib.Error
          ((cons
            (Tezos_base__TzPervasives.Invalid_block _ |
              Tezos_base__TzPervasives.Unavailable_protocol _ |
              Tezos_base__TzPervasives.System_error _ |
              Tezos_base__TzPervasives.Timeout) _) as err) =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pipeline "errors" % string
            (OCaml.Stdlib.app (errors pipeline) err) in
        Lwt_canceler.cancel (canceler pipeline)
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pipeline "errors" % string
            (OCaml.Stdlib.app (errors pipeline) err) in
        op_gtgteq
          (lwt_log_error
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (validator):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (validator):@ %a@]" % string))
                  (t event "unexpected_error" % string)) (a errs_tag err)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler pipeline))
      end).

Definition create (op_staroptstar : option (Tezos_shell.State.Block.t -> unit))
  : Tezos_base__TzPervasives.Time.System.Span.t ->
    Tezos_base__TzPervasives.Time.System.Span.t ->
      Tezos_shell.Block_validator.t ->
        Tezos_base__TzPervasives.P2p_peer.Id.t ->
          Tezos_shell.Distributed_db.chain_db ->
            Tezos_base__TzPervasives.Block_locator.t -> t :=
  let notify_new_block :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        tt
    end in
  fun block_header_timeout =>
    fun block_operations_timeout =>
      fun block_validator =>
        fun peer_id =>
          fun chain_db =>
            fun locator =>
              let canceler := Lwt_canceler.create tt in
              let fetched_headers :=
                Lwt_pipe.create
                  (Some
                    (1024,
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        1))) tt in
              let fetched_blocks :=
                Lwt_pipe.create
                  (Some
                    (128,
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        1))) tt in
              let pipeline :=
                {| canceler := canceler;
                  block_header_timeout := block_header_timeout;
                  block_operations_timeout := block_operations_timeout;
                  headers_fetch_worker := Lwt.return_unit;
                  operations_fetch_worker := Lwt.return_unit;
                  validation_worker := Lwt.return_unit; peer_id := peer_id;
                  chain_db := chain_db; locator := locator;
                  block_validator := block_validator;
                  notify_new_block := notify_new_block;
                  fetched_headers := fetched_headers;
                  fetched_blocks := fetched_blocks; errors := [] |} in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Lwt_canceler.on_cancel (canceler pipeline)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Lwt_pipe.close fetched_blocks in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Lwt_pipe.close fetched_headers in
                    Lwt.return_unit) in
              let '(head, _) := locator pipeline in
              let hash := Block_header.hash head in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field pipeline "headers_fetch_worker" % string
                  (Lwt_utils.worker
                    (Format.asprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "bootstrap_pipeline-headers_fetch." % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal "." % char
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))
                        "bootstrap_pipeline-headers_fetch.%a.%a" % string)
                      P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
                    Internal_event.Lwt_worker_event.on_event
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      headers_fetch_worker_loop pipeline)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Lwt_canceler.cancel (canceler pipeline))) in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field pipeline "operations_fetch_worker" % string
                  (Lwt_utils.worker
                    (Format.asprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "bootstrap_pipeline-operations_fetch." % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal "." % char
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))
                        "bootstrap_pipeline-operations_fetch.%a.%a" % string)
                      P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
                    Internal_event.Lwt_worker_event.on_event
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      operations_fetch_worker_loop pipeline)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Lwt_canceler.cancel (canceler pipeline))) in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field pipeline "validation_worker" % string
                  (Lwt_utils.worker
                    (Format.asprintf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "bootstrap_pipeline-validation." % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal "." % char
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))
                        "bootstrap_pipeline-validation.%a.%a" % string)
                      P2p_peer.Id.pp_short peer_id Block_hash.pp_short hash)
                    Internal_event.Lwt_worker_event.on_event
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      validation_worker_loop pipeline)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Lwt_canceler.cancel (canceler pipeline))) in
              pipeline.

Definition wait_workers (pipeline : t) : Lwt.t unit :=
  op_gtgteq (headers_fetch_worker pipeline)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (operations_fetch_worker pipeline)
        (fun function_parameter =>
          let 'tt := function_parameter in
          validation_worker pipeline)).

Definition wait (pipeline : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (wait_workers pipeline)
    (fun function_parameter =>
      let 'tt := function_parameter in
      match errors pipeline with
      | [] => return_unit
      | errors => Lwt.return_error errors
      end).

Definition cancel (pipeline : t) : Lwt.t unit :=
  op_gtgteq (Lwt_canceler.cancel (canceler pipeline))
    (fun function_parameter =>
      let 'tt := function_parameter in
      wait_workers pipeline).

Definition length (pipeline : t)
  : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
  {| fetched_header_length := Lwt_pipe.length (fetched_headers pipeline);
    fetched_block_length := Lwt_pipe.length (fetched_blocks pipeline) |}.

Definition length_zero
  : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
  {| fetched_header_length := 0; fetched_block_length := 0 |}.

src/lib_shell/chain.ml 58 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open State_logging

let genesis chain_state =
  let genesis = State.Chain.genesis chain_state in
  State.Block.read_opt chain_state genesis.block
  >|= Option.unopt_assert ~loc:__POS__

let known_heads chain_state =
  State.read_chain_data chain_state (fun chain_store _data ->
      Store.Chain_data.Known_heads.elements chain_store)
  >>= fun hashes ->
  Lwt_list.map_p
    (fun h ->
      State.Block.read_opt chain_state h >|= Option.unopt_assert ~loc:__POS__)
    hashes

let head chain_state =
  State.read_chain_data chain_state (fun _chain_store data ->
      Lwt.return data.current_head)

let mem chain_state hash =
  State.read_chain_data chain_state (fun chain_store data ->
      if Block_hash.equal (State.Block.hash data.current_head) hash then
        Lwt.return_true
      else Store.Chain_data.In_main_branch.known (chain_store, hash))

type data = State.chain_data = {
  current_head : State.Block.t;
  current_mempool : Mempool.t;
  live_blocks : Block_hash.Set.t;
  live_operations : Operation_hash.Set.t;
  test_chain : Chain_id.t option;
  save_point : Int32.t * Block_hash.t;
  caboose : Int32.t * Block_hash.t;
}

let data chain_state =
  State.read_chain_data chain_state (fun _chain_store data -> Lwt.return data)

let locator chain_state seed =
  data chain_state
  >>= fun data -> State.compute_locator chain_state data.current_head seed

let locked_set_head chain_store data block live_blocks live_operations =
  let rec pop_blocks ancestor block =
    let hash = State.Block.hash block in
    if Block_hash.equal hash ancestor then Lwt.return_unit
    else
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "pop_block %a" -% t event "pop_block"
            -% a Block_hash.Logging.tag hash)
      >>= fun () ->
      Store.Chain_data.In_main_branch.remove (chain_store, hash)
      >>= fun () ->
      State.Block.predecessor block
      >>= function
      | Some predecessor ->
          pop_blocks ancestor predecessor
      | None ->
          assert false
    (* Cannot pop the genesis... *)
  in
  let push_block pred_hash block =
    let hash = State.Block.hash block in
    lwt_debug
      Tag.DSL.(
        fun f ->
          f "push_block %a" -% t event "push_block"
          -% a Block_hash.Logging.tag hash)
    >>= fun () ->
    Store.Chain_data.In_main_branch.store (chain_store, pred_hash) hash
    >>= fun () -> Lwt.return hash
  in
  Chain_traversal.new_blocks ~from_block:data.current_head ~to_block:block
  >>= fun (ancestor, path) ->
  let ancestor = State.Block.hash ancestor in
  pop_blocks ancestor data.current_head
  >>= fun () ->
  Lwt_list.fold_left_s push_block ancestor path
  >>= fun _ ->
  Store.Chain_data.Current_head.store chain_store (State.Block.hash block)
  >>= fun () ->
  (* TODO more optimized updated of live_{blocks/operations} when the
     new head is a direct successor of the current head...
     Make sure to do the live blocks computation in `init_head`
     when this TODO is resolved. *)
  Lwt.return
    {
      data with
      current_head = block;
      current_mempool = Mempool.empty;
      live_blocks;
      live_operations;
    }

let set_head chain_state block =
  State.Block.max_operations_ttl block
  >>=? fun max_op_ttl ->
  Chain_traversal.live_blocks block max_op_ttl
  >>=? fun (live_blocks, live_operations) ->
  State.update_chain_data chain_state (fun chain_store data ->
      locked_set_head chain_store data block live_blocks live_operations
      >>= fun new_chain_data ->
      Lwt.return (Some new_chain_data, data.current_head))
  >>= fun chain_state -> return chain_state

let test_and_set_head chain_state ~old block =
  State.Block.max_operations_ttl block
  >>=? fun max_op_ttl ->
  Chain_traversal.live_blocks block max_op_ttl
  >>=? fun (live_blocks, live_operations) ->
  State.update_chain_data chain_state (fun chain_store data ->
      if not (State.Block.equal data.current_head old) then
        Lwt.return (None, false)
      else
        locked_set_head chain_store data block live_blocks live_operations
        >>= fun new_chain_data -> Lwt.return (Some new_chain_data, true))
  >>= fun chain_state -> return chain_state

let init_head chain_state =
  head chain_state
  >>= fun block ->
  set_head chain_state block >>=? fun (_ : State.Block.t) -> return_unit
src/lib_shell/chain.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import State_logging.

Definition genesis (chain_state : Tezos_shell.State.Chain.chain_state)
  : Lwt.t Tezos_shell.State.Block.t :=
  let genesis := State.Chain.genesis chain_state in
  op_gtpipeeq (State.Block.read_opt chain_state (block genesis))
    (Option.unopt_assert Stdlib.__POS__).

Definition known_heads (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t (list Tezos_shell.State.Block.t) :=
  op_gtgteq
    (State.read_chain_data chain_state
      (fun chain_store =>
        fun _data => Store.Chain_data.Known_heads.elements chain_store))
    (fun hashes =>
      Lwt_list.map_p
        (fun h =>
          op_gtpipeeq (State.Block.read_opt chain_state h)
            (Option.unopt_assert Stdlib.__POS__)) hashes).

Definition head (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t Tezos_shell.State.Block.t :=
  State.read_chain_data chain_state
    (fun _chain_store => fun data => Lwt._return (current_head data)).

Definition mem
  (chain_state : Tezos_shell.State.Chain.t)
  (hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t bool :=
  State.read_chain_data chain_state
    (fun chain_store =>
      fun data =>
        if Block_hash.equal (State.Block.hash (current_head data)) hash then
          Lwt.return_true
        else
          Store.Chain_data.In_main_branch.known (chain_store, hash)).

Record data := {
  current_head : Tezos_shell.State.Block.t;
  current_mempool : Tezos_base__TzPervasives.Mempool.t;
  live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t;
  live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t;
  test_chain : option Tezos_base__TzPervasives.Chain_id.t;
  save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t;
  caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t }.

Definition data (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t Tezos_shell.State.chain_data :=
  State.read_chain_data chain_state
    (fun _chain_store => fun data => Lwt._return data).

Definition locator
  (chain_state : Tezos_shell.State.Chain.t)
  (seed : Tezos_base__TzPervasives.Block_locator.seed)
  : Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  op_gtgteq (data chain_state)
    (fun data => State.compute_locator chain_state None (current_head data) seed).

Definition locked_set_head
  (chain_store : Tezos_shell__Store.Chain_data.store) (data : data)
  (block : Tezos_shell.State.Block.t)
  (live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
  (live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
  : Lwt.t data :=
  let fix pop_blocks
    (ancestor : Tezos_base__TzPervasives.Block_hash.t) (block :
    Tezos_shell.State.Block.t) : Lwt.t unit :=
    let hash := State.Block.hash block in
    if Block_hash.equal hash ancestor then
      Lwt.return_unit
    else
      op_gtgteq
        (lwt_debug
          (fun f =>
            op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "pop_block " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "pop_block %a" % string)) (t event "pop_block" % string))
              (a Block_hash.Logging.tag hash)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Store.Chain_data.In_main_branch.remove (chain_store, hash))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (State.Block.predecessor block)
                (fun function_parameter =>
                  match function_parameter with
                  | Some predecessor => pop_blocks ancestor predecessor
                  | None =>
                    (* ❌ Assert instruction is not handled. *)
                    assert false
                  end))) in
  let push_block
    (pred_hash : Tezos_base__TzPervasives.Block_hash.t) (block :
    Tezos_shell.State.Block.t) : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
    let hash := State.Block.hash block in
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "push_block " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "push_block %a" % string)) (t event "push_block" % string))
            (a Block_hash.Logging.tag hash)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (Store.Chain_data.In_main_branch.store (chain_store, pred_hash) hash)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt._return hash)) in
  op_gtgteq (Chain_traversal.new_blocks (current_head data) block)
    (fun function_parameter =>
      let '(ancestor, path) := function_parameter in
      let ancestor := State.Block.hash ancestor in
      op_gtgteq (pop_blocks ancestor (current_head data))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Lwt_list.fold_left_s push_block ancestor path)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteq
                (Store.Chain_data.Current_head.store chain_store
                  (State.Block.hash block))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt._return
                    (* ❌ Record substitution not handled *)
                    record_substitution)))).

Definition set_head
  (chain_state : Tezos_shell.State.Chain.t) (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.State.Block.t) :=
  op_gtgteqquestion (State.Block.max_operations_ttl block)
    (fun max_op_ttl =>
      op_gtgteqquestion (Chain_traversal.live_blocks block max_op_ttl)
        (fun function_parameter =>
          let '(live_blocks, live_operations) := function_parameter in
          op_gtgteq
            (State.update_chain_data chain_state
              (fun chain_store =>
                fun data =>
                  op_gtgteq
                    (locked_set_head chain_store data block live_blocks
                      live_operations)
                    (fun new_chain_data =>
                      Lwt._return ((Some new_chain_data), (current_head data)))))
            (fun chain_state => _return chain_state))).

Definition test_and_set_head
  (chain_state : Tezos_shell.State.Chain.t) (old : Tezos_shell.State.Block.t)
  (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  op_gtgteqquestion (State.Block.max_operations_ttl block)
    (fun max_op_ttl =>
      op_gtgteqquestion (Chain_traversal.live_blocks block max_op_ttl)
        (fun function_parameter =>
          let '(live_blocks, live_operations) := function_parameter in
          op_gtgteq
            (State.update_chain_data chain_state
              (fun chain_store =>
                fun data =>
                  if negb (State.Block.equal (current_head data) old) then
                    Lwt._return (None, false)
                  else
                    op_gtgteq
                      (locked_set_head chain_store data block live_blocks
                        live_operations)
                      (fun new_chain_data =>
                        Lwt._return ((Some new_chain_data), true))))
            (fun chain_state => _return chain_state))).

Definition init_head (chain_state : Tezos_shell.State.Chain.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (head chain_state)
    (fun block =>
      op_gtgteqquestion (set_head chain_state block)
        (fun function_parameter =>
          let '_ := function_parameter in
          return_unit)).

src/lib_shell/chain_directory.ml 69 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Chain_services

let get_chain_id state = function
  | `Main ->
      Lwt.return (State.Chain.main state)
  | `Test -> (
      State.Chain.get_exn state (State.Chain.main state)
      >>= fun main_chain ->
      State.Chain.test main_chain
      >>= function
      | None -> Lwt.fail Not_found | Some chain_id -> Lwt.return chain_id )
  | `Hash chain_id ->
      Lwt.return chain_id

let get_chain_id_opt state chain =
  Lwt.catch
    (fun () -> get_chain_id state chain >>= Lwt.return_some)
    (fun _exn -> Lwt.return_none)

let get_chain state chain =
  get_chain_id state chain
  >>= fun chain_id -> State.Chain.get_exn state chain_id

let get_checkpoint state (chain : Chain_services.chain) =
  get_chain state chain
  >>= fun chain ->
  State.Chain.checkpoint chain
  >>= fun header -> Lwt.return (Block_header.hash header)

let predecessors ignored length head =
  let rec loop acc length block =
    if length <= 0 then Lwt.return (List.rev acc)
    else
      State.Block.predecessor block
      >>= function
      | None ->
          Lwt.return (List.rev acc)
      | Some pred ->
          if Block_hash.Set.mem (State.Block.hash block) ignored then
            Lwt.return (List.rev acc)
          else loop (State.Block.hash pred :: acc) (length - 1) pred
  in
  loop [State.Block.hash head] (length - 1) head

let list_blocks chain_state ?(length = 1) ?min_date heads =
  ( match heads with
  | [] ->
      Chain.known_heads chain_state
      >>= fun heads ->
      let heads =
        match min_date with
        | None ->
            heads
        | Some min_date ->
            List.fold_left
              (fun acc block ->
                let timestamp = State.Block.timestamp block in
                if Time.Protocol.(min_date <= timestamp) then block :: acc
                else acc)
              []
              heads
      in
      let sorted_heads =
        List.sort
          (fun b1 b2 ->
            let f1 = State.Block.fitness b1 in
            let f2 = State.Block.fitness b2 in
            ~-(Fitness.compare f1 f2))
          heads
      in
      Lwt.return (List.map (fun b -> Some b) sorted_heads)
  | _ :: _ as heads ->
      Lwt_list.map_p (State.Block.read_opt chain_state) heads )
  >>= fun requested_heads ->
  Lwt_list.fold_left_s
    (fun (ignored, acc) head ->
      match head with
      | None ->
          Lwt.return (ignored, [])
      | Some block ->
          predecessors ignored length block
          >>= fun predecessors ->
          let ignored =
            List.fold_left
              (fun acc v -> Block_hash.Set.add v acc)
              ignored
              predecessors
          in
          Lwt.return (ignored, predecessors :: acc))
    (Block_hash.Set.empty, [])
    requested_heads
  >>= fun (_, blocks) -> return (List.rev blocks)

let rpc_directory =
  let dir : State.Chain.t RPC_directory.t ref = ref RPC_directory.empty in
  let register0 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst0 s) (fun chain p q ->
          f chain p q)
  in
  let register1 s f =
    dir :=
      RPC_directory.register !dir (RPC_service.subst1 s) (fun (chain, a) p q ->
          f chain a p q)
  in
  let register_dynamic_directory2 ?descr s f =
    dir :=
      RPC_directory.register_dynamic_directory
        !dir
        ?descr
        (RPC_path.subst1 s)
        (fun (chain, a) -> f chain a)
  in
  register0 S.chain_id (fun chain () () -> return (State.Chain.id chain)) ;
  register0 S.checkpoint (fun chain () () ->
      State.Chain.checkpoint chain
      >>= fun checkpoint ->
      State.Chain.save_point chain
      >>= fun (save_point, _) ->
      State.Chain.caboose chain
      >>= fun (caboose, _) ->
      State.history_mode (State.Chain.global_state chain)
      >>= fun history_mode ->
      return (checkpoint, save_point, caboose, history_mode)) ;
  (* blocks *)
  register0 S.Blocks.list (fun chain q () ->
      list_blocks chain ?length:q#length ?min_date:q#min_date q#heads) ;
  register_dynamic_directory2
    Block_services.path
    Block_directory.build_rpc_directory ;
  (* invalid_blocks *)
  register0 S.Invalid_blocks.list (fun chain () () ->
      let convert (hash, level, errors) = {hash; level; errors} in
      State.Block.list_invalid chain
      >>= fun blocks -> return (List.map convert blocks)) ;
  register1 S.Invalid_blocks.get (fun chain hash () () ->
      State.Block.read_invalid chain hash
      >>= function
      | None ->
          Lwt.fail Not_found
      | Some {level; errors} ->
          return {hash; level; errors}) ;
  register1 S.Invalid_blocks.delete (fun chain hash () () ->
      State.Block.unmark_invalid chain hash) ;
  !dir

let build_rpc_directory validator =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  let dir = ref rpc_directory in
  (* Mempool *)
  let merge d = dir := RPC_directory.merge !dir d in
  merge
    (RPC_directory.map
       (fun chain ->
         match Validator.get validator (State.Chain.id chain) with
         | Error _ ->
             Lwt.fail Not_found
         | Ok chain_validator ->
             Lwt.return (Chain_validator.prevalidator chain_validator))
       Prevalidator.rpc_directory) ;
  RPC_directory.prefix Chain_services.path
  @@ RPC_directory.map (fun ((), chain) -> get_chain state chain) !dir
src/lib_shell/chain_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Chain_services.

Definition get_chain_id
  (state : Tezos_shell__State.global_state) (function_parameter : variant)
  : Lwt.t Tezos_base__TzPervasives.Chain_id.t :=
  match function_parameter with
  | Main => Lwt._return (State.Chain.main state)
  | Test =>
    op_gtgteq (State.Chain.get_exn state (State.Chain.main state))
      (fun main_chain =>
        op_gtgteq (State.Chain.test main_chain)
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.fail OCaml.Not_found
            | Some chain_id => Lwt._return chain_id
            end))
  | Hash chain_id => Lwt._return chain_id
  end.

Definition get_chain_id_opt
  (state : Tezos_shell__State.global_state) (chain : variant)
  : Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (get_chain_id state chain) Lwt.return_some)
    (fun _exn => Lwt.return_none).

Definition get_chain (state : Tezos_shell__State.global_state) (chain : variant)
  : Lwt.t Tezos_shell.State.Chain.chain_state :=
  op_gtgteq (get_chain_id state chain)
    (fun chain_id => State.Chain.get_exn state chain_id).

Definition get_checkpoint
  (state : Tezos_shell__State.global_state)
  (chain : Tezos_shell_services.Chain_services.chain)
  : Lwt.t Tezos_crypto.Block_hash.t :=
  op_gtgteq (get_chain state chain)
    (fun chain =>
      op_gtgteq (State.Chain.checkpoint chain)
        (fun header => Lwt._return (Block_header.hash header))).

Definition predecessors
  (ignored : Tezos_base__TzPervasives.Block_hash.Set.t) (length : Z)
  (head : Tezos_shell.State.Block.t)
  : Lwt.t (list Tezos_base__TzPervasives.Block_hash.t) :=
  let fix loop
    (acc : list Tezos_base__TzPervasives.Block_hash.t) (length : Z) (block :
    Tezos_shell.State.Block.t)
    : Lwt.t (list Tezos_base__TzPervasives.Block_hash.t) :=
    if OCaml.Stdlib.le length 0 then
      Lwt._return (List.rev acc)
    else
      op_gtgteq (State.Block.predecessor block)
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt._return (List.rev acc)
          | Some pred =>
            if Block_hash.Set.mem (State.Block.hash block) ignored then
              Lwt._return (List.rev acc)
            else
              loop (cons (State.Block.hash pred) acc) (Z.sub length 1) pred
          end) in
  loop (cons (State.Block.hash head) []) (Z.sub length 1) head.

Definition list_blocks
  (chain_state : Tezos_shell.State.Chain.t) (op_staroptstar : option Z)
  : (option Tezos_base__TzPervasives.Time.Protocol.t) ->
    (list Tezos_base__TzPervasives.Block_hash.t) ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (list (list Tezos_base__TzPervasives.Block_hash.Set.elt))) :=
  let length :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 1
    end in
  fun min_date =>
    fun heads =>
      op_gtgteq
        match heads with
        | [] =>
          op_gtgteq (Chain.known_heads chain_state)
            (fun heads =>
              let heads :=
                match min_date with
                | None => heads
                | Some min_date =>
                  List.fold_left
                    (fun acc =>
                      fun block =>
                        let timestamp := State.Block.timestamp block in
                        if op_lteq min_date timestamp then
                          cons block acc
                        else
                          acc) [] heads
                end in
              let sorted_heads :=
                List.sort
                  (fun b1 =>
                    fun b2 =>
                      let f1 := State.Block.fitness b1 in
                      let f2 := State.Block.fitness b2 in
                      Z.opp (Fitness.compare f1 f2)) heads in
              Lwt._return (List.map (fun b => Some b) sorted_heads))
        | (cons _ _) as heads =>
          Lwt_list.map_p (State.Block.read_opt chain_state) heads
        end
        (fun requested_heads =>
          op_gtgteq
            (Lwt_list.fold_left_s
              (fun function_parameter =>
                let '(ignored, acc) := function_parameter in
                fun head =>
                  match head with
                  | None => Lwt._return (ignored, [])
                  | Some block =>
                    op_gtgteq (predecessors ignored length block)
                      (fun predecessors =>
                        let ignored :=
                          List.fold_left
                            (fun acc => fun v => Block_hash.Set.add v acc)
                            ignored predecessors in
                        Lwt._return (ignored, (cons predecessors acc)))
                  end) (Block_hash.Set.empty, []) requested_heads)
            (fun function_parameter =>
              let '(_, blocks) := function_parameter in
              _return (List.rev blocks))).

Definition rpc_directory
  : Tezos_base__TzPervasives.RPC_directory.t Tezos_shell.State.Chain.t :=
  let dir := Stdlib.ref RPC_directory.empty in
  let register0 {A B C D : Type}
    (s :
    Tezos_base__TzPervasives.RPC_service.raw variant A A B C D
      Tezos_rpc.RPC_service.error) (f :
    Tezos_shell.State.Chain.t ->
      B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) (RPC_service.subst0 s)
        (fun chain => fun p => fun q => f chain p q)) in
  let register1 {A B C D E : Type}
    (s :
    Tezos_base__TzPervasives.RPC_service.raw variant A (A * B) C D E
      Tezos_rpc.RPC_service.error) (f :
    Tezos_shell.State.Chain.t ->
      B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) (RPC_service.subst1 s)
        (fun function_parameter =>
          let '(chain, a) := function_parameter in
          fun p => fun q => f chain a p q)) in
  let register_dynamic_directory2 {A B : Type}
    (descr : option string) (s :
    Tezos_base__TzPervasives.RPC_path.path A (A * B)) (f :
    Tezos_shell.State.Chain.t ->
      B ->
        Lwt.t
          (Tezos_base__TzPervasives.RPC_directory.directory
            (Tezos_shell.State.Chain.t * B))) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register_dynamic_directory descr
        (Stdlib.op_exclamation dir) (RPC_path.subst1 s)
        (fun function_parameter =>
          let '(chain, a) := function_parameter in
          f chain a)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.chain_id
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            _return (State.Chain.id chain)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.checkpoint
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (State.Chain.checkpoint chain)
              (fun checkpoint =>
                op_gtgteq (State.Chain.save_point chain)
                  (fun function_parameter =>
                    let '(save_point, _) := function_parameter in
                    op_gtgteq (State.Chain.caboose chain)
                      (fun function_parameter =>
                        let '(caboose, _) := function_parameter in
                        op_gtgteq
                          (State.history_mode (State.Chain.global_state chain))
                          (fun history_mode =>
                            _return
                              (checkpoint, save_point, caboose, history_mode))))))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.Blocks.list
      (fun chain =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            list_blocks chain
              (* ❌ Sending method message is not handled *)
              send
              (* ❌ Sending method message is not handled *)
              send
              (* ❌ Sending method message is not handled *)
              send) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register_dynamic_directory2 None Block_services.path
      Block_directory.build_rpc_directory in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.Invalid_blocks.list
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            let convert
              (function_parameter :
              Tezos_base__TzPervasives.Block_hash.t * Stdlib.Int32.t *
                (list Tezos_base__TzPervasives.error))
              : Tezos_shell_services.Chain_services.invalid_block :=
              let '(hash, level, errors) := function_parameter in
              {| hash := hash; level := level; errors := errors |} in
            op_gtgteq (State.Block.list_invalid chain)
              (fun blocks => _return (List.map convert blocks))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.Invalid_blocks.get
      (fun chain =>
        fun hash =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (State.Block.read_invalid chain hash)
                (fun function_parameter =>
                  match function_parameter with
                  | None => Lwt.fail OCaml.Not_found
                  | Some {| level := level; errors := errors |} =>
                    _return {| hash := hash; level := level; errors := errors |}
                  end)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.Invalid_blocks.delete
      (fun chain =>
        fun hash =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              State.Block.unmark_invalid chain hash) in
  Stdlib.op_exclamation dir.

Definition build_rpc_directory (validator : Tezos_shell.Validator.t)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let distributed_db := Validator.distributed_db validator in
  let state := Distributed_db.state distributed_db in
  let dir := Stdlib.ref rpc_directory in
  let merge
    (d :
    Tezos_base__TzPervasives.RPC_directory.directory Tezos_shell.State.Chain.t)
    : unit :=
    Stdlib.op_coloneq dir (RPC_directory.merge (Stdlib.op_exclamation dir) d) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    merge
      (RPC_directory.map
        (fun chain =>
          match Validator.get validator (State.Chain.id chain) with
          | Stdlib.Error _ => Lwt.fail OCaml.Not_found
          | Stdlib.Ok chain_validator =>
            Lwt._return (Chain_validator.prevalidator chain_validator)
          end) Prevalidator.rpc_directory) in
  apply (RPC_directory.prefix Chain_services.path)
    (RPC_directory.map
      (fun function_parameter =>
        let '(tt, chain) := function_parameter in
        get_chain state chain) (Stdlib.op_exclamation dir)).

src/lib_shell/chain_traversal.ml 85 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open State

let path (b1 : Block.t) (b2 : Block.t) =
  if not (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
    invalid_arg "Chain_traversal.path" ;
  let rec loop acc current =
    if Block.equal b1 current then Lwt.return_some acc
    else
      Block.predecessor current
      >>= function
      | Some pred -> loop (current :: acc) pred | None -> Lwt.return_none
  in
  loop [] b2

let common_ancestor (b1 : Block.t) (b2 : Block.t) =
  if not (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
    invalid_arg "Chain_traversal.path" ;
  let rec loop (b1 : Block.t) (b2 : Block.t) =
    if Block.equal b1 b2 then Lwt.return b1
    else if Time.Protocol.(Block.timestamp b1 <= Block.timestamp b2) then
      Block.predecessor b2
      >>= function None -> assert false | Some b2 -> loop b1 b2
    else
      Block.predecessor b1
      >>= function None -> assert false | Some b1 -> loop b1 b2
  in
  loop b1 b2

let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
  let module Local = struct
    exception Exit
  end in
  let compare b1 b2 =
    match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
    | 0 -> (
      match
        Time.Protocol.compare (Block.timestamp b1) (Block.timestamp b2)
      with
      | 0 ->
          Block.compare b1 b2
      | res ->
          res )
    | res ->
        res
  in
  let (pop, push) =
    (* Poor-man priority queue *)
    let queue : Block.t list ref = ref [] in
    let pop () =
      match !queue with
      | [] ->
          None
      | b :: bs ->
          queue := bs ;
          Some b
    in
    let push b =
      let rec loop = function
        | [] ->
            [b]
        | b' :: bs' as bs ->
            let cmp = compare b b' in
            if cmp = 0 then bs else if cmp < 0 then b' :: loop bs' else b :: bs
      in
      queue := loop !queue
    in
    (pop, push)
  in
  let check_count =
    match max with
    | None ->
        fun () -> ()
    | Some max ->
        let cpt = ref 0 in
        fun () ->
          if !cpt >= max then raise Local.Exit ;
          incr cpt
  in
  let check_fitness =
    match min_fitness with
    | None ->
        fun _ -> true
    | Some min_fitness ->
        fun b -> Fitness.compare min_fitness (Block.fitness b) <= 0
  in
  let check_date =
    match min_date with
    | None ->
        fun _ -> true
    | Some min_date ->
        fun b -> Time.Protocol.(min_date <= Block.timestamp b)
  in
  let rec loop () =
    match pop () with
    | None ->
        Lwt.return_unit
    | Some b -> (
        check_count () ;
        f b
        >>= fun () ->
        Block.predecessor b
        >>= function
        | None ->
            loop ()
        | Some p ->
            if check_fitness p && check_date p then push p ;
            loop () )
  in
  List.iter push heads ;
  try loop () with Local.Exit -> Lwt.return_unit

let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
  match heads with
  | [] ->
      Lwt.return_unit
  | b :: _ ->
      let chain_id = Block.chain_id b in
      if
        not
          (List.for_all
             (fun b -> Chain_id.equal chain_id (Block.chain_id b))
             heads)
      then invalid_arg "State.Helpers.iter_predecessors" ;
      iter_predecessors ?max ?min_fitness ?min_date heads ~f

let new_blocks ~from_block ~to_block =
  common_ancestor from_block to_block
  >>= fun ancestor ->
  path ancestor to_block
  >>= function None -> assert false | Some path -> Lwt.return (ancestor, path)

let live_blocks block n =
  let rec loop bacc oacc chain_state block_head n =
    Block.all_operation_hashes block_head
    >>= fun hashes ->
    let oacc =
      List.fold_left
        (List.fold_left (fun oacc op -> Operation_hash.Set.add op oacc))
        oacc
        hashes
    in
    let bacc = Block_hash.Set.add (Block.hash block_head) bacc in
    if n = 0 then return (bacc, oacc)
    else
      State.Block.predecessor block_head
      >>= function
      | None ->
          let genesis_hash = (State.Chain.genesis chain_state).block in
          let block_hash = Block.hash block_head in
          if Block_hash.equal genesis_hash block_hash then return (bacc, oacc)
          else fail (State.Block_not_found block_hash)
      | Some predecessor ->
          loop bacc oacc chain_state predecessor (pred n)
  in
  loop
    Block_hash.Set.empty
    Operation_hash.Set.empty
    (Block.chain_state block)
    block
    n
src/lib_shell/chain_traversal.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import State.

Definition path
  (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
  : Lwt.t (option (list Tezos_shell.State.Block.t)) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if negb (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
      OCaml.Stdlib.invalid_arg "Chain_traversal.path" % string
    else
      tt in
  let fix loop
    (acc : list Tezos_shell.State.Block.t) (current : Tezos_shell.State.Block.t)
    : Lwt.t (option (list Tezos_shell.State.Block.t)) :=
    if Block.equal b1 current then
      Lwt.return_some acc
    else
      op_gtgteq (Block.predecessor current)
        (fun function_parameter =>
          match function_parameter with
          | Some pred => loop (cons current acc) pred
          | None => Lwt.return_none
          end) in
  loop [] b2.

Definition common_ancestor
  (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
  : Lwt.t Tezos_shell.State.Block.t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if negb (Chain_id.equal (Block.chain_id b1) (Block.chain_id b2)) then
      OCaml.Stdlib.invalid_arg "Chain_traversal.path" % string
    else
      tt in
  let fix loop (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
    : Lwt.t Tezos_shell.State.Block.t :=
    if Block.equal b1 b2 then
      Lwt._return b1
    else
      if op_lteq (Block.timestamp b1) (Block.timestamp b2) then
        op_gtgteq (Block.predecessor b2)
          (fun function_parameter =>
            match function_parameter with
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Some b2 => loop b1 b2
            end)
      else
        op_gtgteq (Block.predecessor b1)
          (fun function_parameter =>
            match function_parameter with
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Some b1 => loop b1 b2
            end) in
  loop b1 b2.

Definition iter_predecessors
  (max : option Z) (min_fitness : option Tezos_base__TzPervasives.Fitness.t)
  (min_date : option Tezos_base__TzPervasives.Time.Protocol.t)
  (heads : list Tezos_shell.State.Block.t)
  (f : Tezos_shell.State.Block.t -> Lwt.t unit) : Lwt.t unit :=
  let Local :=
    (* ❌ The signature name of this module could not be found *)
    existT _ _
      {|
        (* ❌ Exception not handled *)
        unknown_signature_name.Exit := exception
        |} in
  let compare (b1 : Tezos_shell.State.Block.t) (b2 : Tezos_shell.State.Block.t)
    : Z :=
    match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
    | 0 =>
      match Time.Protocol.compare (Block.timestamp b1) (Block.timestamp b2) with
      | 0 => Block.compare b1 b2
      | res => res
      end
    | res => res
    end in
  let '(pop, push) :=
    let queue := Stdlib.ref [] in
    let pop (function_parameter : unit) : option Tezos_shell.State.Block.t :=
      let 'tt := function_parameter in
      match Stdlib.op_exclamation queue with
      | [] => None
      | cons b bs =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Stdlib.op_coloneq queue bs in
        Some b
      end in
    let push (b : Tezos_shell.State.Block.t) : unit :=
      let fix loop (function_parameter : list Tezos_shell.State.Block.t)
        : list Tezos_shell.State.Block.t :=
        match function_parameter with
        | [] => cons b []
        | (cons b' bs') as bs =>
          let cmp := compare b b' in
          if equiv_decb cmp 0 then
            bs
          else
            if OCaml.Stdlib.lt cmp 0 then
              cons b' (loop bs')
            else
              cons b bs
        end in
      Stdlib.op_coloneq queue (loop (Stdlib.op_exclamation queue)) in
    (pop, push) in
  let check_count :=
    match max with
    | None =>
      fun function_parameter =>
        let 'tt := function_parameter in
        tt
    | Some max =>
      let cpt := Stdlib.ref 0 in
      fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if OCaml.Stdlib.ge (Stdlib.op_exclamation cpt) max then
            Stdlib.raise Exit
          else
            tt in
        Stdlib.incr cpt
    end in
  let check_fitness :=
    match min_fitness with
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        true
    | Some min_fitness =>
      fun b => OCaml.Stdlib.le (Fitness.compare min_fitness (Block.fitness b)) 0
    end in
  let check_date :=
    match min_date with
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        true
    | Some min_date => fun b => op_lteq min_date (Block.timestamp b)
    end in
  let fix loop (function_parameter : unit) : Lwt.t unit :=
    let 'tt := function_parameter in
    match pop tt with
    | None => Lwt.return_unit
    | Some b =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := check_count tt in
      op_gtgteq (f b)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Block.predecessor b)
            (fun function_parameter =>
              match function_parameter with
              | None => loop tt
              | Some p =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  if andb (check_fitness p) (check_date p) then
                    push p
                  else
                    tt in
                loop tt
              end))
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := List.iter push heads in
  (* ❌ Try-with are not handled *)
  try (loop tt).

Definition iter_predecessors
  (max : option Z) (min_fitness : option Tezos_base__TzPervasives.Fitness.t)
  (min_date : option Tezos_base__TzPervasives.Time.Protocol.t)
  (heads : list Tezos_shell.State.Block.t)
  (f : Tezos_shell.State.Block.t -> Lwt.t unit) : Lwt.t unit :=
  match heads with
  | [] => Lwt.return_unit
  | cons b _ =>
    let chain_id := Block.chain_id b in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if
        negb
          (List.for_all (fun b => Chain_id.equal chain_id (Block.chain_id b))
            heads) then
        OCaml.Stdlib.invalid_arg "State.Helpers.iter_predecessors" % string
      else
        tt in
    iter_predecessors max min_fitness min_date heads f
  end.

Definition new_blocks
  (from_block : Tezos_shell.State.Block.t)
  (to_block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_shell.State.Block.t * (list Tezos_shell.State.Block.t)) :=
  op_gtgteq (common_ancestor from_block to_block)
    (fun ancestor =>
      op_gtgteq (path ancestor to_block)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            (* ❌ Assert instruction is not handled. *)
            assert false
          | Some path => Lwt._return (ancestor, path)
          end)).

Definition live_blocks (block : Tezos_shell.State.Block.t) (n : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.Set.t *
        Tezos_base__TzPervasives.Operation_hash.Set.t)) :=
  let fix loop
    (bacc : Tezos_base__TzPervasives.Block_hash.Set.t) (oacc :
    Tezos_base__TzPervasives.Operation_hash.Set.t) (chain_state :
    Tezos_shell.State.Chain.chain_state) (block_head :
    Tezos_shell.State.Block.t) (n : Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Block_hash.Set.t *
          Tezos_base__TzPervasives.Operation_hash.Set.t)) :=
    op_gtgteq (Block.all_operation_hashes block_head)
      (fun hashes =>
        let oacc :=
          List.fold_left
            (List.fold_left
              (fun oacc => fun op => Operation_hash.Set.add op oacc)) oacc
            hashes in
        let bacc := Block_hash.Set.add (Block.hash block_head) bacc in
        if equiv_decb n 0 then
          _return (bacc, oacc)
        else
          op_gtgteq (State.Block.predecessor block_head)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                let genesis_hash := block (State.Chain.genesis chain_state) in
                let block_hash := Block.hash block_head in
                if Block_hash.equal genesis_hash block_hash then
                  _return (bacc, oacc)
                else
                  fail (Tezos_base__TzPervasives.Block_not_found block_hash)
              | Some predecessor =>
                loop bacc oacc chain_state predecessor (Z.pred n)
              end)) in
  loop Block_hash.Set.empty Operation_hash.Set.empty (Block.chain_state block)
    block n.

src/lib_shell/chain_validator.ml 139 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Chain_validator_worker_state

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "node.chain_validator"
end)

module Name = struct
  type t = Chain_id.t

  let encoding = Chain_id.encoding

  let base = ["validator"; "chain"]

  let pp = Chain_id.pp_short
end

module Request = struct
  include Request

  type _ t = Validated : State.Block.t -> Event.update t

  let view (type a) (Validated block : a t) : view = State.Block.hash block
end

type limits = {bootstrap_threshold : int; worker_limits : Worker_types.limits}

module Types = struct
  include Worker_state

  type parameters = {
    parent : Name.t option;
    db : Distributed_db.t;
    chain_state : State.Chain.t;
    chain_db : Distributed_db.chain_db;
    block_validator : Block_validator.t;
    block_validator_process : Block_validator_process.t;
    global_valid_block_input : State.Block.t Lwt_watcher.input;
    global_chains_input : (Chain_id.t * bool) Lwt_watcher.input;
    prevalidator_limits : Prevalidator.limits;
    peer_validator_limits : Peer_validator.limits;
    limits : limits;
  }

  type state = {
    parameters : parameters;
    mutable bootstrapped : bool;
    bootstrapped_waiter : unit Lwt.t;
    bootstrapped_wakener : unit Lwt.u;
    valid_block_input : State.Block.t Lwt_watcher.input;
    new_head_input : State.Block.t Lwt_watcher.input;
    mutable child : (state * (unit -> unit Lwt.t (* shutdown *))) option;
    mutable prevalidator : Prevalidator.t option;
    active_peers : Peer_validator.t P2p_peer.Error_table.t;
    bootstrapped_peers : unit P2p_peer.Table.t;
  }

  let view (state : state) _ : view =
    let {bootstrapped; active_peers; bootstrapped_peers; _} = state in
    {
      bootstrapped;
      active_peers =
        P2p_peer.Error_table.fold_keys (fun id l -> id :: l) active_peers [];
      bootstrapped_peers =
        P2p_peer.Table.fold (fun id _ l -> id :: l) bootstrapped_peers [];
    }
end

module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types

type t = Worker.infinite Worker.queue Worker.t

let table = Worker.create_table Queue

let shutdown w = Worker.shutdown w

let shutdown_child nv active_chains =
  Lwt_utils.may
    ~f:
      (fun ({parameters = {chain_state; global_chains_input; _}; _}, shutdown) ->
      Lwt_watcher.notify global_chains_input (State.Chain.id chain_state, false) ;
      Chain_id.Table.remove active_chains (State.Chain.id chain_state) ;
      State.update_chain_data nv.parameters.chain_state (fun _ chain_data ->
          Lwt.return (Some {chain_data with test_chain = None}, ()))
      >>= fun () ->
      shutdown ()
      >>= fun () ->
      nv.child <- None ;
      Lwt.return_unit)
    nv.child

let notify_new_block w block =
  let nv = Worker.state w in
  Option.iter nv.parameters.parent ~f:(fun id ->
      try
        let w = List.assoc id (Worker.list table) in
        let nv = Worker.state w in
        Lwt_watcher.notify nv.valid_block_input block
      with Not_found -> ()) ;
  Lwt_watcher.notify nv.valid_block_input block ;
  Lwt_watcher.notify nv.parameters.global_valid_block_input block ;
  Worker.Queue.push_request_now w (Validated block)

let may_toggle_bootstrapped_chain w =
  let nv = Worker.state w in
  if
    (not nv.bootstrapped)
    && P2p_peer.Table.length nv.bootstrapped_peers
       >= nv.parameters.limits.bootstrap_threshold
  then (
    Log.log_info "bootstrapped" ;
    nv.bootstrapped <- true ;
    Lwt.wakeup_later nv.bootstrapped_wakener () )

let with_activated_peer_validator w peer_id f =
  let nv = Worker.state w in
  P2p_peer.Error_table.find_or_make nv.active_peers peer_id (fun () ->
      Peer_validator.create
        ~notify_new_block:(notify_new_block w)
        ~notify_bootstrapped:(fun () ->
          P2p_peer.Table.add nv.bootstrapped_peers peer_id () ;
          may_toggle_bootstrapped_chain w)
        ~notify_termination:(fun _pv ->
          P2p_peer.Error_table.remove nv.active_peers peer_id ;
          P2p_peer.Table.remove nv.bootstrapped_peers peer_id)
        nv.parameters.peer_validator_limits
        nv.parameters.block_validator
        nv.parameters.chain_db
        peer_id)
  >>=? fun pv ->
  match Peer_validator.status pv with
  | Worker_types.Running _ ->
      f pv
  | Worker_types.Closing (_, _)
  | Worker_types.Closed (_, _, _)
  | Worker_types.Launching _ ->
      return_unit

let may_update_checkpoint chain_state new_head =
  State.Chain.checkpoint chain_state
  >>= fun checkpoint ->
  State.Block.last_allowed_fork_level new_head
  >>=? fun new_level ->
  if new_level <= checkpoint.shell.level then return_unit
  else
    let state = State.Chain.global_state chain_state in
    State.history_mode state
    >>= fun history_mode ->
    let head_level = State.Block.level new_head in
    State.Block.predecessor_n
      new_head
      (Int32.to_int (Int32.sub head_level new_level))
    >>= function
    | None ->
        assert false (* should not happen *)
    | Some new_checkpoint -> (
        State.Block.read_opt chain_state new_checkpoint
        >>= function
        | None ->
            assert false (* should not happen *)
        | Some new_checkpoint -> (
            Log.log_notice
              "@[Update to checkpoint %a (running in mode %a).@]"
              Block_hash.pp
              (State.Block.hash new_checkpoint)
              History_mode.pp
              history_mode ;
            let new_checkpoint = State.Block.header new_checkpoint in
            match history_mode with
            | History_mode.Archive ->
                State.Chain.set_checkpoint chain_state new_checkpoint
                >>= fun () -> return_unit
            | Full ->
                State.Chain.set_checkpoint_then_purge_full
                  chain_state
                  new_checkpoint
            | Rolling ->
                State.Chain.set_checkpoint_then_purge_rolling
                  chain_state
                  new_checkpoint ) )

let may_switch_test_chain w active_chains spawn_child block =
  let nv = Worker.state w in
  let create_child block protocol expiration forking_block =
    let block_header = State.Block.header block in
    let genesis =
      Context.compute_testchain_genesis (State.Block.hash forking_block)
    in
    let chain_id = Context.compute_testchain_chain_id genesis in
    let activated =
      match nv.child with
      | None ->
          false
      | Some (child, _) ->
          Block_hash.equal
            (State.Chain.genesis child.parameters.chain_state).block
            genesis
    in
    let expired = expiration < block_header.shell.timestamp in
    if expired && activated then
      shutdown_child nv active_chains >>= fun () -> return_unit
    else if
      activated || expired
      || not (State.Chain.allow_forked_chain nv.parameters.chain_state)
    then return_unit
    else
      State.Chain.get_opt
        (State.Chain.global_state nv.parameters.chain_state)
        chain_id
      >>= (function
            | Some chain_state ->
                State.update_testchain block ~testchain_state:chain_state
                >>= fun () -> return chain_state
            | None ->
                let try_init_test_chain cont =
                  let bvp = nv.parameters.block_validator_process in
                  Block_validator_process.init_test_chain bvp forking_block
                  >>= function
                  | Ok genesis_header ->
                      State.fork_testchain
                        block
                        chain_id
                        genesis
                        genesis_header
                        protocol
                        expiration
                      >>=? fun chain_state ->
                      Chain.head chain_state
                      >>= fun new_genesis_block ->
                      Lwt_watcher.notify
                        nv.parameters.global_valid_block_input
                        new_genesis_block ;
                      Lwt_watcher.notify nv.valid_block_input new_genesis_block ;
                      return chain_state
                  | Error
                      (Block_validator_errors.Missing_test_protocol
                         missing_protocol
                      :: _) ->
                      Block_validator.fetch_and_compile_protocol
                        nv.parameters.block_validator
                        missing_protocol
                      >>=? fun _ -> cont ()
                  | Error _ as error ->
                      Lwt.return error
                in
                try_init_test_chain
                @@ fun () ->
                try_init_test_chain
                @@ fun () -> failwith "Could not retrieve test protocol")
      >>=? fun chain_state ->
      (* [spawn_child] is a callback to [create_node]. Thus, it takes care of
         global initialization boilerplate (e.g. notifying [global_chains_input],
         adding the chain to the correct tables, ...) *)
      spawn_child
        ~parent:(State.Chain.id chain_state)
        nv.parameters.peer_validator_limits
        nv.parameters.prevalidator_limits
        nv.parameters.block_validator
        nv.parameters.global_valid_block_input
        nv.parameters.global_chains_input
        nv.parameters.db
        chain_state
        nv.parameters.limits
      (* TODO: different limits main/test ? *)
      >>=? fun child ->
      nv.child <- Some child ;
      return_unit
  in
  State.Block.test_chain block
  >>= (function
        | (Not_running, _) ->
            shutdown_child nv active_chains >>= fun () -> return_unit
        | ((Forking _ | Running _), None) ->
            return_unit (* only for snapshots *)
        | ( ( Forking {protocol; expiration; _}
            | Running {protocol; expiration; _} ),
            Some forking_block ) ->
            create_child block protocol expiration forking_block)
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error err ->
      Worker.record_event w (Could_not_switch_testchain err) ;
      Lwt.return_unit

let broadcast_head w ~previous block =
  let nv = Worker.state w in
  if not nv.bootstrapped then Lwt.return_unit
  else
    State.Block.predecessor block
    >>= (function
          | None ->
              Lwt.return_true
          | Some predecessor ->
              Lwt.return (State.Block.equal predecessor previous))
    >>= fun successor ->
    if successor then (
      Distributed_db.Advertise.current_head nv.parameters.chain_db block ;
      Lwt.return_unit )
    else Distributed_db.Advertise.current_branch nv.parameters.chain_db

let safe_get_protocol hash =
  match Registered_protocol.get hash with
  | None ->
      (* FIXME. *)
      (* This should not happen: it should be handled in the validator. *)
      failwith
        "chain_validator: missing protocol '%a' for the current block."
        Protocol_hash.pp_short
        hash
  | Some protocol ->
      return protocol

let on_request (type a) w start_testchain active_chains spawn_child
    (req : a Request.t) : a tzresult Lwt.t =
  let (Request.Validated block) = req in
  let nv = Worker.state w in
  Chain.head nv.parameters.chain_state
  >>= fun head ->
  let head_header = State.Block.header head
  and head_hash = State.Block.hash head
  and block_header = State.Block.header block
  and block_hash = State.Block.hash block in
  ( match nv.prevalidator with
  | None ->
      Lwt.return head_header.shell.fitness
  | Some pv ->
      Prevalidator.fitness pv )
  >>= fun context_fitness ->
  let head_fitness = head_header.shell.fitness in
  let new_fitness = block_header.shell.fitness in
  let accepted_head =
    if Fitness.(context_fitness = head_fitness) then
      Fitness.(new_fitness > head_fitness)
    else Fitness.(new_fitness >= context_fitness)
  in
  if not accepted_head then return Event.Ignored_head
  else
    Chain.set_head nv.parameters.chain_state block
    >>=? fun previous ->
    may_update_checkpoint nv.parameters.chain_state block
    >>=? fun () ->
    broadcast_head w ~previous block
    >>= fun () ->
    ( match nv.prevalidator with
    | Some old_prevalidator ->
        State.Block.protocol_hash block
        >>=? fun new_protocol ->
        let old_protocol = Prevalidator.protocol_hash old_prevalidator in
        if not (Protocol_hash.equal old_protocol new_protocol) then (
          safe_get_protocol new_protocol
          >>=? fun (module Proto) ->
          let (limits, chain_db) = Prevalidator.parameters old_prevalidator in
          (* TODO inject in the new prevalidator the operation
                 from the previous one. *)
          Prevalidator.create limits (module Proto) chain_db
          >>= function
          | Error errs ->
              Log.lwt_log_error
                "@[Failed to reinstantiate prevalidator:@ %a@]"
                pp_print_error
                errs
              >>= fun () ->
              nv.prevalidator <- None ;
              Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit
          | Ok prevalidator ->
              nv.prevalidator <- Some prevalidator ;
              Prevalidator.shutdown old_prevalidator >>= fun () -> return_unit
          )
        else Prevalidator.flush old_prevalidator block_hash
    | None ->
        return_unit )
    >>=? fun () ->
    ( if start_testchain then
      may_switch_test_chain w active_chains spawn_child block
    else Lwt.return_unit )
    >>= fun () ->
    Lwt_watcher.notify nv.new_head_input block ;
    if Block_hash.equal head_hash block_header.shell.predecessor then
      return Event.Head_increment
    else return Event.Branch_switch

let on_completion (type a) w (req : a Request.t) (update : a) request_status =
  let (Request.Validated block) = req in
  let fitness = State.Block.fitness block in
  let request = State.Block.hash block in
  Worker.record_event
    w
    (Processed_block {request; request_status; update; fitness}) ;
  Lwt.return_unit

let on_close w =
  let nv = Worker.state w in
  Distributed_db.deactivate nv.parameters.chain_db
  >>= fun () ->
  let pvs =
    P2p_peer.Error_table.fold_promises
      (fun _ pv acc ->
        ( pv
        >>= function
        | Error _ -> Lwt.return_unit | Ok pv -> Peer_validator.shutdown pv )
        :: acc)
      nv.active_peers
      []
  in
  Lwt.join
    ( ( match nv.prevalidator with
      | Some prevalidator ->
          Prevalidator.shutdown prevalidator
      | None ->
          Lwt.return_unit )
    :: Lwt_utils.may ~f:(fun (_, shutdown) -> shutdown ()) nv.child
    :: pvs )

let on_launch start_prevalidator w _ parameters =
  ( if start_prevalidator then
    State.read_chain_data
      parameters.chain_state
      (fun _ {State.current_head; _} -> Lwt.return current_head)
    >>= fun head ->
    State.Block.protocol_hash head
    >>=? fun head_hash ->
    safe_get_protocol head_hash
    >>= function
    | Ok (module Proto) -> (
        Prevalidator.create
          parameters.prevalidator_limits
          (module Proto)
          parameters.chain_db
        >>= function
        | Error err ->
            Log.lwt_log_error
              "@[Failed to instantiate prevalidator:@ %a@]"
              pp_print_error
              err
            >>= fun () -> return_none
        | Ok prevalidator ->
            return_some prevalidator )
    | Error err ->
        Log.lwt_log_error
          "@[Failed to instantiate prevalidator:@ %a@]"
          pp_print_error
          err
        >>= fun () -> return_none
  else return_none )
  >>=? fun prevalidator ->
  let valid_block_input = Lwt_watcher.create_input () in
  let new_head_input = Lwt_watcher.create_input () in
  let (bootstrapped_waiter, bootstrapped_wakener) = Lwt.wait () in
  let nv =
    {
      parameters;
      valid_block_input;
      new_head_input;
      bootstrapped_wakener;
      bootstrapped_waiter;
      bootstrapped = parameters.limits.bootstrap_threshold <= 0;
      active_peers = P2p_peer.Error_table.create 50;
      (* TODO use `2 * max_connection` *)
      bootstrapped_peers = P2p_peer.Table.create 50;
      (* TODO use `2 * max_connection` *)
      child = None;
      prevalidator;
    }
  in
  if nv.bootstrapped then Lwt.wakeup_later bootstrapped_wakener () ;
  Distributed_db.set_callback
    parameters.chain_db
    {
      notify_branch =
        (fun peer_id locator ->
          Lwt.async (fun () ->
              with_activated_peer_validator w peer_id
              @@ fun pv ->
              Peer_validator.notify_branch pv locator ;
              return_unit));
      notify_head =
        (fun peer_id block ops ->
          Lwt.async (fun () ->
              with_activated_peer_validator w peer_id (fun pv ->
                  Peer_validator.notify_head pv block ;
                  return_unit)
              >>=? fun () ->
              (* TODO notify prevalidator only if head is known ??? *)
              match nv.prevalidator with
              | Some prevalidator ->
                  Prevalidator.notify_operations prevalidator peer_id ops
                  >>= fun () -> return_unit
              | None ->
                  return_unit));
      disconnection =
        (fun peer_id ->
          Lwt.async (fun () ->
              let nv = Worker.state w in
              match P2p_peer.Error_table.find_opt nv.active_peers peer_id with
              | None ->
                  return_unit
              | Some pv ->
                  pv
                  >>=? fun pv ->
                  Peer_validator.shutdown pv >>= fun () -> return_unit));
    } ;
  return nv

let rec create ~start_prevalidator ~start_testchain ~active_chains ?parent
    ~block_validator_process peer_validator_limits prevalidator_limits
    block_validator global_valid_block_input global_chains_input db chain_state
    limits =
  let spawn_child ~parent pvl pl bl gvbi gci db n l =
    create
      ~start_prevalidator
      ~start_testchain
      ~active_chains
      ~parent
      ~block_validator_process
      pvl
      pl
      bl
      gvbi
      gci
      db
      n
      l
    >>=? fun w -> return (Worker.state w, fun () -> Worker.shutdown w)
  in
  let module Handlers = struct
    type self = t

    let on_launch = on_launch start_prevalidator

    let on_request w = on_request w start_testchain active_chains spawn_child

    let on_close = on_close

    let on_error _ _ _ errs = Lwt.return_error errs

    let on_completion = on_completion

    let on_no_request _ = return_unit
  end in
  let parameters =
    {
      parent;
      peer_validator_limits;
      prevalidator_limits;
      block_validator;
      block_validator_process;
      global_valid_block_input;
      global_chains_input;
      db;
      chain_db = Distributed_db.activate db chain_state;
      chain_state;
      limits;
    }
  in
  Chain.init_head chain_state
  >>=? fun () ->
  Worker.launch
    table
    prevalidator_limits.worker_limits
    (State.Chain.id chain_state)
    parameters
    (module Handlers)
  >>=? fun w ->
  Chain_id.Table.add active_chains (State.Chain.id chain_state) w ;
  Lwt_watcher.notify global_chains_input (State.Chain.id chain_state, true) ;
  return w

(** Current block computation *)

let create ~start_prevalidator ~start_testchain ~active_chains
    ~block_validator_process peer_validator_limits prevalidator_limits
    block_validator global_valid_block_input global_chains_input global_db
    state limits =
  (* hide the optional ?parent *)
  create
    ~start_prevalidator
    ~start_testchain
    ~active_chains
    ~block_validator_process
    peer_validator_limits
    prevalidator_limits
    block_validator
    global_valid_block_input
    global_chains_input
    global_db
    state
    limits

let chain_id w =
  let {parameters = {chain_state; _}; _} = Worker.state w in
  State.Chain.id chain_state

let chain_state w =
  let {parameters = {chain_state; _}; _} = Worker.state w in
  chain_state

let prevalidator w =
  let {prevalidator; _} = Worker.state w in
  prevalidator

let chain_db w =
  let {parameters = {chain_db; _}; _} = Worker.state w in
  chain_db

let child w =
  match (Worker.state w).child with
  | None ->
      None
  | Some ({parameters = {chain_state; _}; _}, _) -> (
    try Some (List.assoc (State.Chain.id chain_state) (Worker.list table))
    with Not_found -> None )

let assert_fitness_increases ?(force = false) w distant_header =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  Chain.head chain_state
  >>= fun local_header ->
  fail_when
    ( (not force)
    && Fitness.compare
         distant_header.Block_header.shell.fitness
         (State.Block.fitness local_header)
       <= 0 )
    (failure "Fitness too low")

let assert_checkpoint w (header : Block_header.t) =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Chain.acceptable_block chain_state header
  >>= fun acceptable ->
  fail_unless
    acceptable
    (Validation_errors.Checkpoint_error (Block_header.hash header, None))

let validate_block w ?force hash block operations =
  let nv = Worker.state w in
  assert (Block_hash.equal hash (Block_header.hash block)) ;
  assert_fitness_increases ?force w block
  >>=? fun () ->
  assert_checkpoint w block
  >>=? fun () ->
  Block_validator.validate
    ~canceler:(Worker.canceler w)
    ~notify_new_block:(notify_new_block w)
    nv.parameters.block_validator
    nv.parameters.chain_db
    hash
    block
    operations

let bootstrapped w =
  let {bootstrapped_waiter; _} = Worker.state w in
  Lwt.protected bootstrapped_waiter

let valid_block_watcher w =
  let {valid_block_input; _} = Worker.state w in
  Lwt_watcher.create_stream valid_block_input

let new_head_watcher w =
  let {new_head_input; _} = Worker.state w in
  Lwt_watcher.create_stream new_head_input

let status = Worker.status

let information = Worker.information

let running_workers () = Worker.list table

let pending_requests t = Worker.Queue.pending_requests t

let pending_requests_length t = Worker.Queue.pending_requests_length t

let current_request t = Worker.current_request t

let last_events = Worker.last_events

let ddb_information t =
  let state = Worker.state t in
  let ddb = state.parameters.chain_db in
  Distributed_db.information ddb
src/lib_shell/chain_validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Chain_validator_worker_state.

(* ❌ Applications of functors are not handled. *)
functor_application

Module Name.
  Definition t := Tezos_base__TzPervasives.Chain_id.t.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Chain_id.t :=
    Chain_id.encoding.
  
  Definition base : list string :=
    cons "validator" % string (cons "chain" % string []).
  
  Definition pp
    : Stdlib.Format.formatter -> Tezos_base__TzPervasives.Chain_id.t -> unit :=
    Chain_id.pp_short.
End Name.

Module Request.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Inductive t : forall (_ : Type), Type :=
  | Validated : Tezos_shell.State.Block.t ->
    t Tezos_shell_services.Chain_validator_worker_state.Event.update.
  
  Definition view {A : Type} (function_parameter : t A) : view :=
    let 'Validated block := function_parameter in
    State.Block.hash block.
End Request.

Record limits := {
  bootstrap_threshold : Z;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module Types.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Record parameters := {
    parent : option Name.t;
    db : Tezos_shell.Distributed_db.t;
    chain_state : Tezos_shell.State.Chain.t;
    chain_db : Tezos_shell.Distributed_db.chain_db;
    block_validator : Tezos_shell.Block_validator.t;
    block_validator_process : Tezos_shell.Block_validator_process.t;
    global_valid_block_input :
      Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
    global_chains_input :
      Tezos_base__TzPervasives.Lwt_watcher.input
        (Tezos_base__TzPervasives.Chain_id.t * bool);
    prevalidator_limits : Tezos_shell.Prevalidator.limits;
    peer_validator_limits : Tezos_shell.Peer_validator.limits;
    limits : limits }.
  
  Record state := {
    parameters : parameters;
    bootstrapped : bool;
    bootstrapped_waiter : Lwt.t unit;
    bootstrapped_wakener : Lwt.u unit;
    valid_block_input :
      Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
    new_head_input :
      Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
    child : option (state * (unit -> Lwt.t unit));
    prevalidator : option Tezos_shell.Prevalidator.t;
    active_peers :
      Tezos_base__TzPervasives.P2p_peer.Error_table.t
        Tezos_shell.Peer_validator.t;
    bootstrapped_peers : Tezos_base__TzPervasives.P2p_peer.Table.t unit }.
  
  Definition view {A : Type} (state : state) (function_parameter : A) : view :=
    let '_ := function_parameter in
    let '{|
      bootstrapped := bootstrapped;
        active_peers := active_peers;
        bootstrapped_peers := bootstrapped_peers
        |} := state in
    {|
      active_peers :=
        P2p_peer.Error_table.fold_keys (fun id => fun l => cons id l)
          active_peers [];
      bootstrapped_peers :=
        P2p_peer.Table.fold
          (fun id =>
            fun function_parameter =>
              let '_ := function_parameter in
              fun l => cons id l) bootstrapped_peers [];
      bootstrapped := bootstrapped |}.
End Types.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Import Types.

Definition t := Worker.t (Worker.queue Worker.infinite).

Definition table : Worker.table (Worker.queue Worker.infinite) :=
  Worker.create_table Worker.Queue.

Definition shutdown {A : Type} (w : Worker.t A) : Lwt.t unit :=
  Worker.shutdown w.

Definition shutdown_child {A : Type}
  (nv : Types.state)
  (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t A) : Lwt.t unit :=
  Lwt_utils.may
    (fun function_parameter =>
      let
        '({|
          parameters := {|
            chain_state := chain_state;
              global_chains_input := global_chains_input
              |}
            |}, shutdown) := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Lwt_watcher.notify global_chains_input
          ((State.Chain.id chain_state), false) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Chain_id.Table.remove active_chains (State.Chain.id chain_state)
        in
      op_gtgteq
        (State.update_chain_data (chain_state (parameters nv))
          (fun function_parameter =>
            let '_ := function_parameter in
            fun chain_data =>
              Lwt._return
                ((Some
                  (* ❌ Record substitution not handled *)
                  record_substitution), tt)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (shutdown tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field nv "child" % string None in
              Lwt.return_unit))) (child nv).

Definition notify_new_block
  (w : Worker.t (Worker.queue Worker.infinite))
  (block : Tezos_shell.State.Block.t) : unit :=
  let nv := Worker.state w in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Option.iter
      (fun id =>
        (* ❌ Try-with are not handled *)
        try
          (let w := List.assoc id (Worker.list table) in
          let nv := Worker.state w in
          Lwt_watcher.notify (valid_block_input nv) block))
      (parent (parameters nv)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Lwt_watcher.notify (valid_block_input nv) block in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Lwt_watcher.notify (global_valid_block_input (parameters nv)) block
    in
  Worker.Queue.push_request_now w (Request.Validated block).

Definition may_toggle_bootstrapped_chain {A : Type} (w : Worker.t A) : unit :=
  let nv := Worker.state w in
  if
    andb (negb (bootstrapped nv))
      (OCaml.Stdlib.ge (P2p_peer.Table.length (bootstrapped_peers nv))
        (bootstrap_threshold (limits (parameters nv)))) then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.log_info)
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "bootstrapped" % string
            CamlinternalFormatBasics.End_of_format) "bootstrapped" % string) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field nv "bootstrapped" % string true in
    Lwt.wakeup_later (bootstrapped_wakener nv) tt
  else
    tt.

Definition with_activated_peer_validator
  (w : Worker.t (Worker.queue Worker.infinite))
  (peer_id : Tezos_base__TzPervasives.P2p_peer.Error_table.key)
  (f :
    Tezos_shell.Peer_validator.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let nv := Worker.state w in
  op_gtgteqquestion
    (P2p_peer.Error_table.find_or_make (active_peers nv) peer_id
      (fun function_parameter =>
        let 'tt := function_parameter in
        Peer_validator.create (Some (notify_new_block w))
          (Some
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_peer.Table.add (bootstrapped_peers nv) peer_id tt in
              may_toggle_bootstrapped_chain w))
          (Some
            (fun _pv =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_peer.Error_table.remove (active_peers nv) peer_id in
              P2p_peer.Table.remove (bootstrapped_peers nv) peer_id))
          (peer_validator_limits (parameters nv))
          (block_validator (parameters nv)) (chain_db (parameters nv)) peer_id))
    (fun pv =>
      match Peer_validator.status pv with
      | Tezos_shell_services.Worker_types.Running _ => f pv
      |
        Tezos_shell_services.Worker_types.Closing _ _ |
          Tezos_shell_services.Worker_types.Closed _ _ _ |
          Tezos_shell_services.Worker_types.Launching _ => return_unit
      end).

Definition may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (new_head : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (State.Chain.checkpoint chain_state)
    (fun checkpoint =>
      op_gtgteqquestion (State.Block.last_allowed_fork_level new_head)
        (fun new_level =>
          if OCaml.Stdlib.le new_level (level (shell checkpoint)) then
            return_unit
          else
            let state := State.Chain.global_state chain_state in
            op_gtgteq (State.history_mode state)
              (fun history_mode =>
                let head_level := State.Block.level new_head in
                op_gtgteq
                  (State.Block.predecessor_n new_head
                    (Int32.to_int (Int32.sub head_level new_level)))
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    | Some new_checkpoint =>
                      op_gtgteq
                        (State.Block.read_opt chain_state new_checkpoint)
                        (fun function_parameter =>
                          match function_parameter with
                          | None =>
                            (* ❌ Assert instruction is not handled. *)
                            assert false
                          | Some new_checkpoint =>
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.log_notice)
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        CamlinternalFormatBasics.End_of_format
                                        "" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Update to checkpoint " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " (running in mode " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              ")." % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                CamlinternalFormatBasics.End_of_format)))))))
                                  "@[Update to checkpoint %a (running in mode %a).@]"
                                    % string) Block_hash.pp
                                (State.Block.hash new_checkpoint)
                                History_mode.pp history_mode in
                            let new_checkpoint :=
                              State.Block.header new_checkpoint in
                            match history_mode with
                            | Tezos_shell_services.History_mode.Archive =>
                              op_gtgteq
                                (State.Chain.set_checkpoint chain_state
                                  new_checkpoint)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit)
                            | Tezos_shell_services.History_mode.Full =>
                              State.Chain.set_checkpoint_then_purge_full
                                chain_state new_checkpoint
                            | Tezos_shell_services.History_mode.Rolling =>
                              State.Chain.set_checkpoint_then_purge_rolling
                                chain_state new_checkpoint
                            end
                          end)
                    end)))).

Definition may_switch_test_chain {A B : Type}
  (w : Worker.t A) (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t B)
  (spawn_child :
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_shell.Peer_validator.limits ->
        Tezos_shell.Prevalidator.limits ->
          Tezos_shell.Block_validator.t ->
            (Tezos_base__TzPervasives.Lwt_watcher.input
              Tezos_shell.State.Block.t) ->
              (Tezos_base__TzPervasives.Lwt_watcher.input
                (Tezos_base__TzPervasives.Chain_id.t * bool)) ->
                Tezos_shell.Distributed_db.t ->
                  Tezos_shell.State.Chain.chain_state ->
                    limits ->
                      Lwt.t
                        (Tezos_base__TzPervasives.tzresult
                          (Types.state * (unit -> Lwt.t unit))))
  (block : Tezos_shell.State.Block.t) : Lwt.t unit :=
  let nv := Worker.state w in
  let create_child
    (block : Tezos_shell.State.Block.t) (protocol :
    Tezos_base__TzPervasives.Protocol_hash.t) (expiration :
    Tezos_base.Time.Protocol.t) (forking_block : Tezos_shell.State.Block.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let block_header := State.Block.header block in
    let genesis :=
      Context.compute_testchain_genesis (State.Block.hash forking_block) in
    let chain_id := Context.compute_testchain_chain_id genesis in
    let activated :=
      match child nv with
      | None => false
      | Some (child, _) =>
        Block_hash.equal
          (block (State.Chain.genesis (chain_state (parameters child)))) genesis
      end in
    let expired := OCaml.Stdlib.lt expiration (timestamp (shell block_header))
      in
    if andb expired activated then
      op_gtgteq (shutdown_child nv active_chains)
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)
    else
      if
        orb activated
          (orb expired
            (negb (State.Chain.allow_forked_chain (chain_state (parameters nv)))))
        then
        return_unit
      else
        op_gtgteqquestion
          (op_gtgteq
            (State.Chain.get_opt
              (State.Chain.global_state (chain_state (parameters nv))) chain_id)
            (fun function_parameter =>
              match function_parameter with
              | Some chain_state =>
                op_gtgteq (State.update_testchain block chain_state)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    _return chain_state)
              | None =>
                let try_init_test_chain
                  (cont :
                  unit ->
                    Lwt.t
                      (Tezos_base__TzPervasives.tzresult
                        Tezos_shell.State.Chain.t))
                  : Lwt.t
                    (Tezos_base__TzPervasives.tzresult Tezos_shell.State.Chain.t) :=
                  let bvp := block_validator_process (parameters nv) in
                  op_gtgteq
                    (Block_validator_process.init_test_chain bvp forking_block)
                    (fun function_parameter =>
                      match function_parameter with
                      | Stdlib.Ok genesis_header =>
                        op_gtgteqquestion
                          (State.fork_testchain block chain_id genesis
                            genesis_header protocol expiration)
                          (fun chain_state =>
                            op_gtgteq (Chain.head chain_state)
                              (fun new_genesis_block =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  Lwt_watcher.notify
                                    (global_valid_block_input (parameters nv))
                                    new_genesis_block in
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  Lwt_watcher.notify (valid_block_input nv)
                                    new_genesis_block in
                                _return chain_state))
                      |
                        Stdlib.Error
                          (cons
                            (Tezos_base__TzPervasives.Missing_test_protocol
                              missing_protocol) _) =>
                        op_gtgteqquestion
                          (Block_validator.fetch_and_compile_protocol
                            (block_validator (parameters nv)) None None
                            missing_protocol)
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            cont tt)
                      | (Stdlib.Error _) as error => Lwt._return error
                      end) in
                apply try_init_test_chain
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    apply try_init_test_chain
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Could not retrieve test protocol" % string
                              CamlinternalFormatBasics.End_of_format)
                            "Could not retrieve test protocol" % string)))
              end))
          (fun chain_state =>
            op_gtgteqquestion
              (spawn_child (State.Chain.id chain_state)
                (peer_validator_limits (parameters nv))
                (prevalidator_limits (parameters nv))
                (block_validator (parameters nv))
                (global_valid_block_input (parameters nv))
                (global_chains_input (parameters nv)) (db (parameters nv))
                chain_state (limits (parameters nv)))
              (fun child =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  (* ❌ Set record field not handled. *)
                  set_record_field nv "child" % string (Some child) in
                return_unit)) in
  op_gtgteq
    (op_gtgteq (State.Block.test_chain block)
      (fun function_parameter =>
        match function_parameter with
        | (Tezos_base__TzPervasives.Test_chain_status.Not_running, _) =>
          op_gtgteq (shutdown_child nv active_chains)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        |
          (Tezos_base__TzPervasives.Test_chain_status.Forking _ |
            Tezos_base__TzPervasives.Test_chain_status.Running _, None) =>
          return_unit
        |
          (Tezos_base__TzPervasives.Test_chain_status.Forking {|
            protocol := protocol; expiration := expiration |} |
            Tezos_base__TzPervasives.Test_chain_status.Running {|
              protocol := protocol; expiration := expiration |},
            Some forking_block) =>
          create_child block protocol expiration forking_block
        end))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => Lwt.return_unit
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Worker.record_event w
            (Tezos_shell_services.Chain_validator_worker_state.Event.Could_not_switch_testchain
              err) in
        Lwt.return_unit
      end).

Definition broadcast_head {A : Type}
  (w : Worker.t A) (previous : Tezos_shell.State.Block.t)
  (block : Tezos_shell.State.Block.t) : Lwt.t unit :=
  let nv := Worker.state w in
  if negb (bootstrapped nv) then
    Lwt.return_unit
  else
    op_gtgteq
      (op_gtgteq (State.Block.predecessor block)
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_true
          | Some predecessor =>
            Lwt._return (State.Block.equal predecessor previous)
          end))
      (fun successor =>
        if successor then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Distributed_db.Advertise.current_head (chain_db (parameters nv))
              None None block in
          Lwt.return_unit
        else
          Distributed_db.Advertise.current_branch None
            (chain_db (parameters nv))).

Definition safe_get_protocol (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_updater.Registered_protocol.t) :=
  match Registered_protocol.get hash with
  | None =>
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "chain_validator: missing protocol '" % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              "' for the current block." % string
              CamlinternalFormatBasics.End_of_format)))
        "chain_validator: missing protocol '%a' for the current block." % string)
      Protocol_hash.pp_short hash
  | Some protocol => _return protocol
  end.

Definition on_request {A B C : Type}
  (w : Worker.t A) (start_testchain : bool)
  (active_chains : Tezos_base__TzPervasives.Chain_id.Table.t B)
  (spawn_child :
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_shell.Peer_validator.limits ->
        Tezos_shell.Prevalidator.limits ->
          Tezos_shell.Block_validator.t ->
            (Tezos_base__TzPervasives.Lwt_watcher.input
              Tezos_shell.State.Block.t) ->
              (Tezos_base__TzPervasives.Lwt_watcher.input
                (Tezos_base__TzPervasives.Chain_id.t * bool)) ->
                Tezos_shell.Distributed_db.t ->
                  Tezos_shell.State.Chain.chain_state ->
                    limits ->
                      Lwt.t
                        (Tezos_base__TzPervasives.tzresult
                          (Types.state * (unit -> Lwt.t unit))))
  (req : Request.t C) : Lwt.t (Tezos_base__TzPervasives.tzresult C) :=
  let 'Request.Validated block := req in
  let nv := Worker.state w in
  op_gtgteq (Chain.head (chain_state (parameters nv)))
    (fun head =>
      let head_header : Tezos_base__TzPervasives.Block_header.t :=
        State.Block.header head
      with head_hash : Tezos_base__TzPervasives.Block_hash.t :=
        State.Block.hash head
      with block_header : Tezos_base__TzPervasives.Block_header.t :=
        State.Block.header block
      with block_hash : Tezos_base__TzPervasives.Block_hash.t :=
        State.Block.hash block in
      op_gtgteq
        match prevalidator nv with
        | None => Lwt._return (fitness (shell head_header))
        | Some pv => Prevalidator.fitness pv
        end
        (fun context_fitness =>
          let head_fitness := fitness (shell head_header) in
          let new_fitness := fitness (shell block_header) in
          let accepted_head :=
            if op_eq context_fitness head_fitness then
              op_gt new_fitness head_fitness
            else
              op_gteq new_fitness context_fitness in
          if negb accepted_head then
            _return
              Tezos_shell_services.Chain_validator_worker_state.Event.Ignored_head
          else
            op_gtgteqquestion
              (Chain.set_head (chain_state (parameters nv)) block)
              (fun previous =>
                op_gtgteqquestion
                  (may_update_checkpoint (chain_state (parameters nv)) block)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (broadcast_head w previous block)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          match prevalidator nv with
                          | Some old_prevalidator =>
                            op_gtgteqquestion (State.Block.protocol_hash block)
                              (fun new_protocol =>
                                let old_protocol :=
                                  Prevalidator.protocol_hash old_prevalidator in
                                if
                                  negb
                                    (Protocol_hash.equal old_protocol
                                      new_protocol) then
                                  op_gtgteqquestion
                                    (safe_get_protocol new_protocol)
                                    (fun Proto =>
                                      let Proto := projT2 Proto in
                                      let '(limits, chain_db) :=
                                        Prevalidator.parameters old_prevalidator
                                        in
                                      op_gtgteq
                                        (Prevalidator.create limits Proto
                                          chain_db)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | Stdlib.Error errs =>
                                            op_gtgteq
                                              (Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_error)
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.Formatting_gen
                                                    (CamlinternalFormatBasics.Open_box
                                                      (CamlinternalFormatBasics.Format
                                                        CamlinternalFormatBasics.End_of_format
                                                        "" % string))
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Failed to reinstantiate prevalidator:"
                                                        % string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@ " % string 1 0)
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            CamlinternalFormatBasics.End_of_format)))))
                                                  "@[Failed to reinstantiate prevalidator:@ %a@]"
                                                    % string) pp_print_error
                                                errs)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                let _ :=
                                                  (* ❌ Set record field not handled. *)
                                                  set_record_field nv
                                                    "prevalidator" % string None
                                                  in
                                                op_gtgteq
                                                  (Prevalidator.shutdown
                                                    old_prevalidator)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    return_unit))
                                          | Stdlib.Ok prevalidator =>
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            let _ :=
                                              (* ❌ Set record field not handled. *)
                                              set_record_field nv
                                                "prevalidator" % string
                                                (Some prevalidator) in
                                            op_gtgteq
                                              (Prevalidator.shutdown
                                                old_prevalidator)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                return_unit)
                                          end))
                                else
                                  Prevalidator.flush old_prevalidator block_hash)
                          | None => return_unit
                          end
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              (if start_testchain then
                                may_switch_test_chain w active_chains
                                  spawn_child block
                              else
                                Lwt.return_unit)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  Lwt_watcher.notify (new_head_input nv) block
                                  in
                                if
                                  Block_hash.equal head_hash
                                    (predecessor (shell block_header)) then
                                  _return
                                    Tezos_shell_services.Chain_validator_worker_state.Event.Head_increment
                                else
                                  _return
                                    Tezos_shell_services.Chain_validator_worker_state.Event.Branch_switch))))))).

Definition on_completion {A B : Type}
  (w : Worker.t A) (req : Request.t B) (update : B)
  (request_status : Tezos_shell_services.Worker_types.request_status)
  : Lwt.t unit :=
  let 'Request.Validated block := req in
  let fitness := State.Block.fitness block in
  let request := State.Block.hash block in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Worker.record_event w
      (Tezos_shell_services.Chain_validator_worker_state.Event.Processed_block
        {| request := request; request_status := request_status;
          update := update; fitness := fitness |}) in
  Lwt.return_unit.

Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let nv := Worker.state w in
  op_gtgteq (Distributed_db.deactivate (chain_db (parameters nv)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      let pvs :=
        P2p_peer.Error_table.fold_promises
          (fun function_parameter =>
            let '_ := function_parameter in
            fun pv =>
              fun acc =>
                cons
                  (op_gtgteq pv
                    (fun function_parameter =>
                      match function_parameter with
                      | Stdlib.Error _ => Lwt.return_unit
                      | Stdlib.Ok pv => Peer_validator.shutdown pv
                      end)) acc) (active_peers nv) [] in
      Lwt.join
        (cons
          match prevalidator nv with
          | Some prevalidator => Prevalidator.shutdown prevalidator
          | None => Lwt.return_unit
          end
          (cons
            (Lwt_utils.may
              (fun function_parameter =>
                let '(_, shutdown) := function_parameter in
                shutdown tt) (child nv)) pvs))).

Definition on_launch {A : Type}
  (start_prevalidator : bool) (w : Worker.t (Worker.queue Worker.infinite))
  (function_parameter : A)
  : Types.parameters -> Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
  let '_ := function_parameter in
  fun parameters =>
    op_gtgteqquestion
      (if start_prevalidator then
        op_gtgteq
          (State.read_chain_data (chain_state parameters)
            (fun function_parameter =>
              let '_ := function_parameter in
              fun function_parameter =>
                let '{| State.current_head := current_head |} :=
                  function_parameter in
                Lwt._return current_head))
          (fun head =>
            op_gtgteqquestion (State.Block.protocol_hash head)
              (fun head_hash =>
                op_gtgteq (safe_get_protocol head_hash)
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Ok Proto =>
                      let Proto := projT2 Proto in
                      op_gtgteq
                        (Prevalidator.create (prevalidator_limits parameters)
                          Proto (chain_db parameters))
                        (fun function_parameter =>
                          match function_parameter with
                          | Stdlib.Error err =>
                            op_gtgteq
                              (Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_error)
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        CamlinternalFormatBasics.End_of_format
                                        "" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Failed to instantiate prevalidator:" %
                                        string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "@[Failed to instantiate prevalidator:@ %a@]"
                                    % string) pp_print_error err)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_none)
                          | Stdlib.Ok prevalidator => return_some prevalidator
                          end)
                    | Stdlib.Error err =>
                      op_gtgteq
                        (Log.(Tezos_event_logging__Internal_event.LOG.Legacy_logging.lwt_log_error)
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  CamlinternalFormatBasics.End_of_format
                                  "" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Failed to instantiate prevalidator:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))
                            "@[Failed to instantiate prevalidator:@ %a@]" %
                              string) pp_print_error err)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_none)
                    end)))
      else
        return_none)
      (fun prevalidator =>
        let valid_block_input := Lwt_watcher.create_input tt in
        let new_head_input := Lwt_watcher.create_input tt in
        let '(bootstrapped_waiter, bootstrapped_wakener) := Lwt.wait tt in
        let nv :=
          {| parameters := parameters;
            bootstrapped :=
              OCaml.Stdlib.le (bootstrap_threshold (limits parameters)) 0;
            bootstrapped_waiter := bootstrapped_waiter;
            bootstrapped_wakener := bootstrapped_wakener;
            valid_block_input := valid_block_input;
            new_head_input := new_head_input; child := None;
            prevalidator := prevalidator;
            active_peers := P2p_peer.Error_table.create 50;
            bootstrapped_peers := P2p_peer.Table.create 50 |} in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if bootstrapped nv then
            Lwt.wakeup_later bootstrapped_wakener tt
          else
            tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Distributed_db.set_callback (chain_db parameters)
            {|
              notify_branch :=
                fun peer_id =>
                  fun locator =>
                    Lwt.async
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        apply (with_activated_peer_validator w peer_id)
                          (fun pv =>
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := Peer_validator.notify_branch pv locator in
                            return_unit));
              notify_head :=
                fun peer_id =>
                  fun block =>
                    fun ops =>
                      Lwt.async
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (with_activated_peer_validator w peer_id
                              (fun pv =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ := Peer_validator.notify_head pv block in
                                return_unit))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              match prevalidator nv with
                              | Some prevalidator =>
                                op_gtgteq
                                  (Prevalidator.notify_operations prevalidator
                                    peer_id ops)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit)
                              | None => return_unit
                              end));
              disconnection :=
                fun peer_id =>
                  Lwt.async
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let nv := Worker.state w in
                      match
                        P2p_peer.Error_table.find_opt (active_peers nv) peer_id
                        with
                      | None => return_unit
                      | Some pv =>
                        op_gtgteqquestion pv
                          (fun pv =>
                            op_gtgteq (Peer_validator.shutdown pv)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit))
                      end) |} in
        _return nv).

Fixpoint create
  (start_prevalidator : bool) (start_testchain : bool)
  (active_chains :
    Tezos_base__TzPervasives.Chain_id.Table.t
      (Worker.t (Worker.queue Worker.infinite)))
  (parent : option Tezos_base__TzPervasives.Chain_id.t)
  (block_validator_process : Tezos_shell.Block_validator_process.t)
  (peer_validator_limits : Tezos_shell.Peer_validator.limits)
  (prevalidator_limits : Tezos_shell.Prevalidator.limits)
  (block_validator : Tezos_shell.Block_validator.t)
  (global_valid_block_input :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t)
  (global_chains_input :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool))
  (db : Tezos_shell.Distributed_db.t)
  (chain_state : Tezos_shell.State.Chain.chain_state) (limits : limits)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
  let spawn_child
    (parent : Tezos_base__TzPervasives.Chain_id.t) (pvl :
    Tezos_shell.Peer_validator.limits) (pl : Tezos_shell.Prevalidator.limits)
    (bl : Tezos_shell.Block_validator.t) (gvbi :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t) (gci :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool)) (db :
    Tezos_shell.Distributed_db.t) (n : Tezos_shell.State.Chain.chain_state) (l :
    limits)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Worker.Types.state * (unit -> Lwt.t unit))) :=
    op_gtgteqquestion
      (create start_prevalidator start_testchain active_chains (Some parent)
        block_validator_process pvl pl bl gvbi gci db n l)
      (fun w =>
        _return
          ((Worker.state w),
            (fun function_parameter =>
              let 'tt := function_parameter in
              Worker.shutdown w))) in
  let Handlers :=
    existT _ unit
      {|
        Worker.HANDLERS.on_launch := on_launch start_prevalidator;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_request := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_close := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_error := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_completion := unhandled;
        (* ❌ This kind of definition of value for first-class modules is not handled *)
        Worker.HANDLERS.on_no_request := unhandled
        |} in
  let parameters :=
    {| parent := parent; db := db; chain_state := chain_state;
      chain_db := Distributed_db.activate db chain_state;
      block_validator := block_validator;
      block_validator_process := block_validator_process;
      global_valid_block_input := global_valid_block_input;
      global_chains_input := global_chains_input;
      prevalidator_limits := prevalidator_limits;
      peer_validator_limits := peer_validator_limits; limits := limits |} in
  op_gtgteqquestion (Chain.init_head chain_state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (Worker.launch table None (worker_limits prevalidator_limits)
          (State.Chain.id chain_state) parameters Handlers)
        (fun w =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Chain_id.Table.add active_chains (State.Chain.id chain_state) w in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Lwt_watcher.notify global_chains_input
              ((State.Chain.id chain_state), true) in
          _return w)).

Definition create
  (start_prevalidator : bool) (start_testchain : bool)
  (active_chains :
    Tezos_base__TzPervasives.Chain_id.Table.t
      (Worker.t (Worker.queue Worker.infinite)))
  (block_validator_process : Tezos_shell.Block_validator_process.t)
  (peer_validator_limits : Tezos_shell.Peer_validator.limits)
  (prevalidator_limits : Tezos_shell.Prevalidator.limits)
  (block_validator : Tezos_shell.Block_validator.t)
  (global_valid_block_input :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t)
  (global_chains_input :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool))
  (global_db : Tezos_shell.Distributed_db.t)
  (state : Tezos_shell.State.Chain.chain_state) (limits : limits)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (Worker.t (Worker.queue Worker.infinite))) :=
  create start_prevalidator start_testchain active_chains None
    block_validator_process peer_validator_limits prevalidator_limits
    block_validator global_valid_block_input global_chains_input global_db state
    limits.

Definition chain_id {A : Type} (w : Worker.t A)
  : Tezos_base__TzPervasives.Chain_id.t :=
  let '{| parameters := {| chain_state := chain_state |} |} := Worker.state w in
  State.Chain.id chain_state.

Definition chain_state {A : Type} (w : Worker.t A)
  : Tezos_shell.State.Chain.t :=
  let '{| parameters := {| chain_state := chain_state |} |} := Worker.state w in
  chain_state.

Definition prevalidator {A : Type} (w : Worker.t A)
  : option Tezos_shell.Prevalidator.t :=
  let '{| prevalidator := prevalidator |} := Worker.state w in
  prevalidator.

Definition chain_db {A : Type} (w : Worker.t A)
  : Tezos_shell.Distributed_db.chain_db :=
  let '{| parameters := {| chain_db := chain_db |} |} := Worker.state w in
  chain_db.

Definition child {A : Type} (w : Worker.t A)
  : option (Worker.t (Worker.queue Worker.infinite)) :=
  match child (Worker.state w) with
  | None => None
  | Some ({| parameters := {| chain_state := chain_state |} |}, _) =>
    (* ❌ Try-with are not handled *)
    try (Some (List.assoc (State.Chain.id chain_state) (Worker.list table)))
  end.

Definition assert_fitness_increases {A : Type} (op_staroptstar : option bool)
  : (Worker.t A) ->
    Tezos_base__TzPervasives.Block_header.t ->
      Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let force :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun w =>
    fun distant_header =>
      let pv := Worker.state w in
      let chain_state := Distributed_db.chain_state (chain_db (parameters pv))
        in
      op_gtgteq (Chain.head chain_state)
        (fun local_header =>
          fail_when
            (andb (negb force)
              (OCaml.Stdlib.le
                (Fitness.compare (fitness (Block_header.shell distant_header))
                  (State.Block.fitness local_header)) 0))
            (failure
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Fitness too low" % string
                  CamlinternalFormatBasics.End_of_format)
                "Fitness too low" % string))).

Definition assert_checkpoint {A : Type}
  (w : Worker.t A) (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
  op_gtgteq (State.Chain.acceptable_block chain_state header)
    (fun acceptable =>
      fail_unless acceptable
        (Tezos_base__TzPervasives.Checkpoint_error (Block_header.hash header)
          None)).

Definition validate_block
  (w : Worker.t (Worker.queue Worker.infinite)) (force : option bool)
  (hash : Tezos_base__TzPervasives.Block_hash.t)
  (block : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.t)) :=
  let nv := Worker.state w in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (Block_hash.equal hash (Block_header.hash block)) in
  op_gtgteqquestion (assert_fitness_increases force w block)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (assert_checkpoint w block)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Block_validator.validate (block_validator (parameters nv))
            (Some (Worker.canceler w)) None (Some (notify_new_block w))
            (chain_db (parameters nv)) hash block operations)).

Definition bootstrapped {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let '{| bootstrapped_waiter := bootstrapped_waiter |} := Worker.state w in
  Lwt.protected bootstrapped_waiter.

Definition valid_block_watcher {A : Type} (w : Worker.t A)
  : (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  let '{| valid_block_input := valid_block_input |} := Worker.state w in
  Lwt_watcher.create_stream valid_block_input.

Definition new_head_watcher {A : Type} (w : Worker.t A)
  : (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  let '{| new_head_input := new_head_input |} := Worker.state w in
  Lwt_watcher.create_stream new_head_input.

Definition status {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
  Worker.status.

Definition information {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_information :=
  Worker.information.

Definition running_workers (function_parameter : unit)
  : list (Worker.Name.t * (Worker.t (Worker.queue Worker.infinite))) :=
  let 'tt := function_parameter in
  Worker.list table.

Definition pending_requests {A : Type} (t : Worker.t (Worker.queue A))
  : list (Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.Queue.pending_requests t.

Definition pending_requests_length {A : Type} (t : Worker.t (Worker.queue A))
  : Z := Worker.Queue.pending_requests_length t.

Definition current_request {A : Type} (t : Worker.t A)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t * Worker.Request.view) :=
  Worker.current_request t.

Definition last_events {A : Type}
  : (Worker.t A) ->
    list (Tezos_base__TzPervasives.Internal_event.level * (list Worker.Event.t)) :=
  Worker.last_events.

Definition ddb_information {A : Type} (t : Worker.t A)
  : Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
  let state := Worker.state t in
  let ddb := chain_db (parameters state) in
  Distributed_db.information ddb.

src/lib_shell/distributed_db.ml 208 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Message = Distributed_db_message

module Logging = Internal_event.Legacy_logging.Make (struct
  let name = "node.distributed_db"
end)

type p2p = (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.net

type connection =
  (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.connection

type 'a request_param = {
  p2p : (Message.t, Peer_metadata.t, Connection_metadata.t) P2p.t;
  data : 'a;
  active : unit -> P2p_peer.Set.t;
  send : P2p_peer.Id.t -> Message.t -> unit;
}

module Make_raw (Hash : sig
  type t

  val name : string

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit

  module Logging : sig
    val tag : t Tag.def
  end
end)
(Disk_table : Distributed_db_functors.DISK_TABLE with type key := Hash.t)
(Memory_table : Distributed_db_functors.MEMORY_TABLE with type key := Hash.t)
(Request_message : sig
  type param

  val max_length : int

  val initial_delay : Time.System.Span.t

  val forge : param -> Hash.t list -> Message.t
end)
(Precheck : Distributed_db_functors.PRECHECK
              with type key := Hash.t
               and type value := Disk_table.value) =
struct
  module Request = struct
    type param = Request_message.param request_param

    let active {active; _} = active ()

    let initial_delay = Request_message.initial_delay

    let rec send state gid keys =
      let (first_keys, keys) = List.split_n Request_message.max_length keys in
      let msg = Request_message.forge state.data first_keys in
      state.send gid msg ;
      let open Peer_metadata in
      let (req : requests_kind) =
        match msg with
        | Get_current_branch _ ->
            Branch
        | Get_current_head _ ->
            Head
        | Get_block_headers _ ->
            Block_header
        | Get_operations _ ->
            Operations
        | Get_protocols _ ->
            Protocols
        | Get_operation_hashes_for_blocks _ ->
            Operation_hashes_for_block
        | Get_operations_for_blocks _ ->
            Operations_for_block
        | _ ->
            Other
      in
      let meta = P2p.get_peer_metadata state.p2p gid in
      Peer_metadata.incr meta @@ Scheduled_request req ;
      if keys <> [] then send state gid keys
  end

  module Scheduler =
    Distributed_db_functors.Make_request_scheduler (Hash) (Memory_table)
      (Request)
  module Table =
    Distributed_db_functors.Make_table (Hash) (Disk_table) (Memory_table)
      (Scheduler)
      (Precheck)

  type t = {scheduler : Scheduler.t; table : Table.t}

  let state_of_t {scheduler; table} =
    let table_length = Table.memory_table_length table in
    let scheduler_length = Scheduler.memory_table_length scheduler in
    {
      Chain_validator_worker_state.Distributed_db_state.table_length;
      scheduler_length;
    }

  let create ?global_input request_param param =
    let scheduler = Scheduler.create request_param in
    let table = Table.create ?global_input scheduler param in
    {scheduler; table}

  let shutdown {scheduler; _} =
    Logging.lwt_log_notice
      "Shutting down the distributed data-base scheduler..."
    >>= fun () -> Scheduler.shutdown scheduler
end

module Fake_operation_storage = struct
  type store = State.Chain.t

  type value = Operation.t

  let known _ _ = Lwt.return_false

  let read _ _ = Lwt.return (Error_monad.error_exn Not_found)

  let read_opt _ _ = Lwt.return_none
end

module Raw_operation =
  Make_raw (Operation_hash) (Fake_operation_storage) (Operation_hash.Table)
    (struct
      type param = unit

      let max_length = 10

      let initial_delay = Time.System.Span.of_seconds_exn 0.5

      let forge () keys = Message.Get_operations keys
    end)
    (struct
      type param = unit

      type notified_value = Operation.t

      let precheck _ _ v = Some v
    end)

module Block_header_storage = struct
  type store = State.Chain.t

  type value = Block_header.t

  let known = State.Block.known_valid

  let read chain_state h =
    State.Block.read chain_state h >>=? fun b -> return (State.Block.header b)

  let read_opt chain_state h =
    State.Block.read_opt chain_state h
    >>= fun b -> Lwt.return (Option.map ~f:State.Block.header b)
end

module Raw_block_header =
  Make_raw (Block_hash) (Block_header_storage) (Block_hash.Table)
    (struct
      type param = unit

      let max_length = 10

      let initial_delay = Time.System.Span.of_seconds_exn 0.5

      let forge () keys = Message.Get_block_headers keys
    end)
    (struct
      type param = unit

      type notified_value = Block_header.t

      let precheck _ _ v = Some v
    end)

module Operation_hashes_storage = struct
  type store = State.Chain.t

  type value = Operation_hash.t list

  let known chain_state (h, _) = State.Block.known_valid chain_state h

  let read chain_state (h, i) =
    State.Block.read chain_state h
    >>=? fun b ->
    State.Block.operation_hashes b i >>= fun (ops, _) -> return ops

  let read_opt chain_state (h, i) =
    State.Block.read_opt chain_state h
    >>= function
    | None ->
        Lwt.return_none
    | Some b ->
        State.Block.operation_hashes b i
        >>= fun (ops, _) -> Lwt.return_some ops
end

module Operations_table = Hashtbl.Make (struct
  type t = Block_hash.t * int

  let hash = Hashtbl.hash

  let equal (b1, i1) (b2, i2) = Block_hash.equal b1 b2 && i1 = i2
end)

module Raw_operation_hashes = struct
  include Make_raw
            (struct
              type t = Block_hash.t * int

              let name = "operation_hashes"

              let pp ppf (h, n) = Format.fprintf ppf "%a:%d" Block_hash.pp h n

              let encoding =
                let open Data_encoding in
                obj2 (req "block" Block_hash.encoding) (req "index" uint16)

              module Logging = struct
                let tag = Tag.def ~doc:"Operation hashes" "operation_hashes" pp
              end
            end)
            (Operation_hashes_storage)
            (Operations_table)
            (struct
              type param = unit

              let max_length = 10

              let initial_delay = Time.System.Span.of_seconds_exn 1.

              let forge () keys = Message.Get_operation_hashes_for_blocks keys
            end)
            (struct
              type param = Operation_list_list_hash.t

              type notified_value =
                Operation_hash.t list * Operation_list_list_hash.path

              let precheck (_block, expected_ofs) expected_hash (ops, path) =
                let (received_hash, received_ofs) =
                  Operation_list_list_hash.check_path
                    path
                    (Operation_list_hash.compute ops)
                in
                if
                  received_ofs = expected_ofs
                  && Operation_list_list_hash.compare
                       expected_hash
                       received_hash
                     = 0
                then Some ops
                else None
            end)

  let clear_all table hash n =
    List.iter (fun i -> Table.clear_or_cancel table (hash, i)) (0 -- (n - 1))
end

module Operations_storage = struct
  type store = State.Chain.t

  type value = Operation.t list

  let known chain_state (h, _) = State.Block.known_valid chain_state h

  let read chain_state (h, i) =
    State.Block.read chain_state h
    >>=? fun b -> State.Block.operations b i >>= fun (ops, _) -> return ops

  let read_opt chain_state (h, i) =
    State.Block.read_opt chain_state h
    >>= function
    | None ->
        Lwt.return_none
    | Some b ->
        State.Block.operations b i >>= fun (ops, _) -> Lwt.return_some ops
end

module Raw_operations = struct
  include Make_raw
            (struct
              type t = Block_hash.t * int

              let name = "operations"

              let pp ppf (h, n) = Format.fprintf ppf "%a:%d" Block_hash.pp h n

              let encoding =
                let open Data_encoding in
                obj2 (req "block" Block_hash.encoding) (req "index" uint16)

              module Logging = struct
                let tag = Tag.def ~doc:"Operations" "operations" pp
              end
            end)
            (Operations_storage)
            (Operations_table)
            (struct
              type param = unit

              let max_length = 10

              let initial_delay = Time.System.Span.of_seconds_exn 1.

              let forge () keys = Message.Get_operations_for_blocks keys
            end)
            (struct
              type param = Operation_list_list_hash.t

              type notified_value =
                Operation.t list * Operation_list_list_hash.path

              let precheck (_block, expected_ofs) expected_hash (ops, path) =
                let (received_hash, received_ofs) =
                  Operation_list_list_hash.check_path
                    path
                    (Operation_list_hash.compute (List.map Operation.hash ops))
                in
                if
                  received_ofs = expected_ofs
                  && Operation_list_list_hash.compare
                       expected_hash
                       received_hash
                     = 0
                then Some ops
                else None
            end)

  let clear_all table hash n =
    List.iter (fun i -> Table.clear_or_cancel table (hash, i)) (0 -- (n - 1))
end

module Protocol_storage = struct
  type store = State.t

  type value = Protocol.t

  let known = State.Protocol.known

  let read = State.Protocol.read

  let read_opt = State.Protocol.read_opt
end

module Raw_protocol =
  Make_raw (Protocol_hash) (Protocol_storage) (Protocol_hash.Table)
    (struct
      type param = unit

      let initial_delay = Time.System.Span.of_seconds_exn 10.

      let max_length = 10

      let forge () keys = Message.Get_protocols keys
    end)
    (struct
      type param = unit

      type notified_value = Protocol.t

      let precheck _ _ v = Some v
    end)

type callback = {
  notify_branch : P2p_peer.Id.t -> Block_locator.t -> unit;
  notify_head : P2p_peer.Id.t -> Block_header.t -> Mempool.t -> unit;
  disconnection : P2p_peer.Id.t -> unit;
}

type db = {
  p2p : p2p;
  p2p_readers : p2p_reader P2p_peer.Table.t;
  disk : State.t;
  active_chains : chain_db Chain_id.Table.t;
  protocol_db : Raw_protocol.t;
  block_input : (Block_hash.t * Block_header.t) Lwt_watcher.input;
  operation_input : (Operation_hash.t * Operation.t) Lwt_watcher.input;
}

and chain_db = {
  chain_state : State.Chain.t;
  global_db : db;
  operation_db : Raw_operation.t;
  block_header_db : Raw_block_header.t;
  operation_hashes_db : Raw_operation_hashes.t;
  operations_db : Raw_operations.t;
  mutable callback : callback;
  active_peers : P2p_peer.Set.t ref;
  active_connections : p2p_reader P2p_peer.Table.t;
}

and p2p_reader = {
  gid : P2p_peer.Id.t;
  conn : connection;
  peer_active_chains : chain_db Chain_id.Table.t;
  canceler : Lwt_canceler.t;
  mutable worker : unit Lwt.t;
}

let noop_callback =
  {
    notify_branch = (fun _gid _locator -> ());
    notify_head = (fun _gid _block _ops -> ());
    disconnection = (fun _gid -> ());
  }

type t = db

let state {disk; _} = disk

let chain_state {chain_state; _} = chain_state

let db {global_db; _} = global_db

let information
    ({ global_db = {p2p_readers; active_chains; _};
       operation_db;
       operations_db;
       block_header_db;
       operation_hashes_db;
       active_connections;
       active_peers;
       _ } :
      chain_db) =
  {
    Chain_validator_worker_state.Distributed_db_state.p2p_readers_length =
      P2p_peer.Table.length p2p_readers;
    active_chains_length = Chain_id.Table.length active_chains;
    operation_db = Raw_operation.state_of_t operation_db;
    operations_db = Raw_operations.state_of_t operations_db;
    block_header_db = Raw_block_header.state_of_t block_header_db;
    operations_hashed_db = Raw_operation_hashes.state_of_t operation_hashes_db;
    active_connections_length = P2p_peer.Table.length active_connections;
    active_peers_length = P2p_peer.Set.cardinal !active_peers;
  }

let my_peer_id chain_db = P2p.peer_id chain_db.global_db.p2p

let get_peer_metadata chain_db = P2p.get_peer_metadata chain_db.global_db.p2p

let read_block_header {disk; _} h =
  State.read_block disk h
  >>= function
  | Some b ->
      Lwt.return_some (State.Block.chain_id b, State.Block.header b)
  | None ->
      Lwt.return_none

let find_pending_block_header {peer_active_chains; _} h =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None
        when Raw_block_header.Table.pending chain_db.block_header_db.table h ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let find_pending_operations {peer_active_chains; _} h i =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None
        when Raw_operations.Table.pending chain_db.operations_db.table (h, i)
        ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let find_pending_operation_hashes {peer_active_chains; _} h i =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None
        when Raw_operation_hashes.Table.pending
               chain_db.operation_hashes_db.table
               (h, i) ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let find_pending_operation {peer_active_chains; _} h =
  Chain_id.Table.fold
    (fun _chain_id chain_db acc ->
      match acc with
      | Some _ ->
          acc
      | None when Raw_operation.Table.pending chain_db.operation_db.table h ->
          Some chain_db
      | None ->
          None)
    peer_active_chains
    None

let read_operation {active_chains; _} h =
  Chain_id.Table.fold
    (fun chain_id chain_db acc ->
      acc
      >>= function
      | Some _ ->
          acc
      | None -> (
          Raw_operation.Table.read_opt chain_db.operation_db.table h
          >>= function
          | None -> Lwt.return_none | Some bh -> Lwt.return_some (chain_id, bh)
          ))
    active_chains
    Lwt.return_none

module P2p_reader = struct
  let may_activate global_db state chain_id f =
    match Chain_id.Table.find_opt state.peer_active_chains chain_id with
    | Some chain_db ->
        f chain_db
    | None -> (
      match Chain_id.Table.find_opt global_db.active_chains chain_id with
      | Some chain_db ->
          chain_db.active_peers :=
            P2p_peer.Set.add state.gid !(chain_db.active_peers) ;
          P2p_peer.Table.add chain_db.active_connections state.gid state ;
          Chain_id.Table.add state.peer_active_chains chain_id chain_db ;
          f chain_db
      | None ->
          let meta = P2p.get_peer_metadata global_db.p2p state.gid in
          Peer_metadata.incr meta Unactivated_chain ;
          Lwt.return_unit )

  let deactivate state chain_db =
    chain_db.callback.disconnection state.gid ;
    chain_db.active_peers :=
      P2p_peer.Set.remove state.gid !(chain_db.active_peers) ;
    P2p_peer.Table.remove chain_db.active_connections state.gid

  (* check if the chain advertized by a peer is (still) active *)
  let may_handle global_db state chain_id f =
    match Chain_id.Table.find_opt state.peer_active_chains chain_id with
    | None ->
        let meta = P2p.get_peer_metadata global_db.p2p state.gid in
        Peer_metadata.incr meta Inactive_chain ;
        Lwt.return_unit
    | Some chain_db ->
        f chain_db

  let may_handle_global global_db chain_id f =
    match Chain_id.Table.find_opt global_db.active_chains chain_id with
    | None ->
        Lwt.return_unit
    | Some chain_db ->
        f chain_db

  module Handle_msg_Logging =
  Internal_event.Legacy_logging.Make_semantic (struct
    let name = "node.distributed_db.p2p_reader"
  end)

  let soon () =
    let now = Systime_os.now () in
    match Ptime.add_span now (Ptime.Span.of_int_s 15) with
    | Some s ->
        s
    | None ->
        invalid_arg "Distributed_db.handle_msg: end of time"

  let handle_msg global_db state msg =
    let open Message in
    let open Handle_msg_Logging in
    let meta = P2p.get_peer_metadata global_db.p2p state.gid in
    lwt_debug
      Tag.DSL.(
        fun f ->
          f "Read message from %a: %a"
          -% t event "read_message"
          -% a P2p_peer.Id.Logging.tag state.gid
          -% a Message.Logging.tag msg)
    >>= fun () ->
    match msg with
    | Get_current_branch chain_id ->
        Peer_metadata.incr meta @@ Received_request Branch ;
        may_handle_global global_db chain_id
        @@ fun chain_db ->
        if not (Chain_id.Table.mem state.peer_active_chains chain_id) then
          Peer_metadata.update_requests meta Branch
          @@ P2p.try_send global_db.p2p state.conn
          @@ Get_current_branch chain_id ;
        let seed =
          {
            Block_locator.receiver_id = state.gid;
            sender_id = my_peer_id chain_db;
          }
        in
        Chain.locator chain_db.chain_state seed
        >>= fun locator ->
        Peer_metadata.update_responses meta Branch
        @@ P2p.try_send global_db.p2p state.conn
        @@ Current_branch (chain_id, locator) ;
        Lwt.return_unit
    | Current_branch (chain_id, locator) ->
        may_activate global_db state chain_id
        @@ fun chain_db ->
        let (head, hist) = (locator :> Block_header.t * Block_hash.t list) in
        Lwt_list.exists_p
          (State.Block.known_invalid chain_db.chain_state)
          (Block_header.hash head :: hist)
        >>= fun known_invalid ->
        if known_invalid then (
          P2p.disconnect global_db.p2p state.conn
          >>= fun () ->
          P2p.greylist_peer global_db.p2p state.gid ;
          Lwt.return_unit )
        else if Time.System.(soon () < of_protocol_exn head.shell.timestamp)
        then (
          Peer_metadata.incr meta Future_block ;
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f "Received future block %a from peer %a."
                -% t event "received_future_block"
                -% a Block_hash.Logging.tag (Block_header.hash head)
                -% a P2p_peer.Id.Logging.tag state.gid) )
        else (
          chain_db.callback.notify_branch state.gid locator ;
          (* TODO discriminate between received advertisements
             and responses? *)
          Peer_metadata.incr meta @@ Received_advertisement Branch ;
          Lwt.return_unit )
    | Deactivate chain_id ->
        may_handle global_db state chain_id
        @@ fun chain_db ->
        deactivate state chain_db ;
        Chain_id.Table.remove state.peer_active_chains chain_id ;
        Lwt.return_unit
    | Get_current_head chain_id ->
        may_handle global_db state chain_id
        @@ fun chain_db ->
        Peer_metadata.incr meta @@ Received_request Head ;
        let {Connection_metadata.disable_mempool; _} =
          P2p.connection_remote_metadata chain_db.global_db.p2p state.conn
        in
        ( if disable_mempool then
          Chain.head chain_db.chain_state
          >>= fun head -> Lwt.return (State.Block.header head, Mempool.empty)
        else State.Current_mempool.get chain_db.chain_state )
        >>= fun (head, mempool) ->
        (* TODO bound the sent mempool size *)
        Peer_metadata.update_responses meta Head
        @@ P2p.try_send global_db.p2p state.conn
        @@ Current_head (chain_id, head, mempool) ;
        Lwt.return_unit
    | Current_head (chain_id, header, mempool) ->
        may_handle global_db state chain_id
        @@ fun chain_db ->
        let head = Block_header.hash header in
        State.Block.known_invalid chain_db.chain_state head
        >>= fun known_invalid ->
        let {Connection_metadata.disable_mempool; _} =
          P2p.connection_local_metadata chain_db.global_db.p2p state.conn
        in
        let known_invalid =
          known_invalid || (disable_mempool && mempool <> Mempool.empty)
          (* A non-empty mempool was received while mempool is desactivated,
               so the message is ignored.
               This should probably warrant a reduction of the sender's score. *)
        in
        if known_invalid then (
          P2p.disconnect global_db.p2p state.conn
          >>= fun () ->
          P2p.greylist_peer global_db.p2p state.gid ;
          Lwt.return_unit )
        else if Time.System.(soon () < of_protocol_exn header.shell.timestamp)
        then (
          Peer_metadata.incr meta Future_block ;
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f "Received future block %a from peer %a."
                -% t event "received_future_block"
                -% a Block_hash.Logging.tag head
                -% a P2p_peer.Id.Logging.tag state.gid) )
        else (
          chain_db.callback.notify_head state.gid header mempool ;
          (* TODO discriminate between received advertisements
             and responses? *)
          Peer_metadata.incr meta @@ Received_advertisement Head ;
          Lwt.return_unit )
    | Get_block_headers hashes ->
        Peer_metadata.incr meta @@ Received_request Block_header ;
        Lwt_list.iter_p
          (fun hash ->
            read_block_header global_db hash
            >>= function
            | None ->
                Peer_metadata.incr meta @@ Unadvertised Block ;
                Lwt.return_unit
            | Some (_chain_id, header) ->
                Peer_metadata.update_responses meta Block_header
                @@ P2p.try_send global_db.p2p state.conn
                @@ Block_header header ;
                Lwt.return_unit)
          hashes
    | Block_header block -> (
        let hash = Block_header.hash block in
        match find_pending_block_header state hash with
        | None ->
            Peer_metadata.incr meta Unexpected_response ;
            Lwt.return_unit
        | Some chain_db ->
            Raw_block_header.Table.notify
              chain_db.block_header_db.table
              state.gid
              hash
              block
            >>= fun () ->
            Peer_metadata.incr meta @@ Received_response Block_header ;
            Lwt.return_unit )
    | Get_operations hashes ->
        Peer_metadata.incr meta @@ Received_request Operations ;
        Lwt_list.iter_p
          (fun hash ->
            read_operation global_db hash
            >>= function
            | None ->
                Peer_metadata.incr meta @@ Unadvertised Operations ;
                Lwt.return_unit
            | Some (_chain_id, op) ->
                Peer_metadata.update_responses meta Operations
                @@ P2p.try_send global_db.p2p state.conn
                @@ Operation op ;
                Lwt.return_unit)
          hashes
    | Operation operation -> (
        let hash = Operation.hash operation in
        match find_pending_operation state hash with
        | None ->
            Peer_metadata.incr meta Unexpected_response ;
            Lwt.return_unit
        | Some chain_db ->
            Raw_operation.Table.notify
              chain_db.operation_db.table
              state.gid
              hash
              operation
            >>= fun () ->
            Peer_metadata.incr meta @@ Received_response Operations ;
            Lwt.return_unit )
    | Get_protocols hashes ->
        Peer_metadata.incr meta @@ Received_request Protocols ;
        Lwt_list.iter_p
          (fun hash ->
            State.Protocol.read_opt global_db.disk hash
            >>= function
            | None ->
                Peer_metadata.incr meta @@ Unadvertised Protocol ;
                Lwt.return_unit
            | Some p ->
                Peer_metadata.update_responses meta Protocols
                @@ P2p.try_send global_db.p2p state.conn
                @@ Protocol p ;
                Lwt.return_unit)
          hashes
    | Protocol protocol ->
        let hash = Protocol.hash protocol in
        Raw_protocol.Table.notify
          global_db.protocol_db.table
          state.gid
          hash
          protocol
        >>= fun () ->
        Peer_metadata.incr meta @@ Received_response Protocols ;
        Lwt.return_unit
    | Get_operation_hashes_for_blocks blocks ->
        Peer_metadata.incr meta @@ Received_request Operation_hashes_for_block ;
        Lwt_list.iter_p
          (fun (hash, ofs) ->
            State.read_block global_db.disk hash
            >>= function
            | None ->
                Lwt.return_unit
            | Some block ->
                State.Block.operation_hashes block ofs
                >>= fun (hashes, path) ->
                Peer_metadata.update_responses meta Operation_hashes_for_block
                @@ P2p.try_send global_db.p2p state.conn
                @@ Operation_hashes_for_block (hash, ofs, hashes, path) ;
                Lwt.return_unit)
          blocks
    | Operation_hashes_for_block (block, ofs, ops, path) -> (
      match find_pending_operation_hashes state block ofs with
      | None ->
          Peer_metadata.incr meta Unexpected_response ;
          Lwt.return_unit
      | Some chain_db ->
          Raw_operation_hashes.Table.notify
            chain_db.operation_hashes_db.table
            state.gid
            (block, ofs)
            (ops, path)
          >>= fun () ->
          Peer_metadata.incr meta
          @@ Received_response Operation_hashes_for_block ;
          Lwt.return_unit )
    | Get_operations_for_blocks blocks ->
        Peer_metadata.incr meta @@ Received_request Operations_for_block ;
        Lwt_list.iter_p
          (fun (hash, ofs) ->
            State.read_block global_db.disk hash
            >>= function
            | None ->
                Lwt.return_unit
            | Some block ->
                State.Block.operations block ofs
                >>= fun (ops, path) ->
                Peer_metadata.update_responses meta Operations_for_block
                @@ P2p.try_send global_db.p2p state.conn
                @@ Operations_for_block (hash, ofs, ops, path) ;
                Lwt.return_unit)
          blocks
    | Operations_for_block (block, ofs, ops, path) -> (
      match find_pending_operations state block ofs with
      | None ->
          Peer_metadata.incr meta Unexpected_response ;
          Lwt.return_unit
      | Some chain_db ->
          Raw_operations.Table.notify
            chain_db.operations_db.table
            state.gid
            (block, ofs)
            (ops, path)
          >>= fun () ->
          Peer_metadata.incr meta @@ Received_response Operations_for_block ;
          Lwt.return_unit )

  let rec worker_loop global_db state =
    protect ~canceler:state.canceler (fun () ->
        P2p.recv global_db.p2p state.conn)
    >>= function
    | Ok msg ->
        handle_msg global_db state msg
        >>= fun () -> worker_loop global_db state
    | Error _ ->
        Chain_id.Table.iter
          (fun _ -> deactivate state)
          state.peer_active_chains ;
        P2p_peer.Table.remove global_db.p2p_readers state.gid ;
        Lwt.return_unit

  let run db gid conn =
    let canceler = Lwt_canceler.create () in
    let state =
      {
        conn;
        gid;
        canceler;
        peer_active_chains = Chain_id.Table.create 17;
        worker = Lwt.return_unit;
      }
    in
    Chain_id.Table.iter
      (fun chain_id _chain_db ->
        Lwt.async (fun () ->
            let meta = P2p.get_peer_metadata db.p2p gid in
            Peer_metadata.incr meta (Sent_request Branch) ;
            P2p.send db.p2p conn (Get_current_branch chain_id)))
      db.active_chains ;
    state.worker <-
      Lwt_utils.worker
        (Format.asprintf "db_network_reader.%a" P2p_peer.Id.pp_short gid)
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop db state)
        ~cancel:(fun () -> Lwt_canceler.cancel canceler) ;
    P2p_peer.Table.add db.p2p_readers gid state

  let shutdown s = Lwt_canceler.cancel s.canceler >>= fun () -> s.worker
end

let active_peer_ids p2p () =
  List.fold_left
    (fun acc conn ->
      let {P2p_connection.Info.peer_id; _} = P2p.connection_info p2p conn in
      P2p_peer.Set.add peer_id acc)
    P2p_peer.Set.empty
    (P2p.connections p2p)

let raw_try_send p2p peer_id msg =
  match P2p.find_connection p2p peer_id with
  | None ->
      ()
  | Some conn ->
      ignore (P2p.try_send p2p conn msg : bool)

let create disk p2p =
  let global_request =
    {p2p; data = (); active = active_peer_ids p2p; send = raw_try_send p2p}
  in
  let protocol_db = Raw_protocol.create global_request disk in
  let active_chains = Chain_id.Table.create 17 in
  let p2p_readers = P2p_peer.Table.create 17 in
  let block_input = Lwt_watcher.create_input () in
  let operation_input = Lwt_watcher.create_input () in
  let db =
    {
      p2p;
      p2p_readers;
      disk;
      active_chains;
      protocol_db;
      block_input;
      operation_input;
    }
  in
  db

let activate ({p2p; active_chains; _} as global_db) chain_state =
  P2p.on_new_connection p2p (P2p_reader.run global_db) ;
  P2p.iter_connections p2p (P2p_reader.run global_db) ;
  P2p.activate p2p ;
  let chain_id = State.Chain.id chain_state in
  match Chain_id.Table.find_opt active_chains chain_id with
  | None ->
      let active_peers = ref P2p_peer.Set.empty in
      let p2p_request =
        {
          p2p;
          data = ();
          active = (fun () -> !active_peers);
          send = raw_try_send p2p;
        }
      in
      let operation_db =
        Raw_operation.create
          ~global_input:global_db.operation_input
          p2p_request
          chain_state
      in
      let block_header_db =
        Raw_block_header.create
          ~global_input:global_db.block_input
          p2p_request
          chain_state
      in
      let operation_hashes_db =
        Raw_operation_hashes.create p2p_request chain_state
      in
      let operations_db = Raw_operations.create p2p_request chain_state in
      let chain =
        {
          global_db;
          operation_db;
          block_header_db;
          operation_hashes_db;
          operations_db;
          chain_state;
          callback = noop_callback;
          active_peers;
          active_connections = P2p_peer.Table.create 53;
        }
      in
      P2p.iter_connections p2p (fun _peer_id conn ->
          Lwt.async (fun () -> P2p.send p2p conn (Get_current_branch chain_id))) ;
      Chain_id.Table.add active_chains chain_id chain ;
      chain
  | Some chain ->
      chain

let set_callback chain_db callback = chain_db.callback <- callback

let deactivate chain_db =
  let {active_chains; p2p; _} = chain_db.global_db in
  let chain_id = State.Chain.id chain_db.chain_state in
  Chain_id.Table.remove active_chains chain_id ;
  P2p_peer.Table.iter
    (fun _peer_id reader ->
      P2p_reader.deactivate reader chain_db ;
      Lwt.async (fun () -> P2p.send p2p reader.conn (Deactivate chain_id)))
    chain_db.active_connections ;
  Raw_operation.shutdown chain_db.operation_db
  >>= fun () -> Raw_block_header.shutdown chain_db.block_header_db

let get_chain {active_chains; _} chain_id =
  Chain_id.Table.find_opt active_chains chain_id

let greylist {global_db = {p2p; _}; _} peer_id =
  Lwt.return (P2p.greylist_peer p2p peer_id)

let disconnect {global_db = {p2p; _}; _} peer_id =
  match P2p.find_connection p2p peer_id with
  | None ->
      Lwt.return_unit
  | Some conn ->
      P2p.disconnect p2p conn

let shutdown {p2p_readers; active_chains; _} =
  P2p_peer.Table.fold
    (fun _peer_id reader acc -> P2p_reader.shutdown reader >>= fun () -> acc)
    p2p_readers
    Lwt.return_unit
  >>= fun () ->
  Chain_id.Table.fold
    (fun _ chain_db acc ->
      Raw_operation.shutdown chain_db.operation_db
      >>= fun () ->
      Raw_block_header.shutdown chain_db.block_header_db >>= fun () -> acc)
    active_chains
    Lwt.return_unit

let clear_block chain_db hash n =
  Raw_operations.clear_all chain_db.operations_db.table hash n ;
  Raw_operation_hashes.clear_all chain_db.operation_hashes_db.table hash n ;
  Raw_block_header.Table.clear_or_cancel chain_db.block_header_db.table hash

let commit_block chain_db hash header header_data operations operations_data
    result ~forking_testchain =
  assert (Block_hash.equal hash (Block_header.hash header)) ;
  assert (List.length operations = header.shell.validation_passes) ;
  State.Block.store
    chain_db.chain_state
    header
    header_data
    operations
    operations_data
    result
    ~forking_testchain
  >>=? fun res ->
  clear_block chain_db hash header.shell.validation_passes ;
  return res

let commit_invalid_block chain_db hash header errors =
  assert (Block_hash.equal hash (Block_header.hash header)) ;
  State.Block.store_invalid chain_db.chain_state header errors
  >>=? fun res ->
  clear_block chain_db hash header.shell.validation_passes ;
  return res

let inject_operation chain_db h op =
  assert (Operation_hash.equal h (Operation.hash op)) ;
  Raw_operation.Table.inject chain_db.operation_db.table h op

let commit_protocol db h p =
  State.Protocol.store db.disk p
  >>= fun res ->
  Raw_protocol.Table.clear_or_cancel db.protocol_db.table h ;
  return (res <> None)

let watch_block_header {block_input; _} = Lwt_watcher.create_stream block_input

let watch_operation {operation_input; _} =
  Lwt_watcher.create_stream operation_input

module Raw = struct
  let encoding = P2p_message.encoding Message.cfg.encoding

  let chain_name = Message.cfg.chain_name

  let distributed_db_versions = Message.cfg.distributed_db_versions
end

module Make
    (Table : Distributed_db_functors.DISTRIBUTED_DB) (Kind : sig
      type t

      val proj : t -> Table.t
    end) =
struct
  type key = Table.key

  type value = Table.value

  let known t k = Table.known (Kind.proj t) k

  type error += Missing_data = Table.Missing_data

  type error += Canceled = Table.Canceled

  type error += Timeout = Table.Timeout

  let read t k = Table.read (Kind.proj t) k

  let read_opt t k = Table.read_opt (Kind.proj t) k

  let prefetch t ?peer ?timeout k p =
    Table.prefetch (Kind.proj t) ?peer ?timeout k p

  let fetch t ?peer ?timeout k p = Table.fetch (Kind.proj t) ?peer ?timeout k p

  let clear_or_cancel t k = Table.clear_or_cancel (Kind.proj t) k

  let inject t k v = Table.inject (Kind.proj t) k v

  let pending t k = Table.pending (Kind.proj t) k

  let watch t = Table.watch (Kind.proj t)

  let resolve_pending t k v = Table.resolve_pending (Kind.proj t) k v
end

module Block_header = struct
  type t = Block_header.t

  include (
    Make
      (Raw_block_header.Table)
      (struct
        type t = chain_db

        let proj chain = chain.block_header_db.table
      end) :
        Distributed_db_functors.DISTRIBUTED_DB
          with type t := chain_db
           and type key := Block_hash.t
           and type value := Block_header.t
           and type param := unit )
end

module Operation_hashes =
  Make
    (Raw_operation_hashes.Table)
    (struct
      type t = chain_db

      let proj chain = chain.operation_hashes_db.table
    end)

module Operations =
  Make
    (Raw_operations.Table)
    (struct
      type t = chain_db

      let proj chain = chain.operations_db.table
    end)

module Operation = struct
  include Operation

  include (
    Make
      (Raw_operation.Table)
      (struct
        type t = chain_db

        let proj chain = chain.operation_db.table
      end) :
        Distributed_db_functors.DISTRIBUTED_DB
          with type t := chain_db
           and type key := Operation_hash.t
           and type value := Operation.t
           and type param := unit )
end

module Protocol = struct
  type t = Protocol.t

  include (
    Make
      (Raw_protocol.Table)
      (struct
        type t = db

        let proj db = db.protocol_db.table
      end) :
        Distributed_db_functors.DISTRIBUTED_DB
          with type t := db
           and type key := Protocol_hash.t
           and type value := Protocol.t
           and type param := unit )
end

let broadcast chain_db msg =
  P2p_peer.Table.iter
    (fun _peer_id state ->
      ignore (P2p.try_send chain_db.global_db.p2p state.conn msg))
    chain_db.active_connections

let try_send chain_db peer_id msg =
  match P2p_peer.Table.find_opt chain_db.active_connections peer_id with
  | None ->
      ()
  | Some conn ->
      ignore (P2p.try_send chain_db.global_db.p2p conn.conn msg : bool)

let send chain_db ?peer msg =
  match peer with
  | Some peer ->
      try_send chain_db peer msg
  | None ->
      broadcast chain_db msg

module Request = struct
  let current_head chain_db ?peer () =
    let chain_id = State.Chain.id chain_db.chain_state in
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_request Head)
    | None ->
        () ) ;
    send chain_db ?peer @@ Get_current_head chain_id

  let current_branch chain_db ?peer () =
    let chain_id = State.Chain.id chain_db.chain_state in
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_request Head)
    | None ->
        () ) ;
    send chain_db ?peer @@ Get_current_branch chain_id
end

module Advertise = struct
  let current_head chain_db ?peer ?(mempool = Mempool.empty) head =
    let chain_id = State.Chain.id chain_db.chain_state in
    assert (Chain_id.equal chain_id (State.Block.chain_id head)) ;
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_advertisement Head)
    | None ->
        () ) ;
    let msg_mempool =
      Message.Current_head (chain_id, State.Block.header head, mempool)
    in
    if mempool = Mempool.empty then send chain_db ?peer msg_mempool
    else
      let msg_disable_mempool =
        Message.Current_head (chain_id, State.Block.header head, Mempool.empty)
      in
      let send_mempool state =
        let {Connection_metadata.disable_mempool; _} =
          P2p.connection_remote_metadata chain_db.global_db.p2p state.conn
        in
        let msg =
          if disable_mempool then msg_disable_mempool else msg_mempool
        in
        ignore @@ P2p.try_send chain_db.global_db.p2p state.conn msg
      in
      match peer with
      | Some receiver_id ->
          let state =
            P2p_peer.Table.find chain_db.active_connections receiver_id
          in
          send_mempool state
      | None ->
          List.iter
            (fun (_receiver_id, state) -> send_mempool state)
            (P2p_peer.Table.fold
               (fun k v acc -> (k, v) :: acc)
               chain_db.active_connections
               [])

  let current_branch ?peer chain_db =
    let chain_id = State.Chain.id chain_db.chain_state in
    let chain_state = chain_state chain_db in
    let sender_id = my_peer_id chain_db in
    ( match peer with
    | Some peer ->
        let meta = P2p.get_peer_metadata chain_db.global_db.p2p peer in
        Peer_metadata.incr meta (Sent_advertisement Branch)
    | None ->
        () ) ;
    match peer with
    | Some receiver_id ->
        let seed = {Block_locator.receiver_id; sender_id} in
        Chain.locator chain_state seed
        >>= fun locator ->
        let msg = Message.Current_branch (chain_id, locator) in
        try_send chain_db receiver_id msg ;
        Lwt.return_unit
    | None ->
        Lwt_list.iter_p
          (fun (receiver_id, state) ->
            let seed = {Block_locator.receiver_id; sender_id} in
            Chain.locator chain_state seed
            >>= fun locator ->
            let msg = Message.Current_branch (chain_id, locator) in
            ignore (P2p.try_send chain_db.global_db.p2p state.conn msg) ;
            Lwt.return_unit)
          (P2p_peer.Table.fold
             (fun k v acc -> (k, v) :: acc)
             chain_db.active_connections
             [])
end
src/lib_shell/distributed_db.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ Applications of functors are not handled. *)
functor_application

Definition p2p :=
  Tezos_p2p.P2p.net Message.t Tezos_shell_services.Peer_metadata.t
    Tezos_shell_services.Connection_metadata.t.

Definition connection :=
  Tezos_p2p.P2p.connection Message.t Tezos_shell_services.Peer_metadata.t
    Tezos_shell_services.Connection_metadata.t.

Record request_param {a : Type} := {
  p2p :
    Tezos_p2p.P2p.t Message.t Tezos_shell_services.Peer_metadata.t
      Tezos_shell_services.Connection_metadata.t;
  data : a;
  active : unit -> Tezos_base__TzPervasives.P2p_peer.Set.t;
  send : Tezos_base__TzPervasives.P2p_peer.Id.t -> Message.t -> unit }.
Arguments request_param : clear implicits.

(* ❌ Functors are not handled. *)
functor

Module Fake_operation_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := Tezos_base__TzPervasives.Operation.t.
  
  Definition known {A B : Type} (function_parameter : A) : B -> Lwt.t bool :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      Lwt.return_false.
  
  Definition read {A B C : Type} (function_parameter : A)
    : B -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult C) :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      Lwt._return (Error_monad.error_exn OCaml.Not_found).
  
  Definition read_opt {A B C : Type} (function_parameter : A)
    : B -> Lwt.t (option C) :=
    let '_ := function_parameter in
    fun function_parameter =>
      let '_ := function_parameter in
      Lwt.return_none.
End Fake_operation_storage.

(* ❌ Applications of functors are not handled. *)
functor_application

Module Block_header_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := Tezos_base__TzPervasives.Block_header.t.
  
  Definition known
    : Tezos_shell__State.Chain.t ->
      Tezos_base__TzPervasives.Block_hash.t -> Lwt.t bool :=
    State.Block.known_valid.
  
  Definition read
    (chain_state : Tezos_shell__State.Chain.t)
    (h : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
    op_gtgteqquestion (State.Block.read chain_state h)
      (fun b => _return (State.Block.header b)).
  
  Definition read_opt
    (chain_state : Tezos_shell__State.Chain.t)
    (h : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    op_gtgteq (State.Block.read_opt chain_state h)
      (fun b => Lwt._return (Option.map State.Block.header b)).
End Block_header_storage.

(* ❌ Applications of functors are not handled. *)
functor_application

Module Operation_hashes_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := list Tezos_base__TzPervasives.Operation_hash.t.
  
  Definition known {A : Type}
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * A)
    : Lwt.t bool :=
    let '(h, _) := function_parameter in
    State.Block.known_valid chain_state h.
  
  Definition read
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list Tezos_base__TzPervasives.Operation_hash.t)) :=
    let '(h, i) := function_parameter in
    op_gtgteqquestion (State.Block.read chain_state h)
      (fun b =>
        op_gtgteq (State.Block.operation_hashes b i)
          (fun function_parameter =>
            let '(ops, _) := function_parameter in
            _return ops)).
  
  Definition read_opt
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t (option (list Tezos_base__TzPervasives.Operation_hash.t)) :=
    let '(h, i) := function_parameter in
    op_gtgteq (State.Block.read_opt chain_state h)
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt.return_none
        | Some b =>
          op_gtgteq (State.Block.operation_hashes b i)
            (fun function_parameter =>
              let '(ops, _) := function_parameter in
              Lwt.return_some ops)
        end).
End Operation_hashes_storage.

(* ❌ Applications of functors are not handled. *)
functor_application

Module Raw_operation_hashes.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition clear_all
    (table : Table.t) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
    : unit :=
    List.iter (fun i => Table.clear_or_cancel table (hash, i))
      (op_minusminus 0 (Z.sub n 1)).
End Raw_operation_hashes.

Module Operations_storage.
  Definition store := Tezos_shell.State.Chain.t.
  
  Definition value := list Tezos_base__TzPervasives.Operation.t.
  
  Definition known {A : Type}
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * A)
    : Lwt.t bool :=
    let '(h, _) := function_parameter in
    State.Block.known_valid chain_state h.
  
  Definition read
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list Tezos_base__TzPervasives.Operation.t)) :=
    let '(h, i) := function_parameter in
    op_gtgteqquestion (State.Block.read chain_state h)
      (fun b =>
        op_gtgteq (State.Block.operations b i)
          (fun function_parameter =>
            let '(ops, _) := function_parameter in
            _return ops)).
  
  Definition read_opt
    (chain_state : Tezos_shell__State.Chain.t)
    (function_parameter : Tezos_base__TzPervasives.Block_hash.t * Z)
    : Lwt.t (option (list Tezos_base__TzPervasives.Operation.t)) :=
    let '(h, i) := function_parameter in
    op_gtgteq (State.Block.read_opt chain_state h)
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt.return_none
        | Some b =>
          op_gtgteq (State.Block.operations b i)
            (fun function_parameter =>
              let '(ops, _) := function_parameter in
              Lwt.return_some ops)
        end).
End Operations_storage.

Module Raw_operations.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition clear_all
    (table : Table.t) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
    : unit :=
    List.iter (fun i => Table.clear_or_cancel table (hash, i))
      (op_minusminus 0 (Z.sub n 1)).
End Raw_operations.

Module Protocol_storage.
  Definition store := Tezos_shell.State.t.
  
  Definition value := Tezos_base__TzPervasives.Protocol.t.
  
  Definition known
    : Tezos_shell__State.global_state ->
      Tezos_base__TzPervasives.Protocol_hash.t -> Lwt.t bool :=
    State.Protocol.known.
  
  Definition read
    : Tezos_shell__State.global_state ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t) :=
    State.Protocol.read.
  
  Definition read_opt
    : Tezos_shell__State.global_state ->
      Tezos_base__TzPervasives.Protocol_hash.t ->
        Lwt.t (option Tezos_base__TzPervasives.Protocol.t) :=
    State.Protocol.read_opt.
End Protocol_storage.

(* ❌ Applications of functors are not handled. *)
functor_application

Record callback := {
  notify_branch :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_base__TzPervasives.Block_locator.t -> unit;
  notify_head :
    Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Tezos_base__TzPervasives.Block_header.t ->
        Tezos_base__TzPervasives.Mempool.t -> unit;
  disconnection : Tezos_base__TzPervasives.P2p_peer.Id.t -> unit }.

.

Definition noop_callback : callback :=
  {| notify_branch := fun _gid => fun _locator => tt;
    notify_head := fun _gid => fun _block => fun _ops => tt;
    disconnection := fun _gid => tt |}.

Definition t := db.

Definition state (function_parameter : db) : Tezos_shell.State.t :=
  let '{| disk := disk |} := function_parameter in
  disk.

Definition chain_state (function_parameter : chain_db)
  : Tezos_shell.State.Chain.t :=
  let '{| chain_state := chain_state |} := function_parameter in
  chain_state.

Definition db (function_parameter : chain_db) : db :=
  let '{| global_db := global_db |} := function_parameter in
  global_db.

Definition information (function_parameter : chain_db)
  : Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
  let '{|
    global_db := {| p2p_readers := p2p_readers; active_chains := active_chains |};
      operation_db := operation_db;
      block_header_db := block_header_db;
      operation_hashes_db := operation_hashes_db;
      operations_db := operations_db;
      active_peers := active_peers;
      active_connections := active_connections
      |} := function_parameter in
  {|
    Chain_validator_worker_state.Distributed_db_state.p2p_readers_length :=
      P2p_peer.Table.length p2p_readers;
    Chain_validator_worker_state.Distributed_db_state.active_chains_length :=
      Chain_id.Table.length active_chains;
    Chain_validator_worker_state.Distributed_db_state.operation_db :=
      Raw_operation.state_of_t operation_db;
    Chain_validator_worker_state.Distributed_db_state.operations_db :=
      Raw_operations.state_of_t operations_db;
    Chain_validator_worker_state.Distributed_db_state.block_header_db :=
      Raw_block_header.state_of_t block_header_db;
    Chain_validator_worker_state.Distributed_db_state.operations_hashed_db :=
      Raw_operation_hashes.state_of_t operation_hashes_db;
    Chain_validator_worker_state.Distributed_db_state.active_connections_length :=
      P2p_peer.Table.length active_connections;
    Chain_validator_worker_state.Distributed_db_state.active_peers_length :=
      P2p_peer.Set.cardinal (Stdlib.op_exclamation active_peers) |}.

Definition my_peer_id (chain_db : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t :=
  P2p.peer_id (p2p (global_db chain_db)).

Definition get_peer_metadata (chain_db : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t ->
    Tezos_shell_services.Peer_metadata.t :=
  P2p.get_peer_metadata (p2p (global_db chain_db)).

Definition read_block_header (function_parameter : db)
  : Tezos_base__TzPervasives.Block_hash.t ->
    Lwt.t
      (option
        (Tezos_base__TzPervasives.Chain_id.t *
          Tezos_base__TzPervasives.Block_header.t)) :=
  let '{| disk := disk |} := function_parameter in
  fun h =>
    op_gtgteq (State.read_block disk h)
      (fun function_parameter =>
        match function_parameter with
        | Some b =>
          Lwt.return_some ((State.Block.chain_id b), (State.Block.header b))
        | None => Lwt.return_none
        end).

Definition find_pending_block_header (function_parameter : p2p_reader)
  : Raw_block_header.Table.key -> option chain_db :=
  let '{| peer_active_chains := peer_active_chains |} := function_parameter in
  fun h =>
    Chain_id.Table.fold
      (fun _chain_id =>
        fun chain_db =>
          fun acc =>
            match acc with
            | Some _ => acc
            | None => Some chain_db
            | None => None
            end) peer_active_chains None.

Definition find_pending_operations (function_parameter : p2p_reader)
  : Tezos_base__TzPervasives.Block_hash.t -> Z -> option chain_db :=
  let '{| peer_active_chains := peer_active_chains |} := function_parameter in
  fun h =>
    fun i =>
      Chain_id.Table.fold
        (fun _chain_id =>
          fun chain_db =>
            fun acc =>
              match acc with
              | Some _ => acc
              | None => Some chain_db
              | None => None
              end) peer_active_chains None.

Definition find_pending_operation_hashes (function_parameter : p2p_reader)
  : Tezos_base__TzPervasives.Block_hash.t -> Z -> option chain_db :=
  let '{| peer_active_chains := peer_active_chains |} := function_parameter in
  fun h =>
    fun i =>
      Chain_id.Table.fold
        (fun _chain_id =>
          fun chain_db =>
            fun acc =>
              match acc with
              | Some _ => acc
              | None => Some chain_db
              | None => None
              end) peer_active_chains None.

Definition find_pending_operation (function_parameter : p2p_reader)
  : Raw_operation.Table.key -> option chain_db :=
  let '{| peer_active_chains := peer_active_chains |} := function_parameter in
  fun h =>
    Chain_id.Table.fold
      (fun _chain_id =>
        fun chain_db =>
          fun acc =>
            match acc with
            | Some _ => acc
            | None => Some chain_db
            | None => None
            end) peer_active_chains None.

Definition read_operation (function_parameter : db)
  : Raw_operation.Table.key ->
    Lwt.t
      (option
        (Tezos_base__TzPervasives.Chain_id.Table.key * Raw_operation.Table.value)) :=
  let '{| active_chains := active_chains |} := function_parameter in
  fun h =>
    Chain_id.Table.fold
      (fun chain_id =>
        fun chain_db =>
          fun acc =>
            op_gtgteq acc
              (fun function_parameter =>
                match function_parameter with
                | Some _ => acc
                | None =>
                  op_gtgteq
                    (Raw_operation.Table.read_opt
                      (table (operation_db chain_db)) h)
                    (fun function_parameter =>
                      match function_parameter with
                      | None => Lwt.return_none
                      | Some bh => Lwt.return_some (chain_id, bh)
                      end)
                end)) active_chains Lwt.return_none.

Module P2p_reader.
  Definition may_activate
    (global_db : db) (state : p2p_reader)
    (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
    (f : chain_db -> Lwt.t unit) : Lwt.t unit :=
    match Chain_id.Table.find_opt (peer_active_chains state) chain_id with
    | Some chain_db => f chain_db
    | None =>
      match Chain_id.Table.find_opt (active_chains global_db) chain_id with
      | Some chain_db =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.op_coloneq (active_peers chain_db)
            (P2p_peer.Set.add (gid state)
              (Stdlib.op_exclamation (active_peers chain_db))) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          P2p_peer.Table.add (active_connections chain_db) (gid state) state in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Chain_id.Table.add (peer_active_chains state) chain_id chain_db
          in
        f chain_db
      | None =>
        let meta := P2p.get_peer_metadata (p2p global_db) (gid state) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Peer_metadata.incr meta
            Tezos_shell_services.Peer_metadata.Unactivated_chain in
        Lwt.return_unit
      end
    end.
  
  Definition deactivate (state : p2p_reader) (chain_db : chain_db) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := (disconnection (callback chain_db)) (gid state) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Stdlib.op_coloneq (active_peers chain_db)
        (P2p_peer.Set.remove (gid state)
          (Stdlib.op_exclamation (active_peers chain_db))) in
    P2p_peer.Table.remove (active_connections chain_db) (gid state).
  
  Definition may_handle
    (global_db : db) (state : p2p_reader)
    (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
    (f : chain_db -> Lwt.t unit) : Lwt.t unit :=
    match Chain_id.Table.find_opt (peer_active_chains state) chain_id with
    | None =>
      let meta := P2p.get_peer_metadata (p2p global_db) (gid state) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Peer_metadata.incr meta
          Tezos_shell_services.Peer_metadata.Inactive_chain in
      Lwt.return_unit
    | Some chain_db => f chain_db
    end.
  
  Definition may_handle_global
    (global_db : db) (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
    (f : chain_db -> Lwt.t unit) : Lwt.t unit :=
    match Chain_id.Table.find_opt (active_chains global_db) chain_id with
    | None => Lwt.return_unit
    | Some chain_db => f chain_db
    end.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition soon (function_parameter : unit) : Ptime.t :=
    let 'tt := function_parameter in
    let now := Systime_os.now tt in
    match Ptime.add_span now (Ptime.Span.of_int_s 15) with
    | Some s => s
    | None =>
      OCaml.Stdlib.invalid_arg "Distributed_db.handle_msg: end of time" % string
    end.
  
  Definition handle_msg
    (global_db : db) (state : p2p_reader)
    (msg : Tezos_shell__Distributed_db_message.t) : Lwt.t unit :=
    let meta := P2p.get_peer_metadata (p2p global_db) (gid state) in
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Read message from " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal ": " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))))
                    "Read message from %a: %a" % string))
                (t event "read_message" % string))
              (a P2p_peer.Id.Logging.tag (gid state)))
            (a Message.Logging.tag msg)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        match msg with
        | Message.Get_current_branch chain_id =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply (Peer_metadata.incr meta)
              (Tezos_shell_services.Peer_metadata.Received_request
                Tezos_shell_services.Peer_metadata.Branch) in
          apply (may_handle_global global_db chain_id)
            (fun chain_db =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                if negb (Chain_id.Table.mem (peer_active_chains state) chain_id)
                  then
                  apply
                    (Peer_metadata.update_requests meta
                      Tezos_shell_services.Peer_metadata.Branch)
                    (apply (P2p.try_send (p2p global_db) (conn state))
                      (Message.Get_current_branch chain_id))
                else
                  tt in
              let seed :=
                {| Block_locator.sender_id := my_peer_id chain_db;
                  Block_locator.receiver_id := gid state |} in
              op_gtgteq (Chain.locator (chain_state chain_db) seed)
                (fun locator =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    apply
                      (Peer_metadata.update_responses meta
                        Tezos_shell_services.Peer_metadata.Branch)
                      (apply (P2p.try_send (p2p global_db) (conn state))
                        (Message.Current_branch chain_id locator)) in
                  Lwt.return_unit))
        | Message.Current_branch chain_id locator =>
          apply (may_activate global_db state chain_id)
            (fun chain_db =>
              let '(head, hist) := locator in
              op_gtgteq
                (Lwt_list.exists_p
                  (State.Block.known_invalid (chain_state chain_db))
                  (cons (Block_header.hash head) hist))
                (fun known_invalid =>
                  if known_invalid then
                    op_gtgteq (P2p.disconnect (p2p global_db) None (conn state))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ := P2p.greylist_peer (p2p global_db) (gid state)
                          in
                        Lwt.return_unit)
                  else
                    if
                      op_lt (soon tt) (of_protocol_exn (timestamp (shell head)))
                      then
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Peer_metadata.incr meta
                          Tezos_shell_services.Peer_metadata.Future_block in
                      lwt_log_notice
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Received future block " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " from peer " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Char_literal
                                              "." % char
                                              CamlinternalFormatBasics.End_of_format)))))
                                    "Received future block %a from peer %a." %
                                      string))
                                (t event "received_future_block" % string))
                              (a Block_hash.Logging.tag (Block_header.hash head)))
                            (a P2p_peer.Id.Logging.tag (gid state)))
                    else
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        (notify_branch (callback chain_db)) (gid state) locator
                        in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        apply (Peer_metadata.incr meta)
                          (Tezos_shell_services.Peer_metadata.Received_advertisement
                            Tezos_shell_services.Peer_metadata.Branch) in
                      Lwt.return_unit))
        | Message.Deactivate chain_id =>
          apply (may_handle global_db state chain_id)
            (fun chain_db =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := deactivate state chain_db in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Chain_id.Table.remove (peer_active_chains state) chain_id
                in
              Lwt.return_unit)
        | Message.Get_current_head chain_id =>
          apply (may_handle global_db state chain_id)
            (fun chain_db =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                apply (Peer_metadata.incr meta)
                  (Tezos_shell_services.Peer_metadata.Received_request
                    Tezos_shell_services.Peer_metadata.Head) in
              let '{|
                Connection_metadata.disable_mempool := disable_mempool |} :=
                P2p.connection_remote_metadata (p2p (global_db chain_db))
                  (conn state) in
              op_gtgteq
                (if disable_mempool then
                  op_gtgteq (Chain.head (chain_state chain_db))
                    (fun head =>
                      Lwt._return ((State.Block.header head), Mempool.empty))
                else
                  State.Current_mempool.get (chain_state chain_db))
                (fun function_parameter =>
                  let '(head, mempool) := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    apply
                      (Peer_metadata.update_responses meta
                        Tezos_shell_services.Peer_metadata.Head)
                      (apply (P2p.try_send (p2p global_db) (conn state))
                        (Message.Current_head chain_id head mempool)) in
                  Lwt.return_unit))
        | Message.Current_head chain_id header mempool =>
          apply (may_handle global_db state chain_id)
            (fun chain_db =>
              let head := Block_header.hash header in
              op_gtgteq (State.Block.known_invalid (chain_state chain_db) head)
                (fun known_invalid =>
                  let '{|
                    Connection_metadata.disable_mempool := disable_mempool
                      |} :=
                    P2p.connection_local_metadata (p2p (global_db chain_db))
                      (conn state) in
                  let known_invalid :=
                    orb known_invalid
                      (andb disable_mempool (nequiv_decb mempool Mempool.empty))
                    in
                  if known_invalid then
                    op_gtgteq (P2p.disconnect (p2p global_db) None (conn state))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ := P2p.greylist_peer (p2p global_db) (gid state)
                          in
                        Lwt.return_unit)
                  else
                    if
                      op_lt (soon tt)
                        (of_protocol_exn (timestamp (shell header))) then
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Peer_metadata.incr meta
                          Tezos_shell_services.Peer_metadata.Future_block in
                      lwt_log_notice
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Received future block " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          " from peer " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Char_literal
                                              "." % char
                                              CamlinternalFormatBasics.End_of_format)))))
                                    "Received future block %a from peer %a." %
                                      string))
                                (t event "received_future_block" % string))
                              (a Block_hash.Logging.tag head))
                            (a P2p_peer.Id.Logging.tag (gid state)))
                    else
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        (notify_head (callback chain_db)) (gid state) header
                          mempool in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        apply (Peer_metadata.incr meta)
                          (Tezos_shell_services.Peer_metadata.Received_advertisement
                            Tezos_shell_services.Peer_metadata.Head) in
                      Lwt.return_unit))
        | Message.Get_block_headers hashes =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply (Peer_metadata.incr meta)
              (Tezos_shell_services.Peer_metadata.Received_request
                Tezos_shell_services.Peer_metadata.Block_header) in
          Lwt_list.iter_p
            (fun hash =>
              op_gtgteq (read_block_header global_db hash)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      apply (Peer_metadata.incr meta)
                        (Tezos_shell_services.Peer_metadata.Unadvertised
                          Tezos_shell_services.Peer_metadata.Block) in
                    Lwt.return_unit
                  | Some (_chain_id, header) =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      apply
                        (Peer_metadata.update_responses meta
                          Tezos_shell_services.Peer_metadata.Block_header)
                        (apply (P2p.try_send (p2p global_db) (conn state))
                          (Message.Block_header header)) in
                    Lwt.return_unit
                  end)) hashes
        | Message.Block_header block =>
          let hash := Block_header.hash block in
          match find_pending_block_header state hash with
          | None =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Peer_metadata.incr meta
                Tezos_shell_services.Peer_metadata.Unexpected_response in
            Lwt.return_unit
          | Some chain_db =>
            op_gtgteq
              (Raw_block_header.Table.notify (table (block_header_db chain_db))
                (gid state) hash block)
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  apply (Peer_metadata.incr meta)
                    (Tezos_shell_services.Peer_metadata.Received_response
                      Tezos_shell_services.Peer_metadata.Block_header) in
                Lwt.return_unit)
          end
        | Message.Get_operations hashes =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply (Peer_metadata.incr meta)
              (Tezos_shell_services.Peer_metadata.Received_request
                Tezos_shell_services.Peer_metadata.Operations) in
          Lwt_list.iter_p
            (fun hash =>
              op_gtgteq (read_operation global_db hash)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      apply (Peer_metadata.incr meta)
                        (Tezos_shell_services.Peer_metadata.Unadvertised
                          Tezos_shell_services.Peer_metadata.Operations) in
                    Lwt.return_unit
                  | Some (_chain_id, op) =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      apply
                        (Peer_metadata.update_responses meta
                          Tezos_shell_services.Peer_metadata.Operations)
                        (apply (P2p.try_send (p2p global_db) (conn state))
                          (Message.Operation op)) in
                    Lwt.return_unit
                  end)) hashes
        | Message.Operation operation =>
          let hash := Operation.hash operation in
          match find_pending_operation state hash with
          | None =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Peer_metadata.incr meta
                Tezos_shell_services.Peer_metadata.Unexpected_response in
            Lwt.return_unit
          | Some chain_db =>
            op_gtgteq
              (Raw_operation.Table.notify (table (operation_db chain_db))
                (gid state) hash operation)
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  apply (Peer_metadata.incr meta)
                    (Tezos_shell_services.Peer_metadata.Received_response
                      Tezos_shell_services.Peer_metadata.Operations) in
                Lwt.return_unit)
          end
        | Message.Get_protocols hashes =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply (Peer_metadata.incr meta)
              (Tezos_shell_services.Peer_metadata.Received_request
                Tezos_shell_services.Peer_metadata.Protocols) in
          Lwt_list.iter_p
            (fun hash =>
              op_gtgteq (State.Protocol.read_opt (disk global_db) hash)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      apply (Peer_metadata.incr meta)
                        (Tezos_shell_services.Peer_metadata.Unadvertised
                          Tezos_shell_services.Peer_metadata.Protocol) in
                    Lwt.return_unit
                  | Some p =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      apply
                        (Peer_metadata.update_responses meta
                          Tezos_shell_services.Peer_metadata.Protocols)
                        (apply (P2p.try_send (p2p global_db) (conn state))
                          (Message.Protocol p)) in
                    Lwt.return_unit
                  end)) hashes
        | Message.Protocol protocol =>
          let hash := Protocol.hash protocol in
          op_gtgteq
            (Raw_protocol.Table.notify (table (protocol_db global_db))
              (gid state) hash protocol)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                apply (Peer_metadata.incr meta)
                  (Tezos_shell_services.Peer_metadata.Received_response
                    Tezos_shell_services.Peer_metadata.Protocols) in
              Lwt.return_unit)
        | Message.Get_operation_hashes_for_blocks blocks =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply (Peer_metadata.incr meta)
              (Tezos_shell_services.Peer_metadata.Received_request
                Tezos_shell_services.Peer_metadata.Operation_hashes_for_block)
            in
          Lwt_list.iter_p
            (fun function_parameter =>
              let '(hash, ofs) := function_parameter in
              op_gtgteq (State.read_block (disk global_db) hash)
                (fun function_parameter =>
                  match function_parameter with
                  | None => Lwt.return_unit
                  | Some block =>
                    op_gtgteq (State.Block.operation_hashes block ofs)
                      (fun function_parameter =>
                        let '(hashes, path) := function_parameter in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          apply
                            (Peer_metadata.update_responses meta
                              Tezos_shell_services.Peer_metadata.Operation_hashes_for_block)
                            (apply (P2p.try_send (p2p global_db) (conn state))
                              (Message.Operation_hashes_for_block hash ofs
                                hashes path)) in
                        Lwt.return_unit)
                  end)) blocks
        | Message.Operation_hashes_for_block block ofs ops path =>
          match find_pending_operation_hashes state block ofs with
          | None =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Peer_metadata.incr meta
                Tezos_shell_services.Peer_metadata.Unexpected_response in
            Lwt.return_unit
          | Some chain_db =>
            op_gtgteq
              (Raw_operation_hashes.Table.notify
                (table (operation_hashes_db chain_db)) (gid state) (block, ofs)
                (ops, path))
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  apply (Peer_metadata.incr meta)
                    (Tezos_shell_services.Peer_metadata.Received_response
                      Tezos_shell_services.Peer_metadata.Operation_hashes_for_block)
                  in
                Lwt.return_unit)
          end
        | Message.Get_operations_for_blocks blocks =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            apply (Peer_metadata.incr meta)
              (Tezos_shell_services.Peer_metadata.Received_request
                Tezos_shell_services.Peer_metadata.Operations_for_block) in
          Lwt_list.iter_p
            (fun function_parameter =>
              let '(hash, ofs) := function_parameter in
              op_gtgteq (State.read_block (disk global_db) hash)
                (fun function_parameter =>
                  match function_parameter with
                  | None => Lwt.return_unit
                  | Some block =>
                    op_gtgteq (State.Block.operations block ofs)
                      (fun function_parameter =>
                        let '(ops, path) := function_parameter in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          apply
                            (Peer_metadata.update_responses meta
                              Tezos_shell_services.Peer_metadata.Operations_for_block)
                            (apply (P2p.try_send (p2p global_db) (conn state))
                              (Message.Operations_for_block hash ofs ops path))
                          in
                        Lwt.return_unit)
                  end)) blocks
        | Message.Operations_for_block block ofs ops path =>
          match find_pending_operations state block ofs with
          | None =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Peer_metadata.incr meta
                Tezos_shell_services.Peer_metadata.Unexpected_response in
            Lwt.return_unit
          | Some chain_db =>
            op_gtgteq
              (Raw_operations.Table.notify (table (operations_db chain_db))
                (gid state) (block, ofs) (ops, path))
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  apply (Peer_metadata.incr meta)
                    (Tezos_shell_services.Peer_metadata.Received_response
                      Tezos_shell_services.Peer_metadata.Operations_for_block)
                  in
                Lwt.return_unit)
          end
        end).
  
  Fixpoint worker_loop (global_db : db) (state : p2p_reader) : Lwt.t unit :=
    op_gtgteq
      (protect None (Some (canceler state))
        (fun function_parameter =>
          let 'tt := function_parameter in
          P2p.recv (p2p global_db) (conn state)))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok msg =>
          op_gtgteq (handle_msg global_db state msg)
            (fun function_parameter =>
              let 'tt := function_parameter in
              worker_loop global_db state)
        | Stdlib.Error _ =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Chain_id.Table.iter
              (fun function_parameter =>
                let '_ := function_parameter in
                deactivate state) (peer_active_chains state) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := P2p_peer.Table.remove (p2p_readers global_db) (gid state) in
          Lwt.return_unit
        end).
  
  Definition run
    (db : db) (gid : Tezos_base__TzPervasives.P2p_peer.Id.t) (conn : connection)
    : unit :=
    let canceler := Lwt_canceler.create tt in
    let state :=
      {| gid := gid; conn := conn;
        peer_active_chains := Chain_id.Table.create 17; canceler := canceler;
        worker := Lwt.return_unit |} in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Chain_id.Table.iter
        (fun chain_id =>
          fun _chain_db =>
            Lwt.async
              (fun function_parameter =>
                let 'tt := function_parameter in
                let meta := P2p.get_peer_metadata (p2p db) gid in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Peer_metadata.incr meta
                    (Tezos_shell_services.Peer_metadata.Sent_request
                      Tezos_shell_services.Peer_metadata.Branch) in
                P2p.send (p2p db) conn (Message.Get_current_branch chain_id)))
        (active_chains db) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field state "worker" % string
        (Lwt_utils.worker
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "db_network_reader." % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "db_network_reader.%a" % string) P2p_peer.Id.pp_short gid)
          Internal_event.Lwt_worker_event.on_event
          (fun function_parameter =>
            let 'tt := function_parameter in
            worker_loop db state)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel canceler)) in
    P2p_peer.Table.add (p2p_readers db) gid state.
  
  Definition shutdown (s : p2p_reader) : Lwt.t unit :=
    op_gtgteq (Lwt_canceler.cancel (canceler s))
      (fun function_parameter =>
        let 'tt := function_parameter in
        worker s).
End P2p_reader.

Definition active_peer_ids {A B C : Type}
  (p2p : Tezos_p2p.P2p.net A B C) (function_parameter : unit)
  : Tezos_base__TzPervasives.P2p_peer.Set.t :=
  let 'tt := function_parameter in
  List.fold_left
    (fun acc =>
      fun conn =>
        let '{| P2p_connection.Info.peer_id := peer_id |} :=
          P2p.connection_info p2p conn in
        P2p_peer.Set.add peer_id acc) P2p_peer.Set.empty (P2p.connections p2p).

Definition raw_try_send {A B C : Type}
  (p2p : Tezos_p2p.P2p.net A B C)
  (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t) (msg : A) : unit :=
  match P2p.find_connection p2p peer_id with
  | None => tt
  | Some conn => OCaml.Stdlib.ignore (P2p.try_send p2p conn msg)
  end.

Definition create
  (disk : Protocol_storage.store)
  (p2p :
    Tezos_p2p.P2p.t Message.t Tezos_shell_services.Peer_metadata.t
      Tezos_shell_services.Connection_metadata.t) : db :=
  let global_request :=
    {| p2p := p2p; data := tt; active := active_peer_ids p2p;
      send := raw_try_send p2p |} in
  let protocol_db := Raw_protocol.create None global_request disk in
  let active_chains := Chain_id.Table.create 17 in
  let p2p_readers := P2p_peer.Table.create 17 in
  let block_input := Lwt_watcher.create_input tt in
  let operation_input := Lwt_watcher.create_input tt in
  let db :=
    {| p2p := p2p; p2p_readers := p2p_readers; disk := disk;
      active_chains := active_chains; protocol_db := protocol_db;
      block_input := block_input; operation_input := operation_input |} in
  db.

Definition activate (function_parameter : db)
  : Tezos_shell.State.Chain.chain_state -> chain_db :=
  let '{| p2p := p2p; active_chains := active_chains |} as global_db :=
    function_parameter in
  fun chain_state =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p.on_new_connection p2p (P2p_reader.run global_db) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p.iter_connections p2p (P2p_reader.run global_db) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := P2p.activate p2p in
    let chain_id := State.Chain.id chain_state in
    match Chain_id.Table.find_opt active_chains chain_id with
    | None =>
      let active_peers := Stdlib.ref P2p_peer.Set.empty in
      let p2p_request :=
        {| p2p := p2p; data := tt;
          active :=
            fun function_parameter =>
              let 'tt := function_parameter in
              Stdlib.op_exclamation active_peers; send := raw_try_send p2p |} in
      let operation_db :=
        Raw_operation.create (Some (operation_input global_db)) p2p_request
          chain_state in
      let block_header_db :=
        Raw_block_header.create (Some (block_input global_db)) p2p_request
          chain_state in
      let operation_hashes_db :=
        Raw_operation_hashes.create None p2p_request chain_state in
      let operations_db := Raw_operations.create None p2p_request chain_state in
      let chain :=
        {| chain_state := chain_state; global_db := global_db;
          operation_db := operation_db; block_header_db := block_header_db;
          operation_hashes_db := operation_hashes_db;
          operations_db := operations_db; callback := noop_callback;
          active_peers := active_peers;
          active_connections := P2p_peer.Table.create 53 |} in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        P2p.iter_connections p2p
          (fun _peer_id =>
            fun conn =>
              Lwt.async
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  P2p.send p2p conn (Message.Get_current_branch chain_id))) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Chain_id.Table.add active_chains chain_id chain in
      chain
    | Some chain => chain
    end.

Definition set_callback (chain_db : chain_db) (callback : callback) : unit :=
  (* ❌ Set record field not handled. *)
  set_record_field chain_db "callback" % string callback.

Definition deactivate (chain_db : chain_db) : Lwt.t unit :=
  let '{| p2p := p2p; active_chains := active_chains |} := global_db chain_db in
  let chain_id := State.Chain.id (chain_state chain_db) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Chain_id.Table.remove active_chains chain_id in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    P2p_peer.Table.iter
      (fun _peer_id =>
        fun reader =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := P2p_reader.deactivate reader chain_db in
          Lwt.async
            (fun function_parameter =>
              let 'tt := function_parameter in
              P2p.send p2p (conn reader) (Message.Deactivate chain_id)))
      (active_connections chain_db) in
  op_gtgteq (Raw_operation.shutdown (operation_db chain_db))
    (fun function_parameter =>
      let 'tt := function_parameter in
      Raw_block_header.shutdown (block_header_db chain_db)).

Definition get_chain (function_parameter : db)
  : Tezos_base__TzPervasives.Chain_id.Table.key -> option chain_db :=
  let '{| active_chains := active_chains |} := function_parameter in
  fun chain_id => Chain_id.Table.find_opt active_chains chain_id.

Definition greylist (function_parameter : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit :=
  let '{| global_db := {| p2p := p2p |} |} := function_parameter in
  fun peer_id => Lwt._return (P2p.greylist_peer p2p peer_id).

Definition disconnect (function_parameter : chain_db)
  : Tezos_base__TzPervasives.P2p_peer.Id.t -> Lwt.t unit :=
  let '{| global_db := {| p2p := p2p |} |} := function_parameter in
  fun peer_id =>
    match P2p.find_connection p2p peer_id with
    | None => Lwt.return_unit
    | Some conn => P2p.disconnect p2p None conn
    end.

Definition shutdown (function_parameter : db) : Lwt.t unit :=
  let '{| p2p_readers := p2p_readers; active_chains := active_chains |} :=
    function_parameter in
  op_gtgteq
    (P2p_peer.Table.fold
      (fun _peer_id =>
        fun reader =>
          fun acc =>
            op_gtgteq (P2p_reader.shutdown reader)
              (fun function_parameter =>
                let 'tt := function_parameter in
                acc)) p2p_readers Lwt.return_unit)
    (fun function_parameter =>
      let 'tt := function_parameter in
      Chain_id.Table.fold
        (fun function_parameter =>
          let '_ := function_parameter in
          fun chain_db =>
            fun acc =>
              op_gtgteq (Raw_operation.shutdown (operation_db chain_db))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Raw_block_header.shutdown (block_header_db chain_db))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      acc))) active_chains Lwt.return_unit).

Definition clear_block
  (chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t) (n : Z)
  : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Raw_operations.clear_all (table (operations_db chain_db)) hash n in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Raw_operation_hashes.clear_all (table (operation_hashes_db chain_db)) hash n
    in
  Raw_block_header.Table.clear_or_cancel (table (block_header_db chain_db)) hash.

Definition commit_block
  (chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  (header_data : Stdlib.Bytes.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  (operations_data : list (list Stdlib.Bytes.t))
  (result : Tezos_validation.Block_validation.validation_store)
  (forking_testchain : bool)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult (option Tezos_shell.State.Block.block)) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (Block_hash.equal hash (Block_header.hash header)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      (equiv_decb (List.length operations) (validation_passes (shell header)))
    in
  op_gtgteqquestion
    (State.Block.store None (chain_state chain_db) header header_data operations
      operations_data result forking_testchain)
    (fun res =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := clear_block chain_db hash (validation_passes (shell header)) in
      _return res).

Definition commit_invalid_block
  (chain_db : chain_db) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  (errors : list Tezos_base__TzPervasives.error)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (Block_hash.equal hash (Block_header.hash header)) in
  op_gtgteqquestion
    (State.Block.store_invalid (chain_state chain_db) header errors)
    (fun res =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := clear_block chain_db hash (validation_passes (shell header)) in
      _return res).

Definition inject_operation
  (chain_db : chain_db) (h : Tezos_base__TzPervasives.Operation_hash.t)
  (op : Tezos_base__TzPervasives.Operation.t) : Lwt.t bool :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (Operation_hash.equal h (Operation.hash op)) in
  Raw_operation.Table.inject (table (operation_db chain_db)) h op.

Definition commit_protocol
  (db : db) (h : Raw_protocol.Table.key)
  (p : Tezos_base__TzPervasives.Protocol.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  op_gtgteq (State.Protocol.store (disk db) p)
    (fun res =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Raw_protocol.Table.clear_or_cancel (table (protocol_db db)) h in
      _return (nequiv_decb res None)).

Definition watch_block_header (function_parameter : db)
  : (Lwt_stream.t
    (Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  let '{| block_input := block_input |} := function_parameter in
  Lwt_watcher.create_stream block_input.

Definition watch_operation (function_parameter : db)
  : (Lwt_stream.t
    (Tezos_base__TzPervasives.Operation_hash.t *
      Tezos_base__TzPervasives.Operation.t)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  let '{| operation_input := operation_input |} := function_parameter in
  Lwt_watcher.create_stream operation_input.

Module Raw.
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.t
      (Tezos_p2p.P2p_message.t Message.t) :=
    P2p_message.encoding (encoding Message.cfg).
  
  Definition chain_name
    : Tezos_base__TzPervasives.Distributed_db_version.name :=
    chain_name Message.cfg.
  
  Definition distributed_db_versions
    : list Tezos_base__TzPervasives.Distributed_db_version.t :=
    distributed_db_versions Message.cfg.
End Raw.

(* ❌ Functors are not handled. *)
functor

Module Block_header.
  Definition t := Tezos_base__TzPervasives.Block_header.t.
  
  (* ❌ Structure item `include` not handled. *)
  include
End Block_header.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Module Operation.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Operation.

Module Protocol.
  Definition t := Tezos_base__TzPervasives.Protocol.t.
  
  (* ❌ Structure item `include` not handled. *)
  include
End Protocol.

Definition broadcast (chain_db : chain_db) (msg : Message.t) : unit :=
  P2p_peer.Table.iter
    (fun _peer_id =>
      fun state =>
        OCaml.Stdlib.ignore
          (P2p.try_send (p2p (global_db chain_db)) (conn state) msg))
    (active_connections chain_db).

Definition try_send
  (chain_db : chain_db) (peer_id : Tezos_base__TzPervasives.P2p_peer.Table.key)
  (msg : Message.t) : unit :=
  match P2p_peer.Table.find_opt (active_connections chain_db) peer_id with
  | None => tt
  | Some conn =>
    OCaml.Stdlib.ignore
      (P2p.try_send (p2p (global_db chain_db)) (conn conn) msg)
  end.

Definition send
  (chain_db : chain_db)
  (peer : option Tezos_base__TzPervasives.P2p_peer.Table.key) (msg : Message.t)
  : unit :=
  match peer with
  | Some peer => try_send chain_db peer msg
  | None => broadcast chain_db msg
  end.

Module Request.
  Definition current_head
    (chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
    (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    let chain_id := State.Chain.id (chain_state chain_db) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match peer with
      | Some peer =>
        let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
        Peer_metadata.incr meta
          (Tezos_shell_services.Peer_metadata.Sent_request
            Tezos_shell_services.Peer_metadata.Head)
      | None => tt
      end in
    apply (send chain_db peer) (Message.Get_current_head chain_id).
  
  Definition current_branch
    (chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
    (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    let chain_id := State.Chain.id (chain_state chain_db) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match peer with
      | Some peer =>
        let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
        Peer_metadata.incr meta
          (Tezos_shell_services.Peer_metadata.Sent_request
            Tezos_shell_services.Peer_metadata.Head)
      | None => tt
      end in
    apply (send chain_db peer) (Message.Get_current_branch chain_id).
End Request.

Module Advertise.
  Definition current_head
    (chain_db : chain_db) (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t)
    (op_staroptstar : option Tezos_base__TzPervasives.Mempool.mempool)
    : Tezos_shell.State.Block.t -> unit :=
    let mempool :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Mempool.empty
      end in
    fun head =>
      let chain_id := State.Chain.id (chain_state chain_db) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert (Chain_id.equal chain_id (State.Block.chain_id head)) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        match peer with
        | Some peer =>
          let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
          Peer_metadata.incr meta
            (Tezos_shell_services.Peer_metadata.Sent_advertisement
              Tezos_shell_services.Peer_metadata.Head)
        | None => tt
        end in
      let msg_mempool :=
        Message.Current_head chain_id (State.Block.header head) mempool in
      if equiv_decb mempool Mempool.empty then
        send chain_db peer msg_mempool
      else
        let msg_disable_mempool :=
          Message.Current_head chain_id (State.Block.header head) Mempool.empty
          in
        let send_mempool (state : p2p_reader) : unit :=
          let '{| Connection_metadata.disable_mempool := disable_mempool |} :=
            P2p.connection_remote_metadata (p2p (global_db chain_db))
              (conn state) in
          let msg :=
            if disable_mempool then
              msg_disable_mempool
            else
              msg_mempool in
          apply OCaml.Stdlib.ignore
            (P2p.try_send (p2p (global_db chain_db)) (conn state) msg) in
        match peer with
        | Some receiver_id =>
          let state :=
            P2p_peer.Table.find (active_connections chain_db) receiver_id in
          send_mempool state
        | None =>
          List.iter
            (fun function_parameter =>
              let '(_receiver_id, state) := function_parameter in
              send_mempool state)
            (P2p_peer.Table.fold (fun k => fun v => fun acc => cons (k, v) acc)
              (active_connections chain_db) [])
        end.
  
  Definition current_branch
    (peer : option Tezos_base__TzPervasives.P2p_peer.Id.t) (chain_db : chain_db)
    : Lwt.t unit :=
    let chain_id := State.Chain.id (chain_state chain_db) in
    let chain_state := chain_state chain_db in
    let sender_id := my_peer_id chain_db in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match peer with
      | Some peer =>
        let meta := P2p.get_peer_metadata (p2p (global_db chain_db)) peer in
        Peer_metadata.incr meta
          (Tezos_shell_services.Peer_metadata.Sent_advertisement
            Tezos_shell_services.Peer_metadata.Branch)
      | None => tt
      end in
    match peer with
    | Some receiver_id =>
      let seed :=
        {| Block_locator.sender_id := sender_id;
          Block_locator.receiver_id := receiver_id |} in
      op_gtgteq (Chain.locator chain_state seed)
        (fun locator =>
          let msg := Message.Current_branch chain_id locator in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := try_send chain_db receiver_id msg in
          Lwt.return_unit)
    | None =>
      Lwt_list.iter_p
        (fun function_parameter =>
          let '(receiver_id, state) := function_parameter in
          let seed :=
            {| Block_locator.sender_id := sender_id;
              Block_locator.receiver_id := receiver_id |} in
          op_gtgteq (Chain.locator chain_state seed)
            (fun locator =>
              let msg := Message.Current_branch chain_id locator in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                OCaml.Stdlib.ignore
                  (P2p.try_send (p2p (global_db chain_db)) (conn state) msg) in
              Lwt.return_unit))
        (P2p_peer.Table.fold (fun k => fun v => fun acc => cons (k, v) acc)
          (active_connections chain_db) [])
    end.
End Advertise.

src/lib_shell/distributed_db_functors.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type DISTRIBUTED_DB = sig
  type t

  type key

  type value

  type param

  val known : t -> key -> bool Lwt.t

  type error += Missing_data of key

  type error += Canceled of key

  type error += Timeout of key

  val read : t -> key -> value tzresult Lwt.t

  val read_opt : t -> key -> value option Lwt.t

  val prefetch :
    t ->
    ?peer:P2p_peer.Id.t ->
    ?timeout:Time.System.Span.t ->
    key ->
    param ->
    unit

  val fetch :
    t ->
    ?peer:P2p_peer.Id.t ->
    ?timeout:Time.System.Span.t ->
    key ->
    param ->
    value tzresult Lwt.t

  val clear_or_cancel : t -> key -> unit

  val resolve_pending : t -> key -> value -> unit

  val inject : t -> key -> value -> bool Lwt.t

  val watch : t -> (key * value) Lwt_stream.t * Lwt_watcher.stopper

  val pending : t -> key -> bool
end

module type DISK_TABLE = sig
  type store

  type key

  type value

  val known : store -> key -> bool Lwt.t

  val read : store -> key -> value tzresult Lwt.t

  val read_opt : store -> key -> value option Lwt.t
end

module type MEMORY_TABLE = sig
  type 'a t

  type key

  val create : int -> 'a t

  val find : 'a t -> key -> 'a

  val find_opt : 'a t -> key -> 'a option

  val add : 'a t -> key -> 'a -> unit

  val replace : 'a t -> key -> 'a -> unit

  val remove : 'a t -> key -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val length : 'a t -> int
end

module type SCHEDULER_EVENTS = sig
  type t

  type key

  val request : t -> P2p_peer.Id.t option -> key -> unit

  val notify : t -> P2p_peer.Id.t -> key -> unit

  val notify_cancellation : t -> key -> unit

  val notify_unrequested : t -> P2p_peer.Id.t -> key -> unit

  val notify_duplicate : t -> P2p_peer.Id.t -> key -> unit

  val notify_invalid : t -> P2p_peer.Id.t -> key -> unit

  val memory_table_length : t -> int
end

module type PRECHECK = sig
  type key

  type param

  type notified_value

  type value

  val precheck : key -> param -> notified_value -> value option
end

module Make_table (Hash : sig
  type t

  val name : string

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end)
(Disk_table : DISK_TABLE with type key := Hash.t)
(Memory_table : MEMORY_TABLE with type key := Hash.t)
(Scheduler : SCHEDULER_EVENTS with type key := Hash.t)
(Precheck : PRECHECK with type key := Hash.t and type value := Disk_table.value) : sig
  include
    DISTRIBUTED_DB
      with type key = Hash.t
       and type value = Disk_table.value
       and type param = Precheck.param

  val create :
    ?global_input:(key * value) Lwt_watcher.input ->
    Scheduler.t ->
    Disk_table.store ->
    t

  val notify :
    t -> P2p_peer.Id.t -> key -> Precheck.notified_value -> unit Lwt.t

  val memory_table_length : t -> int
end = struct
  type key = Hash.t

  type value = Disk_table.value

  type param = Precheck.param

  type t = {
    scheduler : Scheduler.t;
    disk : Disk_table.store;
    memory : status Memory_table.t;
    global_input : (key * value) Lwt_watcher.input option;
    input : (key * value) Lwt_watcher.input;
  }

  and status =
    | Pending of {
        waiter : value tzresult Lwt.t;
        wakener : value tzresult Lwt.u;
        mutable waiters : int;
        param : param;
      }
    | Found of value

  let known s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        Disk_table.known s.disk k
    | Some (Pending _) ->
        Lwt.return_false
    | Some (Found _) ->
        Lwt.return_true

  let read_opt s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        Disk_table.read_opt s.disk k
    | Some (Found v) ->
        Lwt.return_some v
    | Some (Pending _) ->
        Lwt.return_none

  type error += Missing_data of key

  type error += Canceled of key

  type error += Timeout of key

  let () =
    (* Missing data key *)
    register_error_kind
      `Permanent
      ~id:("distributed_db." ^ Hash.name ^ ".missing")
      ~title:("Missing " ^ Hash.name)
      ~description:("Some " ^ Hash.name ^ " is missing from the distributed db")
      ~pp:(fun ppf key ->
        Format.fprintf ppf "Missing %s %a" Hash.name Hash.pp key)
      (Data_encoding.obj1 (Data_encoding.req "key" Hash.encoding))
      (function Missing_data key -> Some key | _ -> None)
      (fun key -> Missing_data key) ;
    (* Canceled key *)
    register_error_kind
      `Permanent
      ~title:("Canceled fetch of a " ^ Hash.name)
      ~description:("The fetch of a " ^ Hash.name ^ " has been canceled")
      ~id:("distributed_db." ^ Hash.name ^ ".fetch_canceled")
      ~pp:(fun ppf key ->
        Format.fprintf ppf "Fetch of %s %a canceled" Hash.name Hash.pp key)
      Data_encoding.(obj1 (req "key" Hash.encoding))
      (function Canceled key -> Some key | _ -> None)
      (fun key -> Canceled key) ;
    (* Timeout key *)
    register_error_kind
      `Permanent
      ~title:("Timed out fetch of a " ^ Hash.name)
      ~description:("The fetch of a " ^ Hash.name ^ " has timed out")
      ~id:("distributed_db." ^ Hash.name ^ ".fetch_timeout")
      ~pp:(fun ppf key ->
        Format.fprintf ppf "Fetch of %s %a timed out" Hash.name Hash.pp key)
      Data_encoding.(obj1 (req "key" Hash.encoding))
      (function Timeout key -> Some key | _ -> None)
      (fun key -> Timeout key)

  let read s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        trace (Missing_data k) @@ Disk_table.read s.disk k
    | Some (Found v) ->
        return v
    | Some (Pending _) ->
        fail (Missing_data k)

  let wrap s k ?timeout t =
    let t = Lwt.protected t in
    Lwt.on_cancel t (fun () ->
        match Memory_table.find_opt s.memory k with
        | None ->
            ()
        | Some (Found _) ->
            ()
        | Some (Pending data) ->
            data.waiters <- data.waiters - 1 ;
            if data.waiters = 0 then (
              Memory_table.remove s.memory k ;
              Scheduler.notify_cancellation s.scheduler k )) ;
    match timeout with
    | None ->
        t
    | Some delay ->
        let timeout = Systime_os.sleep delay >>= fun () -> fail (Timeout k) in
        Lwt.pick [t; timeout]

  let fetch s ?peer ?timeout k param =
    match Memory_table.find_opt s.memory k with
    | None -> (
        Disk_table.read_opt s.disk k
        >>= function
        | Some v ->
            return v
        | None -> (
          match Memory_table.find_opt s.memory k with
          | None ->
              let (waiter, wakener) = Lwt.wait () in
              Memory_table.add
                s.memory
                k
                (Pending {waiter; wakener; waiters = 1; param}) ;
              Scheduler.request s.scheduler peer k ;
              wrap s k ?timeout waiter
          | Some (Pending data) ->
              Scheduler.request s.scheduler peer k ;
              data.waiters <- data.waiters + 1 ;
              wrap s k ?timeout data.waiter
          | Some (Found v) ->
              return v ) )
    | Some (Pending data) ->
        Scheduler.request s.scheduler peer k ;
        data.waiters <- data.waiters + 1 ;
        wrap s k ?timeout data.waiter
    | Some (Found v) ->
        return v

  let prefetch s ?peer ?timeout k param =
    try ignore (fetch s ?peer ?timeout k param) with _ -> ()

  let notify s p k v =
    match Memory_table.find_opt s.memory k with
    | None -> (
        Disk_table.known s.disk k
        >>= function
        | true ->
            Scheduler.notify_duplicate s.scheduler p k ;
            Lwt.return_unit
        | false ->
            Scheduler.notify_unrequested s.scheduler p k ;
            Lwt.return_unit )
    | Some (Pending {wakener = w; param; _}) -> (
      match Precheck.precheck k param v with
      | None ->
          Scheduler.notify_invalid s.scheduler p k ;
          Lwt.return_unit
      | Some v ->
          Scheduler.notify s.scheduler p k ;
          Memory_table.replace s.memory k (Found v) ;
          Lwt.wakeup_later w (Ok v) ;
          Option.iter s.global_input ~f:(fun input ->
              Lwt_watcher.notify input (k, v)) ;
          Lwt_watcher.notify s.input (k, v) ;
          Lwt.return_unit )
    | Some (Found _) ->
        Scheduler.notify_duplicate s.scheduler p k ;
        Lwt.return_unit

  let inject s k v =
    match Memory_table.find_opt s.memory k with
    | None -> (
        Disk_table.known s.disk k
        >>= function
        | true ->
            Lwt.return_false
        | false ->
            Memory_table.add s.memory k (Found v) ;
            Lwt.return_true )
    | Some (Pending _) | Some (Found _) ->
        Lwt.return_false

  let resolve_pending s k v =
    match Memory_table.find_opt s.memory k with
    | Some (Pending {wakener; _}) ->
        Scheduler.notify_cancellation s.scheduler k ;
        Memory_table.replace s.memory k (Found v) ;
        Lwt.wakeup_later wakener (Ok v) ;
        Option.iter s.global_input ~f:(fun input ->
            Lwt_watcher.notify input (k, v)) ;
        Lwt_watcher.notify s.input (k, v)
    | _ ->
        ()

  let clear_or_cancel s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        ()
    | Some (Pending {wakener = w; _}) ->
        Scheduler.notify_cancellation s.scheduler k ;
        Memory_table.remove s.memory k ;
        Lwt.wakeup_later w (error (Canceled k))
    | Some (Found _) ->
        Memory_table.remove s.memory k

  let watch s = Lwt_watcher.create_stream s.input

  let create ?global_input scheduler disk =
    let memory = Memory_table.create 17 in
    let input = Lwt_watcher.create_input () in
    {scheduler; disk; memory; input; global_input}

  let pending s k =
    match Memory_table.find_opt s.memory k with
    | None ->
        false
    | Some (Found _) ->
        false
    | Some (Pending _) ->
        true

  let memory_table_length s = Memory_table.length s.memory
end

module type REQUEST = sig
  type key

  type param

  val initial_delay : Time.System.Span.t

  val active : param -> P2p_peer.Set.t

  val send : param -> P2p_peer.Id.t -> key list -> unit
end

module Make_request_scheduler (Hash : sig
  type t

  val name : string

  module Logging : sig
    val tag : t Tag.def
  end
end)
(Table : MEMORY_TABLE with type key := Hash.t)
(Request : REQUEST with type key := Hash.t) : sig
  type t

  val create : Request.param -> t

  val shutdown : t -> unit Lwt.t

  include SCHEDULER_EVENTS with type t := t and type key := Hash.t

  val memory_table_length : t -> int
end = struct
  include Internal_event.Legacy_logging.Make_semantic (struct
    let name = "node.distributed_db.scheduler." ^ Hash.name
  end)

  type key = Hash.t

  type t = {
    param : Request.param;
    pending : status Table.t;
    queue : event Lwt_pipe.t;
    mutable events : event list Lwt.t;
    canceler : Lwt_canceler.t;
    mutable worker : unit Lwt.t;
  }

  and status = {
    peers : P2p_peer.Set.t;
    next_request : Time.System.t;
    delay : Time.System.Span.t;
  }

  and event =
    | Request of P2p_peer.Id.t option * key
    | Notify of P2p_peer.Id.t * key
    | Notify_cancellation of key
    | Notify_invalid of P2p_peer.Id.t * key
    | Notify_duplicate of P2p_peer.Id.t * key
    | Notify_unrequested of P2p_peer.Id.t * key

  let request t p k = assert (Lwt_pipe.push_now t.queue (Request (p, k)))

  let notify t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received %a from %a"
          -% t event "push_received" -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify (p, k)))

  let notify_cancellation t k =
    debug
      Tag.DSL.(
        fun f ->
          f "push cancellation %a"
          -% t event "push_cancellation"
          -% a Hash.Logging.tag k) ;
    assert (Lwt_pipe.push_now t.queue (Notify_cancellation k))

  let notify_invalid t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received invalid %a from %a"
          -% t event "push_received_invalid"
          -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify_invalid (p, k)))

  let notify_duplicate t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received duplicate %a from %a"
          -% t event "push_received_duplicate"
          -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify_duplicate (p, k)))

  let notify_unrequested t p k =
    debug
      Tag.DSL.(
        fun f ->
          f "push received unrequested %a from %a"
          -% t event "push_received_unrequested"
          -% a Hash.Logging.tag k
          -% a P2p_peer.Id.Logging.tag p) ;
    assert (Lwt_pipe.push_now t.queue (Notify_unrequested (p, k)))

  let compute_timeout state =
    let next =
      Table.fold
        (fun _ {next_request; _} acc ->
          match acc with
          | None ->
              Some next_request
          | Some x ->
              Some (Time.System.min x next_request))
        state.pending
        None
    in
    match next with
    | None ->
        fst @@ Lwt.task ()
    | Some next ->
        let now = Systime_os.now () in
        let delay = Ptime.diff next now in
        if Ptime.Span.compare delay Ptime.Span.zero <= 0 then Lwt.return_unit
        else Systime_os.sleep delay

  let process_event state now = function
    | Request (peer, key) -> (
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "registering request %a from %a"
              -% t event "registering_request"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag_opt peer)
        >>= fun () ->
        try
          let data = Table.find state.pending key in
          let peers =
            match peer with
            | None ->
                data.peers
            | Some peer ->
                P2p_peer.Set.add peer data.peers
          in
          let next_request = now in
          Table.replace
            state.pending
            key
            {delay = Request.initial_delay; next_request; peers} ;
          lwt_debug
            Tag.DSL.(
              fun f ->
                f "registering request %a from %a -> replaced"
                -% t event "registering_request_replaced"
                -% a Hash.Logging.tag key
                -% a P2p_peer.Id.Logging.tag_opt peer)
        with Not_found ->
          let peers =
            match peer with
            | None ->
                P2p_peer.Set.empty
            | Some peer ->
                P2p_peer.Set.singleton peer
          in
          Table.add
            state.pending
            key
            {peers; next_request = now; delay = Request.initial_delay} ;
          lwt_debug
            Tag.DSL.(
              fun f ->
                f "registering request %a from %a -> added"
                -% t event "registering_request_added"
                -% a Hash.Logging.tag key
                -% a P2p_peer.Id.Logging.tag_opt peer) )
    | Notify (peer, key) ->
        Table.remove state.pending key ;
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received %a from %a" -% t event "received"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)
    | Notify_cancellation key ->
        Table.remove state.pending key ;
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "canceled %a" -% t event "canceled" -% a Hash.Logging.tag key)
    | Notify_invalid (peer, key) ->
        (* TODO *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received invalid %a from %a"
              -% t event "received_invalid" -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)
    | Notify_unrequested (peer, key) ->
        (* TODO *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received unrequested %a from %a"
              -% t event "received_unrequested"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)
    | Notify_duplicate (peer, key) ->
        (* TODO *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "received duplicate %a from %a"
              -% t event "received_duplicate"
              -% a Hash.Logging.tag key
              -% a P2p_peer.Id.Logging.tag peer)

  let worker_loop state =
    let shutdown = Lwt_canceler.cancellation state.canceler in
    let rec loop state =
      let timeout = compute_timeout state in
      Lwt.choose [(state.events >|= fun _ -> ()); timeout; shutdown]
      >>= fun () ->
      if Lwt.state shutdown <> Lwt.Sleep then
        lwt_debug Tag.DSL.(fun f -> f "terminating" -% t event "terminating")
      else if Lwt.state state.events <> Lwt.Sleep then (
        let now = Systime_os.now () in
        state.events
        >>= fun events ->
        state.events <- Lwt_pipe.pop_all state.queue ;
        Lwt_list.iter_s (process_event state now) events
        >>= fun () -> loop state )
      else
        lwt_debug Tag.DSL.(fun f -> f "timeout" -% t event "timeout")
        >>= fun () ->
        let now = Systime_os.now () in
        let active_peers = Request.active state.param in
        let requests =
          Table.fold
            (fun key {peers; next_request; delay} acc ->
              if Ptime.is_later next_request ~than:now then acc
              else
                let remaining_peers = P2p_peer.Set.inter peers active_peers in
                if
                  P2p_peer.Set.is_empty remaining_peers
                  && not (P2p_peer.Set.is_empty peers)
                then (
                  Table.remove state.pending key ;
                  acc )
                else
                  let requested_peer =
                    P2p_peer.Id.Set.random_elt
                      ( if P2p_peer.Set.is_empty remaining_peers then
                        active_peers
                      else remaining_peers )
                  in
                  let next_request =
                    Option.unopt ~default:Ptime.max (Ptime.add_span now delay)
                  in
                  let next =
                    {
                      peers = remaining_peers;
                      next_request;
                      delay = Time.System.Span.multiply_exn 1.5 delay;
                    }
                  in
                  Table.replace state.pending key next ;
                  let requests =
                    try key :: P2p_peer.Map.find requested_peer acc
                    with Not_found -> [key]
                  in
                  P2p_peer.Map.add requested_peer requests acc)
            state.pending
            P2p_peer.Map.empty
        in
        P2p_peer.Map.iter (Request.send state.param) requests ;
        P2p_peer.Map.fold
          (fun peer request acc ->
            acc
            >>= fun () ->
            Lwt_list.iter_s
              (fun key ->
                lwt_debug
                  Tag.DSL.(
                    fun f ->
                      f "requested %a from %a" -% t event "requested"
                      -% a Hash.Logging.tag key
                      -% a P2p_peer.Id.Logging.tag peer))
              request)
          requests
          Lwt.return_unit
        >>= fun () -> loop state
    in
    loop state

  let create param =
    let state =
      {
        param;
        queue = Lwt_pipe.create ();
        pending = Table.create 17;
        events = Lwt.return_nil;
        canceler = Lwt_canceler.create ();
        worker = Lwt.return_unit;
      }
    in
    state.worker <-
      Lwt_utils.worker
        "db_request_scheduler"
        ~on_event:Internal_event.Lwt_worker_event.on_event
        ~run:(fun () -> worker_loop state)
        ~cancel:(fun () -> Lwt_canceler.cancel state.canceler) ;
    state

  let shutdown s = Lwt_canceler.cancel s.canceler >>= fun () -> s.worker

  let memory_table_length s = Table.length s.pending
end
src/lib_shell/distributed_db_functors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module DISTRIBUTED_DB.
  Record signature {t key value param : Type} := {
    t := t;
    key := key;
    value := value;
    param := param;
    known : t -> key -> Lwt.t bool;
    extensible_type;
    extensible_type;
    extensible_type;
    read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> key -> Lwt.t (option value);
    prefetch : t ->
      (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
        (option Tezos_base__TzPervasives.Time.System.Span.t) ->
          key -> param -> unit;
    fetch : t ->
      (option Tezos_base__TzPervasives.P2p_peer.Id.t) ->
        (option Tezos_base__TzPervasives.Time.System.Span.t) ->
          key -> param -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    clear_or_cancel : t -> key -> unit;
    resolve_pending : t -> key -> value -> unit;
    inject : t -> key -> value -> Lwt.t bool;
    watch : t ->
      (Lwt_stream.t (key * value)) *
        Tezos_base__TzPervasives.Lwt_watcher.stopper;
    pending : t -> key -> bool;
  }.
  Arguments signature : clear implicits.
End DISTRIBUTED_DB.

Module DISK_TABLE.
  Record signature {store key value : Type} := {
    store := store;
    key := key;
    value := value;
    known : store -> key -> Lwt.t bool;
    read : store -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : store -> key -> Lwt.t (option value);
  }.
  Arguments signature : clear implicits.
End DISK_TABLE.

Module MEMORY_TABLE.
  Record signature {t key : Type} := {
    polymorphic_abstract_type;
    key := key;
    create : forall {a : Type}, Z -> t a;
    find : forall {a : Type}, (t a) -> key -> a;
    find_opt : forall {a : Type}, (t a) -> key -> option a;
    add : forall {a : Type}, (t a) -> key -> a -> unit;
    replace : forall {a : Type}, (t a) -> key -> a -> unit;
    remove : forall {a : Type}, (t a) -> key -> unit;
    fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    length : forall {a : Type}, (t a) -> Z;
  }.
  Arguments signature : clear implicits.
End MEMORY_TABLE.

Module SCHEDULER_EVENTS.
  Record signature {t key : Type} := {
    t := t;
    key := key;
    request : t ->
      (option Tezos_base__TzPervasives.P2p_peer.Id.t) -> key -> unit;
    notify : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    notify_cancellation : t -> key -> unit;
    notify_unrequested : t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    notify_duplicate : t ->
      Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    notify_invalid : t -> Tezos_base__TzPervasives.P2p_peer.Id.t -> key -> unit;
    memory_table_length : t -> Z;
  }.
  Arguments signature : clear implicits.
End SCHEDULER_EVENTS.

Module PRECHECK.
  Record signature {key param notified_value value : Type} := {
    key := key;
    param := param;
    notified_value := notified_value;
    value := value;
    precheck : key -> param -> notified_value -> option value;
  }.
  Arguments signature : clear implicits.
End PRECHECK.

(* ❌ Functors are not handled. *)
functor

Module REQUEST.
  Record signature {key param : Type} := {
    key := key;
    param := param;
    initial_delay : Tezos_base__TzPervasives.Time.System.Span.t;
    active : param -> Tezos_base__TzPervasives.P2p_peer.Set.t;
    send : param -> Tezos_base__TzPervasives.P2p_peer.Id.t -> (list key) -> unit;
  }.
  Arguments signature : clear implicits.
End REQUEST.

(* ❌ Functors are not handled. *)
functor

src/lib_shell/distributed_db_message.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Bounded_encoding = struct
  open Data_encoding

  let block_header_max_size = ref (Some (8 * 1024 * 1024))

  (* FIXME: arbitrary *)

  let block_header_cache =
    ref (Block_header.bounded_encoding ?max_size:!block_header_max_size ())

  let block_locator_cache =
    ref
      (Block_locator.bounded_encoding
         ?max_header_size:!block_header_max_size
         ())

  let update_block_header_encoding () =
    block_header_cache :=
      Block_header.bounded_encoding ?max_size:!block_header_max_size () ;
    block_locator_cache :=
      Block_locator.bounded_encoding ?max_header_size:!block_header_max_size ()

  let set_block_header_max_size max =
    block_header_max_size := max ;
    update_block_header_encoding ()

  let block_header = delayed (fun () -> !block_header_cache)

  let block_locator = delayed (fun () -> !block_locator_cache)

  (* FIXME: all constants below are arbitrary high bounds until we
     have the mechanism to update them properly *)
  let operation_max_size = ref (Some (128 * 1024)) (* FIXME: arbitrary *)

  let operation_list_max_size = ref (Some (1024 * 1024)) (* FIXME: arbitrary *)

  let operation_list_max_length = ref None (* FIXME: arbitrary *)

  let operation_max_pass = ref (Some 8) (* FIXME: arbitrary *)

  let operation_cache =
    ref (Operation.bounded_encoding ?max_size:!operation_max_size ())

  let operation_list_cache =
    ref
      (Operation.bounded_list_encoding
         ?max_length:!operation_list_max_length
         ?max_size:!operation_list_max_size
         ?max_operation_size:!operation_max_size
         ?max_pass:!operation_max_pass
         ())

  let operation_hash_list_cache =
    ref
      (Operation.bounded_hash_list_encoding
         ?max_length:!operation_list_max_length
         ?max_pass:!operation_max_pass
         ())

  let update_operation_list_encoding () =
    operation_list_cache :=
      Operation.bounded_list_encoding
        ?max_length:!operation_list_max_length
        ?max_size:!operation_list_max_size
        ?max_operation_size:!operation_max_size
        ?max_pass:!operation_max_pass
        ()

  let update_operation_hash_list_encoding () =
    operation_list_cache :=
      Operation.bounded_list_encoding
        ?max_length:!operation_list_max_length
        ?max_pass:!operation_max_pass
        ()

  let update_operation_encoding () =
    operation_cache :=
      Operation.bounded_encoding ?max_size:!operation_max_size ()

  let set_operation_max_size max =
    operation_max_size := max ;
    update_operation_encoding () ;
    update_operation_list_encoding ()

  let set_operation_list_max_size max =
    operation_list_max_size := max ;
    update_operation_list_encoding ()

  let set_operation_list_max_length max =
    operation_list_max_length := max ;
    update_operation_list_encoding () ;
    update_operation_hash_list_encoding ()

  let set_operation_max_pass max =
    operation_max_pass := max ;
    update_operation_list_encoding () ;
    update_operation_hash_list_encoding ()

  let operation = delayed (fun () -> !operation_cache)

  let operation_list = delayed (fun () -> !operation_list_cache)

  let operation_hash_list = delayed (fun () -> !operation_hash_list_cache)

  let protocol_max_size = ref (Some (2 * 1024 * 1024)) (* FIXME: arbitrary *)

  let protocol_cache =
    ref (Protocol.bounded_encoding ?max_size:!protocol_max_size ())

  let set_protocol_max_size max = protocol_max_size := max

  let protocol = delayed (fun () -> !protocol_cache)

  let mempool_max_operations = ref None

  let mempool_cache =
    ref (Mempool.bounded_encoding ?max_operations:!mempool_max_operations ())

  let set_mempool_max_operations max = mempool_max_operations := max

  let mempool = delayed (fun () -> !mempool_cache)
end

type t =
  | Get_current_branch of Chain_id.t
  | Current_branch of Chain_id.t * Block_locator.t
  | Deactivate of Chain_id.t
  | Get_current_head of Chain_id.t
  | Current_head of Chain_id.t * Block_header.t * Mempool.t
  | Get_block_headers of Block_hash.t list
  | Block_header of Block_header.t
  | Get_operations of Operation_hash.t list
  | Operation of Operation.t
  | Get_protocols of Protocol_hash.t list
  | Protocol of Protocol.t
  | Get_operation_hashes_for_blocks of (Block_hash.t * int) list
  | Operation_hashes_for_block of
      Block_hash.t
      * int
      * Operation_hash.t list
      * Operation_list_list_hash.path
  | Get_operations_for_blocks of (Block_hash.t * int) list
  | Operations_for_block of
      Block_hash.t * int * Operation.t list * Operation_list_list_hash.path

let encoding =
  let open Data_encoding in
  let case ?max_length ~tag ~title encoding unwrap wrap =
    P2p_message.Encoding {tag; title; encoding; wrap; unwrap; max_length}
  in
  [ case
      ~tag:0x10
      ~title:"Get_current_branch"
      (obj1 (req "get_current_branch" Chain_id.encoding))
      (function Get_current_branch chain_id -> Some chain_id | _ -> None)
      (fun chain_id -> Get_current_branch chain_id);
    case
      ~tag:0x11
      ~title:"Current_branch"
      (obj2
         (req "chain_id" Chain_id.encoding)
         (req "current_branch" Bounded_encoding.block_locator))
      (function
        | Current_branch (chain_id, locator) ->
            Some (chain_id, locator)
        | _ ->
            None)
      (fun (chain_id, locator) -> Current_branch (chain_id, locator));
    case
      ~tag:0x12
      ~title:"Deactivate"
      (obj1 (req "deactivate" Chain_id.encoding))
      (function Deactivate chain_id -> Some chain_id | _ -> None)
      (fun chain_id -> Deactivate chain_id);
    case
      ~tag:0x13
      ~title:"Get_current_head"
      (obj1 (req "get_current_head" Chain_id.encoding))
      (function Get_current_head chain_id -> Some chain_id | _ -> None)
      (fun chain_id -> Get_current_head chain_id);
    case
      ~tag:0x14
      ~title:"Current_head"
      (obj3
         (req "chain_id" Chain_id.encoding)
         (req
            "current_block_header"
            (dynamic_size Bounded_encoding.block_header))
         (req "current_mempool" Bounded_encoding.mempool))
      (function
        | Current_head (chain_id, bh, mempool) ->
            Some (chain_id, bh, mempool)
        | _ ->
            None)
      (fun (chain_id, bh, mempool) -> Current_head (chain_id, bh, mempool));
    case
      ~tag:0x20
      ~title:"Get_block_headers"
      (obj1 (req "get_block_headers" (list ~max_length:10 Block_hash.encoding)))
      (function Get_block_headers bhs -> Some bhs | _ -> None)
      (fun bhs -> Get_block_headers bhs);
    case
      ~tag:0x21
      ~title:"Block_header"
      (obj1 (req "block_header" Bounded_encoding.block_header))
      (function Block_header bh -> Some bh | _ -> None)
      (fun bh -> Block_header bh);
    case
      ~tag:0x30
      ~title:"Get_operations"
      (obj1
         (req "get_operations" (list ~max_length:10 Operation_hash.encoding)))
      (function Get_operations bhs -> Some bhs | _ -> None)
      (fun bhs -> Get_operations bhs);
    case
      ~tag:0x31
      ~title:"Operation"
      (obj1 (req "operation" Bounded_encoding.operation))
      (function Operation o -> Some o | _ -> None)
      (fun o -> Operation o);
    case
      ~tag:0x40
      ~title:"Get_protocols"
      (obj1 (req "get_protocols" (list ~max_length:10 Protocol_hash.encoding)))
      (function Get_protocols protos -> Some protos | _ -> None)
      (fun protos -> Get_protocols protos);
    case
      ~tag:0x41
      ~title:"Protocol"
      (obj1 (req "protocol" Bounded_encoding.protocol))
      (function Protocol proto -> Some proto | _ -> None)
      (fun proto -> Protocol proto);
    case
      ~tag:0x50
      ~title:"Get_operation_hashes_for_blocks"
      (obj1
         (req
            "get_operation_hashes_for_blocks"
            (list ~max_length:10 (tup2 Block_hash.encoding int8))))
      (function
        | Get_operation_hashes_for_blocks keys -> Some keys | _ -> None)
      (fun keys -> Get_operation_hashes_for_blocks keys);
    case
      ~tag:0x51
      ~title:"Operation_hashes_for_blocks"
      (merge_objs
         (obj1
            (req
               "operation_hashes_for_block"
               (obj2
                  (req "hash" Block_hash.encoding)
                  (req "validation_pass" int8))))
         Bounded_encoding.operation_hash_list)
      (function
        | Operation_hashes_for_block (block, ofs, ops, path) ->
            Some ((block, ofs), (path, ops))
        | _ ->
            None)
      (fun ((block, ofs), (path, ops)) ->
        Operation_hashes_for_block (block, ofs, ops, path));
    case
      ~tag:0x60
      ~title:"Get_operations_for_blocks"
      (obj1
         (req
            "get_operations_for_blocks"
            (list
               ~max_length:10
               (obj2
                  (req "hash" Block_hash.encoding)
                  (req "validation_pass" int8)))))
      (function Get_operations_for_blocks keys -> Some keys | _ -> None)
      (fun keys -> Get_operations_for_blocks keys);
    case
      ~tag:0x61
      ~title:"Operations_for_blocks"
      (merge_objs
         (obj1
            (req
               "operations_for_block"
               (obj2
                  (req "hash" Block_hash.encoding)
                  (req "validation_pass" int8))))
         Bounded_encoding.operation_list)
      (function
        | Operations_for_block (block, ofs, ops, path) ->
            Some ((block, ofs), (path, ops))
        | _ ->
            None)
      (fun ((block, ofs), (path, ops)) ->
        Operations_for_block (block, ofs, ops, path)) ]

let cfg : _ P2p.message_config =
  {
    encoding;
    chain_name = Distributed_db_version.chain_name;
    distributed_db_versions = [Distributed_db_version.zero];
  }

let raw_encoding = P2p_message.encoding encoding

let pp_json ppf msg =
  Data_encoding.Json.pp
    ppf
    (Data_encoding.Json.construct raw_encoding (Message msg))

module Logging = struct
  let tag = Tag.def ~doc:"Message" "message" pp_json
end
src/lib_shell/distributed_db_message.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Bounded_encoding.
  Import Data_encoding.
  
  Definition block_header_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul (Z.mul 8 1024) 1024)).
  
  Definition block_header_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        Tezos_base__TzPervasives.Block_header.t) :=
    Stdlib.ref
      (Block_header.bounded_encoding
        (Stdlib.op_exclamation block_header_max_size) tt).
  
  Definition block_locator_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        Tezos_base__TzPervasives.Block_locator.t) :=
    Stdlib.ref
      (Block_locator.bounded_encoding
        (Stdlib.op_exclamation block_header_max_size) None tt).
  
  Definition update_block_header_encoding (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Stdlib.op_coloneq block_header_cache
        (Block_header.bounded_encoding
          (Stdlib.op_exclamation block_header_max_size) tt) in
    Stdlib.op_coloneq block_locator_cache
      (Block_locator.bounded_encoding
        (Stdlib.op_exclamation block_header_max_size) None tt).
  
  Definition set_block_header_max_size (max : option Z) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.op_coloneq block_header_max_size max in
    update_block_header_encoding tt.
  
  Definition block_header
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Block_header.t :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation block_header_cache).
  
  Definition block_locator
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Block_locator.t :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation block_locator_cache).
  
  Definition operation_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul 128 1024)).
  
  Definition operation_list_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul 1024 1024)).
  
  Definition operation_list_max_length : Stdlib.ref (option Z) :=
    Stdlib.ref None.
  
  Definition operation_max_pass : Stdlib.ref (option Z) := Stdlib.ref (Some 8).
  
  Definition operation_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Operation.t) :=
    Stdlib.ref
      (Operation.bounded_encoding (Stdlib.op_exclamation operation_max_size) tt).
  
  Definition operation_list_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        (Tezos_crypto.Operation_list_list_hash.path *
          (list Tezos_base__TzPervasives.Operation.t))) :=
    Stdlib.ref
      (Operation.bounded_list_encoding
        (Stdlib.op_exclamation operation_list_max_length)
        (Stdlib.op_exclamation operation_list_max_size)
        (Stdlib.op_exclamation operation_max_size)
        (Stdlib.op_exclamation operation_max_pass) tt).
  
  Definition operation_hash_list_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        (Tezos_crypto.Operation_list_list_hash.path *
          (list Tezos_crypto.Operation_hash.t))) :=
    Stdlib.ref
      (Operation.bounded_hash_list_encoding
        (Stdlib.op_exclamation operation_list_max_length)
        (Stdlib.op_exclamation operation_max_pass) tt).
  
  Definition update_operation_list_encoding (function_parameter : unit)
    : unit :=
    let 'tt := function_parameter in
    Stdlib.op_coloneq operation_list_cache
      (Operation.bounded_list_encoding
        (Stdlib.op_exclamation operation_list_max_length)
        (Stdlib.op_exclamation operation_list_max_size)
        (Stdlib.op_exclamation operation_max_size)
        (Stdlib.op_exclamation operation_max_pass) tt).
  
  Definition update_operation_hash_list_encoding (function_parameter : unit)
    : unit :=
    let 'tt := function_parameter in
    Stdlib.op_coloneq operation_list_cache
      (Operation.bounded_list_encoding
        (Stdlib.op_exclamation operation_list_max_length) None None
        (Stdlib.op_exclamation operation_max_pass) tt).
  
  Definition update_operation_encoding (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    Stdlib.op_coloneq operation_cache
      (Operation.bounded_encoding (Stdlib.op_exclamation operation_max_size) tt).
  
  Definition set_operation_max_size (max : option Z) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.op_coloneq operation_max_size max in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := update_operation_encoding tt in
    update_operation_list_encoding tt.
  
  Definition set_operation_list_max_size (max : option Z) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.op_coloneq operation_list_max_size max in
    update_operation_list_encoding tt.
  
  Definition set_operation_list_max_length (max : option Z) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.op_coloneq operation_list_max_length max in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := update_operation_list_encoding tt in
    update_operation_hash_list_encoding tt.
  
  Definition set_operation_max_pass (max : option Z) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Stdlib.op_coloneq operation_max_pass max in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := update_operation_list_encoding tt in
    update_operation_hash_list_encoding tt.
  
  Definition operation
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Operation.t :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation operation_cache).
  
  Definition operation_list
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Tezos_crypto.Operation_list_list_hash.path *
        (list Tezos_base__TzPervasives.Operation.t)) :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation operation_list_cache).
  
  Definition operation_hash_list
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Tezos_crypto.Operation_list_list_hash.path *
        (list Tezos_crypto.Operation_hash.t)) :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation operation_hash_list_cache).
  
  Definition protocol_max_size : Stdlib.ref (option Z) :=
    Stdlib.ref (Some (Z.mul (Z.mul 2 1024) 1024)).
  
  Definition protocol_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Protocol.t) :=
    Stdlib.ref
      (Protocol.bounded_encoding (Stdlib.op_exclamation protocol_max_size) tt).
  
  Definition set_protocol_max_size (max : option Z) : unit :=
    Stdlib.op_coloneq protocol_max_size max.
  
  Definition protocol
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Protocol.t :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation protocol_cache).
  
  Definition mempool_max_operations : Stdlib.ref (option Z) := Stdlib.ref None.
  
  Definition mempool_cache
    : Stdlib.ref
      (Tezos_data_encoding.Data_encoding.t
        Tezos_base__TzPervasives.Mempool.mempool) :=
    Stdlib.ref
      (Mempool.bounded_encoding (Stdlib.op_exclamation mempool_max_operations)
        tt).
  
  Definition set_mempool_max_operations (max : option Z) : unit :=
    Stdlib.op_coloneq mempool_max_operations max.
  
  Definition mempool
    : Tezos_base__TzPervasives.Data_encoding.encoding
      Tezos_base__TzPervasives.Mempool.mempool :=
    delayed
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_exclamation mempool_cache).
End Bounded_encoding.

Inductive t : Type :=
| Get_current_branch : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_branch : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_locator.t -> t
| Deactivate : Tezos_base__TzPervasives.Chain_id.t -> t
| Get_current_head : Tezos_base__TzPervasives.Chain_id.t -> t
| Current_head : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_header.t -> Tezos_base__TzPervasives.Mempool.t
  -> t
| Get_block_headers : (list Tezos_base__TzPervasives.Block_hash.t) -> t
| Block_header : Tezos_base__TzPervasives.Block_header.t -> t
| Get_operations : (list Tezos_base__TzPervasives.Operation_hash.t) -> t
| Operation : Tezos_base__TzPervasives.Operation.t -> t
| Get_protocols : (list Tezos_base__TzPervasives.Protocol_hash.t) -> t
| Protocol : Tezos_base__TzPervasives.Protocol.t -> t
| Get_operation_hashes_for_blocks :
  (list (Tezos_base__TzPervasives.Block_hash.t * Z)) -> t
| Operation_hashes_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
  (list Tezos_base__TzPervasives.Operation_hash.t) ->
  Tezos_base__TzPervasives.Operation_list_list_hash.path -> t
| Get_operations_for_blocks : (list (Tezos_base__TzPervasives.Block_hash.t * Z))
  -> t
| Operations_for_block : Tezos_base__TzPervasives.Block_hash.t -> Z ->
  (list Tezos_base__TzPervasives.Operation.t) ->
  Tezos_base__TzPervasives.Operation_list_list_hash.path -> t.

Definition encoding : list (Tezos_p2p.P2p_message.encoding t) :=
  let case {A B : Type}
    (max_length : option Z) (tag : Z) (title : string) (encoding :
    Tezos_base__TzPervasives.Data_encoding.t A) (unwrap : B -> option A) (wrap :
    A -> B) : Tezos_p2p.P2p_message.encoding B :=
    Tezos_p2p.P2p_message.Encoding
      {| tag := tag; title := title; encoding := encoding; wrap := wrap;
        unwrap := unwrap; max_length := max_length |} in
  cons
    (case None 16 "Get_current_branch" % string
      (obj1 (req None None "get_current_branch" % string Chain_id.encoding))
      (fun function_parameter =>
        match function_parameter with
        | Get_current_branch chain_id => Some chain_id
        | _ => None
        end) (fun chain_id => Get_current_branch chain_id))
    (cons
      (case None 17 "Current_branch" % string
        (obj2 (req None None "chain_id" % string Chain_id.encoding)
          (req None None "current_branch" % string
            Bounded_encoding.block_locator))
        (fun function_parameter =>
          match function_parameter with
          | Current_branch chain_id locator => Some (chain_id, locator)
          | _ => None
          end)
        (fun function_parameter =>
          let '(chain_id, locator) := function_parameter in
          Current_branch chain_id locator))
      (cons
        (case None 18 "Deactivate" % string
          (obj1 (req None None "deactivate" % string Chain_id.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Deactivate chain_id => Some chain_id
            | _ => None
            end) (fun chain_id => Deactivate chain_id))
        (cons
          (case None 19 "Get_current_head" % string
            (obj1 (req None None "get_current_head" % string Chain_id.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Get_current_head chain_id => Some chain_id
              | _ => None
              end) (fun chain_id => Get_current_head chain_id))
          (cons
            (case None 20 "Current_head" % string
              (obj3 (req None None "chain_id" % string Chain_id.encoding)
                (req None None "current_block_header" % string
                  (dynamic_size None Bounded_encoding.block_header))
                (req None None "current_mempool" % string
                  Bounded_encoding.mempool))
              (fun function_parameter =>
                match function_parameter with
                | Current_head chain_id bh mempool =>
                  Some (chain_id, bh, mempool)
                | _ => None
                end)
              (fun function_parameter =>
                let '(chain_id, bh, mempool) := function_parameter in
                Current_head chain_id bh mempool))
            (cons
              (case None 32 "Get_block_headers" % string
                (obj1
                  (req None None "get_block_headers" % string
                    (list (Some 10) Block_hash.encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Get_block_headers bhs => Some bhs
                  | _ => None
                  end) (fun bhs => Get_block_headers bhs))
              (cons
                (case None 33 "Block_header" % string
                  (obj1
                    (req None None "block_header" % string
                      Bounded_encoding.block_header))
                  (fun function_parameter =>
                    match function_parameter with
                    | Block_header bh => Some bh
                    | _ => None
                    end) (fun bh => Block_header bh))
                (cons
                  (case None 48 "Get_operations" % string
                    (obj1
                      (req None None "get_operations" % string
                        (list (Some 10) Operation_hash.encoding)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Get_operations bhs => Some bhs
                      | _ => None
                      end) (fun bhs => Get_operations bhs))
                  (cons
                    (case None 49 "Operation" % string
                      (obj1
                        (req None None "operation" % string
                          Bounded_encoding.operation))
                      (fun function_parameter =>
                        match function_parameter with
                        | Operation o => Some o
                        | _ => None
                        end) (fun o => Operation o))
                    (cons
                      (case None 64 "Get_protocols" % string
                        (obj1
                          (req None None "get_protocols" % string
                            (list (Some 10) Protocol_hash.encoding)))
                        (fun function_parameter =>
                          match function_parameter with
                          | Get_protocols protos => Some protos
                          | _ => None
                          end) (fun protos => Get_protocols protos))
                      (cons
                        (case None 65 "Protocol" % string
                          (obj1
                            (req None None "protocol" % string
                              Bounded_encoding.protocol))
                          (fun function_parameter =>
                            match function_parameter with
                            | Protocol proto => Some proto
                            | _ => None
                            end) (fun proto => Protocol proto))
                        (cons
                          (case None 80
                            "Get_operation_hashes_for_blocks" % string
                            (obj1
                              (req None None
                                "get_operation_hashes_for_blocks" % string
                                (list (Some 10) (tup2 Block_hash.encoding int8))))
                            (fun function_parameter =>
                              match function_parameter with
                              | Get_operation_hashes_for_blocks keys =>
                                Some keys
                              | _ => None
                              end)
                            (fun keys => Get_operation_hashes_for_blocks keys))
                          (cons
                            (case None 81 "Operation_hashes_for_blocks" % string
                              (merge_objs
                                (obj1
                                  (req None None
                                    "operation_hashes_for_block" % string
                                    (obj2
                                      (req None None "hash" % string
                                        Block_hash.encoding)
                                      (req None None "validation_pass" % string
                                        int8))))
                                Bounded_encoding.operation_hash_list)
                              (fun function_parameter =>
                                match function_parameter with
                                | Operation_hashes_for_block block ofs ops path
                                  => Some ((block, ofs), (path, ops))
                                | _ => None
                                end)
                              (fun function_parameter =>
                                let '((block, ofs), (path, ops)) :=
                                  function_parameter in
                                Operation_hashes_for_block block ofs ops path))
                            (cons
                              (case None 96 "Get_operations_for_blocks" % string
                                (obj1
                                  (req None None
                                    "get_operations_for_blocks" % string
                                    (list (Some 10)
                                      (obj2
                                        (req None None "hash" % string
                                          Block_hash.encoding)
                                        (req None None
                                          "validation_pass" % string int8)))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Get_operations_for_blocks keys => Some keys
                                  | _ => None
                                  end)
                                (fun keys => Get_operations_for_blocks keys))
                              (cons
                                (case None 97 "Operations_for_blocks" % string
                                  (merge_objs
                                    (obj1
                                      (req None None
                                        "operations_for_block" % string
                                        (obj2
                                          (req None None "hash" % string
                                            Block_hash.encoding)
                                          (req None None
                                            "validation_pass" % string int8))))
                                    Bounded_encoding.operation_list)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Operations_for_block block ofs ops path =>
                                      Some ((block, ofs), (path, ops))
                                    | _ => None
                                    end)
                                  (fun function_parameter =>
                                    let '((block, ofs), (path, ops)) :=
                                      function_parameter in
                                    Operations_for_block block ofs ops path)) [])))))))))))))).

Definition cfg : Tezos_p2p.P2p.message_config t :=
  {| encoding := encoding; chain_name := Distributed_db_version.chain_name;
    distributed_db_versions := cons Distributed_db_version.zero [] |}.

Definition raw_encoding
  : Tezos_base__TzPervasives.Data_encoding.t (Tezos_p2p.P2p_message.t t) :=
  P2p_message.encoding encoding.

Definition pp_json (ppf : Stdlib.Format.formatter) (msg : t) : unit :=
  Data_encoding.Json.pp ppf
    (Data_encoding.Json.construct raw_encoding
      (Tezos_p2p.P2p_message.Message msg)).

Module Logging.
  Definition tag : Tezos_base__TzPervasives.Tag.def t :=
    Tag.def (Some "Message" % string) "message" % string pp_json.
End Logging.

src/lib_shell/injection_directory.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let read_chain_id validator chain =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  match chain with
  | None ->
      Lwt.return_none
  | Some chain ->
      Chain_directory.get_chain_id state chain >>= Lwt.return_some

let inject_block validator ?force ?chain bytes operations =
  read_chain_id validator chain
  >>= fun chain_id ->
  Validator.validate_block validator ?force ?chain_id bytes operations
  >>=? fun (hash, block) -> return (hash, block >>=? fun _ -> return_unit)

let inject_operation validator ?chain bytes =
  read_chain_id validator chain
  >>= fun chain_id ->
  let t =
    match Data_encoding.Binary.of_bytes Operation.encoding bytes with
    | None ->
        failwith "Can't parse the operation"
    | Some op ->
        Validator.inject_operation validator ?chain_id op
  in
  let hash = Operation_hash.hash_bytes [bytes] in
  Lwt.return (hash, t)

let inject_protocol state proto =
  let proto_bytes =
    Data_encoding.Binary.to_bytes_exn Protocol.encoding proto
  in
  let hash = Protocol_hash.hash_bytes [proto_bytes] in
  let validation =
    Updater.compile hash proto
    >>= function
    | false ->
        failwith "Compilation failed (%a)" Protocol_hash.pp_short hash
    | true -> (
        State.Protocol.store state proto
        >>= function
        | None ->
            failwith
              "Previously registered protocol (%a)"
              Protocol_hash.pp_short
              hash
        | Some _ ->
            return_unit )
  in
  Lwt.return (hash, validation)

let build_rpc_directory validator =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let register0 s f =
    dir := RPC_directory.register !dir s (fun () p q -> f p q)
  in
  register0 Injection_services.S.block (fun q (raw, operations) ->
      inject_block validator ?chain:q#chain ~force:q#force raw operations
      >>=? fun (hash, wait) ->
      (if q#async then return_unit else wait) >>=? fun () -> return hash) ;
  register0 Injection_services.S.operation (fun q contents ->
      inject_operation validator ?chain:q#chain contents
      >>= fun (hash, wait) ->
      (if q#async then return_unit else wait) >>=? fun () -> return hash) ;
  register0 Injection_services.S.protocol (fun q protocol ->
      inject_protocol state protocol
      >>= fun (hash, wait) ->
      (if q#async then return_unit else wait) >>=? fun () -> return hash) ;
  !dir
src/lib_shell/injection_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition read_chain_id
  (validator : Tezos_shell.Validator.t)
  (chain : option Tezos_shell_services.Chain_services.chain)
  : Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
  let distributed_db := Validator.distributed_db validator in
  let state := Distributed_db.state distributed_db in
  match chain with
  | None => Lwt.return_none
  | Some chain =>
    op_gtgteq (Chain_directory.get_chain_id state chain) Lwt.return_some
  end.

Definition inject_block
  (validator : Tezos_shell.Validator.t) (force : option bool)
  (chain : option Tezos_shell_services.Chain_services.chain)
  (bytes : Stdlib.Bytes.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.t *
        (Lwt.t (Tezos_base__TzPervasives.tzresult unit)))) :=
  op_gtgteq (read_chain_id validator chain)
    (fun chain_id =>
      op_gtgteqquestion
        (Validator.validate_block validator force chain_id string operations)
        (fun function_parameter =>
          let '(hash, block) := function_parameter in
          _return
            (hash,
              (op_gtgteqquestion block
                (fun function_parameter =>
                  let '_ := function_parameter in
                  return_unit))))).

Definition inject_operation
  (validator : Tezos_shell.Validator.t)
  (chain : option Tezos_shell_services.Chain_services.chain)
  (bytes : Stdlib.Bytes.t)
  : Lwt.t
    (Tezos_base__TzPervasives.Operation_hash.t *
      (Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  op_gtgteq (read_chain_id validator chain)
    (fun chain_id =>
      let t :=
        match Data_encoding.Binary.of_bytes Operation.encoding string with
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Can't parse the operation" % string
                CamlinternalFormatBasics.End_of_format)
              "Can't parse the operation" % string)
        | Some op => Validator.inject_operation validator chain_id op
        end in
      let hash := Operation_hash.hash_bytes None (cons string []) in
      Lwt._return (hash, t)).

Definition inject_protocol
  (state : Tezos_shell__State.global_state)
  (proto : Tezos_base__TzPervasives.Protocol.t)
  : Lwt.t
    (Tezos_base__TzPervasives.Protocol_hash.t *
      (Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  let proto_bytes := Data_encoding.Binary.to_bytes_exn Protocol.encoding proto
    in
  let hash := Protocol_hash.hash_bytes None (cons proto_bytes []) in
  let validation :=
    op_gtgteq (Updater.compile hash proto)
      (fun function_parameter =>
        match function_parameter with
        | false =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Compilation failed (" % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))
              "Compilation failed (%a)" % string) Protocol_hash.pp_short hash
        | true =>
          op_gtgteq (State.Protocol.store state proto)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Previously registered protocol (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format)))
                    "Previously registered protocol (%a)" % string)
                  Protocol_hash.pp_short hash
              | Some _ => return_unit
              end)
        end) in
  Lwt._return (hash, validation).

Definition build_rpc_directory (validator : Tezos_shell.Validator.t)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let distributed_db := Validator.distributed_db validator in
  let state := Distributed_db.state distributed_db in
  let dir := Stdlib.ref RPC_directory.empty in
  let register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun p => fun q => f p q)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 Injection_services.S.block
      (fun q =>
        fun function_parameter =>
          let '(raw, operations) := function_parameter in
          op_gtgteqquestion
            (inject_block validator
              (Some
                (* ❌ Sending method message is not handled *)
                send)
              (* ❌ Sending method message is not handled *)
              send raw operations)
            (fun function_parameter =>
              let '(hash, wait) := function_parameter in
              op_gtgteqquestion
                (if
                  (* ❌ Sending method message is not handled *)
                  send then
                  return_unit
                else
                  wait)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return hash))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 Injection_services.S.operation
      (fun q =>
        fun contents =>
          op_gtgteq
            (inject_operation validator
              (* ❌ Sending method message is not handled *)
              send contents)
            (fun function_parameter =>
              let '(hash, wait) := function_parameter in
              op_gtgteqquestion
                (if
                  (* ❌ Sending method message is not handled *)
                  send then
                  return_unit
                else
                  wait)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return hash))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 Injection_services.S.protocol
      (fun q =>
        fun protocol =>
          op_gtgteq (inject_protocol state protocol)
            (fun function_parameter =>
              let '(hash, wait) := function_parameter in
              op_gtgteqquestion
                (if
                  (* ❌ Sending method message is not handled *)
                  send then
                  return_unit
                else
                  wait)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return hash))) in
  Stdlib.op_exclamation dir.

src/lib_shell/mempool_peer_worker.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Validating batches of operations with some peer-based
 * compartimentatilsation. *)

type limits = {
  max_promises_per_request : int;
  worker_limits : Worker_types.limits;
}

module type T = sig
  module Mempool_worker : Mempool_worker.T

  type t

  type input = Operation_hash.t list

  val create : limits -> P2p_peer.Id.t -> Mempool_worker.t -> t tzresult Lwt.t

  val shutdown : t -> input Lwt.t

  val validate : t -> input -> unit tzresult Lwt.t
end

module type STATIC = sig
  val max_pending_requests : int
end

module Make (Static : STATIC) (Mempool_worker : Mempool_worker.T) :
  T with module Mempool_worker = Mempool_worker = struct
  (* 0. Prelude: set up base modules and types *)
  (* See interface file for info if needed. *)

  module Proto = Mempool_worker.Proto
  module Mempool_worker = Mempool_worker

  type input = Operation_hash.t list

  type result =
    | Cannot_download of error list
    | Cannot_parse of error list
    | Cannot_validate of error list
    | Mempool_result of Mempool_worker.result

  type output = result Operation_hash.Map.t

  let pp_input ppf input =
    Format.fprintf
      ppf
      "@[<v 0>%a@]"
      (Format.pp_print_list Operation_hash.pp)
      input

  let result_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Cannot download"
          (obj1 (req "download_errors" (list Error_monad.error_encoding)))
          (function Cannot_download errs -> Some errs | _ -> None)
          (fun errs -> Cannot_download errs);
        case
          (Tag 1)
          ~title:"Cannot parse"
          (obj1 (req "parse_errors" (list Error_monad.error_encoding)))
          (function Cannot_parse errs -> Some errs | _ -> None)
          (fun errs -> Cannot_parse errs);
        case
          (Tag 2)
          ~title:"Cannot validate"
          (obj1 (req "validation_errors" (list Error_monad.error_encoding)))
          (function Cannot_validate errs -> Some errs | _ -> None)
          (fun errs -> Cannot_validate errs);
        case
          (Tag 3)
          ~title:"Validation result"
          (obj1 (req "validation_result" Mempool_worker.result_encoding))
          (function Mempool_result result -> Some result | _ -> None)
          (fun result -> Mempool_result result) ]

  module Log = Internal_event.Legacy_logging.Make (struct
    let name = "node.mempool.peer_worker"
  end)

  (* 1. Core: the carefully scheduled work performed by the worker *)

  module Work : sig
    val process_batch : Mempool_worker.t -> int -> input -> output Lwt.t
  end = struct
    type t = {
      pool : unit Lwt_pool.t;
      received : Operation_hash.t Queue.t;
      downloading : (Operation_hash.t * Operation.t tzresult Lwt.t) Queue.t;
      applying :
        (Mempool_worker.operation * Mempool_worker.result tzresult Lwt.t)
        Queue.t;
      mutable results : result Operation_hash.Map.t;
    }

    (* Primitives *)

    let is_empty t =
      Queue.is_empty t.received
      && Queue.is_empty t.downloading
      && Queue.is_empty t.applying

    let has_resolved t =
      match Lwt.state t with
      | Lwt.Return _ | Lwt.Fail _ ->
          true
      | Lwt.Sleep ->
          false

    let head_is_resolved q =
      (not (Queue.is_empty q)) && has_resolved (snd (Queue.peek q))

    let select t =
      (* A `select`-like function to wait on any of the pipeline's buffers'
       * heads to resolve *)
      assert (not (Queue.is_empty t.downloading && Queue.is_empty t.applying)) ;
      let first_task_or_never q =
        if Queue.is_empty q then Lwt_utils.never_ending ()
        else snd (Queue.peek q) >>= fun _ -> Lwt.return_unit
      in
      Lwt.choose
        [first_task_or_never t.downloading; first_task_or_never t.applying]

    let record_result pipeline op_hash result =
      pipeline.results <-
        Operation_hash.Map.add op_hash result pipeline.results

    let q_of_list l =
      let q = Queue.create () in
      List.iter (fun x -> Queue.add x q) l ;
      q

    let create pool_size op_hashes =
      {
        pool = Lwt_pool.create pool_size Lwt.return;
        received = q_of_list op_hashes;
        downloading = Queue.create ();
        applying = Queue.create ();
        results = Operation_hash.Map.empty;
      }

    let cancel pipeline =
      let cancel_snd (_, p) = Lwt.cancel p in
      Queue.iter cancel_snd pipeline.downloading ;
      Queue.iter cancel_snd pipeline.applying

    (* Exported interactions *)

    let step mempool_worker pipeline =
      (* Going through each buffer one by one. *)
      (* op_hash: Opertation_hash.t
       * op: Operation.t
       * mop: Mempool_worker.operation *)
      if head_is_resolved pipeline.applying then (
        let (op, p) = Queue.pop pipeline.applying in
        p
        >>= function
        | Error errs ->
            record_result pipeline op.hash (Cannot_validate errs) ;
            Lwt.return_unit
        | Ok mempool_result ->
            record_result pipeline op.hash (Mempool_result mempool_result) ;
            Lwt.return_unit )
      else if head_is_resolved pipeline.downloading then
        let (op_hash, p) = Queue.pop pipeline.downloading in
        p
        >>= function
        | Error errs ->
            record_result pipeline op_hash (Cannot_download errs) ;
            Lwt.return_unit
        | Ok op -> (
          match Mempool_worker.parse op with
          | Error errs ->
              record_result pipeline op_hash (Cannot_parse errs) ;
              Lwt.return_unit
          | Ok mop ->
              let p =
                Lwt_pool.use pipeline.pool (fun () ->
                    Mempool_worker.validate mempool_worker mop)
              in
              Queue.push (mop, p) pipeline.applying ;
              Lwt.return_unit )
      else if not (Queue.is_empty pipeline.received) then (
        let op_hash = Queue.pop pipeline.received in
        (* TODO[?] should we specify the current peer for fetching? *)
        let chain_db = Mempool_worker.chain_db mempool_worker in
        let p =
          Lwt_pool.use pipeline.pool (fun () ->
              Distributed_db.Operation.fetch chain_db op_hash ())
        in
        Queue.push (op_hash, p) pipeline.downloading ;
        Lwt.return_unit )
      else
        (* There are some pending operations, we need to wait on them *)
        select pipeline

    let process_batch mempool_worker pool_size input =
      let pipeline = create pool_size input in
      let rec loop () =
        if is_empty pipeline then Lwt.return pipeline.results
        else step mempool_worker pipeline >>= fun () -> loop ()
      in
      let work = loop () in
      Lwt.on_cancel work (fun () -> cancel pipeline) ;
      work
  end

  (* 2. Boilerplate: the set up for the worker architecture *)

  module Name = struct
    type t = P2p_peer.Id.t

    let encoding = P2p_peer.Id.encoding

    let base =
      let proto_hash =
        let (_ : string) = Format.flush_str_formatter () in
        Format.fprintf Format.str_formatter "%a" Protocol_hash.pp Proto.hash ;
        Format.flush_str_formatter ()
      in
      ["node"; "mempool"; "peer_worker"; proto_hash]

    let pp = P2p_peer.Id.pp
  end

  module Request = struct
    type 'a t = Batch : input -> output t

    type view = input

    let view : type a. a t -> view = fun (Batch os) -> os

    let encoding =
      let open Data_encoding in
      list Operation_hash.encoding

    let pp ppf = function
      | [] ->
          Format.fprintf ppf "@[<v 2>Request:@, Empty List of Operations@]"
      | os ->
          Format.fprintf
            ppf
            "@[<v 2>Request:@,%a@]"
            (Format.pp_print_list Operation_hash.pp)
            os
  end

  module Event = struct
    type t =
      | Start of input
      | End_ok of (Request.view * Worker_types.request_status * output)
      | End_error of (Request.view * Worker_types.request_status * error list)

    let level req =
      let open Internal_event in
      match req with
      | Start _ ->
          Info
      | End_ok _ ->
          Info
      | End_error _ ->
          Error

    let encoding =
      let open Data_encoding in
      union
        [ case
            (Tag 0)
            ~title:"Start"
            (obj1 (req "input" (list Operation_hash.encoding)))
            (function Start input -> Some input | _ -> None)
            (fun input -> Start input);
          case
            (Tag 1)
            ~title:"End_ok"
            (obj3
               (req "request" Request.encoding)
               (req "status" Worker_types.request_status_encoding)
               (req "output" (Operation_hash.Map.encoding result_encoding)))
            (function
              | End_ok (view, status, result) ->
                  Some (view, status, result)
              | _ ->
                  None)
            (fun (view, status, result) -> End_ok (view, status, result));
          case
            (Tag 2)
            ~title:"End_error"
            (obj3
               (req "failed_request" Request.encoding)
               (req "status" Worker_types.request_status_encoding)
               (req "error" RPC_error.encoding))
            (function
              | End_error (view, status, errs) ->
                  Some (view, status, errs)
              | _ ->
                  None)
            (fun (view, status, errs) -> End_error (view, status, errs)) ]

    let pp ppf = function
      | Start input ->
          Format.fprintf ppf "@[<v 0>Starting: %a@]" pp_input input
      | End_ok (view, _, _) ->
          Format.fprintf ppf "@[<v 0>Finished: %a@]" Request.pp view
      | End_error (view, _, errs) ->
          Format.fprintf
            ppf
            "@[<v 0>Errors: %a, Operations: %a@]"
            (Format.pp_print_list Error_monad.pp)
            errs
            Request.pp
            view
  end

  module Types = struct
    type parameters = Mempool_worker.t * int

    type state = {mempool_worker : Mempool_worker.t; pool_size : int}

    type view = unit

    let view _ _ = ()

    let encoding = Data_encoding.unit

    let pp _ _ = ()
  end

  module Logger = Worker_logger.Make (Event) (Request)
  module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)

  type t = Worker.bounded Worker.queue Worker.t

  let table =
    let open Worker in
    create_table (Bounded {size = Static.max_pending_requests})

  (* 3. Workers' work: setting workers' callbacks to perform core work *)

  module Handlers = struct
    type self = t

    let on_launch _ _ (mempool_worker, pool_size) =
      return Types.{mempool_worker; pool_size}

    let on_request : type a. self -> a Request.t -> a tzresult Lwt.t =
     fun t (Request.Batch os) ->
      let st = Worker.state t in
      Worker.record_event t (Event.Start os) ;
      Work.process_batch st.mempool_worker st.pool_size os
      >>= fun r -> return r

    let on_no_request _ = return_unit

    let on_close _ = Lwt.return_unit

    let on_error t view st errs =
      Worker.record_event t (Event.End_error (view, st, errs)) ;
      Lwt.return_error errs

    let on_completion :
        type a.
        self -> a Request.t -> a -> Worker_types.request_status -> unit Lwt.t =
     fun t req output st ->
      match req with
      | Request.Batch _ ->
          Worker.record_event t (Event.End_ok (Request.view req, st, output)) ;
          Lwt.return_unit
  end

  (* 4. Public interface: exporting a thin wrapper around workers and work. *)
  (* See interface file for documentation *)

  let validate t os =
    Worker.Queue.push_request_and_wait t (Request.Batch os)
    >>=? fun (_ : output) -> return_unit

  let create limits peer_id mempool_worker =
    Worker.launch
      table
      limits.worker_limits
      peer_id
      (mempool_worker, limits.max_promises_per_request)
      (module Handlers)

  let shutdown w =
    let recycled = Operation_hash.Set.empty in
    let recycled =
      List.fold_left
        (fun recycled (_, input) ->
          List.fold_left
            (fun recycled op_h -> Operation_hash.Set.add op_h recycled)
            recycled
            input)
        recycled
        (Worker.Queue.pending_requests w)
    in
    let recycled =
      match Worker.current_request w with
      | Some (_, _, input) ->
          List.fold_left
            (fun recycled op_h -> Operation_hash.Set.add op_h recycled)
            recycled
            input
      | None ->
          recycled
    in
    let input = Operation_hash.Set.elements recycled in
    Worker.shutdown w >>= fun () -> Lwt.return input
end
src/lib_shell/mempool_peer_worker.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  max_promises_per_request : Z;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module T.
  Record signature {Mempool_worker_Proto_P_block_header_data
    Mempool_worker_Proto_P_block_header
    Mempool_worker_Proto_P_block_header_metadata
    Mempool_worker_Proto_P_operation_data
    Mempool_worker_Proto_P_operation_receipt Mempool_worker_Proto_P_operation
    Mempool_worker_Proto_P_validation_state Mempool_worker_t
    Mempool_worker_operation Mempool_worker_result t : Type} := {
    Mempool_worker : Mempool_worker.T.signature Mempool_worker_Proto_P_block_header_data Mempool_worker_Proto_P_block_header Mempool_worker_Proto_P_block_header_metadata Mempool_worker_Proto_P_operation_data Mempool_worker_Proto_P_operation_receipt Mempool_worker_Proto_P_operation Mempool_worker_Proto_P_validation_state Mempool_worker_t Mempool_worker_operation Mempool_worker_result;
    t := t;
    input := list Tezos_base__TzPervasives.Operation_hash.t;
    create : limits ->
      Tezos_base__TzPervasives.P2p_peer.Id.t ->
        Mempool_worker.(Tezos_shell__Mempool_worker.T.t) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult t);
    shutdown : t -> Lwt.t input;
    validate : t -> input -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
  }.
  Arguments signature : clear implicits.
End T.

Module STATIC.
  Record signature := {
    max_pending_requests : Z;
  }.
End STATIC.

(* ❌ Functors are not handled. *)
functor

src/lib_shell/mempool_worker.ml 1 error
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type limits = {worker_limits : Worker_types.limits}

module type T = sig
  module Proto : Registered_protocol.T

  type t

  type operation = private {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type result =
    | Applied of Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Not_in_branch

  val result_encoding : result Data_encoding.t

  (** Creates/tear-down a new mempool validator context. *)
  val create : limits -> Distributed_db.chain_db -> t tzresult Lwt.t

  val shutdown : t -> unit Lwt.t

  (** parse a new operation and add it to the mempool context *)
  val parse : Operation.t -> operation tzresult

  (** validate a new operation and add it to the mempool context *)
  val validate : t -> operation -> result tzresult Lwt.t

  val chain_db : t -> Distributed_db.chain_db

  val rpc_directory : t RPC_directory.t
end

module type STATIC = sig
  val max_size_parsed_cache : int
end

module Make (Static : STATIC) (Proto : Registered_protocol.T) :
  T with module Proto = Proto = struct
  module Proto = Proto

  (* used for rpc *)
  module Proto_services = Block_services.Make (Proto) (Proto)

  type operation = {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type result =
    | Applied of Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Not_in_branch

  let result_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Applied"
          (obj1 (req "receipt" Proto.operation_receipt_encoding))
          (function Applied receipt -> Some receipt | _ -> None)
          (fun receipt -> Applied receipt);
        case
          (Tag 1)
          ~title:"Branch Delayed"
          (obj1 (req "error" (list Error_monad.error_encoding)))
          (function Branch_delayed error -> Some error | _ -> None)
          (fun error -> Branch_delayed error);
        case
          (Tag 2)
          ~title:"Branch Refused"
          (obj1 (req "error" (list Error_monad.error_encoding)))
          (function Branch_refused error -> Some error | _ -> None)
          (fun error -> Branch_refused error);
        case
          (Tag 3)
          ~title:"Refused"
          (obj1 (req "error" (list Error_monad.error_encoding)))
          (function Refused error -> Some error | _ -> None)
          (fun error -> Refused error);
        case
          (Tag 4)
          ~title:"Duplicate"
          empty
          (function Duplicate -> Some () | _ -> None)
          (fun () -> Duplicate);
        case
          (Tag 5)
          ~title:"Not_in_branch"
          empty
          (function Not_in_branch -> Some () | _ -> None)
          (fun () -> Not_in_branch) ]

  let pp_result ppf = function
    | Applied _ ->
        Format.pp_print_string ppf "applied"
    | Branch_delayed _ ->
        Format.pp_print_string ppf "branch delayed"
    | Branch_refused _ ->
        Format.pp_print_string ppf "branch refused"
    | Refused _ ->
        Format.pp_print_string ppf "refused"
    | Duplicate ->
        Format.pp_print_string ppf "duplicate"
    | Not_in_branch ->
        Format.pp_print_string ppf "not in branch"

  let operation_encoding =
    let open Data_encoding in
    conv
      (fun {hash; raw; protocol_data} -> (hash, raw, protocol_data))
      (fun (hash, raw, protocol_data) -> {hash; raw; protocol_data})
      (obj3
         (req "hash" Operation_hash.encoding)
         (req "raw" Operation.encoding)
         (req "protocol_data" Proto.operation_data_encoding))

  module Log = Internal_event.Legacy_logging.Make (struct
    let name = "node.mempool_validator"
  end)

  module Name = struct
    type t = Chain_id.t

    let encoding = Chain_id.encoding

    let base =
      let proto_hash =
        let (_ : string) = Format.flush_str_formatter () in
        Format.fprintf Format.str_formatter "%a" Protocol_hash.pp Proto.hash ;
        Format.flush_str_formatter ()
      in
      ["node"; "mempool"; "worker"; proto_hash]

    let pp = Chain_id.pp_short
  end

  module Request = struct
    type 'a t = Validate : operation -> result t [@@ocaml.unboxed]

    type view = View : _ t -> view

    let view req = View req

    let encoding =
      let open Data_encoding in
      conv
        (fun (View (Validate op)) -> op)
        (fun op -> View (Validate op))
        operation_encoding

    let pp ppf (View (Validate {hash; _})) =
      Format.fprintf ppf "Validating new operation %a" Operation_hash.pp hash
  end

  module Event = struct
    type t =
      | Request of
          (Request.view * Worker_types.request_status * error list option)
      | Debug of string

    let level req =
      match req with
      | Debug _ ->
          Internal_event.Debug
      | Request _ ->
          Internal_event.Info

    let encoding =
      let open Data_encoding in
      union
        [ case
            (Tag 0)
            ~title:"Debug"
            (obj1 (req "message" string))
            (function Debug msg -> Some msg | _ -> None)
            (fun msg -> Debug msg);
          case
            (Tag 1)
            ~title:"Request"
            (obj2
               (req "request" Request.encoding)
               (req "status" Worker_types.request_status_encoding))
            (function Request (req, t, None) -> Some (req, t) | _ -> None)
            (fun (req, t) -> Request (req, t, None));
          case
            (Tag 2)
            ~title:"Failed request"
            (obj3
               (req "error" RPC_error.encoding)
               (req "failed_request" Request.encoding)
               (req "status" Worker_types.request_status_encoding))
            (function
              | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
            (fun (errs, req, t) -> Request (req, t, Some errs)) ]

    let pp ppf = function
      | Debug msg ->
          Format.fprintf ppf "%s" msg
      | Request (view, {pushed; treated; completed}, None) ->
          Format.fprintf
            ppf
            "@[<v 0>%a@, %a@]"
            Request.pp
            view
            Worker_types.pp_status
            {pushed; treated; completed}
      | Request (view, {pushed; treated; completed}, Some errors) ->
          Format.fprintf
            ppf
            "@[<v 0>%a@, %a, %a@]"
            Request.pp
            view
            Worker_types.pp_status
            {pushed; treated; completed}
            (Format.pp_print_list Error_monad.pp)
            errors
  end

  (* parsed operations' cache. used for memoization *)
  module ParsedCache = struct
    type t = {
      table : operation tzresult Operation_hash.Table.t;
      ring : Operation_hash.t Ring.t;
    }

    let create () : t =
      {
        table = Operation_hash.Table.create Static.max_size_parsed_cache;
        ring = Ring.create Static.max_size_parsed_cache;
      }

    let add t raw_op parsed_op =
      let hash = Operation.hash raw_op in
      Option.iter
        ~f:(Operation_hash.Table.remove t.table)
        (Ring.add_and_return_erased t.ring hash) ;
      Operation_hash.Table.replace t.table hash parsed_op

    let find_opt t raw_op =
      let hash = Operation.hash raw_op in
      Operation_hash.Table.find_opt t.table hash

    let rem t hash =
      (* NOTE: hashes are not removed from the ring. As a result, the cache size
       * bound can be lowered. This is a non-issue because it's only a cache. *)
      Operation_hash.Table.remove t.table hash
  end

  (* validated operations' cache. used for memoization *)
  module ValidatedCache = struct
    type t = (result * Operation.t) Operation_hash.Table.t

    let encoding =
      let open Data_encoding in
      Operation_hash.Table.encoding (tup2 result_encoding Operation.encoding)

    let pp break ppf table =
      let open Format in
      Operation_hash.Table.iter
        (fun h (r, _) ->
          fprintf ppf "Operation %a: %a" Operation_hash.pp_short h pp_result r ;
          break ppf)
        table

    let create () = Operation_hash.Table.create 1000

    let add t parsed_op result =
      Operation_hash.Table.replace t parsed_op.hash result

    let find_opt t parsed_op = Operation_hash.Table.find_opt t parsed_op.hash

    let iter f t = Operation_hash.Table.iter f t

    let to_mempool t =
      let empty =
        {
          Proto_services.Mempool.applied = [];
          refused = Operation_hash.Map.empty;
          branch_refused = Operation_hash.Map.empty;
          branch_delayed = Operation_hash.Map.empty;
          unprocessed = Operation_hash.Map.empty;
        }
      in
      let map_op op =
        let protocol_data =
          Data_encoding.Binary.of_bytes_exn
            Proto.operation_data_encoding
            op.Operation.proto
        in
        {Proto.shell = op.shell; protocol_data}
      in
      Operation_hash.Table.fold
        (fun hash (result, raw_op) acc ->
          let proto_op = map_op raw_op in
          match result with
          | Applied _ ->
              {
                acc with
                Proto_services.Mempool.applied =
                  (hash, proto_op) :: acc.Proto_services.Mempool.applied;
              }
          | Branch_refused err ->
              {
                acc with
                Proto_services.Mempool.branch_refused =
                  Operation_hash.Map.add
                    hash
                    (proto_op, err)
                    acc.Proto_services.Mempool.branch_refused;
              }
          | Branch_delayed err ->
              {
                acc with
                Proto_services.Mempool.branch_delayed =
                  Operation_hash.Map.add
                    hash
                    (proto_op, err)
                    acc.Proto_services.Mempool.branch_delayed;
              }
          | Refused err ->
              {
                acc with
                Proto_services.Mempool.refused =
                  Operation_hash.Map.add
                    hash
                    (proto_op, err)
                    acc.Proto_services.Mempool.refused;
              }
          | _ ->
              acc)
        t
        empty

    let clear t = Operation_hash.Table.clear t
  end

  module Types = struct
    type parameters = {
      limits : limits;
      chain_db : Distributed_db.chain_db;
      validation_state : Proto.validation_state;
    }

    (* internal worker state *)
    type state = {
      (* state of the validator. this is updated at each apply_operation *)
      mutable validation_state : Proto.validation_state;
      cache : ValidatedCache.t;
      (* live blocks and operations, initialized at worker launch *)
      live_blocks : Block_hash.Set.t;
      live_operations : Operation_hash.Set.t;
      operation_stream :
        (result * Operation.shell_header * Proto.operation_data)
        Lwt_watcher.input;
      parameters : parameters;
    }

    type view = {cache : ValidatedCache.t}

    let view (state : state) _ : view = {cache = state.cache}

    let encoding =
      let open Data_encoding in
      conv
        (fun {cache} -> cache)
        (fun cache -> {cache})
        ValidatedCache.encoding

    let pp ppf {cache} =
      ValidatedCache.pp
        (fun ppf ->
          Format.pp_print_string ppf ";" ;
          Format.pp_print_space ppf ())
        ppf
        cache
  end

  module Logger = Worker_logger.Make (Event) (Request)
  module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
  open Types

  type t = Worker.infinite Worker.queue Worker.t

  let parsed_cache = ParsedCache.create ()

  let shutdown w = Worker.shutdown w

  (*** prevalidation ****)
  open Validation_errors

  let create ?protocol_data ~predecessor ~timestamp () =
    let { Block_header.shell =
            { fitness = predecessor_fitness;
              timestamp = predecessor_timestamp;
              level = predecessor_level;
              _ };
          _ } =
      State.Block.header predecessor
    in
    State.Block.context predecessor
    >>=? fun predecessor_context ->
    let predecessor_hash = State.Block.hash predecessor in
    ( match protocol_data with
    | None ->
        return_none
    | Some protocol_data -> (
      match
        Data_encoding.Binary.of_bytes
          Proto.block_header_data_encoding
          protocol_data
      with
      | None ->
          failwith "Invalid block header"
      | Some protocol_data ->
          return_some protocol_data ) )
    >>=? fun protocol_data ->
    let predecessor_context =
      Shell_context.wrap_disk_context predecessor_context
    in
    Proto.begin_construction
      ~chain_id:(State.Block.chain_id predecessor)
      ~predecessor_context
      ~predecessor_timestamp
      ~predecessor_fitness
      ~predecessor_level
      ~predecessor:predecessor_hash
      ~timestamp
      ?protocol_data
      ()

  let apply_operation state op =
    if Operation_hash.Set.mem op.hash state.live_operations then
      Lwt.return (None, Duplicate)
    else if
      not (Block_hash.Set.mem op.raw.Operation.shell.branch state.live_blocks)
    then Lwt.return (None, Not_in_branch)
    else
      Proto.apply_operation
        state.validation_state
        {shell = op.raw.shell; protocol_data = op.protocol_data}
      >|= function
      | Ok (validation_state, receipt) ->
          (Some validation_state, Applied receipt)
      | Error errors -> (
          ( None,
            match classify_errors errors with
            | `Branch ->
                Branch_refused errors
            | `Permanent ->
                Refused errors
            | `Temporary ->
                Branch_delayed errors ) )

  (*** end prevalidation ***)

  let parse_helper raw_op =
    let hash = Operation.hash raw_op in
    let size = Data_encoding.Binary.length Operation.encoding raw_op in
    if size > Proto.max_operation_data_length then
      error (Oversized_operation {size; max = Proto.max_operation_data_length})
    else
      match
        Data_encoding.Binary.of_bytes
          Proto.operation_data_encoding
          raw_op.Operation.proto
      with
      | None ->
          error Parse_error
      | Some protocol_data ->
          ok {hash; raw = raw_op; protocol_data}

  (* this function update the internal state of the worker *)
  let validate_helper w parsed_op =
    let state = Worker.state w in
    apply_operation state parsed_op
    >>= fun (validation_state, result) ->
    ( match validation_state with
    | Some validation_state ->
        state.validation_state <- validation_state
    | None ->
        () ) ;
    Lwt.return result

  let notify_helper w result {Operation.shell; proto} =
    let state = Worker.state w in
    (* this function is called by on_validate where we take care of the error *)
    let protocol_data =
      Data_encoding.Binary.of_bytes_exn Proto.operation_data_encoding proto
    in
    Lwt_watcher.notify state.operation_stream (result, shell, protocol_data)

  (* memoization is done only at on_* level *)
  let on_validate w parsed_op =
    let state = Worker.state w in
    match ValidatedCache.find_opt state.cache parsed_op with
    | None | Some (Branch_delayed _, _) ->
        validate_helper w parsed_op
        >>= fun result ->
        ValidatedCache.add state.cache parsed_op (result, parsed_op.raw) ;
        (* operations are notified only the first time *)
        notify_helper w result parsed_op.raw ;
        Lwt.return result
    | Some (result, _) ->
        Lwt.return result

  (* worker's handlers *)
  let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
   fun w request ->
    match request with
    | Request.Validate parsed_op ->
        on_validate w parsed_op >>= return

  let on_launch (_ : t) (_ : Name.t)
      ({chain_db; validation_state; _} as parameters) =
    let chain_state = Distributed_db.chain_state chain_db in
    Chain.data chain_state
    >>= fun {current_mempool = _mempool; live_blocks; live_operations; _} ->
    (* remove all operations that are already included *)
    Operation_hash.Set.iter
      (fun hash -> ParsedCache.rem parsed_cache hash)
      live_operations ;
    return
      {
        validation_state;
        cache = ValidatedCache.create ();
        live_blocks;
        live_operations;
        operation_stream = Lwt_watcher.create_input ();
        parameters;
      }

  let on_close w =
    let state = Worker.state w in
    Lwt_watcher.shutdown_input state.operation_stream ;
    ValidatedCache.iter
      (fun hash _ ->
        Distributed_db.Operation.clear_or_cancel state.parameters.chain_db hash)
      state.cache ;
    ValidatedCache.clear state.cache ;
    Lwt.return_unit

  let on_error w r st errs =
    Worker.record_event w (Event.Request (r, st, Some errs)) ;
    Lwt.return_error errs

  let on_completion w r _ st =
    Worker.record_event w (Event.Request (Request.view r, st, None)) ;
    Lwt.return_unit

  let table = Worker.create_table Queue

  let create limits chain_db =
    let chain_state = Distributed_db.chain_state chain_db in
    let chain_id = State.Chain.id chain_state in
    let module Handlers = struct
      type self = t

      let on_launch = on_launch

      let on_close = on_close

      let on_error = on_error

      let on_completion = on_completion

      let on_no_request _ = return_unit

      let on_request = on_request
    end in
    Chain.data chain_state
    >>= fun {current_head = predecessor; _} ->
    let timestamp = Time.System.to_protocol (Systime_os.now ()) in
    create ~predecessor ~timestamp ()
    >>=? fun validation_state ->
    Worker.launch
      table
      limits.worker_limits
      chain_id
      {limits; chain_db; validation_state}
      (module Handlers)

  (* Exporting functions *)

  let validate t parsed_op =
    Worker.Queue.push_request_and_wait t (Request.Validate parsed_op)

  (* atomic parse + memoization *)
  let parse raw_op =
    match ParsedCache.find_opt parsed_cache raw_op with
    | None ->
        let parsed_op = parse_helper raw_op in
        ParsedCache.add parsed_cache raw_op parsed_op ;
        parsed_op
    | Some parsed_op ->
        parsed_op

  let chain_db t =
    let state = Worker.state t in
    state.parameters.chain_db

  let pending_rpc_directory : t RPC_directory.t =
    RPC_directory.gen_register
      RPC_directory.empty
      (Proto_services.S.Mempool.pending_operations RPC_path.open_root)
      (fun w () () ->
        let state = Worker.state w in
        RPC_answer.return (ValidatedCache.to_mempool state.cache))

  let monitor_rpc_directory : t RPC_directory.t =
    RPC_directory.gen_register
      RPC_directory.empty
      (Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
      (fun w params () ->
        let state = Worker.state w in
        let filter_result = function
          | Applied _ ->
              params#applied
          | Refused _ ->
              params#refused
          | Branch_refused _ ->
              params#branch_refused
          | Branch_delayed _ ->
              params#branch_delayed
          | _ ->
              false
        in
        let (op_stream, stopper) =
          Lwt_watcher.create_stream state.operation_stream
        in
        let shutdown () = Lwt_watcher.shutdown stopper in
        let next () =
          Lwt_stream.get op_stream
          >>= function
          | Some (kind, shell, protocol_data) when filter_result kind ->
              Lwt.return_some [{Proto.shell; protocol_data}]
          | _ ->
              Lwt.return_none
        in
        RPC_answer.return_stream {next; shutdown})

  (* /mempool/<chain_id>/pending
     /mempool/<chain_id>/monitor *)
  let rpc_directory =
    RPC_directory.merge pending_rpc_directory monitor_rpc_directory
end
src/lib_shell/mempool_worker.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module T.
  Record signature {Proto_P_block_header_data Proto_P_block_header
    Proto_P_block_header_metadata Proto_P_operation_data
    Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state t
    operation result : Type} := {
    Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
    t := t;
    operation := operation;
    result := result;
    result_encoding : Tezos_base__TzPervasives.Data_encoding.t result;
    create : limits ->
      Tezos_shell.Distributed_db.chain_db ->
        Lwt.t (Tezos_base__TzPervasives.tzresult t);
    shutdown : t -> Lwt.t unit;
    parse : Tezos_base__TzPervasives.Operation.t ->
      Tezos_base__TzPervasives.tzresult operation;
    validate : t ->
      operation -> Lwt.t (Tezos_base__TzPervasives.tzresult result);
    chain_db : t -> Tezos_shell.Distributed_db.chain_db;
    rpc_directory : Tezos_base__TzPervasives.RPC_directory.t t;
  }.
  Arguments signature : clear implicits.
End T.

Module STATIC.
  Record signature := {
    max_size_parsed_cache : Z;
  }.
End STATIC.

(* ❌ Functors are not handled. *)
functor

src/lib_shell/monitor_directory.ml 50 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let build_rpc_directory validator mainchain_validator =
  let distributed_db = Validator.distributed_db validator in
  let state = Distributed_db.state distributed_db in
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let gen_register0 s f =
    dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
  in
  let gen_register1 s f =
    dir := RPC_directory.gen_register !dir s (fun ((), a) p q -> f a p q)
  in
  gen_register0 Monitor_services.S.bootstrapped (fun () () ->
      let (block_stream, stopper) =
        Chain_validator.new_head_watcher mainchain_validator
      in
      let first_run = ref true in
      let next () =
        if !first_run then (
          first_run := false ;
          let chain_state = Chain_validator.chain_state mainchain_validator in
          Chain.head chain_state
          >>= fun head ->
          let head_hash = State.Block.hash head in
          let head_header = State.Block.header head in
          Lwt.return_some (head_hash, head_header.shell.timestamp) )
        else
          Lwt.pick
            [ Lwt_stream.get block_stream
              >|= Option.map ~f:(fun b ->
                      ( State.Block.hash b,
                        (State.Block.header b).shell.timestamp ));
              ( Chain_validator.bootstrapped mainchain_validator
              >|= fun () -> None ) ]
      in
      let shutdown () = Lwt_watcher.shutdown stopper in
      RPC_answer.return_stream {next; shutdown}) ;
  gen_register0 Monitor_services.S.valid_blocks (fun q () ->
      let (block_stream, stopper) = State.watcher state in
      let shutdown () = Lwt_watcher.shutdown stopper in
      let in_chains block =
        match q#chains with
        | [] ->
            Lwt.return_true
        | chains ->
            let chain_id = State.Block.chain_id block in
            Lwt_list.filter_map_p
              (Chain_directory.get_chain_id_opt state)
              chains
            >>= fun chains ->
            Lwt.return (List.exists (Chain_id.equal chain_id) chains)
      in
      let in_protocols block =
        match q#protocols with
        | [] ->
            Lwt.return_true
        | protocols -> (
            State.Block.predecessor block
            >>= function
            | None ->
                Lwt.return_false (* won't happen *)
            | Some pred ->
                State.Block.context_exn pred
                >>= fun context ->
                Context.get_protocol context
                >>= fun protocol ->
                Lwt.return
                  (List.exists (Protocol_hash.equal protocol) protocols) )
      in
      let in_next_protocols block =
        match q#next_protocols with
        | [] ->
            Lwt.return_true
        | protocols ->
            State.Block.context_exn block
            >>= fun context ->
            Context.get_protocol context
            >>= fun next_protocol ->
            Lwt.return
              (List.exists (Protocol_hash.equal next_protocol) protocols)
      in
      let stream =
        Lwt_stream.filter_map_s
          (fun block ->
            in_chains block
            >>= fun in_chains ->
            in_next_protocols block
            >>= fun in_next_protocols ->
            in_protocols block
            >>= fun in_protocols ->
            if in_chains && in_protocols && in_next_protocols then
              Lwt.return_some
                ( (State.Block.chain_id block, State.Block.hash block),
                  State.Block.header block )
            else Lwt.return_none)
          block_stream
      in
      let next () = Lwt_stream.get stream in
      RPC_answer.return_stream {next; shutdown}) ;
  gen_register1 Monitor_services.S.heads (fun chain q () ->
      (* TODO: when `chain = `Test`, should we reset then stream when
       the `testnet` change, or dias we currently do ?? *)
      Chain_directory.get_chain state chain
      >>= fun chain ->
      match Validator.get validator (State.Chain.id chain) with
      | Error _ ->
          Lwt.fail Not_found
      | Ok chain_validator ->
          let (block_stream, stopper) =
            Chain_validator.new_head_watcher chain_validator
          in
          Chain.head chain
          >>= fun head ->
          let shutdown () = Lwt_watcher.shutdown stopper in
          let in_next_protocols block =
            match q#next_protocols with
            | [] ->
                Lwt.return_true
            | protocols ->
                State.Block.context_exn block
                >>= fun context ->
                Context.get_protocol context
                >>= fun next_protocol ->
                Lwt.return
                  (List.exists (Protocol_hash.equal next_protocol) protocols)
          in
          let stream =
            Lwt_stream.filter_map_s
              (fun block ->
                in_next_protocols block
                >>= fun in_next_protocols ->
                if in_next_protocols then
                  Lwt.return_some
                    (State.Block.hash block, State.Block.header block)
                else Lwt.return_none)
              block_stream
          in
          in_next_protocols head
          >>= fun first_block_is_among_next_protocols ->
          let first_call =
            (* Skip the first block if this is false *)
            ref first_block_is_among_next_protocols
          in
          let next () =
            if !first_call then (
              first_call := false ;
              Lwt.return_some (State.Block.hash head, State.Block.header head)
              )
            else Lwt_stream.get stream
          in
          RPC_answer.return_stream {next; shutdown}) ;
  gen_register0 Monitor_services.S.protocols (fun () () ->
      let (stream, stopper) = State.Protocol.watcher state in
      let shutdown () = Lwt_watcher.shutdown stopper in
      let next () = Lwt_stream.get stream in
      RPC_answer.return_stream {next; shutdown}) ;
  gen_register0 Monitor_services.S.commit_hash (fun () () ->
      RPC_answer.return Tezos_version.Current_git_info.commit_hash) ;
  gen_register0 Monitor_services.S.active_chains (fun () () ->
      let (stream, stopper) = Validator.chains_watcher validator in
      let shutdown () = Lwt_watcher.shutdown stopper in
      let first_call =
        (* Only notify the newly created chains if this is false *)
        ref true
      in
      let next () =
        let convert (chain_id, b) =
          if not b then Lwt.return (Monitor_services.Stopping chain_id)
          else if Chain_id.equal (State.Chain.main state) chain_id then
            Lwt.return (Monitor_services.Active_main chain_id)
          else
            State.Chain.get_exn state chain_id
            >>= fun chain_state ->
            let {State.Chain.protocol; _} = State.Chain.genesis chain_state in
            let expiration_date =
              Option.unopt_exn
                (Invalid_argument
                   (Format.asprintf
                      "Monitor.active_chains: no expiration date for the \
                       chain %a"
                      Chain_id.pp
                      chain_id))
                (State.Chain.expiration chain_state)
            in
            Lwt.return
              (Monitor_services.Active_test
                 {chain = chain_id; protocol; expiration_date})
        in
        if !first_call then (
          first_call := false ;
          Lwt_list.map_p
            (fun c -> convert (c, true))
            (Validator.get_active_chains validator)
          >>= fun l -> Lwt.return_some l )
        else
          Lwt_stream.get stream
          >>= function
          | None ->
              Lwt.return_none
          | Some c ->
              convert c >>= fun status -> Lwt.return_some [status]
      in
      RPC_answer.return_stream {next; shutdown}) ;
  !dir
src/lib_shell/monitor_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition build_rpc_directory
  (validator : Tezos_shell.Validator.t)
  (mainchain_validator : Tezos_shell.Chain_validator.t)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let distributed_db := Validator.distributed_db validator in
  let state := Distributed_db.state distributed_db in
  let dir := Stdlib.ref RPC_directory.empty in
  let gen_register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t variant) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.gen_register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun p => fun q => f p q)) in
  let gen_register1 {A B C D : Type}
    (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
    A -> B -> C -> Lwt.t variant) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.gen_register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let '(tt, a) := function_parameter in
          fun p => fun q => f a p q)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register0 Monitor_services.S.bootstrapped
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let '(block_stream, stopper) :=
            Chain_validator.new_head_watcher mainchain_validator in
          let first_run := Stdlib.ref true in
          let next (function_parameter : unit)
            : Lwt.t
              (option
                (Tezos_base__TzPervasives.Block_hash.t *
                  Tezos_base.Time.Protocol.t)) :=
            let 'tt := function_parameter in
            if Stdlib.op_exclamation first_run then
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Stdlib.op_coloneq first_run false in
              let chain_state := Chain_validator.chain_state mainchain_validator
                in
              op_gtgteq (Chain.head chain_state)
                (fun head =>
                  let head_hash := State.Block.hash head in
                  let head_header := State.Block.header head in
                  Lwt.return_some (head_hash, (timestamp (shell head_header))))
            else
              Lwt.pick
                (cons
                  (op_gtpipeeq (Lwt_stream.get block_stream)
                    (Option.map
                      (fun b =>
                        ((State.Block.hash b),
                          (timestamp (shell (State.Block.header b)))))))
                  (cons
                    (op_gtpipeeq
                      (Chain_validator.bootstrapped mainchain_validator)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        None)) [])) in
          let shutdown (function_parameter : unit) : unit :=
            let 'tt := function_parameter in
            Lwt_watcher.shutdown stopper in
          RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register0 Monitor_services.S.valid_blocks
      (fun q =>
        fun function_parameter =>
          let 'tt := function_parameter in
          let '(block_stream, stopper) := State.watcher state in
          let shutdown (function_parameter : unit) : unit :=
            let 'tt := function_parameter in
            Lwt_watcher.shutdown stopper in
          let in_chains (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
            match
              (* ❌ Sending method message is not handled *)
              send with
            | [] => Lwt.return_true
            | chains =>
              let chain_id := State.Block.chain_id block in
              op_gtgteq
                (Lwt_list.filter_map_p (Chain_directory.get_chain_id_opt state)
                  chains)
                (fun chains =>
                  Lwt._return (List._exists (Chain_id.equal chain_id) chains))
            end in
          let in_protocols (block : Tezos_shell.State.Block.t) : Lwt.t bool :=
            match
              (* ❌ Sending method message is not handled *)
              send with
            | [] => Lwt.return_true
            | protocols =>
              op_gtgteq (State.Block.predecessor block)
                (fun function_parameter =>
                  match function_parameter with
                  | None => Lwt.return_false
                  | Some pred =>
                    op_gtgteq (State.Block.context_exn pred)
                      (fun context =>
                        op_gtgteq (Context.get_protocol context)
                          (fun protocol =>
                            Lwt._return
                              (List._exists (Protocol_hash.equal protocol)
                                protocols)))
                  end)
            end in
          let in_next_protocols (block : Tezos_shell.State.Block.t)
            : Lwt.t bool :=
            match
              (* ❌ Sending method message is not handled *)
              send with
            | [] => Lwt.return_true
            | protocols =>
              op_gtgteq (State.Block.context_exn block)
                (fun context =>
                  op_gtgteq (Context.get_protocol context)
                    (fun next_protocol =>
                      Lwt._return
                        (List._exists (Protocol_hash.equal next_protocol)
                          protocols)))
            end in
          let stream :=
            Lwt_stream.filter_map_s
              (fun block =>
                op_gtgteq (in_chains block)
                  (fun in_chains =>
                    op_gtgteq (in_next_protocols block)
                      (fun in_next_protocols =>
                        op_gtgteq (in_protocols block)
                          (fun in_protocols =>
                            if
                              andb in_chains
                                (andb in_protocols in_next_protocols) then
                              Lwt.return_some
                                (((State.Block.chain_id block),
                                  (State.Block.hash block)),
                                  (State.Block.header block))
                            else
                              Lwt.return_none)))) block_stream in
          let next (function_parameter : unit)
            : Lwt.t
              (option
                ((Tezos_base__TzPervasives.Chain_id.t *
                  Tezos_base__TzPervasives.Block_hash.t) *
                  Tezos_base__TzPervasives.Block_header.t)) :=
            let 'tt := function_parameter in
            Lwt_stream.get stream in
          RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register1 Monitor_services.S.heads
      (fun chain =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Chain_directory.get_chain state chain)
              (fun chain =>
                match Validator.get validator (State.Chain.id chain) with
                | Stdlib.Error _ => Lwt.fail OCaml.Not_found
                | Stdlib.Ok chain_validator =>
                  let '(block_stream, stopper) :=
                    Chain_validator.new_head_watcher chain_validator in
                  op_gtgteq (Chain.head chain)
                    (fun head =>
                      let shutdown (function_parameter : unit) : unit :=
                        let 'tt := function_parameter in
                        Lwt_watcher.shutdown stopper in
                      let in_next_protocols (block : Tezos_shell.State.Block.t)
                        : Lwt.t bool :=
                        match
                          (* ❌ Sending method message is not handled *)
                          send with
                        | [] => Lwt.return_true
                        | protocols =>
                          op_gtgteq (State.Block.context_exn block)
                            (fun context =>
                              op_gtgteq (Context.get_protocol context)
                                (fun next_protocol =>
                                  Lwt._return
                                    (List._exists
                                      (Protocol_hash.equal next_protocol)
                                      protocols)))
                        end in
                      let stream :=
                        Lwt_stream.filter_map_s
                          (fun block =>
                            op_gtgteq (in_next_protocols block)
                              (fun in_next_protocols =>
                                if in_next_protocols then
                                  Lwt.return_some
                                    ((State.Block.hash block),
                                      (State.Block.header block))
                                else
                                  Lwt.return_none)) block_stream in
                      op_gtgteq (in_next_protocols head)
                        (fun first_block_is_among_next_protocols =>
                          let first_call :=
                            Stdlib.ref first_block_is_among_next_protocols in
                          let next (function_parameter : unit)
                            : Lwt.t
                              (option
                                (Tezos_base__TzPervasives.Block_hash.t *
                                  Tezos_base__TzPervasives.Block_header.t)) :=
                            let 'tt := function_parameter in
                            if Stdlib.op_exclamation first_call then
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ := Stdlib.op_coloneq first_call false in
                              Lwt.return_some
                                ((State.Block.hash head),
                                  (State.Block.header head))
                            else
                              Lwt_stream.get stream in
                          RPC_answer.return_stream
                            {| next := next; shutdown := shutdown |}))
                end)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register0 Monitor_services.S.protocols
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let '(stream, stopper) := State.Protocol.watcher state in
          let shutdown (function_parameter : unit) : unit :=
            let 'tt := function_parameter in
            Lwt_watcher.shutdown stopper in
          let next (function_parameter : unit)
            : Lwt.t (option Tezos_base__TzPervasives.Protocol_hash.t) :=
            let 'tt := function_parameter in
            Lwt_stream.get stream in
          RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register0 Monitor_services.S.commit_hash
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          RPC_answer._return Tezos_version.Current_git_info.commit_hash) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register0 Monitor_services.S.active_chains
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let '(stream, stopper) := Validator.chains_watcher validator in
          let shutdown (function_parameter : unit) : unit :=
            let 'tt := function_parameter in
            Lwt_watcher.shutdown stopper in
          let first_call := Stdlib.ref true in
          let next (function_parameter : unit)
            : Lwt.t
              (option (list Tezos_shell_services.Monitor_services.chain_status)) :=
            let 'tt := function_parameter in
            let convert
              (function_parameter : Tezos_base__TzPervasives.Chain_id.t * bool)
              : Lwt.t Tezos_shell_services.Monitor_services.chain_status :=
              let '(chain_id, b) := function_parameter in
              if negb b then
                Lwt._return
                  (Tezos_shell_services.Monitor_services.Stopping chain_id)
              else
                if Chain_id.equal (State.Chain.main state) chain_id then
                  Lwt._return
                    (Tezos_shell_services.Monitor_services.Active_main chain_id)
                else
                  op_gtgteq (State.Chain.get_exn state chain_id)
                    (fun chain_state =>
                      let '{| State.Chain.protocol := protocol |} :=
                        State.Chain.genesis chain_state in
                      let expiration_date :=
                        Option.unopt_exn
                          (OCaml.Invalid_argument
                            (Format.asprintf
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Monitor.active_chains: no expiration date for the chain "
                                    % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Monitor.active_chains: no expiration date for the chain %a"
                                  % string) Chain_id.pp chain_id))
                          (State.Chain.expiration chain_state) in
                      Lwt._return
                        (Tezos_shell_services.Monitor_services.Active_test
                          {| chain := chain_id; protocol := protocol;
                            expiration_date := expiration_date |})) in
            if Stdlib.op_exclamation first_call then
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Stdlib.op_coloneq first_call false in
              op_gtgteq
                (Lwt_list.map_p (fun c => convert (c, true))
                  (Validator.get_active_chains validator))
                (fun l => Lwt.return_some l)
            else
              op_gtgteq (Lwt_stream.get stream)
                (fun function_parameter =>
                  match function_parameter with
                  | None => Lwt.return_none
                  | Some c =>
                    op_gtgteq (convert c)
                      (fun status => Lwt.return_some (cons status []))
                  end) in
          RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
  Stdlib.op_exclamation dir.

src/lib_shell/node.ml 82 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018-2019 Nomadic Labs, <contact@nomadic-labs.com>          *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

open Lwt.Infix
open Tezos_base

module Initialization_event = struct
  type t = {
    time_stamp : float;
    status : [`P2p_layer_disabled | `Bootstrapping | `P2p_maintain_started];
  }

  let status_names =
    [ ("p2p_layer_disabled", `P2p_layer_disabled);
      ("bootstrapping", `Bootstrapping);
      ("p2p_maintain_started", `P2p_maintain_started) ]

  module Definition = struct
    let name = "shell-node"

    type nonrec t = t

    let encoding =
      let open Data_encoding in
      let v0_encoding =
        conv
          (function {time_stamp; status} -> (time_stamp, status))
          (fun (time_stamp, status) -> {time_stamp; status})
          (obj2
             (req "time-stamp" float)
             (req "status" (string_enum status_names)))
      in
      With_version.(encoding ~name (first_version v0_encoding))

    let pp ppf {status; _} =
      Format.fprintf
        ppf
        "%s initialization: %s"
        name
        (List.find (fun (_, s) -> s = status) status_names |> fst)

    let doc = "Status of the initialization of the P2P layer."

    let level _ = Internal_event.Notice
  end

  module Event = Internal_event.Make (Definition)

  let lwt_emit status =
    let time_stamp = Unix.gettimeofday () in
    Event.emit (fun () -> {time_stamp; status})
    >>= function
    | Ok () ->
        Lwt.return_unit
    | Error el ->
        Format.kasprintf
          Lwt.fail_with
          "Initialization_event.emit: %a"
          pp_print_error
          el
end

type t = {
  state : State.t;
  distributed_db : Distributed_db.t;
  validator : Validator.t;
  mainchain_validator : Chain_validator.t;
  p2p : Distributed_db.p2p;
  (* For P2P RPCs *)
  shutdown : unit -> unit Lwt.t;
}

let peer_metadata_cfg : _ P2p.peer_meta_config =
  {
    peer_meta_encoding = Peer_metadata.encoding;
    peer_meta_initial = Peer_metadata.empty;
    score = Peer_metadata.score;
  }

let connection_metadata_cfg cfg : _ P2p.conn_meta_config =
  {
    conn_meta_encoding = Connection_metadata.encoding;
    private_node = (fun {private_node; _} -> private_node);
    conn_meta_value = (fun _ -> cfg);
  }

let init_connection_metadata opt =
  let open Connection_metadata in
  match opt with
  | None ->
      {disable_mempool = false; private_node = false}
  | Some c ->
      {
        disable_mempool = c.P2p.disable_mempool;
        private_node = c.P2p.private_mode;
      }

let init_p2p ?(sandboxed = false) p2p_params =
  match p2p_params with
  | None ->
      let c_meta = init_connection_metadata None in
      Initialization_event.lwt_emit `P2p_layer_disabled
      >>= fun () ->
      return
        (P2p.faked_network Distributed_db_message.cfg peer_metadata_cfg c_meta)
  | Some (config, limits) ->
      let c_meta = init_connection_metadata (Some config) in
      let conn_metadata_cfg = connection_metadata_cfg c_meta in
      Initialization_event.lwt_emit `Bootstrapping
      >>= fun () ->
      let message_cfg =
        if sandboxed then
          {
            Distributed_db_message.cfg with
            chain_name = Distributed_db_version.sandboxed_chain_name;
          }
        else Distributed_db_message.cfg
      in
      P2p.create
        ~config
        ~limits
        peer_metadata_cfg
        conn_metadata_cfg
        message_cfg
      >>=? fun p2p ->
      Initialization_event.lwt_emit `P2p_maintain_started
      >>= fun () -> return p2p

type config = {
  genesis : State.Chain.genesis;
  store_root : string;
  context_root : string;
  protocol_root : string;
  patch_context : (Context.t -> Context.t Lwt.t) option;
  p2p : (P2p.config * P2p.limits) option;
  checkpoint : Block_header.t option;
}

and peer_validator_limits = Peer_validator.limits = {
  new_head_request_timeout : Time.System.Span.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

and prevalidator_limits = Prevalidator.limits = {
  max_refused_operations : int;
  operation_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
  operations_batch_size : int;
}

and block_validator_limits = Block_validator.limits = {
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

and chain_validator_limits = Chain_validator.limits = {
  bootstrap_threshold : int;
  worker_limits : Worker_types.limits;
}

let default_block_validator_limits =
  {
    protocol_timeout = Time.System.Span.of_seconds_exn 120.;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Debug};
  }

let default_prevalidator_limits =
  {
    operation_timeout = Time.System.Span.of_seconds_exn 10.;
    max_refused_operations = 1000;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
    operations_batch_size = 50;
  }

let default_peer_validator_limits =
  {
    block_header_timeout = Time.System.Span.of_seconds_exn 300.;
    block_operations_timeout = Time.System.Span.of_seconds_exn 300.;
    protocol_timeout = Time.System.Span.of_seconds_exn 600.;
    new_head_request_timeout = Time.System.Span.of_seconds_exn 90.;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
  }

let default_chain_validator_limits =
  {
    bootstrap_threshold = 4;
    worker_limits = {backlog_size = 1000; backlog_level = Internal_event.Info};
  }

let may_update_checkpoint chain_state checkpoint history_mode =
  match checkpoint with
  | None ->
      return_unit
  | Some checkpoint -> (
      State.best_known_head_for_checkpoint chain_state checkpoint
      >>= fun new_head ->
      Chain.set_head chain_state new_head
      >>= fun _old_head ->
      match history_mode with
      | History_mode.Archive ->
          State.Chain.set_checkpoint chain_state checkpoint
          >>= fun () -> return_unit
      | Full ->
          State.Chain.set_checkpoint_then_purge_full chain_state checkpoint
      | Rolling ->
          State.Chain.set_checkpoint_then_purge_rolling chain_state checkpoint
      )

module Local_logging = Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.worker"
end)

let store_known_protocols state =
  let open Local_logging in
  let embedded_protocols = Registered_protocol.list_embedded () in
  Lwt_list.iter_s
    (fun protocol_hash ->
      State.Protocol.known state protocol_hash
      >>= function
      | true ->
          lwt_log_info
            Tag.DSL.(
              fun f ->
                f "protocol %a is already in store: nothing to do"
                -% a Protocol_hash.Logging.tag protocol_hash
                -% t event "embedded_protocol_already_stored")
      | false -> (
        match Registered_protocol.get_embedded_sources protocol_hash with
        | None ->
            lwt_log_info
              Tag.DSL.(
                fun f ->
                  f "protocol %a won't be stored: missing source files"
                  -% a Protocol_hash.Logging.tag protocol_hash
                  -% t event "embedded_protocol_missing_sources")
        | Some protocol -> (
            let hash = Protocol.hash protocol in
            if not (Protocol_hash.equal hash protocol_hash) then
              lwt_log_info
                Tag.DSL.(
                  fun f ->
                    f "protocol %a won't be stored: wrong hash"
                    -% a Protocol_hash.Logging.tag protocol_hash
                    -% t event "embedded_protocol_inconsistent_hash")
            else
              State.Protocol.store state protocol
              >>= function
              | Some hash' ->
                  assert (hash = hash') ;
                  lwt_log_info
                    Tag.DSL.(
                      fun f ->
                        f "protocol %a successfully stored"
                        -% a Protocol_hash.Logging.tag protocol_hash
                        -% t event "embedded_protocol_stored")
              | None ->
                  lwt_log_info
                    Tag.DSL.(
                      fun f ->
                        f "protocol %a is already in store: nothing to do"
                        -% a Protocol_hash.Logging.tag protocol_hash
                        -% t event "embedded_protocol_already_stored") ) ))
    embedded_protocols

let create ?(sandboxed = false) ?sandbox_parameters ~singleprocess
    { genesis;
      store_root;
      context_root;
      protocol_root;
      patch_context;
      p2p = p2p_params;
      checkpoint } peer_validator_limits block_validator_limits
    prevalidator_limits chain_validator_limits history_mode =
  let (start_prevalidator, start_testchain) =
    match p2p_params with
    | Some (config, _limits) ->
        (not config.P2p.disable_mempool, not config.P2p.disable_testchain)
    | None ->
        (true, true)
  in
  init_p2p ~sandboxed p2p_params
  >>=? fun p2p ->
  (let open Block_validator_process in
  if singleprocess then
    State.init ~store_root ~context_root ?history_mode ?patch_context genesis
    >>=? fun (state, mainchain_state, context_index, history_mode) ->
    init (Internal context_index)
    >>=? fun validator_process ->
    return (validator_process, state, mainchain_state, history_mode)
  else
    init
      (External
         {
           context_root;
           protocol_root;
           process_path = Sys.executable_name;
           sandbox_parameters;
         })
    >>=? fun validator_process ->
    let commit_genesis =
      Block_validator_process.commit_genesis
        validator_process
        ~genesis_hash:genesis.block
    in
    State.init
      ~store_root
      ~context_root
      ?history_mode
      ?patch_context
      ~commit_genesis
      genesis
    >>=? fun (state, mainchain_state, _context_index, history_mode) ->
    return (validator_process, state, mainchain_state, history_mode))
  >>=? fun (validator_process, state, mainchain_state, history_mode) ->
  may_update_checkpoint mainchain_state checkpoint history_mode
  >>=? fun () ->
  let distributed_db = Distributed_db.create state p2p in
  store_known_protocols state
  >>= fun () ->
  Validator.create
    state
    distributed_db
    peer_validator_limits
    block_validator_limits
    validator_process
    prevalidator_limits
    chain_validator_limits
    ~start_testchain
  >>=? fun validator ->
  (* TODO : Check that the testchain is correctly activated after a node restart *)
  Validator.activate
    validator
    ~start_prevalidator
    ~validator_process
    mainchain_state
  >>=? fun mainchain_validator ->
  let shutdown () =
    let open Local_logging in
    lwt_log_info
      Tag.DSL.(
        fun f -> f "Shutting down the p2p layer..." -% t event "shutdown")
    >>= fun () ->
    P2p.shutdown p2p
    >>= fun () ->
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "Shutting down the distributed database..." -% t event "shutdown")
    >>= fun () ->
    Distributed_db.shutdown distributed_db
    >>= fun () ->
    lwt_log_info
      Tag.DSL.(
        fun f -> f "Shutting down the validator..." -% t event "shutdown")
    >>= fun () ->
    Validator.shutdown validator
    >>= fun () ->
    lwt_log_info
      Tag.DSL.(fun f -> f "Closing down the state..." -% t event "shutdown")
    >>= fun () -> State.close state
  in
  return {state; distributed_db; validator; mainchain_validator; p2p; shutdown}

let shutdown node = node.shutdown ()

let build_rpc_directory node =
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let merge d = dir := RPC_directory.merge !dir d in
  let register0 s f =
    dir := RPC_directory.register !dir s (fun () p q -> f p q)
  in
  merge
    (Protocol_directory.build_rpc_directory
       (Block_validator.running_worker ())
       node.state) ;
  merge
    (Monitor_directory.build_rpc_directory
       node.validator
       node.mainchain_validator) ;
  merge (Injection_directory.build_rpc_directory node.validator) ;
  merge (Chain_directory.build_rpc_directory node.validator) ;
  merge (P2p_directory.build_rpc_directory node.p2p) ;
  merge (Worker_directory.build_rpc_directory node.state) ;
  merge (Stat_directory.rpc_directory ()) ;
  register0 RPC_service.error_service (fun () () ->
      return (Data_encoding.Json.schema Error_monad.error_encoding)) ;
  RPC_directory.register_describe_directory_service
    !dir
    RPC_service.description_service
src/lib_shell/node.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Import Tezos_base.

Module Initialization_event.
  Record t := {
    time_stamp : Z;
    status : variant }.
  
  Definition status_names : list (string * variant) :=
    cons
      ("p2p_layer_disabled" % string,
        (* ❌ Variants not supported *)
        variant)
      (cons
        ("bootstrapping" % string,
          (* ❌ Variants not supported *)
          variant)
        (cons
          ("p2p_maintain_started" % string,
            (* ❌ Variants not supported *)
            variant) [])).
  
  Module Definition.
    Definition name : string := "shell-node" % string.
    
    Definition t := t.
    
    Definition encoding : Tezos_data_encoding__Data_encoding.encoding t :=
      let v0_encoding :=
        conv
          (fun function_parameter =>
            let '{| time_stamp := time_stamp; status := status |} :=
              function_parameter in
            (time_stamp, status))
          (fun function_parameter =>
            let '(time_stamp, status) := function_parameter in
            {| time_stamp := time_stamp; status := status |}) None
          (obj2 (req None None "time-stamp" % string float)
            (req None None "status" % string (string_enum status_names))) in
      encoding name (first_version v0_encoding).
    
    Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
      : unit :=
      let '{| status := status |} := function_parameter in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              " initialization: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))
          "%s initialization: %s" % string) name
        (OCaml.Stdlib.reverse_apply
          (List.find
            (fun function_parameter =>
              let '(_, s) := function_parameter in
              equiv_decb s status) status_names) fst).
    
    Definition doc : string :=
      "Status of the initialization of the P2P layer." % string.
    
    Definition level {A : Type} (function_parameter : A)
      : Tezos_base__TzPervasives.Internal_event.level :=
      let '_ := function_parameter in
      Tezos_base__TzPervasives.Internal_event.Notice.
  End Definition.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition lwt_emit (status : variant) : Lwt.t unit :=
    let time_stamp := Unix.gettimeofday tt in
    op_gtgteq
      (Event.emit None
        (fun function_parameter =>
          let 'tt := function_parameter in
          {| time_stamp := time_stamp; status := status |}))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok tt => Lwt.return_unit
        | Stdlib.Error el =>
          Format.kasprintf Lwt.fail_with
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Initialization_event.emit: " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))
              "Initialization_event.emit: %a" % string) pp_print_error el
        end).
End Initialization_event.

Record t := {
  state : Tezos_shell.State.t;
  distributed_db : Tezos_shell.Distributed_db.t;
  validator : Tezos_shell.Validator.t;
  mainchain_validator : Tezos_shell.Chain_validator.t;
  p2p : Tezos_shell.Distributed_db.p2p;
  shutdown : unit -> Lwt.t unit }.

Definition peer_metadata_cfg
  : Tezos_p2p.P2p.peer_meta_config Tezos_shell_services.Peer_metadata.t :=
  {| peer_meta_encoding := Peer_metadata.encoding;
    peer_meta_initial := Peer_metadata.empty; score := Peer_metadata.score |}.

Definition connection_metadata_cfg
  (cfg : Tezos_shell_services.Connection_metadata.t)
  : Tezos_p2p.P2p.conn_meta_config Tezos_shell_services.Connection_metadata.t :=
  {| conn_meta_encoding := Connection_metadata.encoding;
    conn_meta_value :=
      fun function_parameter =>
        let '_ := function_parameter in
        cfg;
    private_node :=
      fun function_parameter =>
        let '{| private_node := private_node |} := function_parameter in
        private_node |}.

Definition init_connection_metadata (opt : option Tezos_p2p.P2p.config)
  : Tezos_shell_services.Connection_metadata.t :=
  match opt with
  | None => {| disable_mempool := false; private_node := false |}
  | Some c =>
    {| disable_mempool := P2p.disable_mempool c;
      private_node := P2p.private_mode c |}
  end.

Definition init_p2p (op_staroptstar : option bool)
  : (option (Tezos_p2p.P2p.config * Tezos_p2p.P2p.limits)) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_p2p.P2p.net Tezos_shell.Distributed_db_message.t
          Tezos_shell_services.Peer_metadata.t
          Tezos_shell_services.Connection_metadata.t)) :=
  let sandboxed :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun p2p_params =>
    match p2p_params with
    | None =>
      let c_meta := init_connection_metadata None in
      op_gtgteq
        (Initialization_event.lwt_emit
          (* ❌ Variants not supported *)
          variant)
        (fun function_parameter =>
          let 'tt := function_parameter in
          _return
            (P2p.faked_network Distributed_db_message.cfg peer_metadata_cfg
              c_meta))
    | Some (config, limits) =>
      let c_meta := init_connection_metadata (Some config) in
      let conn_metadata_cfg := connection_metadata_cfg c_meta in
      op_gtgteq
        (Initialization_event.lwt_emit
          (* ❌ Variants not supported *)
          variant)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let message_cfg :=
            if sandboxed then
              (* ❌ Record substitution not handled *)
              record_substitution
            else
              Distributed_db_message.cfg in
          op_gtgteqquestion
            (P2p.create config limits peer_metadata_cfg conn_metadata_cfg
              message_cfg)
            (fun p2p =>
              op_gtgteq
                (Initialization_event.lwt_emit
                  (* ❌ Variants not supported *)
                  variant)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  _return p2p)))
    end.

.

Definition default_block_validator_limits : block_validator_limits :=
  {|
    protocol_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 120. is approximated by the integer 120 *)
        120;
    worker_limits :=
      {| backlog_size := 1000;
        backlog_level := Tezos_base__TzPervasives.Internal_event.Debug |} |}.

Definition default_prevalidator_limits : prevalidator_limits :=
  {| max_refused_operations := 1000;
    operation_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 10. is approximated by the integer 10 *)
        10;
    worker_limits :=
      {| backlog_size := 1000;
        backlog_level := Tezos_base__TzPervasives.Internal_event.Info |};
    operations_batch_size := 50 |}.

Definition default_peer_validator_limits : peer_validator_limits :=
  {|
    new_head_request_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 90. is approximated by the integer 90 *)
        90;
    block_header_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 300. is approximated by the integer 300 *)
        300;
    block_operations_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 300. is approximated by the integer 300 *)
        300;
    protocol_timeout :=
      Time.System.Span.of_seconds_exn
        (* ❌ Float constant 600. is approximated by the integer 600 *)
        600;
    worker_limits :=
      {| backlog_size := 1000;
        backlog_level := Tezos_base__TzPervasives.Internal_event.Info |} |}.

Definition default_chain_validator_limits : chain_validator_limits :=
  {| bootstrap_threshold := 4;
    worker_limits :=
      {| backlog_size := 1000;
        backlog_level := Tezos_base__TzPervasives.Internal_event.Info |} |}.

Definition may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.t)
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t)
  (history_mode : Tezos_shell_services.History_mode.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match checkpoint with
  | None => return_unit
  | Some checkpoint =>
    op_gtgteq (State.best_known_head_for_checkpoint chain_state checkpoint)
      (fun new_head =>
        op_gtgteq (Chain.set_head chain_state new_head)
          (fun _old_head =>
            match history_mode with
            | Tezos_shell_services.History_mode.Archive =>
              op_gtgteq (State.Chain.set_checkpoint chain_state checkpoint)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)
            | Tezos_shell_services.History_mode.Full =>
              State.Chain.set_checkpoint_then_purge_full chain_state checkpoint
            | Tezos_shell_services.History_mode.Rolling =>
              State.Chain.set_checkpoint_then_purge_rolling chain_state
                checkpoint
            end))
  end.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition store_known_protocols (state : Tezos_shell__State.global_state)
  : Lwt.t unit :=
  let embedded_protocols := Registered_protocol.list_embedded tt in
  Lwt_list.iter_s
    (fun protocol_hash =>
      op_gtgteq (State.Protocol.known state protocol_hash)
        (fun function_parameter =>
          match function_parameter with
          | true =>
            lwt_log_info
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "protocol " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " is already in store: nothing to do" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "protocol %a is already in store: nothing to do" %
                          string)) (a Protocol_hash.Logging.tag protocol_hash))
                  (t event "embedded_protocol_already_stored" % string))
          | false =>
            match Registered_protocol.get_embedded_sources protocol_hash with
            | None =>
              lwt_log_info
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "protocol " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " won't be stored: missing source files" %
                                  string CamlinternalFormatBasics.End_of_format)))
                          "protocol %a won't be stored: missing source files" %
                            string)) (a Protocol_hash.Logging.tag protocol_hash))
                    (t event "embedded_protocol_missing_sources" % string))
            | Some protocol =>
              let hash := Protocol.hash protocol in
              if negb (Protocol_hash.equal hash protocol_hash) then
                lwt_log_info
                  (fun f =>
                    op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "protocol " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " won't be stored: wrong hash" % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "protocol %a won't be stored: wrong hash" % string))
                        (a Protocol_hash.Logging.tag protocol_hash))
                      (t event "embedded_protocol_inconsistent_hash" % string))
              else
                op_gtgteq (State.Protocol.store state protocol)
                  (fun function_parameter =>
                    match function_parameter with
                    | Some hash' =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        (* ❌ Assert instruction is not handled. *)
                        assert (equiv_decb hash hash') in
                      lwt_log_info
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "protocol " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " successfully stored" % string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "protocol %a successfully stored" % string))
                              (a Protocol_hash.Logging.tag protocol_hash))
                            (t event "embedded_protocol_stored" % string))
                    | None =>
                      lwt_log_info
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "protocol " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " is already in store: nothing to do" %
                                          string
                                        CamlinternalFormatBasics.End_of_format)))
                                  "protocol %a is already in store: nothing to do"
                                    % string))
                              (a Protocol_hash.Logging.tag protocol_hash))
                            (t event "embedded_protocol_already_stored" % string))
                    end)
            end
          end)) embedded_protocols.

Definition create (op_staroptstar : option bool)
  : (option Tezos_base__TzPervasives.Data_encoding.json) ->
    bool ->
      config ->
        Tezos_shell.Peer_validator.limits ->
          Tezos_shell.Block_validator.limits ->
            Tezos_shell.Prevalidator.limits ->
              Tezos_shell.Chain_validator.limits ->
                (option Tezos_shell_services.History_mode.t) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let sandboxed :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun sandbox_parameters =>
    fun singleprocess =>
      fun function_parameter =>
        let '{|
          genesis := genesis;
            store_root := store_root;
            context_root := context_root;
            protocol_root := protocol_root;
            patch_context := patch_context;
            p2p := p2p_params;
            checkpoint := checkpoint
            |} := function_parameter in
        fun peer_validator_limits =>
          fun block_validator_limits =>
            fun prevalidator_limits =>
              fun chain_validator_limits =>
                fun history_mode =>
                  let '(start_prevalidator, start_testchain) :=
                    match p2p_params with
                    | Some (config, _limits) =>
                      ((negb (P2p.disable_mempool config)),
                        (negb (P2p.disable_testchain config)))
                    | None => (true, true)
                    end in
                  op_gtgteqquestion (init_p2p (Some sandboxed) p2p_params)
                    (fun p2p =>
                      op_gtgteqquestion
                        (if singleprocess then
                          op_gtgteqquestion
                            (State.init patch_context None None None store_root
                              context_root history_mode genesis)
                            (fun function_parameter =>
                              let
                                '(state, mainchain_state, context_index,
                                  history_mode) := function_parameter in
                              op_gtgteqquestion
                                (init
                                  (Tezos_shell.Block_validator_process.Internal
                                    context_index))
                                (fun validator_process =>
                                  _return
                                    (validator_process, state, mainchain_state,
                                      history_mode)))
                        else
                          op_gtgteqquestion
                            (init
                              (Tezos_shell.Block_validator_process.External
                                {| context_root := context_root;
                                  protocol_root := protocol_root;
                                  process_path := Sys.executable_name;
                                  sandbox_parameters := sandbox_parameters |}))
                            (fun validator_process =>
                              let commit_genesis :=
                                Block_validator_process.commit_genesis
                                  validator_process (block genesis) in
                              op_gtgteqquestion
                                (State.init patch_context (Some commit_genesis)
                                  None None store_root context_root history_mode
                                  genesis)
                                (fun function_parameter =>
                                  let
                                    '(state, mainchain_state, _context_index,
                                      history_mode) := function_parameter in
                                  _return
                                    (validator_process, state, mainchain_state,
                                      history_mode))))
                        (fun function_parameter =>
                          let
                            '(validator_process, state, mainchain_state,
                              history_mode) := function_parameter in
                          op_gtgteqquestion
                            (may_update_checkpoint mainchain_state checkpoint
                              history_mode)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              let distributed_db :=
                                Distributed_db.create state p2p in
                              op_gtgteq (store_known_protocols state)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (Validator.create state distributed_db
                                      peer_validator_limits
                                      block_validator_limits validator_process
                                      prevalidator_limits chain_validator_limits
                                      start_testchain)
                                    (fun validator =>
                                      op_gtgteqquestion
                                        (Validator.activate validator
                                          start_prevalidator validator_process
                                          mainchain_state)
                                        (fun mainchain_validator =>
                                          let shutdown
                                            (function_parameter : unit)
                                            : Lwt.t unit :=
                                            let 'tt := function_parameter in
                                            op_gtgteq
                                              (lwt_log_info
                                                (fun f =>
                                                  op_minuspercent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Shutting down the p2p layer..."
                                                            % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "Shutting down the p2p layer..."
                                                          % string))
                                                    (t event "shutdown" % string)))
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                op_gtgteq (P2p.shutdown p2p)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteq
                                                      (lwt_log_info
                                                        (fun f =>
                                                          op_minuspercent
                                                            (f
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Shutting down the distributed database..."
                                                                    % string
                                                                  CamlinternalFormatBasics.End_of_format)
                                                                "Shutting down the distributed database..."
                                                                  % string))
                                                            (t event
                                                              "shutdown" %
                                                                string)))
                                                      (fun function_parameter =>
                                                        let 'tt :=
                                                          function_parameter in
                                                        op_gtgteq
                                                          (Distributed_db.shutdown
                                                            distributed_db)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let 'tt :=
                                                              function_parameter
                                                              in
                                                            op_gtgteq
                                                              (lwt_log_info
                                                                (fun f =>
                                                                  op_minuspercent
                                                                    (f
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "Shutting down the validator..."
                                                                            %
                                                                            string
                                                                          CamlinternalFormatBasics.End_of_format)
                                                                        "Shutting down the validator..."
                                                                          %
                                                                          string))
                                                                    (t event
                                                                      "shutdown"
                                                                        % string)))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                op_gtgteq
                                                                  (Validator.shutdown
                                                                    validator)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let 'tt :=
                                                                      function_parameter
                                                                      in
                                                                    op_gtgteq
                                                                      (lwt_log_info
                                                                        (fun f
                                                                          =>
                                                                          op_minuspercent
                                                                            (f
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Closing down the state..."
                                                                                    %
                                                                                    string
                                                                                  CamlinternalFormatBasics.End_of_format)
                                                                                "Closing down the state..."
                                                                                  %
                                                                                  string))
                                                                            (t
                                                                              event
                                                                              "shutdown"
                                                                                %
                                                                                string)))
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        let
                                                                          'tt :=
                                                                          function_parameter
                                                                          in
                                                                        State.close
                                                                          state)))))))
                                            in
                                          _return
                                            {| state := state;
                                              distributed_db := distributed_db;
                                              validator := validator;
                                              mainchain_validator :=
                                                mainchain_validator; p2p := p2p;
                                              shutdown := shutdown |})))))).

Definition shutdown (node : t) : Lwt.t unit := (shutdown node) tt.

Definition build_rpc_directory (node : t)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let dir := Stdlib.ref RPC_directory.empty in
  let merge (d : Tezos_base__TzPervasives.RPC_directory.directory unit)
    : unit :=
    Stdlib.op_coloneq dir (RPC_directory.merge (Stdlib.op_exclamation dir) d) in
  let register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun p => fun q => f p q)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    merge
      (Protocol_directory.build_rpc_directory
        (Block_validator.running_worker tt) (state node)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    merge
      (Monitor_directory.build_rpc_directory (validator node)
        (mainchain_validator node)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := merge (Injection_directory.build_rpc_directory (validator node)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := merge (Chain_directory.build_rpc_directory (validator node)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := merge (P2p_directory.build_rpc_directory (p2p node)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := merge (Worker_directory.build_rpc_directory (state node)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := merge (Stat_directory.rpc_directory tt) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 RPC_service.error_service
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return (Data_encoding.Json.schema None Error_monad.error_encoding))
    in
  RPC_directory.register_describe_directory_service (Stdlib.op_exclamation dir)
    RPC_service.description_service.

src/lib_shell/p2p_directory.ml 120 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let info_of_point_info i =
  let open P2p_point.Info in
  let open P2p_point.State in
  let state =
    match P2p_point_state.get i with
    | Requested _ ->
        Requested
    | Accepted {current_peer_id; _} ->
        Accepted current_peer_id
    | Running {current_peer_id; _} ->
        Running current_peer_id
    | Disconnected ->
        Disconnected
  in
  P2p_point_state.Info.
    {
      trusted = trusted i;
      state;
      greylisted_until = greylisted_until i;
      last_failed_connection = last_failed_connection i;
      last_rejected_connection = last_rejected_connection i;
      last_established_connection = last_established_connection i;
      last_disconnection = last_disconnection i;
      last_seen = last_seen i;
      last_miss = last_miss i;
    }

let info_of_peer_info pool i =
  let open P2p_peer.Info in
  let open P2p_peer.State in
  let (state, id_point) =
    match P2p_peer_state.get i with
    | Accepted {current_point; _} ->
        (Accepted, Some current_point)
    | Running {current_point; _} ->
        (Running, Some current_point)
    | Disconnected ->
        (Disconnected, None)
  in
  let peer_id = P2p_peer_state.Info.peer_id i in
  let score = P2p_pool.Peers.get_score pool peer_id in
  let conn_opt = P2p_pool.Connection.find_by_peer_id pool peer_id in
  let stat =
    match conn_opt with
    | None ->
        P2p_stat.empty
    | Some conn ->
        P2p_conn.stat conn
  in
  let meta_opt =
    match conn_opt with
    | None ->
        None
    | Some conn ->
        Some (P2p_conn.remote_metadata conn)
  in
  P2p_peer_state.Info.
    {
      score;
      trusted = trusted i;
      conn_metadata = meta_opt;
      peer_metadata = peer_metadata i;
      state;
      id_point;
      stat;
      last_failed_connection = last_failed_connection i;
      last_rejected_connection = last_rejected_connection i;
      last_established_connection = last_established_connection i;
      last_disconnection = last_disconnection i;
      last_seen = last_seen i;
      last_miss = last_miss i;
    }

let build_rpc_directory net =
  let dir = RPC_directory.empty in
  (* Network : Global *)
  let dir =
    RPC_directory.register0 dir P2p_services.S.version (fun () () ->
        return (P2p.announced_version net))
  in
  let dir =
    (* DEPRECATED: use [version] instead. *)
    RPC_directory.register0 dir P2p_services.S.versions (fun () () ->
        return [P2p.announced_version net])
  in
  let dir =
    RPC_directory.register0 dir P2p_services.S.self (fun () () ->
        match P2p.pool net with
        | None ->
            failwith "The P2P layer is disabled."
        | Some pool ->
            return (P2p_pool.config pool).identity.peer_id)
  in
  let dir =
    RPC_directory.register0 dir P2p_services.S.stat (fun () () ->
        match P2p.connect_handler net with
        | None ->
            return P2p_stat.empty
        | Some connect_handler ->
            return (P2p_connect_handler.stat connect_handler))
  in
  let dir =
    RPC_directory.gen_register0 dir P2p_services.S.events (fun () () ->
        let (stream, stopper) = P2p.watcher net in
        let shutdown () = Lwt_watcher.shutdown stopper in
        let next () = Lwt_stream.get stream in
        RPC_answer.return_stream {next; shutdown})
  in
  let dir =
    RPC_directory.register1 dir P2p_services.S.connect (fun point q () ->
        match P2p.connect_handler net with
        | None ->
            failwith "The P2P layer is disabled."
        | Some connect_handler ->
            P2p_connect_handler.connect
              ~timeout:q#timeout
              connect_handler
              point
            >>=? fun _conn -> return_unit)
  in
  (* Network : Connection *)
  let dir =
    RPC_directory.opt_register1
      dir
      P2p_services.Connections.S.info
      (fun peer_id () () ->
        return
        @@ Option.apply (P2p.pool net) ~f:(fun pool ->
               Option.map
                 ~f:P2p_conn.info
                 (P2p_pool.Connection.find_by_peer_id pool peer_id)))
  in
  let dir =
    RPC_directory.lwt_register1
      dir
      P2p_services.Connections.S.kick
      (fun peer_id q () ->
        match P2p.pool net with
        | None ->
            Lwt.return_unit
        | Some pool -> (
          match P2p_pool.Connection.find_by_peer_id pool peer_id with
          | None ->
              Lwt.return_unit
          | Some conn ->
              P2p_conn.disconnect ~wait:q#wait conn ))
  in
  let dir =
    RPC_directory.register0 dir P2p_services.Connections.S.list (fun () () ->
        match P2p.pool net with
        | None ->
            return_nil
        | Some pool ->
            return
            @@ P2p_pool.Connection.fold pool ~init:[] ~f:(fun _peer_id c acc ->
                   P2p_conn.info c :: acc))
  in
  (* Network : Peer_id *)
  let dir =
    RPC_directory.register0 dir P2p_services.Peers.S.list (fun q () ->
        match P2p.pool net with
        | None ->
            return_nil
        | Some pool ->
            return
            @@ P2p_pool.Peers.fold_known pool ~init:[] ~f:(fun peer_id i a ->
                   let info = info_of_peer_info pool i in
                   match q#filters with
                   | [] ->
                       (peer_id, info) :: a
                   | filters when P2p_peer.State.filter filters info.state ->
                       (peer_id, info) :: a
                   | _ ->
                       a))
  in
  let dir =
    RPC_directory.opt_register1
      dir
      P2p_services.Peers.S.info
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            return_none
        | Some pool ->
            return
            @@ Option.map
                 ~f:(info_of_peer_info pool)
                 (P2p_pool.Peers.info pool peer_id))
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.events
      (fun peer_id q () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool -> (
          match P2p_pool.Peers.info pool peer_id with
          | None ->
              RPC_answer.return []
          | Some gi ->
              let rev = false and max = max_int in
              let evts =
                P2p_peer_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a)
              in
              let evts = (if rev then List.rev_sub else List.sub) evts max in
              if not q#monitor then RPC_answer.return evts
              else
                let (stream, stopper) = P2p_peer_state.Info.watch gi in
                let shutdown () = Lwt_watcher.shutdown stopper in
                let first_request = ref true in
                let next () =
                  if not !first_request then
                    Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i])
                  else (
                    first_request := false ;
                    Lwt.return_some evts )
                in
                RPC_answer.return_stream {next; shutdown} ))
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.ban
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.untrust pool peer_id ;
            P2p_pool.Peers.ban pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.unban
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.unban pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.trust
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.trust pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Peers.S.untrust
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Peers.untrust pool peer_id ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.register1
      dir
      P2p_services.Peers.S.banned
      (fun peer_id () () ->
        match P2p.pool net with
        | None ->
            return_false
        | Some pool when P2p_pool.Peers.get_trusted pool peer_id ->
            return_false
        | Some pool ->
            return (P2p_pool.Peers.banned pool peer_id))
  in
  (* Network : Point *)
  let dir =
    RPC_directory.register0 dir P2p_services.Points.S.list (fun q () ->
        match P2p.pool net with
        | None ->
            return_nil
        | Some pool ->
            return
            @@ P2p_pool.Points.fold_known pool ~init:[] ~f:(fun point i a ->
                   let info = info_of_point_info i in
                   match q#filters with
                   | [] ->
                       (point, info) :: a
                   | filters when P2p_point.State.filter filters info.state ->
                       (point, info) :: a
                   | _ ->
                       a))
  in
  let dir =
    RPC_directory.opt_register1
      dir
      P2p_services.Points.S.info
      (fun point () () ->
        match P2p.pool net with
        | None ->
            return_none
        | Some pool ->
            return
            @@ Option.map
                 (P2p_pool.Points.info pool point)
                 ~f:info_of_point_info)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.events
      (fun point_id q () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool -> (
          match P2p_pool.Points.info pool point_id with
          | None ->
              RPC_answer.return []
          | Some gi ->
              let rev = false and max = max_int in
              let evts =
                P2p_point_state.Info.fold gi ~init:[] ~f:(fun a e -> e :: a)
              in
              let evts = (if rev then List.rev_sub else List.sub) evts max in
              if not q#monitor then RPC_answer.return evts
              else
                let (stream, stopper) = P2p_point_state.Info.watch gi in
                let shutdown () = Lwt_watcher.shutdown stopper in
                let first_request = ref true in
                let next () =
                  if not !first_request then
                    Lwt_stream.get stream >|= Option.map ~f:(fun i -> [i])
                  else (
                    first_request := false ;
                    Lwt.return_some evts )
                in
                RPC_answer.return_stream {next; shutdown} ))
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.ban
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.untrust pool point ;
            P2p_pool.Points.ban pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.unban
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.unban pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.trust
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.trust pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.untrust
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool ->
            P2p_pool.Points.untrust pool point ;
            RPC_answer.return_unit)
  in
  let dir =
    RPC_directory.gen_register1
      dir
      P2p_services.Points.S.banned
      (fun point () () ->
        match P2p.pool net with
        | None ->
            RPC_answer.not_found
        | Some pool when P2p_pool.Points.get_trusted pool point ->
            RPC_answer.return false
        | Some pool ->
            RPC_answer.return (P2p_pool.Points.banned pool point))
  in
  (* Network : Greylist *)
  let dir =
    RPC_directory.register dir P2p_services.ACL.S.clear (fun () () () ->
        match P2p.pool net with
        | None ->
            return_unit
        | Some pool ->
            P2p_pool.acl_clear pool ; return_unit)
  in
  dir
src/lib_shell/p2p_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition info_of_point_info {A : Type}
  (i : Tezos_p2p.P2p_point_state.Info.t A)
  : Tezos_base__TzPervasives.P2p_point.Info.t :=
  let state :=
    match P2p_point_state.get i with
    | Tezos_p2p.P2p_point_state.Requested _ =>
      Tezos_base__TzPervasives.P2p_point.State.Requested
    |
      Tezos_p2p.P2p_point_state.Accepted {|
        current_peer_id := current_peer_id |} =>
      Tezos_base__TzPervasives.P2p_point.State.Accepted current_peer_id
    | Tezos_p2p.P2p_point_state.Running {| current_peer_id := current_peer_id |}
      => Tezos_base__TzPervasives.P2p_point.State.Running current_peer_id
    | Tezos_p2p.P2p_point_state.Disconnected =>
      Tezos_base__TzPervasives.P2p_point.State.Disconnected
    end in
  {| trusted := trusted i; greylisted_until := greylisted_until i;
    state := state; last_failed_connection := last_failed_connection i;
    last_rejected_connection := last_rejected_connection i;
    last_established_connection := last_established_connection i;
    last_disconnection := last_disconnection i; last_seen := last_seen i;
    last_miss := last_miss i |}.

Definition info_of_peer_info {A B C D E F : Type}
  (pool : Tezos_p2p__P2p_pool.t A B C)
  (i : Tezos_p2p.P2p_peer_state.Info.t D E F)
  : Tezos_base__TzPervasives.P2p_peer.Info.t E C :=
  let '(state, id_point) :=
    match P2p_peer_state.get i with
    | Tezos_p2p.P2p_peer_state.Accepted {| current_point := current_point |} =>
      (Tezos_base__TzPervasives.P2p_peer.State.Accepted, (Some current_point))
    | Tezos_p2p.P2p_peer_state.Running {| current_point := current_point |} =>
      (Tezos_base__TzPervasives.P2p_peer.State.Running, (Some current_point))
    | Tezos_p2p.P2p_peer_state.Disconnected =>
      (Tezos_base__TzPervasives.P2p_peer.State.Disconnected, None)
    end in
  let peer_id := P2p_peer_state.Info.peer_id i in
  let score := P2p_pool.Peers.get_score pool peer_id in
  let conn_opt := P2p_pool.Connection.find_by_peer_id pool peer_id in
  let stat :=
    match conn_opt with
    | None => P2p_stat.empty
    | Some conn => P2p_conn.stat conn
    end in
  let meta_opt :=
    match conn_opt with
    | None => None
    | Some conn => Some (P2p_conn.remote_metadata conn)
    end in
  {| score := score; trusted := trusted i; conn_metadata := meta_opt;
    peer_metadata := peer_metadata i; state := state; id_point := id_point;
    stat := stat; last_failed_connection := last_failed_connection i;
    last_rejected_connection := last_rejected_connection i;
    last_established_connection := last_established_connection i;
    last_disconnection := last_disconnection i; last_seen := last_seen i;
    last_miss := last_miss i |}.

Definition build_rpc_directory {A : Type}
  (net :
    Tezos_p2p.P2p.net A Tezos_shell_services.Peer_metadata.t
      Tezos_shell_services.Connection_metadata.t)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let dir := RPC_directory.empty in
  let dir :=
    RPC_directory.register0 dir P2p_services.S.version
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return (P2p.announced_version net)) in
  let dir :=
    RPC_directory.register0 dir P2p_services.S.versions
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return (cons (P2p.announced_version net) [])) in
  let dir :=
    RPC_directory.register0 dir P2p_services.S.self
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          match P2p.pool net with
          | None =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "The P2P layer is disabled." % string
                  CamlinternalFormatBasics.End_of_format)
                "The P2P layer is disabled." % string)
          | Some pool => _return (peer_id (identity (P2p_pool.config pool)))
          end) in
  let dir :=
    RPC_directory.register0 dir P2p_services.S.stat
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          match P2p.connect_handler net with
          | None => _return P2p_stat.empty
          | Some connect_handler =>
            _return (P2p_connect_handler.stat connect_handler)
          end) in
  let dir :=
    RPC_directory.gen_register0 dir P2p_services.S.events
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let '(stream, stopper) := P2p.watcher net in
          let shutdown (function_parameter : unit) : unit :=
            let 'tt := function_parameter in
            Lwt_watcher.shutdown stopper in
          let next (function_parameter : unit)
            : Lwt.t (option Tezos_base__TzPervasives.P2p_connection.P2p_event.t) :=
            let 'tt := function_parameter in
            Lwt_stream.get stream in
          RPC_answer.return_stream {| next := next; shutdown := shutdown |}) in
  let dir :=
    RPC_directory.register1 dir P2p_services.S.connect
      (fun point =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.connect_handler net with
            | None =>
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "The P2P layer is disabled." % string
                    CamlinternalFormatBasics.End_of_format)
                  "The P2P layer is disabled." % string)
            | Some connect_handler =>
              op_gtgteqquestion
                (P2p_connect_handler.connect
                  (Some
                    (* ❌ Sending method message is not handled *)
                    send) connect_handler point) (fun _conn => return_unit)
            end) in
  let dir :=
    RPC_directory.opt_register1 dir P2p_services.Connections.S.info
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            apply _return
              (Option.apply
                (fun pool =>
                  Option.map P2p_conn.info
                    (P2p_pool.Connection.find_by_peer_id pool peer_id))
                (P2p.pool net))) in
  let dir :=
    RPC_directory.lwt_register1 dir P2p_services.Connections.S.kick
      (fun peer_id =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => Lwt.return_unit
            | Some pool =>
              match P2p_pool.Connection.find_by_peer_id pool peer_id with
              | None => Lwt.return_unit
              | Some conn =>
                P2p_conn.disconnect
                  (Some
                    (* ❌ Sending method message is not handled *)
                    send) conn
              end
            end) in
  let dir :=
    RPC_directory.register0 dir P2p_services.Connections.S.list
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          match P2p.pool net with
          | None => return_nil
          | Some pool =>
            apply _return
              (P2p_pool.Connection.fold pool []
                (fun _peer_id => fun c => fun acc => cons (P2p_conn.info c) acc))
          end) in
  let dir :=
    RPC_directory.register0 dir P2p_services.Peers.S.list
      (fun q =>
        fun function_parameter =>
          let 'tt := function_parameter in
          match P2p.pool net with
          | None => return_nil
          | Some pool =>
            apply _return
              (P2p_pool.Peers.fold_known pool []
                (fun peer_id =>
                  fun i =>
                    fun a =>
                      let info := info_of_peer_info pool i in
                      match
                        (* ❌ Sending method message is not handled *)
                        send with
                      | [] => cons (peer_id, info) a
                      | filters => cons (peer_id, info) a
                      | _ => a
                      end))
          end) in
  let dir :=
    RPC_directory.opt_register1 dir P2p_services.Peers.S.info
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => return_none
            | Some pool =>
              apply _return
                (Option.map (info_of_peer_info pool)
                  (P2p_pool.Peers.info pool peer_id))
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Peers.S.events
      (fun peer_id =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              match P2p_pool.Peers.info pool peer_id with
              | None => RPC_answer._return []
              | Some gi =>
                let rev : bool :=
                  false
                with max : Z :=
                  Stdlib.max_int in
                let evts :=
                  P2p_peer_state.Info.fold gi [] (fun a => fun e => cons e a) in
                let evts :=
                  (if rev then
                    List.rev_sub
                  else
                    List.sub) evts max in
                if
                  negb
                    (* ❌ Sending method message is not handled *)
                    send then
                  RPC_answer._return evts
                else
                  let '(stream, stopper) := P2p_peer_state.Info.watch gi in
                  let shutdown (function_parameter : unit) : unit :=
                    let 'tt := function_parameter in
                    Lwt_watcher.shutdown stopper in
                  let first_request := Stdlib.ref true in
                  let next (function_parameter : unit)
                    : Lwt.t
                      (option
                        (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t)) :=
                    let 'tt := function_parameter in
                    if negb (Stdlib.op_exclamation first_request) then
                      op_gtpipeeq (Lwt_stream.get stream)
                        (Option.map (fun i => cons i []))
                    else
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ := Stdlib.op_coloneq first_request false in
                      Lwt.return_some evts in
                  RPC_answer.return_stream
                    {| next := next; shutdown := shutdown |}
              end
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Peers.S.ban
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Peers.untrust pool peer_id in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Peers.ban pool peer_id in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Peers.S.unban
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Peers.unban pool peer_id in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Peers.S.trust
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Peers.trust pool peer_id in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Peers.S.untrust
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Peers.untrust pool peer_id in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.register1 dir P2p_services.Peers.S.banned
      (fun peer_id =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => return_false
            | Some pool => return_false
            | Some pool => _return (P2p_pool.Peers.banned pool peer_id)
            end) in
  let dir :=
    RPC_directory.register0 dir P2p_services.Points.S.list
      (fun q =>
        fun function_parameter =>
          let 'tt := function_parameter in
          match P2p.pool net with
          | None => return_nil
          | Some pool =>
            apply _return
              (P2p_pool.Points.fold_known pool []
                (fun point =>
                  fun i =>
                    fun a =>
                      let info := info_of_point_info i in
                      match
                        (* ❌ Sending method message is not handled *)
                        send with
                      | [] => cons (point, info) a
                      | filters => cons (point, info) a
                      | _ => a
                      end))
          end) in
  let dir :=
    RPC_directory.opt_register1 dir P2p_services.Points.S.info
      (fun point =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => return_none
            | Some pool =>
              apply _return
                (Option.map info_of_point_info (P2p_pool.Points.info pool point))
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Points.S.events
      (fun point_id =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              match P2p_pool.Points.info pool point_id with
              | None => RPC_answer._return []
              | Some gi =>
                let rev : bool :=
                  false
                with max : Z :=
                  Stdlib.max_int in
                let evts :=
                  P2p_point_state.Info.fold gi [] (fun a => fun e => cons e a)
                  in
                let evts :=
                  (if rev then
                    List.rev_sub
                  else
                    List.sub) evts max in
                if
                  negb
                    (* ❌ Sending method message is not handled *)
                    send then
                  RPC_answer._return evts
                else
                  let '(stream, stopper) := P2p_point_state.Info.watch gi in
                  let shutdown (function_parameter : unit) : unit :=
                    let 'tt := function_parameter in
                    Lwt_watcher.shutdown stopper in
                  let first_request := Stdlib.ref true in
                  let next (function_parameter : unit)
                    : Lwt.t
                      (option
                        (list Tezos_base__TzPervasives.P2p_point.Pool_event.t)) :=
                    let 'tt := function_parameter in
                    if negb (Stdlib.op_exclamation first_request) then
                      op_gtpipeeq (Lwt_stream.get stream)
                        (Option.map (fun i => cons i []))
                    else
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ := Stdlib.op_coloneq first_request false in
                      Lwt.return_some evts in
                  RPC_answer.return_stream
                    {| next := next; shutdown := shutdown |}
              end
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Points.S.ban
      (fun point =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Points.untrust pool point in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Points.ban pool point in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Points.S.unban
      (fun point =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Points.unban pool point in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Points.S.trust
      (fun point =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Points.trust pool point in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Points.S.untrust
      (fun point =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.Points.untrust pool point in
              RPC_answer.return_unit
            end) in
  let dir :=
    RPC_directory.gen_register1 dir P2p_services.Points.S.banned
      (fun point =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => RPC_answer.not_found
            | Some pool => RPC_answer._return false
            | Some pool =>
              RPC_answer._return (P2p_pool.Points.banned pool point)
            end) in
  let dir :=
    RPC_directory.register dir P2p_services.ACL.S.clear
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match P2p.pool net with
            | None => return_unit
            | Some pool =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := P2p_pool.acl_clear pool in
              return_unit
            end) in
  dir.

src/lib_shell/peer_validator.ml 95 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* FIXME ignore/postpone fetching/validating of block in the future... *)

open Peer_validator_worker_state

module Name = struct
  type t = Chain_id.t * P2p_peer.Id.t

  let encoding = Data_encoding.tup2 Chain_id.encoding P2p_peer.Id.encoding

  let base = ["validator"; "peer"]

  let pp ppf (chain, peer) =
    Format.fprintf
      ppf
      "%a:%a"
      Chain_id.pp_short
      chain
      P2p_peer.Id.pp_short
      peer
end

module Request = struct
  include Request

  type _ t =
    | New_head : Block_hash.t * Block_header.t -> unit t
    | New_branch :
        Block_hash.t * Block_locator.t * Block_locator.seed
        -> unit t

  let view (type a) (req : a t) : view =
    match req with
    | New_head (hash, _) ->
        New_head hash
    | New_branch (hash, locator, seed) ->
        (* the seed is associated to each locator
           w.r.t. the peer_id of the sender *)
        New_branch (hash, Block_locator.estimated_length seed locator)
end

type limits = {
  new_head_request_timeout : Time.System.Span.t;
  block_header_timeout : Time.System.Span.t;
  block_operations_timeout : Time.System.Span.t;
  protocol_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
}

module Types = struct
  include Worker_state

  type parameters = {
    chain_db : Distributed_db.chain_db;
    block_validator : Block_validator.t;
    (* callback to chain_validator *)
    notify_new_block : State.Block.t -> unit;
    notify_bootstrapped : unit -> unit;
    notify_termination : unit -> unit;
    limits : limits;
  }

  type state = {
    peer_id : P2p_peer.Id.t;
    parameters : parameters;
    mutable bootstrapped : bool;
    mutable pipeline : Bootstrap_pipeline.t option;
    mutable last_validated_head : Block_header.t;
    mutable last_advertised_head : Block_header.t;
  }

  let pipeline_length = function
    | None ->
        Bootstrap_pipeline.length_zero
    | Some p ->
        Bootstrap_pipeline.length p

  let view (state : state) _ : view =
    let {bootstrapped; pipeline; last_validated_head; last_advertised_head; _}
        =
      state
    in
    {
      bootstrapped;
      pipeline_length = pipeline_length pipeline;
      last_validated_head = Block_header.hash last_validated_head;
      last_advertised_head = Block_header.hash last_advertised_head;
    }
end

module Logger = Worker_logger.Make (Event) (Request)
module Worker = Worker.Make (Name) (Event) (Request) (Types) (Logger)
open Types

type t = Worker.dropbox Worker.t

let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))

let set_bootstrapped pv =
  if not pv.bootstrapped then (
    pv.bootstrapped <- true ;
    pv.parameters.notify_bootstrapped () )

let bootstrap_new_branch w _head unknown_prefix =
  let pv = Worker.state w in
  let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in
  (* sender and receiver are inverted here because they are from
     the point of view of the node sending the locator *)
  let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in
  let len = Block_locator.estimated_length seed unknown_prefix in
  debug
    w
    "validating new branch from peer %a (approx. %d blocks)"
    P2p_peer.Id.pp_short
    pv.peer_id
    len ;
  let pipeline =
    Bootstrap_pipeline.create
      ~notify_new_block:pv.parameters.notify_new_block
      ~block_header_timeout:pv.parameters.limits.block_header_timeout
      ~block_operations_timeout:pv.parameters.limits.block_operations_timeout
      pv.parameters.block_validator
      pv.peer_id
      pv.parameters.chain_db
      unknown_prefix
  in
  pv.pipeline <- Some pipeline ;
  Worker.protect
    w
    ~on_error:(fun error ->
      (* if the peer_validator is killed, let's cancel the pipeline *)
      pv.pipeline <- None ;
      Bootstrap_pipeline.cancel pipeline >>= fun () -> Lwt.return_error error)
    (fun () -> Bootstrap_pipeline.wait pipeline)
  >>=? fun () ->
  pv.pipeline <- None ;
  set_bootstrapped pv ;
  debug
    w
    "done validating new branch from peer %a."
    P2p_peer.Id.pp_short
    pv.peer_id ;
  return_unit

let validate_new_head w hash (header : Block_header.t) =
  let pv = Worker.state w in
  debug
    w
    "fetching operations for new head %a from peer %a"
    Block_hash.pp_short
    hash
    P2p_peer.Id.pp_short
    pv.peer_id ;
  map_p
    (fun i ->
      Worker.protect w (fun () ->
          Distributed_db.Operations.fetch
            ~timeout:pv.parameters.limits.block_operations_timeout
            pv.parameters.chain_db
            ~peer:pv.peer_id
            (hash, i)
            header.shell.operations_hash))
    (0 -- (header.shell.validation_passes - 1))
  >>=? fun operations ->
  debug
    w
    "requesting validation for new head %a from peer %a"
    Block_hash.pp_short
    hash
    P2p_peer.Id.pp_short
    pv.peer_id ;
  Block_validator.validate
    ~notify_new_block:pv.parameters.notify_new_block
    pv.parameters.block_validator
    pv.parameters.chain_db
    hash
    header
    operations
  >>=? fun _block ->
  debug
    w
    "end of validation for new head %a from peer %a"
    Block_hash.pp_short
    hash
    P2p_peer.Id.pp_short
    pv.peer_id ;
  set_bootstrapped pv ;
  let meta =
    Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id
  in
  Peer_metadata.incr meta Valid_blocks ;
  return_unit

let only_if_fitness_increases w distant_header cont =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  Chain.head chain_state
  >>= fun local_header ->
  if
    Fitness.compare
      distant_header.Block_header.shell.fitness
      (State.Block.fitness local_header)
    <= 0
  then (
    set_bootstrapped pv ;
    debug
      w
      "ignoring head %a with non increasing fitness from peer: %a."
      Block_hash.pp_short
      (Block_header.hash distant_header)
      P2p_peer.Id.pp_short
      pv.peer_id ;
    (* Don't download a branch that cannot beat the current head. *)
    let meta =
      Distributed_db.get_peer_metadata pv.parameters.chain_db pv.peer_id
    in
    Peer_metadata.incr meta Old_heads ;
    return_unit )
  else cont ()

let assert_acceptable_head w hash (header : Block_header.t) =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Chain.acceptable_block chain_state header
  >>= fun acceptable ->
  fail_unless
    acceptable
    (Validation_errors.Checkpoint_error (hash, Some pv.peer_id))

let may_validate_new_head w hash (header : Block_header.t) =
  let pv = Worker.state w in
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Block.known_valid chain_state hash
  >>= fun valid_block ->
  State.Block.known_invalid chain_state hash
  >>= fun invalid_block ->
  State.Block.known_valid chain_state header.shell.predecessor
  >>= fun valid_predecessor ->
  State.Block.known_invalid chain_state header.shell.predecessor
  >>= fun invalid_predecessor ->
  if valid_block then (
    debug
      w
      "ignoring previously validated block %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    set_bootstrapped pv ;
    pv.last_validated_head <- header ;
    return_unit )
  else if invalid_block then (
    debug
      w
      "ignoring known invalid block %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    fail Validation_errors.Known_invalid )
  else if invalid_predecessor then (
    debug
      w
      "ignoring known invalid block %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    Distributed_db.commit_invalid_block
      pv.parameters.chain_db
      hash
      header
      [Validation_errors.Known_invalid]
    >>=? fun _ -> fail Validation_errors.Known_invalid )
  else if not valid_predecessor then (
    debug
      w
      "missing predecessor for new head %a from peer %a"
      Block_hash.pp_short
      hash
      P2p_peer.Id.pp_short
      pv.peer_id ;
    Distributed_db.Request.current_branch
      pv.parameters.chain_db
      ~peer:pv.peer_id
      () ;
    return_unit )
  else
    only_if_fitness_increases w header
    @@ fun () ->
    assert_acceptable_head w hash header
    >>=? fun () -> validate_new_head w hash header

let may_validate_new_branch w distant_hash locator =
  let pv = Worker.state w in
  let (distant_header, _) =
    (locator : Block_locator.t :> Block_header.t * _)
  in
  only_if_fitness_increases w distant_header
  @@ fun () ->
  assert_acceptable_head w (Block_header.hash distant_header) distant_header
  >>=? fun () ->
  let chain_state = Distributed_db.chain_state pv.parameters.chain_db in
  State.Block.known_ancestor chain_state locator
  >>= function
  | None ->
      debug
        w
        "ignoring branch %a without common ancestor from peer: %a."
        Block_hash.pp_short
        distant_hash
        P2p_peer.Id.pp_short
        pv.peer_id ;
      fail Validation_errors.Unknown_ancestor
  | Some unknown_prefix ->
      let (_, history) = Block_locator.raw unknown_prefix in
      if history <> [] then
        bootstrap_new_branch w distant_header unknown_prefix
      else return_unit

let on_no_request w =
  let pv = Worker.state w in
  debug
    w
    "no new head from peer %a for %g seconds."
    P2p_peer.Id.pp_short
    pv.peer_id
    (Ptime.Span.to_float_s pv.parameters.limits.new_head_request_timeout) ;
  Distributed_db.Request.current_head
    pv.parameters.chain_db
    ~peer:pv.peer_id
    () ;
  return_unit

let on_request (type a) w (req : a Request.t) : a tzresult Lwt.t =
  let pv = Worker.state w in
  match req with
  | Request.New_head (hash, header) ->
      debug
        w
        "processing new head %a from peer %a."
        Block_hash.pp_short
        hash
        P2p_peer.Id.pp_short
        pv.peer_id ;
      may_validate_new_head w hash header
  | Request.New_branch (hash, locator, _seed) ->
      (* TODO penalize empty locator... ?? *)
      debug
        w
        "processing new branch %a from peer %a."
        Block_hash.pp_short
        hash
        P2p_peer.Id.pp_short
        pv.peer_id ;
      may_validate_new_branch w hash locator

let on_completion w r _ st =
  Worker.record_event w (Event.Request (Request.view r, st, None)) ;
  Lwt.return_unit

let on_error w r st err =
  let pv = Worker.state w in
  match err with
  | ( Validation_errors.Unknown_ancestor
    | Validation_errors.Invalid_locator _
    | Block_validator_errors.Invalid_block _ )
    :: _ as errors ->
      Distributed_db.greylist pv.parameters.chain_db pv.peer_id
      >>= fun () ->
      debug
        w
        "Terminating the validation worker for peer %a (kickban)."
        P2p_peer.Id.pp_short
        pv.peer_id ;
      debug w "%a" Error_monad.pp_print_error errors ;
      Worker.trigger_shutdown w ;
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      Lwt.return_error err
  | Block_validator_errors.System_error _ :: _ ->
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      return_unit
  | Block_validator_errors.Unavailable_protocol {protocol; _} :: _ -> (
      Block_validator.fetch_and_compile_protocol
        pv.parameters.block_validator
        ~peer:pv.peer_id
        ~timeout:pv.parameters.limits.protocol_timeout
        protocol
      >>= function
      | Ok _ ->
          Distributed_db.Request.current_head
            pv.parameters.chain_db
            ~peer:pv.peer_id
            () ;
          return_unit
      | Error _ ->
          (* TODO: punish *)
          debug
            w
            "Terminating the validation worker for peer %a (missing protocol \
             %a)."
            P2p_peer.Id.pp_short
            pv.peer_id
            Protocol_hash.pp_short
            protocol ;
          Worker.record_event w (Event.Request (r, st, Some err)) ;
          Lwt.return_error err )
  | Validation_errors.Too_short_locator _ :: _ ->
      debug
        w
        "Terminating the validation worker for peer %a (kick)."
        P2p_peer.Id.pp_short
        pv.peer_id ;
      Worker.trigger_shutdown w ;
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      return_unit
  | _ ->
      Worker.record_event w (Event.Request (r, st, Some err)) ;
      Lwt.return_error err

let on_close w =
  let pv = Worker.state w in
  Distributed_db.disconnect pv.parameters.chain_db pv.peer_id
  >>= fun () ->
  pv.parameters.notify_termination () ;
  Lwt.return_unit

let on_launch _ name parameters =
  let chain_state = Distributed_db.chain_state parameters.chain_db in
  State.Block.read_opt chain_state (State.Chain.genesis chain_state).block
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun genesis ->
  let rec pv =
    {
      peer_id = snd name;
      parameters = {parameters with notify_new_block};
      bootstrapped = false;
      pipeline = None;
      last_validated_head = State.Block.header genesis;
      last_advertised_head = State.Block.header genesis;
    }
  and notify_new_block block =
    pv.last_validated_head <- State.Block.header block ;
    parameters.notify_new_block block
  in
  return pv

let table =
  let merge w (Worker.Any_request neu) old =
    let pv = Worker.state w in
    match neu with
    | Request.New_branch (_, locator, _) ->
        let (header, _) = (locator : Block_locator.t :> _ * _) in
        pv.last_advertised_head <- header ;
        Some (Worker.Any_request neu)
    | Request.New_head (_, header) -> (
        pv.last_advertised_head <- header ;
        (* TODO penalize decreasing fitness *)
        match old with
        | Some (Worker.Any_request (Request.New_branch _) as old) ->
            Some old (* ignore *)
        | Some (Worker.Any_request (Request.New_head _)) ->
            Some (Any_request neu)
        | None ->
            Some (Any_request neu) )
  in
  Worker.create_table (Dropbox {merge})

let create ?(notify_new_block = fun _ -> ())
    ?(notify_bootstrapped = fun () -> ()) ?(notify_termination = fun _ -> ())
    limits block_validator chain_db peer_id =
  let name = (State.Chain.id (Distributed_db.chain_state chain_db), peer_id) in
  let parameters =
    {
      chain_db;
      notify_termination;
      block_validator;
      notify_new_block;
      notify_bootstrapped;
      limits;
    }
  in
  let module Handlers = struct
    type self = t

    let on_launch = on_launch

    let on_request = on_request

    let on_close = on_close

    let on_error = on_error

    let on_completion = on_completion

    let on_no_request = on_no_request
  end in
  Worker.launch
    table
    ~timeout:limits.new_head_request_timeout
    limits.worker_limits
    name
    parameters
    (module Handlers)

let notify_branch w locator =
  let (header, _) = (locator : Block_locator.t :> _ * _) in
  let hash = Block_header.hash header in
  let pv = Worker.state w in
  let sender_id = Distributed_db.my_peer_id pv.parameters.chain_db in
  (* sender and receiver are inverted here because they are from
     the point of view of the node sending the locator *)
  let seed = {Block_locator.sender_id = pv.peer_id; receiver_id = sender_id} in
  Worker.Dropbox.put_request w (New_branch (hash, locator, seed))

let notify_head w header =
  let hash = Block_header.hash header in
  Worker.Dropbox.put_request w (New_head (hash, header))

let shutdown w = Worker.shutdown w

let peer_id w =
  let pv = Worker.state w in
  pv.peer_id

let bootstrapped w =
  let pv = Worker.state w in
  pv.bootstrapped

let current_head w =
  let pv = Worker.state w in
  pv.last_validated_head

let status = Worker.status

let information = Worker.information

let running_workers () = Worker.list table

let current_request t = Worker.current_request t

let last_events = Worker.last_events

let pipeline_length w =
  let state = Worker.state w in
  Types.pipeline_length state.pipeline
src/lib_shell/peer_validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Peer_validator_worker_state.

Module Name.
  Definition t :=
    Tezos_base__TzPervasives.Chain_id.t * Tezos_base__TzPervasives.P2p_peer.Id.t.
  
  Definition encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.P2p_peer.Id.t) :=
    Data_encoding.tup2 Chain_id.encoding P2p_peer.Id.encoding.
  
  Definition base : list string :=
    cons "validator" % string (cons "peer" % string []).
  
  Definition pp
    (ppf : Stdlib.Format.formatter)
    (function_parameter :
      Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.P2p_peer.Id.t) : unit :=
    let '(chain, peer) := function_parameter in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Char_literal ":" % char
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a:%a" % string)
      Chain_id.pp_short chain P2p_peer.Id.pp_short peer.
End Name.

Module Request.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Inductive t : forall (_ : Type), Type :=
  | New_head : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_header.t -> t unit
  | New_branch : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_locator.t ->
    Tezos_base__TzPervasives.Block_locator.seed -> t unit.
  
  Definition view {A : Type} (req : t A) : view :=
    match req with
    | New_head hash _ => New_head hash
    | New_branch hash locator seed =>
      New_branch hash (Block_locator.estimated_length seed locator)
    end.
End Request.

Record limits := {
  new_head_request_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_header_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  block_operations_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  protocol_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits }.

Module Types.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Record parameters := {
    chain_db : Tezos_shell.Distributed_db.chain_db;
    block_validator : Tezos_shell.Block_validator.t;
    notify_new_block : Tezos_shell.State.Block.t -> unit;
    notify_bootstrapped : unit -> unit;
    notify_termination : unit -> unit;
    limits : limits }.
  
  Record state := {
    peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t;
    parameters : parameters;
    bootstrapped : bool;
    pipeline : option Tezos_shell.Bootstrap_pipeline.t;
    last_validated_head : Tezos_base__TzPervasives.Block_header.t;
    last_advertised_head : Tezos_base__TzPervasives.Block_header.t }.
  
  Definition pipeline_length
    (function_parameter : option Tezos_shell.Bootstrap_pipeline.t)
    : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
    match function_parameter with
    | None => Bootstrap_pipeline.length_zero
    | Some p => Bootstrap_pipeline.length p
    end.
  
  Definition view {A : Type} (state : state) (function_parameter : A) : view :=
    let '_ := function_parameter in
    let '{|
      bootstrapped := bootstrapped;
        pipeline := pipeline;
        last_validated_head := last_validated_head;
        last_advertised_head := last_advertised_head
        |} := state in
    {| bootstrapped := bootstrapped;
      pipeline_length := pipeline_length pipeline;
      last_validated_head := Block_header.hash last_validated_head;
      last_advertised_head := Block_header.hash last_advertised_head |}.
End Types.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Import Types.

Definition t := Worker.t Worker.dropbox.

Definition debug {A B : Type} (w : Worker.t A)
  : (Stdlib.format4 B Stdlib.Format.formatter unit unit) -> B :=
  Format.kasprintf
    (fun msg =>
      Worker.record_event w
        (Tezos_shell_services.Peer_validator_worker_state.Event.Debug msg)).

Definition set_bootstrapped (pv : Types.state) : unit :=
  if negb (bootstrapped pv) then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field pv "bootstrapped" % string true in
    (notify_bootstrapped (parameters pv)) tt
  else
    tt.

Definition bootstrap_new_branch {A B : Type}
  (w : Worker.t A) (_head : B)
  (unknown_prefix : Tezos_base__TzPervasives.Block_locator.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let sender_id := Distributed_db.my_peer_id (chain_db (parameters pv)) in
  let seed :=
    {| Block_locator.sender_id := peer_id pv;
      Block_locator.receiver_id := sender_id |} in
  let len := Block_locator.estimated_length seed unknown_prefix in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    debug w
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "validating new branch from peer " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " (approx. " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " blocks)" % string
                  CamlinternalFormatBasics.End_of_format)))))
        "validating new branch from peer %a (approx. %d blocks)" % string)
      P2p_peer.Id.pp_short (peer_id pv) len in
  let pipeline :=
    Bootstrap_pipeline.create (Some (notify_new_block (parameters pv)))
      (block_header_timeout (limits (parameters pv)))
      (block_operations_timeout (limits (parameters pv)))
      (block_validator (parameters pv)) (peer_id pv) (chain_db (parameters pv))
      unknown_prefix in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field pv "pipeline" % string (Some pipeline) in
  op_gtgteqquestion
    (Worker.protect w
      (Some
        (fun error =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field pv "pipeline" % string None in
          op_gtgteq (Bootstrap_pipeline.cancel pipeline)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.return_error error)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Bootstrap_pipeline.wait pipeline))
    (fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field pv "pipeline" % string None in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := set_bootstrapped pv in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        debug w
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "done validating new branch from peer " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal "." % char
                  CamlinternalFormatBasics.End_of_format)))
            "done validating new branch from peer %a." % string)
          P2p_peer.Id.pp_short (peer_id pv) in
      return_unit).

Definition validate_new_head {A : Type}
  (w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    debug w
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "fetching operations for new head " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " from peer " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))))
        "fetching operations for new head %a from peer %a" % string)
      Block_hash.pp_short hash P2p_peer.Id.pp_short (peer_id pv) in
  op_gtgteqquestion
    (map_p
      (fun i =>
        Worker.protect w None
          (fun function_parameter =>
            let 'tt := function_parameter in
            Distributed_db.Operations.fetch (chain_db (parameters pv))
              (Some (peer_id pv))
              (Some (block_operations_timeout (limits (parameters pv))))
              (hash, i) (operations_hash (shell header))))
      (op_minusminus 0 (Z.sub (validation_passes (shell header)) 1)))
    (fun operations =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        debug w
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "requesting validation for new head " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " from peer " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))))
            "requesting validation for new head %a from peer %a" % string)
          Block_hash.pp_short hash P2p_peer.Id.pp_short (peer_id pv) in
      op_gtgteqquestion
        (Block_validator.validate (block_validator (parameters pv)) None None
          (Some (notify_new_block (parameters pv))) (chain_db (parameters pv))
          hash header operations)
        (fun _block =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            debug w
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "end of validation for new head " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " from peer " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "end of validation for new head %a from peer %a" % string)
              Block_hash.pp_short hash P2p_peer.Id.pp_short (peer_id pv) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := set_bootstrapped pv in
          let meta :=
            Distributed_db.get_peer_metadata (chain_db (parameters pv))
              (peer_id pv) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Peer_metadata.incr meta
              Tezos_shell_services.Peer_metadata.Valid_blocks in
          return_unit)).

Definition only_if_fitness_increases {A : Type}
  (w : Worker.t A) (distant_header : Tezos_base__TzPervasives.Block_header.t)
  (cont : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
  op_gtgteq (Chain.head chain_state)
    (fun local_header =>
      if
        OCaml.Stdlib.le
          (Fitness.compare (fitness (Block_header.shell distant_header))
            (State.Block.fitness local_header)) 0 then
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := set_bootstrapped pv in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "ignoring head " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " with non increasing fitness from peer: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "." % char
                        CamlinternalFormatBasics.End_of_format)))))
              "ignoring head %a with non increasing fitness from peer: %a." %
                string) Block_hash.pp_short (Block_header.hash distant_header)
            P2p_peer.Id.pp_short (peer_id pv) in
        let meta :=
          Distributed_db.get_peer_metadata (chain_db (parameters pv))
            (peer_id pv) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Peer_metadata.incr meta Tezos_shell_services.Peer_metadata.Old_heads
          in
        return_unit
      else
        cont tt).

Definition assert_acceptable_head {A : Type}
  (w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
  op_gtgteq (State.Chain.acceptable_block chain_state header)
    (fun acceptable =>
      fail_unless acceptable
        (Tezos_base__TzPervasives.Checkpoint_error hash (Some (peer_id pv)))).

Definition may_validate_new_head {A : Type}
  (w : Worker.t A) (hash : Tezos_base__TzPervasives.Block_hash.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let chain_state := Distributed_db.chain_state (chain_db (parameters pv)) in
  op_gtgteq (State.Block.known_valid chain_state hash)
    (fun valid_block =>
      op_gtgteq (State.Block.known_invalid chain_state hash)
        (fun invalid_block =>
          op_gtgteq
            (State.Block.known_valid chain_state (predecessor (shell header)))
            (fun valid_predecessor =>
              op_gtgteq
                (State.Block.known_invalid chain_state
                  (predecessor (shell header)))
                (fun invalid_predecessor =>
                  if valid_block then
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      debug w
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "ignoring previously validated block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " from peer " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))))
                          "ignoring previously validated block %a from peer %a"
                            % string) Block_hash.pp_short hash
                        P2p_peer.Id.pp_short (peer_id pv) in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := set_bootstrapped pv in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      (* ❌ Set record field not handled. *)
                      set_record_field pv "last_validated_head" % string header
                      in
                    return_unit
                  else
                    if invalid_block then
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        debug w
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "ignoring known invalid block " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " from peer " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))))
                            "ignoring known invalid block %a from peer %a" %
                              string) Block_hash.pp_short hash
                          P2p_peer.Id.pp_short (peer_id pv) in
                      fail Tezos_base__TzPervasives.Known_invalid
                    else
                      if invalid_predecessor then
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          debug w
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "ignoring known invalid block " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " from peer " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format))))
                              "ignoring known invalid block %a from peer %a" %
                                string) Block_hash.pp_short hash
                            P2p_peer.Id.pp_short (peer_id pv) in
                        op_gtgteqquestion
                          (Distributed_db.commit_invalid_block
                            (chain_db (parameters pv)) hash header
                            (cons Tezos_base__TzPervasives.Known_invalid []))
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            fail Tezos_base__TzPervasives.Known_invalid)
                      else
                        if negb valid_predecessor then
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            debug w
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "missing predecessor for new head " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      " from peer " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))))
                                "missing predecessor for new head %a from peer %a"
                                  % string) Block_hash.pp_short hash
                              P2p_peer.Id.pp_short (peer_id pv) in
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            Distributed_db.Request.current_branch
                              (chain_db (parameters pv)) (Some (peer_id pv)) tt
                            in
                          return_unit
                        else
                          apply (only_if_fitness_increases w header)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (assert_acceptable_head w hash header)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  validate_new_head w hash header)))))).

Definition may_validate_new_branch {A : Type}
  (w : Worker.t A) (distant_hash : Tezos_base__TzPervasives.Block_hash.t)
  (locator : Tezos_base__TzPervasives.Block_locator.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  let '(distant_header, _) := locator in
  apply (only_if_fitness_increases w distant_header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (assert_acceptable_head w (Block_header.hash distant_header)
          distant_header)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let chain_state :=
            Distributed_db.chain_state (chain_db (parameters pv)) in
          op_gtgteq (State.Block.known_ancestor chain_state locator)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  debug w
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "ignoring branch " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " without common ancestor from peer: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal "." % char
                                CamlinternalFormatBasics.End_of_format)))))
                      "ignoring branch %a without common ancestor from peer: %a."
                        % string) Block_hash.pp_short distant_hash
                    P2p_peer.Id.pp_short (peer_id pv) in
                fail Tezos_base__TzPervasives.Unknown_ancestor
              | Some unknown_prefix =>
                let '(_, history) := Block_locator.raw unknown_prefix in
                if nequiv_decb history [] then
                  bootstrap_new_branch w distant_header unknown_prefix
                else
                  return_unit
              end))).

Definition on_no_request {A : Type} (w : Worker.t A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let pv := Worker.state w in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    debug w
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "no new head from peer " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " for " % string
              (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_g
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal " seconds." % string
                  CamlinternalFormatBasics.End_of_format)))))
        "no new head from peer %a for %g seconds." % string)
      P2p_peer.Id.pp_short (peer_id pv)
      (Ptime.Span.to_float_s (new_head_request_timeout (limits (parameters pv))))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Distributed_db.Request.current_head (chain_db (parameters pv))
      (Some (peer_id pv)) tt in
  return_unit.

Definition on_request {A B : Type}
  (w : Worker.t A) (req : Request.(Tezos_shell__Worker.REQUEST.t) B)
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  let pv := Worker.state w in
  match req with
  | Request.New_head hash header =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      debug w
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "processing new head " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " from peer " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))))
          "processing new head %a from peer %a." % string) Block_hash.pp_short
        hash P2p_peer.Id.pp_short (peer_id pv) in
    may_validate_new_head w hash header
  | Request.New_branch hash locator _seed =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      debug w
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "processing new branch " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " from peer " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))))
          "processing new branch %a from peer %a." % string) Block_hash.pp_short
        hash P2p_peer.Id.pp_short (peer_id pv) in
    may_validate_new_branch w hash locator
  end.

Definition on_completion {A B C : Type}
  (w : Worker.t A) (r : Request.(Tezos_shell__Worker.REQUEST.t) B)
  (function_parameter : C)
  : Tezos_shell_services.Worker_types.request_status -> Lwt.t unit :=
  let '_ := function_parameter in
  fun st =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Worker.record_event w
        (Tezos_shell_services.Peer_validator_worker_state.Event.Request
          ((Request.(Tezos_shell__Worker.REQUEST.view) r), st, None)) in
    Lwt.return_unit.

Definition on_error {A : Type}
  (w : Worker.t A)
  (r : Tezos_shell_services__Peer_validator_worker_state.Request.view)
  (st : Tezos_shell_services.Worker_types.request_status)
  (err : Tezos_base__TzPervasives.trace)
  : Lwt.t (Result.result unit Tezos_base__TzPervasives.trace) :=
  let pv := Worker.state w in
  match err with
  |
    (cons
      (Tezos_base__TzPervasives.Unknown_ancestor |
        Tezos_base__TzPervasives.Invalid_locator _ _ |
        Tezos_base__TzPervasives.Invalid_block _) _) as errors =>
    op_gtgteq (Distributed_db.greylist (chain_db (parameters pv)) (peer_id pv))
      (fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Terminating the validation worker for peer " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " (kickban)." % string
                    CamlinternalFormatBasics.End_of_format)))
              "Terminating the validation worker for peer %a (kickban)." %
                string) P2p_peer.Id.pp_short (peer_id pv) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          debug w
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Error_monad.pp_print_error errors in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Worker.trigger_shutdown w in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Worker.record_event w
            (Tezos_shell_services.Peer_validator_worker_state.Event.Request
              (r, st, (Some err))) in
        Lwt.return_error err)
  | cons (Tezos_base__TzPervasives.System_error _) _ =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Worker.record_event w
        (Tezos_shell_services.Peer_validator_worker_state.Event.Request
          (r, st, (Some err))) in
    return_unit
  |
    cons
      (Tezos_base__TzPervasives.Unavailable_protocol {| protocol := protocol |})
      _ =>
    op_gtgteq
      (Block_validator.fetch_and_compile_protocol
        (block_validator (parameters pv)) (Some (peer_id pv))
        (Some (protocol_timeout (limits (parameters pv)))) protocol)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok _ =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Distributed_db.Request.current_head (chain_db (parameters pv))
              (Some (peer_id pv)) tt in
          return_unit
        | Stdlib.Error _ =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            debug w
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Terminating the validation worker for peer " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " (missing protocol " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal ")." % string
                          CamlinternalFormatBasics.End_of_format)))))
                "Terminating the validation worker for peer %a (missing protocol %a)."
                  % string) P2p_peer.Id.pp_short (peer_id pv)
              Protocol_hash.pp_short protocol in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Worker.record_event w
              (Tezos_shell_services.Peer_validator_worker_state.Event.Request
                (r, st, (Some err))) in
          Lwt.return_error err
        end)
  | cons (Tezos_base__TzPervasives.Too_short_locator _ _) _ =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      debug w
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Terminating the validation worker for peer " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " (kick)." % string
                CamlinternalFormatBasics.End_of_format)))
          "Terminating the validation worker for peer %a (kick)." % string)
        P2p_peer.Id.pp_short (peer_id pv) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Worker.trigger_shutdown w in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Worker.record_event w
        (Tezos_shell_services.Peer_validator_worker_state.Event.Request
          (r, st, (Some err))) in
    return_unit
  | _ =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Worker.record_event w
        (Tezos_shell_services.Peer_validator_worker_state.Event.Request
          (r, st, (Some err))) in
    Lwt.return_error err
  end.

Definition on_close {A : Type} (w : Worker.t A) : Lwt.t unit :=
  let pv := Worker.state w in
  op_gtgteq (Distributed_db.disconnect (chain_db (parameters pv)) (peer_id pv))
    (fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := (notify_termination (parameters pv)) tt in
      Lwt.return_unit).

Definition on_launch {A B : Type} (function_parameter : A)
  : (B * Tezos_base__TzPervasives.P2p_peer.Id.t) ->
    Types.parameters -> Lwt.t (Tezos_base__TzPervasives.tzresult Types.state) :=
  let '_ := function_parameter in
  fun name =>
    fun parameters =>
      let chain_state := Distributed_db.chain_state (chain_db parameters) in
      op_gtgteq
        (op_gtpipeeq
          (State.Block.read_opt chain_state
            (block (State.Chain.genesis chain_state)))
          (Option.unopt_assert Stdlib.__POS__))
        (fun genesis =>
          let fix pv : Types.state :=
            {| peer_id := snd name;
              parameters :=
                (* ❌ Record substitution not handled *)
                record_substitution; bootstrapped := false; pipeline := None;
              last_validated_head := State.Block.header genesis;
              last_advertised_head := State.Block.header genesis |}
          with notify_new_block (block : Tezos_shell.State.Block.t) : unit :=
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field pv "last_validated_head" % string
                (State.Block.header block) in
            (notify_new_block parameters) block in
          _return pv).

Definition table : Worker.table Worker.dropbox :=
  let merge {A : Type}
    (w : Worker.t A) (function_parameter : Worker.any_request)
    : (option Worker.any_request) -> option Worker.any_request :=
    let 'Worker.Any_request neu := function_parameter in
    fun old =>
      let pv := Worker.state w in
      match neu with
      | Request.New_branch _ locator _ =>
        let '(header, _) := locator in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pv "last_advertised_head" % string header in
        Some (Worker.Any_request neu)
      | Request.New_head _ header =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field pv "last_advertised_head" % string header in
        match old with
        | Some ((Worker.Any_request (Request.New_branch _ _ _)) as old) =>
          Some old
        | Some (Worker.Any_request (Request.New_head _ _)) =>
          Some (Worker.Any_request neu)
        | None => Some (Worker.Any_request neu)
        end
      end in
  Worker.create_table (Worker.Dropbox {| merge := merge |}).

Definition create (op_staroptstar : option (Tezos_shell.State.Block.t -> unit))
  : (option (unit -> unit)) ->
    (option (unit -> unit)) ->
      limits ->
        Tezos_shell.Block_validator.t ->
          Tezos_shell.Distributed_db.chain_db ->
            Tezos_base__TzPervasives.P2p_peer.Id.t ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult (Worker.t Worker.dropbox)) :=
  let notify_new_block :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        tt
    end in
  fun op_staroptstar =>
    let notify_bootstrapped :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None =>
        fun function_parameter =>
          let 'tt := function_parameter in
          tt
      end in
    fun op_staroptstar =>
      let notify_termination :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          fun function_parameter =>
            let '_ := function_parameter in
            tt
        end in
      fun limits =>
        fun block_validator =>
          fun chain_db =>
            fun peer_id =>
              let name :=
                ((State.Chain.id (Distributed_db.chain_state chain_db)), peer_id)
                in
              let parameters :=
                {| chain_db := chain_db; block_validator := block_validator;
                  notify_new_block := notify_new_block;
                  notify_bootstrapped := notify_bootstrapped;
                  notify_termination := notify_termination; limits := limits |}
                in
              let Handlers :=
                existT _ unit
                  {|
                    (* ❌ This kind of definition of value for first-class modules is not handled *)
                    Worker.HANDLERS.on_launch := unhandled;
                    (* ❌ This kind of definition of value for first-class modules is not handled *)
                    Worker.HANDLERS.on_request := unhandled;
                    (* ❌ This kind of definition of value for first-class modules is not handled *)
                    Worker.HANDLERS.on_close := unhandled;
                    (* ❌ This kind of definition of value for first-class modules is not handled *)
                    Worker.HANDLERS.on_error := unhandled;
                    (* ❌ This kind of definition of value for first-class modules is not handled *)
                    Worker.HANDLERS.on_completion := unhandled;
                    (* ❌ This kind of definition of value for first-class modules is not handled *)
                    Worker.HANDLERS.on_no_request := unhandled
                    |} in
              Worker.launch table (Some (new_head_request_timeout limits))
                (worker_limits limits) name parameters Handlers.

Definition notify_branch
  (w : Worker.t Worker.dropbox)
  (locator : Tezos_base__TzPervasives.Block_locator.t) : unit :=
  let '(header, _) := locator in
  let hash := Block_header.hash header in
  let pv := Worker.state w in
  let sender_id := Distributed_db.my_peer_id (chain_db (parameters pv)) in
  let seed :=
    {| Block_locator.sender_id := peer_id pv;
      Block_locator.receiver_id := sender_id |} in
  Worker.Dropbox.put_request w (Request.New_branch hash locator seed).

Definition notify_head
  (w : Worker.t Worker.dropbox)
  (header : Tezos_base__TzPervasives.Block_header.t) : unit :=
  let hash := Block_header.hash header in
  Worker.Dropbox.put_request w (Request.New_head hash header).

Definition shutdown {A : Type} (w : Worker.t A) : Lwt.t unit :=
  Worker.shutdown w.

Definition peer_id {A : Type} (w : Worker.t A)
  : Tezos_base__TzPervasives.P2p_peer.Id.t :=
  let pv := Worker.state w in
  peer_id pv.

Definition bootstrapped {A : Type} (w : Worker.t A) : bool :=
  let pv := Worker.state w in
  bootstrapped pv.

Definition current_head {A : Type} (w : Worker.t A)
  : Tezos_base__TzPervasives.Block_header.t :=
  let pv := Worker.state w in
  last_validated_head pv.

Definition status {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_status :=
  Worker.status.

Definition information {A : Type}
  : (Worker.t A) -> Tezos_shell_services.Worker_types.worker_information :=
  Worker.information.

Definition running_workers (function_parameter : unit)
  : list (Worker.Name.(Tezos_shell__Worker.NAME.t) * (Worker.t Worker.dropbox)) :=
  let 'tt := function_parameter in
  Worker.list table.

Definition current_request {A : Type} (t : Worker.t A)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Worker.Request.(Tezos_shell__Worker.REQUEST.view)) :=
  Worker.current_request t.

Definition last_events {A : Type}
  : (Worker.t A) ->
    list
      (Tezos_base__TzPervasives.Internal_event.level *
        (list Worker.Event.(Tezos_shell__Worker.EVENT.t))) := Worker.last_events.

Definition pipeline_length {A : Type} (w : Worker.t A)
  : Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length :=
  let state := Worker.state w in
  Types.pipeline_length (pipeline state).

src/lib_shell/prevalidation.ml 20 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Validation_errors

module type T = sig
  module Proto : Registered_protocol.T

  type t

  type operation = private {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  val compare : operation -> operation -> int

  val parse : Operation.t -> operation tzresult

  (** Creates a new prevalidation context w.r.t. the protocol associate to the
      predecessor block . When ?protocol_data is passed to this function, it will
      be used to create the new block *)
  val create :
    ?protocol_data:Bytes.t ->
    predecessor:State.Block.t ->
    timestamp:Time.Protocol.t ->
    unit ->
    t tzresult Lwt.t

  type result =
    | Applied of t * Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Outdated

  val apply_operation : t -> operation -> result Lwt.t

  type status = {
    applied_operations : (operation * Proto.operation_receipt) list;
    block_result : Tezos_protocol_environment.validation_result;
    block_metadata : Proto.block_header_metadata;
  }

  val status : t -> status tzresult Lwt.t

  val pp_result : Format.formatter -> result -> unit
end

module Make (Proto : Registered_protocol.T) : T with module Proto = Proto =
struct
  module Proto = Proto

  type operation = {
    hash : Operation_hash.t;
    raw : Operation.t;
    protocol_data : Proto.operation_data;
  }

  type t = {
    state : Proto.validation_state;
    applied : (operation * Proto.operation_receipt) list;
    live_blocks : Block_hash.Set.t;
    live_operations : Operation_hash.Set.t;
  }

  type result =
    | Applied of t * Proto.operation_receipt
    | Branch_delayed of error list
    | Branch_refused of error list
    | Refused of error list
    | Duplicate
    | Outdated

  let parse (raw : Operation.t) =
    let hash = Operation.hash raw in
    let size = Data_encoding.Binary.length Operation.encoding raw in
    if size > Proto.max_operation_data_length then
      error (Oversized_operation {size; max = Proto.max_operation_data_length})
    else
      match
        Data_encoding.Binary.of_bytes
          Proto.operation_data_encoding
          raw.Operation.proto
      with
      | None ->
          error Parse_error
      | Some protocol_data ->
          ok {hash; raw; protocol_data}

  let compare op1 op2 =
    Proto.compare_operations
      {shell = op1.raw.shell; protocol_data = op1.protocol_data}
      {shell = op2.raw.shell; protocol_data = op2.protocol_data}

  let create ?protocol_data ~predecessor ~timestamp () =
    (* The prevalidation module receives input from the system byt handles
       protocol values. It translates timestamps here. *)
    let { Block_header.shell =
            { fitness = predecessor_fitness;
              timestamp = predecessor_timestamp;
              level = predecessor_level;
              _ };
          _ } =
      State.Block.header predecessor
    in
    State.Block.context predecessor
    >>=? fun predecessor_context ->
    let predecessor_header = State.Block.header predecessor in
    let predecessor_hash = State.Block.hash predecessor in
    State.Block.max_operations_ttl predecessor
    >>=? fun max_op_ttl ->
    Chain_traversal.live_blocks predecessor max_op_ttl
    >>=? fun (live_blocks, live_operations) ->
    Block_validation.update_testchain_status
      predecessor_context
      predecessor_header
      timestamp
    >>=? fun predecessor_context ->
    ( match protocol_data with
    | None ->
        return_none
    | Some protocol_data -> (
      match
        Data_encoding.Binary.of_bytes
          Proto.block_header_data_encoding
          protocol_data
      with
      | None ->
          failwith "Invalid block header"
      | Some protocol_data ->
          return_some protocol_data ) )
    >>=? fun protocol_data ->
    let predecessor_context =
      Shell_context.wrap_disk_context predecessor_context
    in
    Proto.begin_construction
      ~chain_id:(State.Block.chain_id predecessor)
      ~predecessor_context
      ~predecessor_timestamp
      ~predecessor_fitness
      ~predecessor_level
      ~predecessor:predecessor_hash
      ~timestamp
      ?protocol_data
      ()
    >>=? fun state ->
    (* FIXME arbitrary value, to be customisable *)
    return {state; applied = []; live_blocks; live_operations}

  let apply_operation pv op =
    if Operation_hash.Set.mem op.hash pv.live_operations then
      Lwt.return Outdated
    else
      Proto.apply_operation
        pv.state
        {shell = op.raw.shell; protocol_data = op.protocol_data}
      >|= function
      | Ok (state, receipt) ->
          let pv =
            {
              state;
              applied = (op, receipt) :: pv.applied;
              live_blocks = pv.live_blocks;
              live_operations =
                Operation_hash.Set.add op.hash pv.live_operations;
            }
          in
          Applied (pv, receipt)
      | Error errors -> (
        match classify_errors errors with
        | `Branch ->
            Branch_refused errors
        | `Permanent ->
            Refused errors
        | `Temporary ->
            Branch_delayed errors )

  type status = {
    applied_operations : (operation * Proto.operation_receipt) list;
    block_result : Tezos_protocol_environment.validation_result;
    block_metadata : Proto.block_header_metadata;
  }

  let status pv =
    Proto.finalize_block pv.state
    >>=? fun (block_result, block_metadata) ->
    return {block_metadata; block_result; applied_operations = pv.applied}

  let pp_result ppf =
    let open Format in
    function
    | Applied _ ->
        pp_print_string ppf "applied"
    | Branch_delayed err ->
        fprintf ppf "branch delayed (%a)" pp_print_error err
    | Branch_refused err ->
        fprintf ppf "branch refused (%a)" pp_print_error err
    | Refused err ->
        fprintf ppf "refused (%a)" pp_print_error err
    | Duplicate ->
        pp_print_string ppf "duplicate"
    | Outdated ->
        pp_print_string ppf "outdated"
end

let preapply ~predecessor ~timestamp ~protocol_data operations =
  State.Block.context predecessor
  >>=? fun predecessor_context ->
  Context.get_protocol predecessor_context
  >>= fun protocol ->
  ( match Registered_protocol.get protocol with
  | None ->
      (* FIXME. *)
      (* This should not happen: it should be handled in the validator. *)
      failwith
        "Prevalidation: missing protocol '%a' for the current block."
        Protocol_hash.pp_short
        protocol
  | Some protocol ->
      return protocol )
  >>=? fun (module Proto) ->
  let module Prevalidation = Make (Proto) in
  let apply_operation_with_preapply_result preapp t op =
    let open Preapply_result in
    Prevalidation.apply_operation t op
    >>= function
    | Applied (t, _) ->
        let applied = (op.hash, op.raw) :: preapp.applied in
        Lwt.return ({preapp with applied}, t)
    | Branch_delayed errors ->
        let branch_delayed =
          Operation_hash.Map.add op.hash (op.raw, errors) preapp.branch_delayed
        in
        Lwt.return ({preapp with branch_delayed}, t)
    | Branch_refused errors ->
        let branch_refused =
          Operation_hash.Map.add op.hash (op.raw, errors) preapp.branch_refused
        in
        Lwt.return ({preapp with branch_refused}, t)
    | Refused errors ->
        let refused =
          Operation_hash.Map.add op.hash (op.raw, errors) preapp.refused
        in
        Lwt.return ({preapp with refused}, t)
    | Duplicate | Outdated ->
        Lwt.return (preapp, t)
  in
  Prevalidation.create ~protocol_data ~predecessor ~timestamp ()
  >>=? fun validation_state ->
  Lwt_list.fold_left_s
    (fun (acc_validation_result, acc_validation_state) operations ->
      Lwt_list.fold_left_s
        (fun (acc_validation_result, acc_validation_state) op ->
          match Prevalidation.parse op with
          | Error _ ->
              (* FIXME *)
              Lwt.return (acc_validation_result, acc_validation_state)
          | Ok op ->
              apply_operation_with_preapply_result
                acc_validation_result
                acc_validation_state
                op)
        (Preapply_result.empty, acc_validation_state)
        operations
      >>= fun (new_validation_result, new_validation_state) ->
      (* Applied operations are reverted ; revert to the initial ordering *)
      let new_validation_result =
        {
          new_validation_result with
          applied = List.rev new_validation_result.applied;
        }
      in
      Lwt.return
        (acc_validation_result @ [new_validation_result], new_validation_state))
    ([], validation_state)
    operations
  >>= fun (validation_result_list, validation_state) ->
  let operations_hash =
    Operation_list_list_hash.compute
      (List.map
         (fun r ->
           Operation_list_hash.compute (List.map fst r.Preapply_result.applied))
         validation_result_list)
  in
  Prevalidation.status validation_state
  >>=? fun {block_result; _} ->
  let pred_shell_header = State.Block.shell_header predecessor in
  let level = Int32.succ pred_shell_header.level in
  Block_validation.may_patch_protocol ~level block_result
  >>= fun {fitness; context; message; _} ->
  State.Block.protocol_hash predecessor
  >>=? fun pred_protocol ->
  let context = Shell_context.unwrap_disk_context context in
  Context.get_protocol context
  >>= fun protocol ->
  let proto_level =
    if Protocol_hash.equal protocol pred_protocol then
      pred_shell_header.proto_level
    else (pred_shell_header.proto_level + 1) mod 256
  in
  let shell_header : Block_header.shell_header =
    {
      level;
      proto_level;
      predecessor = State.Block.hash predecessor;
      timestamp;
      validation_passes = List.length validation_result_list;
      operations_hash;
      fitness;
      context = Context_hash.zero (* place holder *);
    }
  in
  ( if Protocol_hash.equal protocol pred_protocol then return (context, message)
  else
    match Registered_protocol.get protocol with
    | None ->
        fail
          (Block_validator_errors.Unavailable_protocol
             {block = State.Block.hash predecessor; protocol})
    | Some (module NewProto) ->
        let context = Shell_context.wrap_disk_context context in
        NewProto.init context shell_header
        >>=? fun {context; message; _} ->
        let context = Shell_context.unwrap_disk_context context in
        return (context, message) )
  >>=? fun (context, message) ->
  let context = Context.hash ?message ~time:timestamp context in
  return ({shell_header with context}, validation_result_list)
src/lib_shell/prevalidation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Validation_errors.

Module T.
  Record signature {Proto_P_block_header_data Proto_P_block_header
    Proto_P_block_header_metadata Proto_P_operation_data
    Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state t
    operation result status : Type} := {
    Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
    t := t;
    operation := operation;
    compare : operation -> operation -> Z;
    parse : Tezos_base__TzPervasives.Operation.t ->
      Tezos_base__TzPervasives.tzresult operation;
    create : (option Stdlib.Bytes.t) ->
      Tezos_shell.State.Block.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          unit -> Lwt.t (Tezos_base__TzPervasives.tzresult t);
    result := result;
    apply_operation : t -> operation -> Lwt.t result;
    status := status;
    status : t -> Lwt.t (Tezos_base__TzPervasives.tzresult status);
    pp_result : Stdlib.Format.formatter -> result -> unit;
  }.
  Arguments signature : clear implicits.
End T.

(* ❌ Functors are not handled. *)
functor

Definition preapply
  (predecessor : Tezos_shell.State.Block.t)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (protocol_data : Stdlib.Bytes.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_header.shell_header *
        (list
          (Tezos_base__TzPervasives.Preapply_result.t
            Tezos_base__TzPervasives.error)))) :=
  op_gtgteqquestion (State.Block.context predecessor)
    (fun predecessor_context =>
      op_gtgteq (Context.get_protocol predecessor_context)
        (fun protocol =>
          op_gtgteqquestion
            match Registered_protocol.get protocol with
            | None =>
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Prevalidation: missing protocol '" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        "' for the current block." % string
                        CamlinternalFormatBasics.End_of_format)))
                  "Prevalidation: missing protocol '%a' for the current block."
                    % string) Protocol_hash.pp_short protocol
            | Some protocol => _return protocol
            end
            (fun Proto =>
              let Proto := projT2 Proto in
              let Prevalidation :=
                (* ❌ Applications of functors are not supported for first-class module values *)
                unsupported_functor_application in
              let apply_operation_with_preapply_result
                (preapp :
                Tezos_base__TzPervasives.Preapply_result.t
                  Tezos_base__TzPervasives.error) (t : Prevalidation.t) (op :
                Prevalidation.operation)
                : Lwt.t
                  ((Tezos_base__TzPervasives.Preapply_result.t
                    Tezos_base__TzPervasives.error) * Prevalidation.t) :=
                op_gtgteq (Prevalidation.apply_operation t op)
                  (fun function_parameter =>
                    match function_parameter with
                    | Prevalidation.Applied t _ =>
                      let applied := cons ((hash op), (raw op)) (applied preapp)
                        in
                      Lwt._return
                        ((* ❌ Record substitution not handled *)
                        record_substitution, t)
                    | Prevalidation.Branch_delayed errors =>
                      let branch_delayed :=
                        Operation_hash.Map.add (hash op) ((raw op), errors)
                          (branch_delayed preapp) in
                      Lwt._return
                        ((* ❌ Record substitution not handled *)
                        record_substitution, t)
                    | Prevalidation.Branch_refused errors =>
                      let branch_refused :=
                        Operation_hash.Map.add (hash op) ((raw op), errors)
                          (branch_refused preapp) in
                      Lwt._return
                        ((* ❌ Record substitution not handled *)
                        record_substitution, t)
                    | Prevalidation.Refused errors =>
                      let refused :=
                        Operation_hash.Map.add (hash op) ((raw op), errors)
                          (refused preapp) in
                      Lwt._return
                        ((* ❌ Record substitution not handled *)
                        record_substitution, t)
                    | Prevalidation.Duplicate | Prevalidation.Outdated =>
                      Lwt._return (preapp, t)
                    end) in
              op_gtgteqquestion
                (Prevalidation.create (Some protocol_data) predecessor timestamp
                  tt)
                (fun validation_state =>
                  op_gtgteq
                    (Lwt_list.fold_left_s
                      (fun function_parameter =>
                        let '(acc_validation_result, acc_validation_state) :=
                          function_parameter in
                        fun operations =>
                          op_gtgteq
                            (Lwt_list.fold_left_s
                              (fun function_parameter =>
                                let
                                  '(acc_validation_result, acc_validation_state) :=
                                  function_parameter in
                                fun op =>
                                  match Prevalidation.parse op with
                                  | Stdlib.Error _ =>
                                    Lwt._return
                                      (acc_validation_result,
                                        acc_validation_state)
                                  | Stdlib.Ok op =>
                                    apply_operation_with_preapply_result
                                      acc_validation_result acc_validation_state
                                      op
                                  end)
                              (Preapply_result.empty, acc_validation_state)
                              operations)
                            (fun function_parameter =>
                              let
                                '(new_validation_result, new_validation_state) :=
                                function_parameter in
                              let new_validation_result :=
                                (* ❌ Record substitution not handled *)
                                record_substitution in
                              Lwt._return
                                ((OCaml.Stdlib.app acc_validation_result
                                  (cons new_validation_result [])),
                                  new_validation_state))) ([], validation_state)
                      operations)
                    (fun function_parameter =>
                      let '(validation_result_list, validation_state) :=
                        function_parameter in
                      let operations_hash :=
                        Operation_list_list_hash.compute
                          (List.map
                            (fun r =>
                              Operation_list_hash.compute
                                (List.map fst (Preapply_result.applied r)))
                            validation_result_list) in
                      op_gtgteqquestion (Prevalidation.status validation_state)
                        (fun function_parameter =>
                          let '{| block_result := block_result |} :=
                            function_parameter in
                          let pred_shell_header :=
                            State.Block.shell_header predecessor in
                          let level := Int32.succ (level pred_shell_header) in
                          op_gtgteq
                            (Block_validation.may_patch_protocol level
                              block_result)
                            (fun function_parameter =>
                              let '{|
                                context := context;
                                  fitness := fitness;
                                  message := message
                                  |} := function_parameter in
                              op_gtgteqquestion
                                (State.Block.protocol_hash predecessor)
                                (fun pred_protocol =>
                                  let context :=
                                    Shell_context.unwrap_disk_context context in
                                  op_gtgteq (Context.get_protocol context)
                                    (fun protocol =>
                                      let proto_level :=
                                        if
                                          Protocol_hash.equal protocol
                                            pred_protocol then
                                          proto_level pred_shell_header
                                        else
                                          Z.modulo
                                            (Z.add
                                              (proto_level pred_shell_header) 1)
                                            256 in
                                      let shell_header :=
                                        {| level := level;
                                          proto_level := proto_level;
                                          predecessor :=
                                            State.Block.hash predecessor;
                                          timestamp := timestamp;
                                          validation_passes :=
                                            List.length validation_result_list;
                                          operations_hash := operations_hash;
                                          fitness := fitness;
                                          context := Context_hash.zero |} in
                                      op_gtgteqquestion
                                        (if
                                          Protocol_hash.equal protocol
                                            pred_protocol then
                                          _return (context, message)
                                        else
                                          match Registered_protocol.get protocol
                                            with
                                          | None =>
                                            fail
                                              (Tezos_base__TzPervasives.Unavailable_protocol
                                                {|
                                                  block :=
                                                    State.Block.hash predecessor;
                                                  protocol := protocol |})
                                          | Some NewProto =>
                                            let NewProto := projT2 NewProto in
                                            let context :=
                                              Shell_context.wrap_disk_context
                                                context in
                                            op_gtgteqquestion
                                              (NewProto.(Tezos_protocol_updater__Registered_protocol.T.init)
                                                context shell_header)
                                              (fun function_parameter =>
                                                let '{|
                                                  context := context;
                                                    message := message
                                                    |} := function_parameter in
                                                let context :=
                                                  Shell_context.unwrap_disk_context
                                                    context in
                                                _return (context, message))
                                          end)
                                        (fun function_parameter =>
                                          let '(context, message) :=
                                            function_parameter in
                                          let context :=
                                            Context.hash timestamp message
                                              context in
                                          _return
                                            ((* ❌ Record substitution not handled *)
                                            record_substitution,
                                              validation_result_list))))))))))).

src/lib_shell/prevalidator.ml 46 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Prevalidator_worker_state

type limits = {
  max_refused_operations : int;
  operation_timeout : Time.System.Span.t;
  worker_limits : Worker_types.limits;
  operations_batch_size : int;
}

type name_t = Chain_id.t * Protocol_hash.t

module type T = sig
  module Proto : Registered_protocol.T

  val name : name_t

  val parameters : limits * Distributed_db.chain_db

  module Prevalidation : Prevalidation.T with module Proto = Proto

  type types_state = {
    chain_db : Distributed_db.chain_db;
    limits : limits;
    mutable predecessor : State.Block.t;
    mutable timestamp : Time.System.t;
    mutable live_blocks : Block_hash.Set.t;
    mutable live_operations : Operation_hash.Set.t;
    refused : Operation_hash.t Ring.t;
    mutable refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_refused : Operation_hash.t Ring.t;
    mutable branch_refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_delayed : Operation_hash.t Ring.t;
    mutable branch_delays : (Operation.t * error list) Operation_hash.Map.t;
    mutable fetching : Operation_hash.Set.t;
    mutable pending : Operation.t Operation_hash.Map.t;
    mutable mempool : Mempool.t;
    mutable in_mempool : Operation_hash.Set.t;
    mutable applied : (Operation_hash.t * Operation.t) list;
    mutable applied_count : int;
    mutable validation_state : Prevalidation.t tzresult;
    mutable operation_stream :
      ( [`Applied | `Refused | `Branch_refused | `Branch_delayed]
      * Operation.shell_header
      * Proto.operation_data )
      Lwt_watcher.input;
    mutable advertisement : [`Pending of Mempool.t | `None];
    mutable rpc_directory : types_state RPC_directory.t lazy_t;
  }

  module Name : Worker.NAME with type t = name_t

  module Types : Worker.TYPES with type state = types_state

  module Worker :
    Worker.T
      with type Event.t = Event.t
       and type 'a Request.t = 'a Request.t
       and type Request.view = Request.view
       and type Types.state = types_state

  type worker = Worker.infinite Worker.queue Worker.t

  val list_pendings :
    Distributed_db.chain_db ->
    from_block:State.Block.t ->
    to_block:State.Block.t ->
    live_blocks:Block_hash.Set.t ->
    Operation.t Operation_hash.Map.t ->
    Operation.t Operation_hash.Map.t Lwt.t

  val validation_result : types_state -> error Preapply_result.t

  val fitness : unit -> Fitness.t Lwt.t

  val initialization_errors : unit tzresult Lwt.t

  val worker : worker Lazy.t
end

module type ARG = sig
  val limits : limits

  val chain_db : Distributed_db.chain_db

  val chain_id : Chain_id.t
end

type t = (module T)

module Make (Proto : Registered_protocol.T) (Arg : ARG) : T = struct
  module Proto = Proto

  let name = (Arg.chain_id, Proto.hash)

  let parameters = (Arg.limits, Arg.chain_db)

  module Prevalidation = Prevalidation.Make (Proto)

  type types_state = {
    chain_db : Distributed_db.chain_db;
    limits : limits;
    mutable predecessor : State.Block.t;
    mutable timestamp : Time.System.t;
    mutable live_blocks : Block_hash.Set.t;
    (* just a cache *)
    mutable live_operations : Operation_hash.Set.t;
    (* just a cache *)
    refused : Operation_hash.t Ring.t;
    mutable refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_refused : Operation_hash.t Ring.t;
    mutable branch_refusals : (Operation.t * error list) Operation_hash.Map.t;
    branch_delayed : Operation_hash.t Ring.t;
    mutable branch_delays : (Operation.t * error list) Operation_hash.Map.t;
    mutable fetching : Operation_hash.Set.t;
    mutable pending : Operation.t Operation_hash.Map.t;
    mutable mempool : Mempool.t;
    mutable in_mempool : Operation_hash.Set.t;
    mutable applied : (Operation_hash.t * Operation.t) list;
    mutable applied_count : int;
    mutable validation_state : Prevalidation.t tzresult;
    mutable operation_stream :
      ( [`Applied | `Refused | `Branch_refused | `Branch_delayed]
      * Operation.shell_header
      * Proto.operation_data )
      Lwt_watcher.input;
    mutable advertisement : [`Pending of Mempool.t | `None];
    mutable rpc_directory : types_state RPC_directory.t lazy_t;
  }

  module Name = struct
    type t = name_t

    let encoding = Data_encoding.tup2 Chain_id.encoding Protocol_hash.encoding

    let chain_id_string =
      let (_ : string) = Format.flush_str_formatter () in
      Chain_id.pp_short Format.str_formatter Arg.chain_id ;
      Format.flush_str_formatter ()

    let proto_hash_string =
      let (_ : string) = Format.flush_str_formatter () in
      Protocol_hash.pp_short Format.str_formatter Proto.hash ;
      Format.flush_str_formatter ()

    let base = ["prevalidator"; chain_id_string; proto_hash_string]

    let pp fmt (chain_id, proto_hash) =
      Chain_id.pp_short fmt chain_id ;
      Format.pp_print_string fmt "." ;
      Protocol_hash.pp_short fmt proto_hash
  end

  module Types = struct
    (* Invariants:
       - an operation is in only one of these sets (map domains):
         pv.refusals pv.pending pv.fetching pv.live_operations pv.in_mempool
       - pv.in_mempool is the domain of all fields of pv.prevalidation_result
       - pv.prevalidation_result.refused = Ø, refused ops are in pv.refused
       - the 'applied' operations in pv.validation_result are in reverse order. *)
    type state = types_state

    type parameters = limits * Distributed_db.chain_db

    include Worker_state

    let view (state : state) _ : view =
      let domain map =
        Operation_hash.Map.fold
          (fun elt _ acc -> Operation_hash.Set.add elt acc)
          map
          Operation_hash.Set.empty
      in
      {
        head = State.Block.hash state.predecessor;
        timestamp = state.timestamp;
        fetching = state.fetching;
        pending = domain state.pending;
        applied = List.rev (List.map (fun (h, _) -> h) state.applied);
        delayed =
          Operation_hash.Set.union
            (domain state.branch_delays)
            (domain state.branch_refusals);
      }
  end

  module Logger = Worker_logger.Make (Event) (Request)

  module Worker :
    Worker.T
      with type Name.t = Name.t
       and type Event.t = Event.t
       and type 'a Request.t = 'a Request.t
       and type Request.view = Request.view
       and type Types.state = Types.state
       and type Types.parameters = Types.parameters =
    Worker.Make (Name) (Prevalidator_worker_state.Event)
      (Prevalidator_worker_state.Request)
      (Types)
      (Logger)

  (** Centralised operation stream for the RPCs *)
  let notify_operation {operation_stream; _} result {Operation.shell; proto} =
    let protocol_data =
      Data_encoding.Binary.of_bytes Proto.operation_data_encoding proto
    in
    match protocol_data with
    | Some protocol_data ->
        Lwt_watcher.notify operation_stream (result, shell, protocol_data)
    | None ->
        ()

  open Types

  type worker = Worker.infinite Worker.queue Worker.t

  let debug w = Format.kasprintf (fun msg -> Worker.record_event w (Debug msg))

  let list_pendings chain_db ~from_block ~to_block ~live_blocks old_mempool =
    let rec pop_blocks ancestor block mempool =
      let hash = State.Block.hash block in
      if Block_hash.equal hash ancestor then Lwt.return mempool
      else
        State.Block.all_operations block
        >>= fun operations ->
        Lwt_list.fold_left_s
          (Lwt_list.fold_left_s (fun mempool op ->
               let h = Operation.hash op in
               Distributed_db.inject_operation chain_db h op
               >>= fun (_ : bool) ->
               Lwt.return (Operation_hash.Map.add h op mempool)))
          mempool
          operations
        >>= fun mempool ->
        State.Block.predecessor block
        >>= function
        | None ->
            assert false
        | Some predecessor ->
            pop_blocks ancestor predecessor mempool
    in
    let push_block mempool block =
      State.Block.all_operation_hashes block
      >|= fun operations ->
      List.iter
        (List.iter (Distributed_db.Operation.clear_or_cancel chain_db))
        operations ;
      List.fold_left
        (List.fold_left (fun mempool h -> Operation_hash.Map.remove h mempool))
        mempool
        operations
    in
    Chain_traversal.new_blocks ~from_block ~to_block
    >>= fun (ancestor, path) ->
    pop_blocks (State.Block.hash ancestor) from_block old_mempool
    >>= fun mempool ->
    Lwt_list.fold_left_s push_block mempool path
    >>= fun new_mempool ->
    let (new_mempool, outdated) =
      Operation_hash.Map.partition
        (fun _oph op ->
          Block_hash.Set.mem op.Operation.shell.branch live_blocks)
        new_mempool
    in
    Operation_hash.Map.iter
      (fun oph _op -> Distributed_db.Operation.clear_or_cancel chain_db oph)
      outdated ;
    Lwt.return new_mempool

  let already_handled pv oph =
    Operation_hash.Map.mem oph pv.refusals
    || Operation_hash.Map.mem oph pv.pending
    || Operation_hash.Set.mem oph pv.fetching
    || Operation_hash.Set.mem oph pv.live_operations
    || Operation_hash.Set.mem oph pv.in_mempool

  let validation_result (state : types_state) =
    {
      Preapply_result.applied = List.rev state.applied;
      branch_delayed = state.branch_delays;
      branch_refused = state.branch_refusals;
      refused = Operation_hash.Map.empty;
    }

  let advertise (w : worker) pv mempool =
    match pv.advertisement with
    | `Pending {Mempool.known_valid; pending} ->
        pv.advertisement <-
          `Pending
            {
              known_valid = known_valid @ mempool.Mempool.known_valid;
              pending = Operation_hash.Set.union pending mempool.pending;
            }
    | `None ->
        pv.advertisement <- `Pending mempool ;
        Lwt.async (fun () ->
            Lwt_unix.sleep 0.01
            >>= fun () ->
            Worker.Queue.push_request_now w Advertise ;
            Lwt.return_unit)

  let is_endorsement (op : Prevalidation.operation) =
    Proto.acceptable_passes
      {shell = op.raw.shell; protocol_data = op.protocol_data}
    = [0]

  let is_endorsement_raw op =
    match Prevalidation.parse op with
    | Ok op ->
        is_endorsement op
    | Error _ ->
        false

  let handle_unprocessed w pv =
    ( match pv.validation_state with
    | Error err ->
        Operation_hash.Map.iter
          (fun h op ->
            Option.iter
              (Ring.add_and_return_erased pv.branch_delayed h)
              ~f:(fun e ->
                pv.branch_delays <-
                  Operation_hash.Map.remove e pv.branch_delays ;
                pv.in_mempool <- Operation_hash.Set.remove e pv.in_mempool) ;
            pv.in_mempool <- Operation_hash.Set.add h pv.in_mempool ;
            pv.branch_delays <-
              Operation_hash.Map.add h (op, err) pv.branch_delays)
          pv.pending ;
        pv.pending <- Operation_hash.Map.empty ;
        Lwt.return_unit
    | Ok state -> (
      match Operation_hash.Map.cardinal pv.pending with
      | 0 ->
          Lwt.return_unit
      | n ->
          debug w "processing %d operations" n ;
          let operations =
            List.map snd (Operation_hash.Map.bindings pv.pending)
          in
          Lwt_utils.fold_left_s_n
            ~n:pv.limits.operations_batch_size
            (fun (acc_validation_state, acc_mempool) op ->
              let refused hash raw errors =
                notify_operation pv `Refused raw ;
                let new_mempool =
                  Mempool.
                    {
                      acc_mempool with
                      pending = Operation_hash.Set.add hash acc_mempool.pending;
                    }
                in
                Option.iter
                  (Ring.add_and_return_erased pv.refused hash)
                  ~f:(fun e ->
                    pv.refusals <- Operation_hash.Map.remove e pv.refusals) ;
                pv.refusals <-
                  Operation_hash.Map.add hash (raw, errors) pv.refusals ;
                Distributed_db.Operation.clear_or_cancel pv.chain_db hash ;
                Lwt.return (acc_validation_state, new_mempool)
              in
              match Prevalidation.parse op with
              | Error errors ->
                  refused (Operation.hash op) op errors
              | Ok op -> (
                  Prevalidation.apply_operation state op
                  >>= function
                  | Applied (new_acc_validation_state, _) ->
                      if
                        pv.applied_count <= 2000
                        (* this test is a quick fix while we wait for the new mempool *)
                        || is_endorsement op
                      then (
                        notify_operation pv `Applied op.raw ;
                        let new_mempool =
                          Mempool.
                            {
                              acc_mempool with
                              known_valid = op.hash :: acc_mempool.known_valid;
                            }
                        in
                        pv.applied <- (op.hash, op.raw) :: pv.applied ;
                        pv.in_mempool <-
                          Operation_hash.Set.add op.hash pv.in_mempool ;
                        Lwt.return (new_acc_validation_state, new_mempool) )
                      else Lwt.return (acc_validation_state, acc_mempool)
                  | Branch_delayed errors ->
                      notify_operation pv `Branch_delayed op.raw ;
                      let new_mempool =
                        if is_endorsement op then
                          Mempool.
                            {
                              acc_mempool with
                              pending =
                                Operation_hash.Set.add
                                  op.hash
                                  acc_mempool.pending;
                            }
                        else acc_mempool
                      in
                      Option.iter
                        (Ring.add_and_return_erased pv.branch_delayed op.hash)
                        ~f:(fun e ->
                          pv.branch_delays <-
                            Operation_hash.Map.remove e pv.branch_delays ;
                          pv.in_mempool <-
                            Operation_hash.Set.remove e pv.in_mempool) ;
                      pv.in_mempool <-
                        Operation_hash.Set.add op.hash pv.in_mempool ;
                      pv.branch_delays <-
                        Operation_hash.Map.add
                          op.hash
                          (op.raw, errors)
                          pv.branch_delays ;
                      Lwt.return (acc_validation_state, new_mempool)
                  | Branch_refused errors ->
                      notify_operation pv `Branch_refused op.raw ;
                      let new_mempool =
                        if is_endorsement op then
                          Mempool.
                            {
                              acc_mempool with
                              pending =
                                Operation_hash.Set.add
                                  op.hash
                                  acc_mempool.pending;
                            }
                        else acc_mempool
                      in
                      Option.iter
                        (Ring.add_and_return_erased pv.branch_refused op.hash)
                        ~f:(fun e ->
                          pv.branch_refusals <-
                            Operation_hash.Map.remove e pv.branch_refusals ;
                          pv.in_mempool <-
                            Operation_hash.Set.remove e pv.in_mempool) ;
                      pv.in_mempool <-
                        Operation_hash.Set.add op.hash pv.in_mempool ;
                      pv.branch_refusals <-
                        Operation_hash.Map.add
                          op.hash
                          (op.raw, errors)
                          pv.branch_refusals ;
                      Lwt.return (acc_validation_state, new_mempool)
                  | Refused errors ->
                      refused op.hash op.raw errors
                  | Duplicate | Outdated ->
                      Lwt.return (acc_validation_state, acc_mempool) ))
            (state, Mempool.empty)
            operations
          >>= fun ((state, advertised_mempool), remaining_op) ->
          ( if remaining_op != [] then
            Worker.Queue.push_request w Request.Leftover
          else Lwt.return_unit )
          >>= fun () ->
          pv.validation_state <- Ok state ;
          pv.pending <- Operation_hash.Map.empty ;
          advertise
            w
            pv
            {
              advertised_mempool with
              known_valid = List.rev advertised_mempool.known_valid;
            } ;
          Lwt.return_unit ) )
    >>= fun () ->
    pv.mempool <-
      {
        Mempool.known_valid = List.rev_map fst pv.applied;
        pending =
          Operation_hash.Map.fold
            (fun k (op, _) s ->
              if is_endorsement_raw op then Operation_hash.Set.add k s else s)
            pv.branch_delays
          @@ Operation_hash.Map.fold
               (fun k (op, _) s ->
                 if is_endorsement_raw op then Operation_hash.Set.add k s
                 else s)
               pv.branch_refusals
          @@ Operation_hash.Set.empty;
      } ;
    State.Current_mempool.set
      (Distributed_db.chain_state pv.chain_db)
      ~head:(State.Block.hash pv.predecessor)
      pv.mempool
    >>= fun () -> Lwt_main.yield ()

  let fetch_operation w pv ?peer oph =
    debug w "fetching operation %a" Operation_hash.pp_short oph ;
    Distributed_db.Operation.fetch
      ~timeout:pv.limits.operation_timeout
      pv.chain_db
      ?peer
      oph
      ()
    >>= function
    | Ok op ->
        Worker.Queue.push_request_now w (Arrived (oph, op)) ;
        Lwt.return_unit
    | Error (Distributed_db.Operation.Canceled _ :: _) ->
        debug
          w
          "operation %a included before being prevalidated"
          Operation_hash.pp_short
          oph ;
        Lwt.return_unit
    | Error _ ->
        (* should not happen *)
        Lwt.return_unit

  let rpc_directory =
    lazy
      (let dir : state RPC_directory.t ref = ref RPC_directory.empty in
       let module Proto_services = Block_services.Make (Proto) (Proto) in
       (* TODO
       refused => Operation_hash.Set.t ;
       kick le peer
    *)
       dir :=
         RPC_directory.register
           !dir
           (Proto_services.S.Mempool.pending_operations RPC_path.open_root)
           (fun pv () () ->
             let map_op op =
               let protocol_data_opt =
                 Data_encoding.Binary.of_bytes
                   Proto.operation_data_encoding
                   op.Operation.proto
               in
               match protocol_data_opt with
               | Some protocol_data ->
                   Some {Proto.shell = op.shell; protocol_data}
               | None ->
                   None
             in
             let map_op_error oph (op, error) acc =
               match map_op op with
               | None ->
                   acc
               | Some res ->
                   Operation_hash.Map.add oph (res, error) acc
             in
             let applied =
               List.filter_map
                 (fun (hash, op) ->
                   match map_op op with
                   | Some op ->
                       Some (hash, op)
                   | None ->
                       None)
                 (List.rev pv.applied)
             in
             let filter f map =
               Operation_hash.Map.fold f map Operation_hash.Map.empty
             in
             let refused = filter map_op_error pv.refusals in
             let branch_refused = filter map_op_error pv.branch_refusals in
             let branch_delayed = filter map_op_error pv.branch_delays in
             let unprocessed =
               Operation_hash.Map.fold
                 (fun oph op acc ->
                   match map_op op with
                   | Some op ->
                       Operation_hash.Map.add oph op acc
                   | None ->
                       acc)
                 pv.pending
                 Operation_hash.Map.empty
             in
             return
               {
                 Proto_services.Mempool.applied;
                 refused;
                 branch_refused;
                 branch_delayed;
                 unprocessed;
               }) ;
       dir :=
         RPC_directory.register
           !dir
           (Proto_services.S.Mempool.request_operations RPC_path.open_root)
           (fun pv () () ->
             Distributed_db.Request.current_head pv.chain_db () ;
             return_unit) ;
       dir :=
         RPC_directory.gen_register
           !dir
           (Proto_services.S.Mempool.monitor_operations RPC_path.open_root)
           (fun { applied;
                  refusals = refused;
                  branch_refusals = branch_refused;
                  branch_delays = branch_delayed;
                  operation_stream;
                  _ }
                params
                ()
                ->
             let (op_stream, stopper) =
               Lwt_watcher.create_stream operation_stream
             in
             (* Convert ops *)
             let map_op op =
               let protocol_data =
                 Data_encoding.Binary.of_bytes_exn
                   Proto.operation_data_encoding
                   op.Operation.proto
               in
               Proto.{shell = op.shell; protocol_data}
             in
             let fold_op _k (op, _error) acc = map_op op :: acc in
             (* First call : retrieve the current set of op from the mempool *)
             let applied =
               if params#applied then List.map map_op (List.map snd applied)
               else []
             in
             let refused =
               if params#refused then
                 Operation_hash.Map.fold fold_op refused []
               else []
             in
             let branch_refused =
               if params#branch_refused then
                 Operation_hash.Map.fold fold_op branch_refused []
               else []
             in
             let branch_delayed =
               if params#branch_delayed then
                 Operation_hash.Map.fold fold_op branch_delayed []
               else []
             in
             let current_mempool =
               List.concat [applied; refused; branch_refused; branch_delayed]
             in
             let current_mempool = ref (Some current_mempool) in
             let filter_result = function
               | `Applied ->
                   params#applied
               | `Refused ->
                   params#refused
               | `Branch_refused ->
                   params#branch_refused
               | `Branch_delayed ->
                   params#branch_delayed
             in
             let rec next () =
               match !current_mempool with
               | Some mempool ->
                   current_mempool := None ;
                   Lwt.return_some mempool
               | None -> (
                   Lwt_stream.get op_stream
                   >>= function
                   | Some (kind, shell, protocol_data) when filter_result kind
                     ->
                       (* NOTE: Should the protocol change, a new Prevalidation
                        * context would be created. Thus, we use the same Proto. *)
                       let bytes =
                         Data_encoding.Binary.to_bytes_exn
                           Proto.operation_data_encoding
                           protocol_data
                       in
                       let protocol_data =
                         Data_encoding.Binary.of_bytes_exn
                           Proto.operation_data_encoding
                           bytes
                       in
                       Lwt.return_some [{Proto.shell; protocol_data}]
                   | Some _ ->
                       next ()
                   | None ->
                       Lwt.return_none )
             in
             let shutdown () = Lwt_watcher.shutdown stopper in
             RPC_answer.return_stream {next; shutdown}) ;
       !dir)

  module Handlers = struct
    type self = worker

    let on_operation_arrived (pv : state) oph op =
      pv.fetching <- Operation_hash.Set.remove oph pv.fetching ;
      if not (Block_hash.Set.mem op.Operation.shell.branch pv.live_blocks) then
        Distributed_db.Operation.clear_or_cancel pv.chain_db oph
        (* TODO: put in a specific delayed map ? *)
      else if
        not (already_handled pv oph) (* prevent double inclusion on flush *)
      then pv.pending <- Operation_hash.Map.add oph op pv.pending

    let on_inject pv op =
      let oph = Operation.hash op in
      if already_handled pv oph then return_unit
        (* FIXME : is this an error ? *)
      else
        Lwt.return pv.validation_state
        >>=? fun validation_state ->
        Lwt.return (Prevalidation.parse op)
        >>=? fun parsed_op ->
        Prevalidation.apply_operation validation_state parsed_op
        >>= function
        | Applied (_, _result) ->
            Distributed_db.inject_operation pv.chain_db oph op
            >>= fun (_ : bool) ->
            pv.pending <- Operation_hash.Map.add parsed_op.hash op pv.pending ;
            return_unit
        | res ->
            failwith
              "Error while applying operation %a:@ %a"
              Operation_hash.pp
              oph
              Prevalidation.pp_result
              res

    let on_notify w pv peer mempool =
      let all_ophs =
        List.fold_left
          (fun s oph -> Operation_hash.Set.add oph s)
          mempool.Mempool.pending
          mempool.known_valid
      in
      let to_fetch =
        Operation_hash.Set.filter
          (fun oph -> not (already_handled pv oph))
          all_ophs
      in
      pv.fetching <- Operation_hash.Set.union to_fetch pv.fetching ;
      Operation_hash.Set.iter
        (fun oph -> Lwt.ignore_result (fetch_operation w pv ~peer oph))
        to_fetch

    let on_flush w pv predecessor =
      Lwt_watcher.shutdown_input pv.operation_stream ;
      State.Block.max_operations_ttl predecessor
      >>=? fun max_op_ttl ->
      Chain_traversal.live_blocks predecessor max_op_ttl
      >>=? fun (new_live_blocks, new_live_operations) ->
      list_pendings
        pv.chain_db
        ~from_block:pv.predecessor
        ~to_block:predecessor
        ~live_blocks:new_live_blocks
        (Preapply_result.operations (validation_result pv))
      >>= fun pending ->
      let timestamp_system = Tezos_stdlib_unix.Systime_os.now () in
      let timestamp = Time.System.to_protocol timestamp_system in
      Prevalidation.create ~predecessor ~timestamp ()
      >>= fun validation_state ->
      debug
        w
        "%d operations were not washed by the flush"
        (Operation_hash.Map.cardinal pending) ;
      pv.predecessor <- predecessor ;
      pv.live_blocks <- new_live_blocks ;
      pv.live_operations <- new_live_operations ;
      pv.timestamp <- timestamp_system ;
      pv.mempool <- {known_valid = []; pending = Operation_hash.Set.empty} ;
      pv.pending <- pending ;
      pv.in_mempool <- Operation_hash.Set.empty ;
      Ring.clear pv.branch_delayed ;
      pv.branch_delays <- Operation_hash.Map.empty ;
      Ring.clear pv.branch_refused ;
      pv.branch_refusals <- Operation_hash.Map.empty ;
      pv.applied <- [] ;
      pv.applied_count <- 0 ;
      pv.validation_state <- validation_state ;
      pv.operation_stream <- Lwt_watcher.create_input () ;
      return_unit

    let on_advertise pv =
      match pv.advertisement with
      | `None ->
          () (* should not happen *)
      | `Pending mempool ->
          pv.advertisement <- `None ;
          Distributed_db.Advertise.current_head
            pv.chain_db
            ~mempool
            pv.predecessor

    let on_request : type r. worker -> r Request.t -> r tzresult Lwt.t =
     fun w request ->
      let pv = Worker.state w in
      ( match request with
      | Request.Flush hash ->
          on_advertise pv ;
          (* TODO: rebase the advertisement instead *)
          let chain_state = Distributed_db.chain_state pv.chain_db in
          State.Block.read chain_state hash
          >>=? fun block -> on_flush w pv block >>=? fun () -> return (() : r)
      | Request.Notify (peer, mempool) ->
          on_notify w pv peer mempool ;
          return_unit
      | Request.Leftover ->
          (* unprocessed ops are handled just below *)
          return_unit
      | Request.Inject op ->
          on_inject pv op
      | Request.Arrived (oph, op) ->
          on_operation_arrived pv oph op ;
          return_unit
      | Request.Advertise ->
          on_advertise pv ; return_unit )
      >>=? fun r -> handle_unprocessed w pv >>= fun () -> return r

    let on_close w =
      let pv = Worker.state w in
      Operation_hash.Set.iter
        (Distributed_db.Operation.clear_or_cancel pv.chain_db)
        pv.fetching ;
      Lwt.return_unit

    let on_launch w _ (limits, chain_db) =
      let chain_state = Distributed_db.chain_state chain_db in
      Chain.data chain_state
      >>= fun { current_head = predecessor;
                current_mempool = mempool;
                live_blocks;
                live_operations;
                _ } ->
      let timestamp_system = Tezos_stdlib_unix.Systime_os.now () in
      let timestamp = Time.System.to_protocol timestamp_system in
      Prevalidation.create ~predecessor ~timestamp ()
      >>= fun validation_state ->
      let fetching =
        List.fold_left
          (fun s h -> Operation_hash.Set.add h s)
          Operation_hash.Set.empty
          mempool.known_valid
      in
      let pv =
        {
          limits;
          chain_db;
          predecessor;
          timestamp = timestamp_system;
          live_blocks;
          live_operations;
          mempool = {known_valid = []; pending = Operation_hash.Set.empty};
          refused = Ring.create limits.max_refused_operations;
          refusals = Operation_hash.Map.empty;
          fetching;
          pending = Operation_hash.Map.empty;
          in_mempool = Operation_hash.Set.empty;
          applied = [];
          applied_count = 0;
          branch_refused = Ring.create limits.max_refused_operations;
          branch_refusals = Operation_hash.Map.empty;
          branch_delayed = Ring.create limits.max_refused_operations;
          branch_delays = Operation_hash.Map.empty;
          validation_state;
          operation_stream = Lwt_watcher.create_input ();
          advertisement = `None;
          rpc_directory;
        }
      in
      List.iter
        (fun oph -> Lwt.ignore_result (fetch_operation w pv oph))
        mempool.known_valid ;
      return pv

    let on_error w r st errs =
      Worker.record_event w (Event.Request (r, st, Some errs)) ;
      match r with
      | Request.(View (Inject _)) ->
          return_unit
      | _ ->
          Lwt.return_error errs

    let on_completion w r _ st =
      Worker.record_event w (Event.Request (Request.view r, st, None)) ;
      Lwt.return_unit

    let on_no_request _ = return_unit
  end

  let table = Worker.create_table Queue

  (* NOTE: we register a single worker for each instantiation of this Make
   * functor (and thus a single worker for the single instantiaion of Worker).
   * Whislt this is somewhat abusing the intended purpose of worker, it is part
   * of a transition plan to a one-worker-per-peer architecture. *)
  let worker_promise =
    Worker.launch
      table
      Arg.limits.worker_limits
      name
      (Arg.limits, Arg.chain_db)
      (module Handlers)

  let initialization_errors = worker_promise >>=? fun _ -> return_unit

  let worker =
    lazy
      ( match Lwt.state worker_promise with
      | Lwt.Return (Ok worker) ->
          worker
      | Lwt.Return (Error _) | Lwt.Fail _ | Lwt.Sleep ->
          assert false )

  let fitness () =
    let w = Lazy.force worker in
    let pv = Worker.state w in
    Lwt.return pv.validation_state
    >>=? (fun state ->
           Prevalidation.status state
           >>=? fun status -> return status.block_result.fitness)
    >>= function
    | Ok fitness ->
        Lwt.return fitness
    | Error _ ->
        Lwt.return (State.Block.fitness pv.predecessor)
end

module ChainProto_registry = Registry.Make (struct
  type v = t

  type t = Chain_id.t * Protocol_hash.t

  let compare (c1, p1) (c2, p2) =
    let pc = Protocol_hash.compare p1 p2 in
    if pc = 0 then Chain_id.compare c1 c2 else pc
end)

let create limits (module Proto : Registered_protocol.T) chain_db =
  let chain_state = Distributed_db.chain_state chain_db in
  let chain_id = State.Chain.id chain_state in
  match ChainProto_registry.query (chain_id, Proto.hash) with
  | None ->
      let module Prevalidator =
        Make
          (Proto)
          (struct
            let limits = limits

            let chain_db = chain_db

            let chain_id = chain_id
          end)
      in
      (* Checking initialization errors before giving a reference to dnagerous
       * `worker` value to caller. *)
      Prevalidator.initialization_errors
      >>=? fun () ->
      ChainProto_registry.register Prevalidator.name (module Prevalidator : T) ;
      return (module Prevalidator : T)
  | Some p ->
      return p

let shutdown (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  ChainProto_registry.remove Prevalidator.name ;
  Prevalidator.Worker.shutdown w

let flush (t : t) head =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.push_request_and_wait w (Request.Flush head)

let notify_operations (t : t) peer mempool =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.push_request w (Request.Notify (peer, mempool))

let operations (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  let pv = Prevalidator.Worker.state w in
  ( {(Prevalidator.validation_result pv) with applied = List.rev pv.applied},
    pv.pending )

let pending (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  let pv = Prevalidator.Worker.state w in
  let ops = Preapply_result.operations (Prevalidator.validation_result pv) in
  Lwt.return ops

let timestamp (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  let pv = Prevalidator.Worker.state w in
  pv.timestamp

let fitness (t : t) =
  let module Prevalidator : T = (val t) in
  Prevalidator.fitness ()

let inject_operation (t : t) op =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.push_request_and_wait w (Inject op)

let status (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.status w

let running_workers () =
  ChainProto_registry.fold (fun (id, proto) t acc -> (id, proto, t) :: acc) []

let pending_requests (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.pending_requests w

let current_request (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.current_request w

let last_events (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.last_events w

let protocol_hash (t : t) =
  let module Prevalidator : T = (val t) in
  Prevalidator.Proto.hash

let parameters (t : t) =
  let module Prevalidator : T = (val t) in
  Prevalidator.parameters

let information (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.information w

let pipeline_length (t : t) =
  let module Prevalidator : T = (val t) in
  let w = Lazy.force Prevalidator.worker in
  Prevalidator.Worker.Queue.pending_requests_length w

let empty_rpc_directory : unit RPC_directory.t =
  RPC_directory.register
    RPC_directory.empty
    (Block_services.Empty.S.Mempool.pending_operations RPC_path.open_root)
    (fun _pv () () ->
      return
        {
          Block_services.Empty.Mempool.applied = [];
          refused = Operation_hash.Map.empty;
          branch_refused = Operation_hash.Map.empty;
          branch_delayed = Operation_hash.Map.empty;
          unprocessed = Operation_hash.Map.empty;
        })

let rpc_directory : t option RPC_directory.t =
  RPC_directory.register_dynamic_directory
    RPC_directory.empty
    (Block_services.mempool_path RPC_path.open_root)
    (function
      | None ->
          Lwt.return
            (RPC_directory.map (fun _ -> Lwt.return_unit) empty_rpc_directory)
      | Some t -> (
          let module Prevalidator : T = (val t : T) in
          Prevalidator.initialization_errors
          >>= function
          | Error _ ->
              Lwt.return
                (RPC_directory.map
                   (fun _ -> Lwt.return_unit)
                   empty_rpc_directory)
          | Ok () ->
              let w = Lazy.force Prevalidator.worker in
              let pv = Prevalidator.Worker.state w in
              let pv_rpc_dir = Lazy.force pv.rpc_directory in
              Lwt.return
                (RPC_directory.map (fun _ -> Lwt.return pv) pv_rpc_dir) ))
src/lib_shell/prevalidator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Prevalidator_worker_state.

Record limits := {
  max_refused_operations : Z;
  operation_timeout : Tezos_base__TzPervasives.Time.System.Span.t;
  worker_limits : Tezos_shell_services.Worker_types.limits;
  operations_batch_size : Z }.

Definition name_t :=
  Tezos_base__TzPervasives.Chain_id.t * Tezos_base__TzPervasives.Protocol_hash.t.

Module T.
  Record signature {Proto_P_block_header_data Proto_P_block_header
    Proto_P_block_header_metadata Proto_P_operation_data
    Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state
    Prevalidation_t Prevalidation_operation Prevalidation_result
    Prevalidation_status types_state Types_parameters Types_view Worker_Name_t
    Worker_Types_parameters Worker_Types_view Worker_t Worker_table Worker_queue
    Worker_bounded Worker_infinite Worker_dropbox Worker_buffer_kind
    Worker_any_request : Type} := {
    Proto : Registered_protocol.T.signature Proto_P_block_header_data Proto_P_block_header Proto_P_block_header_metadata Proto_P_operation_data Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state;
    name : name_t;
    parameters : limits * Tezos_shell.Distributed_db.chain_db;
    Prevalidation : Prevalidation.T.signature Prevalidation_Proto_P_block_header_data Prevalidation_Proto_P_block_header Prevalidation_Proto_P_block_header_metadata Prevalidation_Proto_P_operation_data Prevalidation_Proto_P_operation_receipt Prevalidation_Proto_P_operation Prevalidation_Proto_P_validation_state Prevalidation_t Prevalidation_operation Prevalidation_result Prevalidation_status;
    types_state := types_state;
    Name : Worker.NAME.signature name_t;
    Types : Worker.TYPES.signature types_state Types_parameters Types_view;
    Worker : Worker.T.signature (Tezos_shell_services.Prevalidator_worker_state.Request.t
      a) (Tezos_shell_services.Prevalidator_worker_state.Request.t a) (Tezos_shell_services.Prevalidator_worker_state.Request.t
      a) Tezos_shell_services.Prevalidator_worker_state.Request.view types_state Worker_Types_parameters Tezos_shell_services.Prevalidator_worker_state.Request.view Worker_t Worker_table Worker_queue Worker_bounded Worker_infinite Worker_dropbox Worker_buffer_kind Worker_any_request;
    worker := Worker.t (Worker.queue Worker.infinite);
    list_pendings : Tezos_shell.Distributed_db.chain_db ->
      Tezos_shell.State.Block.t ->
        Tezos_shell.State.Block.t ->
          Tezos_base__TzPervasives.Block_hash.Set.t ->
            (Tezos_base__TzPervasives.Operation_hash.Map.t
              Tezos_base__TzPervasives.Operation.t) ->
              Lwt.t
                (Tezos_base__TzPervasives.Operation_hash.Map.t
                  Tezos_base__TzPervasives.Operation.t);
    validation_result : types_state ->
      Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error;
    fitness : unit -> Lwt.t Tezos_base__TzPervasives.Fitness.t;
    initialization_errors : Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    worker : Stdlib.Lazy.t worker;
  }.
  Arguments signature : clear implicits.
End T.

Module ARG.
  Record signature := {
    limits : limits;
    chain_db : Tezos_shell.Distributed_db.chain_db;
    chain_id : Tezos_base__TzPervasives.Chain_id.t;
  }.
End ARG.

Definition t :=
  {'(Proto_P_block_header_data, Proto_P_block_header,
    Proto_P_block_header_metadata, Proto_P_operation_data,
    Proto_P_operation_receipt, Proto_P_operation, Proto_P_validation_state,
    Prevalidation_t, Prevalidation_operation, Prevalidation_result,
    Prevalidation_status, types_state, Types_parameters, Types_view,
    Worker_Name_t, Worker_Types_parameters, Worker_Types_view, Worker_t,
    Worker_table, Worker_queue, Worker_bounded, Worker_infinite, Worker_dropbox,
    Worker_buffer_kind, Worker_any_request) : _ &
    T.signature Proto_P_block_header_data Proto_P_block_header
      Proto_P_block_header_metadata Proto_P_operation_data
      Proto_P_operation_receipt Proto_P_operation Proto_P_validation_state
      Prevalidation_t Prevalidation_operation Prevalidation_result
      Prevalidation_status types_state Types_parameters Types_view Worker_Name_t
      Worker_Types_parameters Worker_Types_view Worker_t Worker_table
      Worker_queue Worker_bounded Worker_infinite Worker_dropbox
      Worker_buffer_kind Worker_any_request}.

(* ❌ Functors are not handled. *)
functor

(* ❌ Applications of functors are not handled. *)
functor_application

Definition create
  (limits : limits)
  (Proto :
    {'(P_block_header_data, P_block_header, P_block_header_metadata,
      P_operation_data, P_operation_receipt, P_operation, P_validation_state) :
      _ &
      Tezos_protocol_updater.Registered_protocol.T.signature P_block_header_data
        P_block_header P_block_header_metadata P_operation_data
        P_operation_receipt P_operation P_validation_state})
  : Tezos_shell.Distributed_db.chain_db ->
    Lwt.t (Tezos_base__TzPervasives.tzresult ChainProto_registry.v) :=
  let Proto := projT2 Proto in
  fun chain_db =>
    let chain_state := Distributed_db.chain_state chain_db in
    let chain_id := State.Chain.id chain_state in
    match
      ChainProto_registry.query
        (chain_id, Proto.(Tezos_protocol_updater__Registered_protocol.T.hash))
      with
    | None =>
      let Prevalidator :=
        (* ❌ Applications of functors are not supported for first-class module values *)
        unsupported_functor_application in
      op_gtgteqquestion Prevalidator.(T.initialization_errors)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            ChainProto_registry.register Prevalidator.(T.name) Prevalidator in
          _return Prevalidator)
    | Some p => _return p
    end.

Definition shutdown (t : t) : Lwt.t unit :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := ChainProto_registry.remove Prevalidator.(T.name) in
  Prevalidator.Worker.shutdown w.

Definition flush (t : t) (head : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.push_request_and_wait w
    (Tezos_shell_services.Prevalidator_worker_state.Request.Flush head).

Definition notify_operations
  (t : t) (peer : Tezos_base__TzPervasives.P2p_peer.Id.t)
  (mempool : Tezos_base__TzPervasives.Mempool.t) : Lwt.t unit :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.push_request w
    (Tezos_shell_services.Prevalidator_worker_state.Request.Notify peer mempool).

Definition operations (t : t)
  : (Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
    *
    (Tezos_base__TzPervasives.Operation_hash.Map.t
      Tezos_base__TzPervasives.Operation.t) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  let pv := Prevalidator.Worker.state w in
  ((* ❌ Record substitution not handled *)
  record_substitution, (pending pv)).

Definition pending (t : t)
  : Lwt.t (Tezos_crypto.Operation_hash.Map.t Tezos_base.Operation.t) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  let pv := Prevalidator.Worker.state w in
  let ops := Preapply_result.operations (Prevalidator.(T.validation_result) pv)
    in
  Lwt._return ops.

Definition timestamp (t : t) : Tezos_base__TzPervasives.Time.System.t :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  let pv := Prevalidator.Worker.state w in
  timestamp pv.

Definition fitness (t : t) : Lwt.t Tezos_base__TzPervasives.Fitness.t :=
  let Prevalidator := projT2 t in
  Prevalidator.(T.fitness) tt.

Definition inject_operation (t : t) (op : Tezos_base__TzPervasives.Operation.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.push_request_and_wait w
    (Tezos_shell_services.Prevalidator_worker_state.Request.Inject op).

Definition status (t : t) : Tezos_shell_services.Worker_types.worker_status :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.status w.

Definition running_workers (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Chain_id.t *
      Tezos_base__TzPervasives.Protocol_hash.t * ChainProto_registry.v) :=
  let 'tt := function_parameter in
  ChainProto_registry.fold
    (fun function_parameter =>
      let '(id, proto) := function_parameter in
      fun t => fun acc => cons (id, proto, t) acc) [].

Definition pending_requests (t : t)
  : list
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Prevalidator_worker_state.Request.view) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.pending_requests w.

Definition current_request (t : t)
  : option
    (Tezos_base__TzPervasives.Time.System.t *
      Tezos_base__TzPervasives.Time.System.t *
      Tezos_shell_services.Prevalidator_worker_state.Request.view) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.current_request w.

Definition last_events (t : t)
  : list
    (Tezos_base__TzPervasives.Internal_event.level *
      (list Tezos_shell_services.Prevalidator_worker_state.Event.t)) :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.last_events w.

Definition protocol_hash (t : t) : Tezos_base__TzPervasives.Protocol_hash.t :=
  let Prevalidator := projT2 t in
  Prevalidator.(T.Proto).(Tezos_protocol_updater__Registered_protocol.T.hash).

Definition parameters (t : t) : limits * Tezos_shell.Distributed_db.chain_db :=
  let Prevalidator := projT2 t in
  Prevalidator.(T.parameters).

Definition information (t : t)
  : Tezos_shell_services.Worker_types.worker_information :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.information w.

Definition pipeline_length (t : t) : Z :=
  let Prevalidator := projT2 t in
  let w := Lazy.force Prevalidator.(T.worker) in
  Prevalidator.Worker.Queue.pending_requests_length w.

Definition empty_rpc_directory
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  RPC_directory.register RPC_directory.empty
    (Block_services.Empty.S.Mempool.pending_operations RPC_path.open_root)
    (fun _pv =>
      fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return
            {| Block_services.Empty.Mempool.applied := [];
              Block_services.Empty.Mempool.refused := Operation_hash.Map.empty;
              Block_services.Empty.Mempool.branch_refused :=
                Operation_hash.Map.empty;
              Block_services.Empty.Mempool.branch_delayed :=
                Operation_hash.Map.empty;
              Block_services.Empty.Mempool.unprocessed :=
                Operation_hash.Map.empty |}).

Definition rpc_directory
  : Tezos_base__TzPervasives.RPC_directory.t (option t) :=
  RPC_directory.register_dynamic_directory None RPC_directory.empty
    (Block_services.mempool_path RPC_path.open_root)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        Lwt._return
          (RPC_directory.map
            (fun function_parameter =>
              let '_ := function_parameter in
              Lwt.return_unit) empty_rpc_directory)
      | Some t =>
        let Prevalidator := projT2 t in
        op_gtgteq Prevalidator.(T.initialization_errors)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error _ =>
              Lwt._return
                (RPC_directory.map
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Lwt.return_unit) empty_rpc_directory)
            | Stdlib.Ok tt =>
              let w := Lazy.force Prevalidator.(T.worker) in
              let pv := Prevalidator.Worker.state w in
              let pv_rpc_dir := Lazy.force (rpc_directory pv) in
              Lwt._return
                (RPC_directory.map
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Lwt._return pv) pv_rpc_dir)
            end)
      end).

src/lib_shell/protocol_directory.ml 13 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let build_rpc_directory block_validator state =
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let gen_register0 s f =
    dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
  in
  let register1 s f =
    dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q)
  in
  gen_register0 Protocol_services.S.list (fun () () ->
      State.Protocol.list state
      >>= fun set ->
      let protocols =
        List.fold_left
          (fun acc x -> Protocol_hash.Set.add x acc)
          set
          (Registered_protocol.list_embedded ())
      in
      RPC_answer.return (Protocol_hash.Set.elements protocols)) ;
  register1 Protocol_services.S.contents (fun hash () () ->
      match Registered_protocol.get_embedded_sources hash with
      | Some p ->
          return p
      | None ->
          State.Protocol.read state hash) ;
  register1 Protocol_services.S.fetch (fun hash () () ->
      Block_validator.fetch_and_compile_protocol block_validator hash
      >>=? fun _proto -> return_unit) ;
  !dir
src/lib_shell/protocol_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition build_rpc_directory
  (block_validator : Tezos_shell.Block_validator.t)
  (state : Tezos_shell__State.global_state)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let dir := Stdlib.ref RPC_directory.empty in
  let gen_register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t variant) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.gen_register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun p => fun q => f p q)) in
  let register1 {A B C D : Type}
    (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
    A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let '(tt, a) := function_parameter in
          fun p => fun q => f a p q)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    gen_register0 Protocol_services.S.list
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (State.Protocol.list state)
            (fun set =>
              let protocols :=
                List.fold_left (fun acc => fun x => Protocol_hash.Set.add x acc)
                  set (Registered_protocol.list_embedded tt) in
              RPC_answer._return (Protocol_hash.Set.elements protocols))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 Protocol_services.S.contents
      (fun hash =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            match Registered_protocol.get_embedded_sources hash with
            | Some p => _return p
            | None => State.Protocol.read state hash
            end) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 Protocol_services.S.fetch
      (fun hash =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Block_validator.fetch_and_compile_protocol block_validator None
                None hash) (fun _proto => return_unit)) in
  Stdlib.op_exclamation dir.

src/lib_shell/protocol_validator.ml 65 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Validation_errors

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.validator.block"
end)

type t = {
  db : Distributed_db.t;
  mutable worker : unit Lwt.t;
  request : unit Lwt_condition.t;
  mutable pending :
    ( Protocol.t
    * Registered_protocol.t tzresult Lwt.t
    * Registered_protocol.t tzresult Lwt.u )
    Protocol_hash.Map.t;
  canceler : Lwt_canceler.t;
}

(** Block validation *)

let rec worker_loop bv =
  ( if Protocol_hash.Map.cardinal bv.pending = 0 then
    Lwt_condition.wait bv.request >>= return
  else
    let (hash, (protocol, _, wakener)) = Protocol_hash.Map.choose bv.pending in
    bv.pending <- Protocol_hash.Map.remove hash bv.pending ;
    Updater.compile hash protocol
    >>= fun valid ->
    ( if valid then Distributed_db.commit_protocol bv.db hash protocol
    else
      (* no need to tag 'invalid' protocol on disk,
             the economic protocol prevents us from
             being spammed with protocol validation. *)
      return_true )
    >>=? fun _ ->
    if valid then
      match Registered_protocol.get hash with
      | Some protocol ->
          Lwt.wakeup_later wakener (Ok protocol)
      | None ->
          Lwt.wakeup_later
            wakener
            (error (Invalid_protocol {hash; error = Dynlinking_failed}))
    else
      Lwt.wakeup_later
        wakener
        (error (Invalid_protocol {hash; error = Compilation_failed})) ;
    return_unit )
  >>= function
  | Ok () ->
      worker_loop bv
  | Error (Canceled :: _) | Error (Exn Lwt_pipe.Closed :: _) ->
      lwt_log_notice
        Tag.DSL.(fun f -> f "terminating" -% t event "terminating")
  | Error err ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "@[Unexpected error (worker):@ %a@]"
            -% t event "unexpected_error" -% a errs_tag err)
      >>= fun () -> Lwt_canceler.cancel bv.canceler

let create db =
  let canceler = Lwt_canceler.create () in
  let pending = Protocol_hash.Map.empty in
  let request = Lwt_condition.create () in
  let bv = {canceler; pending; request; db; worker = Lwt.return_unit} in
  Lwt_canceler.on_cancel bv.canceler (fun () ->
      Protocol_hash.Map.iter (fun _ (_, r, _) -> Lwt.cancel r) bv.pending ;
      Lwt.return_unit) ;
  bv.worker <-
    Lwt_utils.worker
      "block_validator"
      ~on_event:Internal_event.Lwt_worker_event.on_event
      ~run:(fun () -> worker_loop bv)
      ~cancel:(fun () -> Lwt_canceler.cancel bv.canceler) ;
  bv

let shutdown {canceler; worker; _} =
  Lwt_canceler.cancel canceler >>= fun () -> worker

let validate state hash protocol =
  match Registered_protocol.get hash with
  | Some protocol ->
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "previously validated protocol %a (before pipe)"
            -% t event "previously_validated_protocol"
            -% a Protocol_hash.Logging.tag hash)
      >>= fun () -> return protocol
  | None -> (
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "pushing validation request for protocol %a"
            -% t event "pushing_validation_request"
            -% a Protocol_hash.Logging.tag hash)
      >>= fun () ->
      match Protocol_hash.Map.find_opt hash state.pending with
      | None ->
          let (res, wakener) = Lwt.task () in
          let broadcast = Protocol_hash.Map.cardinal state.pending = 0 in
          state.pending <-
            Protocol_hash.Map.add hash (protocol, res, wakener) state.pending ;
          if broadcast then Lwt_condition.broadcast state.request () ;
          res
      | Some (_, res, _) ->
          res )

let fetch_and_compile_protocol pv ?peer ?timeout hash =
  match Registered_protocol.get hash with
  | Some proto ->
      return proto
  | None ->
      Distributed_db.Protocol.read_opt pv.db hash
      >>= (function
            | Some protocol ->
                return protocol
            | None ->
                lwt_log_notice
                  Tag.DSL.(
                    fun f ->
                      f "Fetching protocol %a%a"
                      -% t event "fetching_protocol"
                      -% a Protocol_hash.Logging.tag hash
                      -% a P2p_peer.Id.Logging.tag_source peer)
                >>= fun () ->
                Distributed_db.Protocol.fetch pv.db ?peer ?timeout hash ())
      >>=? fun protocol ->
      validate pv hash protocol >>=? fun proto -> return proto

let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) =
  let protocol_level = State.Block.protocol_level block in
  let chain_state = State.Block.chain_state block in
  State.Block.context block
  >>=? fun context ->
  let protocol =
    Context.get_protocol context
    >>= fun protocol_hash ->
    fetch_and_compile_protocol pv ?peer ?timeout protocol_hash
    >>=? fun _p ->
    let chain_id = State.Chain.id chain_state in
    State.Chain.update_level_indexed_protocol_store
      chain_state
      chain_id
      protocol_level
      protocol_hash
      (State.Block.header block)
    >>= fun () -> return_unit
  and test_protocol =
    Context.get_test_chain context
    >>= function
    | Not_running ->
        return_unit
    | Forking {protocol; _} | Running {protocol; _} ->
        fetch_and_compile_protocol pv ?peer ?timeout protocol
        >>=? fun _ ->
        State.Chain.test chain_state
        >>= (function
              | None ->
                  Lwt.return_unit
              | Some chain_id ->
                  State.Chain.update_level_indexed_protocol_store
                    chain_state
                    chain_id
                    protocol_level
                    protocol
                    (State.Block.header block))
        >>= fun () -> return_unit
  in
  protocol >>=? fun () -> test_protocol

let prefetch_and_compile_protocols pv ?peer ?timeout block =
  try ignore (fetch_and_compile_protocols pv ?peer ?timeout block)
  with _ -> ()
src/lib_shell/protocol_validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Validation_errors.

(* ❌ Structure item `include` not handled. *)
include

Record t := {
  db : Tezos_shell.Distributed_db.t;
  worker : Lwt.t unit;
  request : Lwt_condition.t unit;
  pending :
    Tezos_base__TzPervasives.Protocol_hash.Map.t
      (Tezos_base__TzPervasives.Protocol.t *
        (Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t)) *
        (Lwt.u
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_updater.Registered_protocol.t)));
  canceler : Tezos_base__TzPervasives.Lwt_canceler.t }.

Fixpoint worker_loop (bv : t) : Lwt.t unit :=
  op_gtgteq
    (if equiv_decb (Protocol_hash.Map.cardinal (pending bv)) 0 then
      op_gtgteq (Lwt_condition.wait None (request bv)) _return
    else
      let '(hash, (protocol, _, wakener)) :=
        Protocol_hash.Map.choose (pending bv) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field bv "pending" % string
          (Protocol_hash.Map.remove hash (pending bv)) in
      op_gtgteq (Updater.compile hash protocol)
        (fun valid =>
          op_gtgteqquestion
            (if valid then
              Distributed_db.commit_protocol (db bv) hash protocol
            else
              return_true)
            (fun function_parameter =>
              let '_ := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                if valid then
                  match Registered_protocol.get hash with
                  | Some protocol =>
                    Lwt.wakeup_later wakener (Stdlib.Ok protocol)
                  | None =>
                    Lwt.wakeup_later wakener
                      (error
                        (Tezos_base__TzPervasives.Invalid_protocol
                          {| hash := hash;
                            error :=
                              Tezos_shell_services.Validation_errors.Dynlinking_failed
                            |}))
                  end
                else
                  Lwt.wakeup_later wakener
                    (error
                      (Tezos_base__TzPervasives.Invalid_protocol
                        {| hash := hash;
                          error :=
                            Tezos_shell_services.Validation_errors.Compilation_failed
                          |})) in
              return_unit)))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => worker_loop bv
      |
        Stdlib.Error (cons Tezos_base__TzPervasives.Canceled _) |
          Stdlib.Error (cons (Tezos_base__TzPervasives.Exn Closed) _) =>
        lwt_log_notice
          (fun f =>
            op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "terminating" % string
                    CamlinternalFormatBasics.End_of_format)
                  "terminating" % string)) (t event "terminating" % string))
      | Stdlib.Error err =>
        op_gtgteq
          (lwt_log_error
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unexpected error (worker):" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))
                      "@[Unexpected error (worker):@ %a@]" % string))
                  (t event "unexpected_error" % string)) (a errs_tag err)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_canceler.cancel (canceler bv))
      end).

Definition create (db : Tezos_shell.Distributed_db.t) : t :=
  let canceler := Lwt_canceler.create tt in
  let pending := Protocol_hash.Map.empty in
  let request := Lwt_condition.create tt in
  let bv :=
    {| db := db; worker := Lwt.return_unit; request := request;
      pending := pending; canceler := canceler |} in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Lwt_canceler.on_cancel (canceler bv)
      (fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Protocol_hash.Map.iter
            (fun function_parameter =>
              let '_ := function_parameter in
              fun function_parameter =>
                let '(_, r, _) := function_parameter in
                Lwt.cancel r) (pending bv) in
        Lwt.return_unit) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field bv "worker" % string
      (Lwt_utils.worker "block_validator" % string
        Internal_event.Lwt_worker_event.on_event
        (fun function_parameter =>
          let 'tt := function_parameter in
          worker_loop bv)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt_canceler.cancel (canceler bv))) in
  bv.

Definition shutdown (function_parameter : t) : Lwt.t unit :=
  let '{| worker := worker; canceler := canceler |} := function_parameter in
  op_gtgteq (Lwt_canceler.cancel canceler)
    (fun function_parameter =>
      let 'tt := function_parameter in
      worker).

Definition validate
  (state : t) (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  (protocol : Tezos_base__TzPervasives.Protocol.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_updater.Registered_protocol.t) :=
  match Registered_protocol.get hash with
  | Some protocol =>
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "previously validated protocol " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        " (before pipe)" % string
                        CamlinternalFormatBasics.End_of_format)))
                  "previously validated protocol %a (before pipe)" % string))
              (t event "previously_validated_protocol" % string))
            (a Protocol_hash.Logging.tag hash)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        _return protocol)
  | None =>
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "pushing validation request for protocol " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "pushing validation request for protocol %a" % string))
              (t event "pushing_validation_request" % string))
            (a Protocol_hash.Logging.tag hash)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        match Protocol_hash.Map.find_opt hash (pending state) with
        | None =>
          let '(res, wakener) := Lwt.task tt in
          let broadcast :=
            equiv_decb (Protocol_hash.Map.cardinal (pending state)) 0 in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field state "pending" % string
              (Protocol_hash.Map.add hash (protocol, res, wakener)
                (pending state)) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if broadcast then
              Lwt_condition.broadcast (request state) tt
            else
              tt in
          res
        | Some (_, res, _) => res
        end)
  end.

Definition fetch_and_compile_protocol
  (pv : t) (peer : option Tezos_base__P2p_peer_id.t)
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (hash : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_updater.Registered_protocol.t) :=
  match Registered_protocol.get hash with
  | Some proto => _return proto
  | None =>
    op_gtgteqquestion
      (op_gtgteq (Distributed_db.Protocol.read_opt (db pv) hash)
        (fun function_parameter =>
          match function_parameter with
          | Some protocol => _return protocol
          | None =>
            op_gtgteq
              (lwt_log_notice
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Fetching protocol " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)))
                            "Fetching protocol %a%a" % string))
                        (t event "fetching_protocol" % string))
                      (a Protocol_hash.Logging.tag hash))
                    (a P2p_peer.Id.Logging.tag_source peer)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Distributed_db.Protocol.fetch (db pv) peer timeout hash tt)
          end))
      (fun protocol =>
        op_gtgteqquestion (validate pv hash protocol)
          (fun proto => _return proto))
  end.

Definition fetch_and_compile_protocols
  (pv : t) (peer : option Tezos_base__P2p_peer_id.t)
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (block : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let protocol_level := State.Block.protocol_level block in
  let chain_state := State.Block.chain_state block in
  op_gtgteqquestion (State.Block.context block)
    (fun context =>
      let protocol : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
        op_gtgteq (Context.get_protocol context)
          (fun protocol_hash =>
            op_gtgteqquestion
              (fetch_and_compile_protocol pv peer timeout protocol_hash)
              (fun _p =>
                let chain_id := State.Chain.id chain_state in
                op_gtgteq
                  (State.Chain.update_level_indexed_protocol_store chain_state
                    chain_id protocol_level protocol_hash
                    (State.Block.header block))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      with test_protocol : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
        op_gtgteq (Context.get_test_chain context)
          (fun function_parameter =>
            match function_parameter with
            | Tezos_base__TzPervasives.Test_chain_status.Not_running =>
              return_unit
            |
              Tezos_base__TzPervasives.Test_chain_status.Forking {|
                protocol := protocol |} |
                Tezos_base__TzPervasives.Test_chain_status.Running {|
                  protocol := protocol |} =>
              op_gtgteqquestion
                (fetch_and_compile_protocol pv peer timeout protocol)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_gtgteq
                    (op_gtgteq (State.Chain.test chain_state)
                      (fun function_parameter =>
                        match function_parameter with
                        | None => Lwt.return_unit
                        | Some chain_id =>
                          State.Chain.update_level_indexed_protocol_store
                            chain_state chain_id protocol_level protocol
                            (State.Block.header block)
                        end))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit))
            end) in
      op_gtgteqquestion protocol
        (fun function_parameter =>
          let 'tt := function_parameter in
          test_protocol)).

Definition prefetch_and_compile_protocols
  (pv : t) (peer : option Tezos_base__P2p_peer_id.t)
  (timeout : option Tezos_base__TzPervasives.Time.System.Span.t)
  (block : Tezos_shell.State.Block.t) : unit :=
  (* ❌ Try-with are not handled *)
  try (OCaml.Stdlib.ignore (fetch_and_compile_protocols pv peer timeout block)).

src/lib_shell/snapshots.ml 101 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type status =
  | Export_unspecified_hash of Block_hash.t
  | Export_info of History_mode.t * Block_hash.t * Int32.t
  | Export_success of string
  | Set_history_mode of History_mode.t
  | Import_info of string
  | Import_unspecified_hash
  | Import_loading
  | Set_head of Block_hash.t
  | Import_success of string

let status_pp ppf = function
  | Export_unspecified_hash h ->
      Format.fprintf
        ppf
        "There is no block hash specified with the `--block` option. Using %a \
         (last checkpoint)"
        Block_hash.pp
        h
  | Export_info (hm, h, l) ->
      Format.fprintf
        ppf
        "Exporting a snapshot in %a mode, targeting block hash %a at level %a"
        History_mode.pp
        hm
        Block_hash.pp
        h
        Format.pp_print_int
        (Int32.to_int l)
  | Export_success filename ->
      Format.fprintf ppf "@[Successful export: %s@]" filename
  | Set_history_mode hm ->
      Format.fprintf ppf "Setting history-mode to %a" History_mode.pp hm
  | Import_info filename ->
      Format.fprintf ppf "Importing data from snapshot file %s" filename
  | Import_unspecified_hash ->
      Format.fprintf
        ppf
        "You may consider using the --block <block_hash> argument to verify \
         that the block imported is the one you expect"
  | Import_loading ->
      Format.fprintf
        ppf
        "Retrieving and validating data. This can take a while, please bear \
         with us"
  | Set_head h ->
      Format.fprintf ppf "Setting current head to block %a" Block_hash.pp h
  | Import_success filename ->
      Format.fprintf ppf "@[Successful import from file %s@]" filename

type t = status Time.System.stamped

module Definition = struct
  let name = "snapshot"

  type nonrec t = t

  let encoding =
    let open Data_encoding in
    Time.System.stamped_encoding
    @@ union
         [ case
             (Tag 0)
             ~title:"Export_unspecified_hash"
             Block_hash.encoding
             (function Export_unspecified_hash h -> Some h | _ -> None)
             (fun h -> Export_unspecified_hash h);
           case
             (Tag 1)
             ~title:"Export_info"
             (obj3
                (req "history_mode" History_mode.encoding)
                (req "block_hash" Block_hash.encoding)
                (req "level" int32))
             (function Export_info (hm, h, l) -> Some (hm, h, l) | _ -> None)
             (fun (hm, h, l) -> Export_info (hm, h, l));
           case
             (Tag 2)
             ~title:"Export_success"
             string
             (function Export_success s -> Some s | _ -> None)
             (fun s -> Export_success s);
           case
             (Tag 3)
             ~title:"Set_history_mode"
             History_mode.encoding
             (function Set_history_mode hm -> Some hm | _ -> None)
             (fun hm -> Set_history_mode hm);
           case
             (Tag 4)
             ~title:"Import_info"
             string
             (function Import_info s -> Some s | _ -> None)
             (fun s -> Import_info s);
           case
             (Tag 5)
             ~title:"Import_unspecified_hash"
             empty
             (function Import_unspecified_hash -> Some () | _ -> None)
             (fun () -> Import_unspecified_hash);
           case
             (Tag 6)
             ~title:"Import_loading"
             empty
             (function Import_loading -> Some () | _ -> None)
             (fun () -> Import_loading);
           case
             (Tag 7)
             ~title:"Set_head"
             Block_hash.encoding
             (function Set_head h -> Some h | _ -> None)
             (fun h -> Set_head h);
           case
             (Tag 8)
             ~title:"Import_success"
             string
             (function Import_success s -> Some s | _ -> None)
             (fun s -> Import_success s) ]

  let pp ppf (status : t) = Format.fprintf ppf "%a" status_pp status.data

  let doc = "Snapshots status."

  let level (status : t) =
    match status.data with
    | Export_unspecified_hash _
    | Export_info _
    | Export_success _
    | Set_history_mode _
    | Import_info _
    | Import_unspecified_hash
    | Import_loading
    | Set_head _
    | Import_success _ ->
        Internal_event.Notice
end

module Event_snapshot = Internal_event.Make (Definition)

let lwt_emit (status : status) =
  let time = Systime_os.now () in
  Event_snapshot.emit
    ~section:(Internal_event.Section.make_sanitized [Definition.name])
    (fun () -> Time.System.stamp ~time status)
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error el ->
      Format.kasprintf
        Lwt.fail_with
        "Snapshot_event.emit: %a"
        pp_print_error
        el

type error += Wrong_snapshot_export of History_mode.t * History_mode.t

type error +=
  | Wrong_block_export of
      Block_hash.t * [`Pruned | `Too_few_predecessors | `Cannot_be_found]

type error += Inconsistent_imported_block of Block_hash.t * Block_hash.t

type error += Snapshot_import_failure of string

type error += Wrong_protocol_hash of Protocol_hash.t

type error +=
  | Inconsistent_operation_hashes of
      (Operation_list_list_hash.t * Operation_list_list_hash.t)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"WrongSnapshotExport"
    ~title:"Wrong snapshot export"
    ~description:
      "Snapshot exports is not compatible with the current configuration."
    ~pp:(fun ppf (src, dst) ->
      Format.fprintf
        ppf
        "Cannot export a %a snapshot from a %a node."
        History_mode.pp
        dst
        History_mode.pp
        src)
    (obj2 (req "src" History_mode.encoding) (req "dst" History_mode.encoding))
    (function
      | Wrong_snapshot_export (src, dst) -> Some (src, dst) | _ -> None)
    (fun (src, dst) -> Wrong_snapshot_export (src, dst)) ;
  let pp_wrong_block_export_error ppf kind =
    let str =
      match kind with
      | `Pruned ->
          "is pruned"
      | `Too_few_predecessors ->
          "has not enough predecessors"
      | `Cannot_be_found ->
          "cannot be found"
    in
    Format.fprintf ppf "%s" str
  in
  let error_kind_encoding =
    string_enum
      [ ("pruned", `Pruned);
        ("too_few_predecessors", `Too_few_predecessors);
        ("cannot_be_found", `Cannot_be_found) ]
  in
  register_error_kind
    `Permanent
    ~id:"WrongBlockExport"
    ~title:"Wrong block export"
    ~description:"The block to export in the snapshot is not valid."
    ~pp:(fun ppf (bh, kind) ->
      Format.fprintf
        ppf
        "Fails to export snapshot as the block with block hash %a %a."
        Block_hash.pp
        bh
        pp_wrong_block_export_error
        kind)
    (obj2
       (req "block_hash" Block_hash.encoding)
       (req "kind" error_kind_encoding))
    (function Wrong_block_export (bh, kind) -> Some (bh, kind) | _ -> None)
    (fun (bh, kind) -> Wrong_block_export (bh, kind)) ;
  register_error_kind
    `Permanent
    ~id:"InconsistentImportedBlock"
    ~title:"Inconsistent imported block"
    ~description:"The imported block is not the expected one."
    ~pp:(fun ppf (got, exp) ->
      Format.fprintf
        ppf
        "The block contained in the file is %a instead of %a."
        Block_hash.pp
        got
        Block_hash.pp
        exp)
    (obj2
       (req "block_hash" Block_hash.encoding)
       (req "block_hash_expected" Block_hash.encoding))
    (function
      | Inconsistent_imported_block (got, exp) -> Some (got, exp) | _ -> None)
    (fun (got, exp) -> Inconsistent_imported_block (got, exp)) ;
  register_error_kind
    `Permanent
    ~id:"SnapshotImportFailure"
    ~title:"Snapshot import failure"
    ~description:"The imported snapshot is malformed."
    ~pp:(fun ppf msg ->
      Format.fprintf
        ppf
        "The data contained in the snapshot is not valid. The import \
         mechanism failed to validate the file: %s."
        msg)
    (obj1 (req "message" string))
    (function Snapshot_import_failure str -> Some str | _ -> None)
    (fun str -> Snapshot_import_failure str) ;
  register_error_kind
    `Permanent
    ~id:"WrongProtocolHash"
    ~title:"Wrong protocol hash"
    ~description:"Wrong protocol hash"
    ~pp:(fun ppf p ->
      Format.fprintf
        ppf
        "Wrong protocol hash (%a) found in snapshot. Snapshot is corrupted."
        Protocol_hash.pp
        p)
    (obj1 (req "protocol_hash" Protocol_hash.encoding))
    (function Wrong_protocol_hash p -> Some p | _ -> None)
    (fun p -> Wrong_protocol_hash p) ;
  register_error_kind
    `Permanent
    ~id:"InconsistentOperationHashes"
    ~title:"Inconsistent operation hashes"
    ~description:"The operations given do not match their hashes."
    ~pp:(fun ppf (oph, oph') ->
      Format.fprintf
        ppf
        "Inconsistent operation hashes. Expected: %a, got: %a."
        Operation_list_list_hash.pp
        oph
        Operation_list_list_hash.pp
        oph')
    (obj2
       (req "expected_operation_hashes" Operation_list_list_hash.encoding)
       (req "received_operation_hashes" Operation_list_list_hash.encoding))
    (function
      | Inconsistent_operation_hashes (oph, oph') ->
          Some (oph, oph')
      | _ ->
          None)
    (fun (oph, oph') -> Inconsistent_operation_hashes (oph, oph'))

let ( // ) = Filename.concat

let context_dir data_dir = data_dir // "context"

let store_dir data_dir = data_dir // "store"

let compute_export_limit block_store chain_data_store block_header
    export_rolling =
  let block_hash = Block_header.hash block_header in
  Store.Block.Contents.read_opt (block_store, block_hash)
  >>= (function
        | Some contents ->
            return contents
        | None ->
            fail (Wrong_block_export (block_hash, `Pruned)))
  >>=? fun {max_operations_ttl; _} ->
  if not export_rolling then
    Store.Chain_data.Caboose.read chain_data_store
    >>=? fun (caboose_level, _) -> return (max 1l caboose_level)
  else
    let limit =
      Int32.(
        sub block_header.Block_header.shell.level (of_int max_operations_ttl))
    in
    (* fails when the limit exceeds the genesis or the genesis is
       included in the export limit *)
    fail_when
      (limit <= 0l)
      (Wrong_block_export (block_hash, `Too_few_predecessors))
    >>=? fun () -> return limit

(** When called with a block, returns its predecessor if it exists and
    its protocol_data if the block is a transition block (i.e. protocol
    level changing block) or when there is no more predecessor. *)
let pruned_block_iterator index block_store limit header =
  if header.Block_header.shell.level <= limit then
    Context.get_protocol_data_from_header index header
    >>= fun protocol_data -> return (None, Some protocol_data)
  else
    let pred_hash = header.Block_header.shell.predecessor in
    State.Block.Header.read (block_store, pred_hash)
    >>=? fun pred_header ->
    Store.Block.Operations.bindings (block_store, pred_hash)
    >>= fun pred_operations ->
    Store.Block.Operation_hashes.bindings (block_store, pred_hash)
    >>= fun pred_operation_hashes ->
    let pruned_block =
      {
        Context.Pruned_block.block_header = pred_header;
        operations = pred_operations;
        operation_hashes = pred_operation_hashes;
      }
    in
    let header_proto_level = header.Block_header.shell.proto_level in
    let pred_header_proto_level = pred_header.Block_header.shell.proto_level in
    if header_proto_level <> pred_header_proto_level then
      Context.get_protocol_data_from_header index header
      >>= fun proto_data -> return (Some pruned_block, Some proto_data)
    else return (Some pruned_block, None)

let export ?(export_rolling = false) ~context_index ~store ~genesis filename
    block =
  let chain_id = Chain_id.of_block_hash genesis in
  let chain_store = Store.Chain.get store chain_id in
  let chain_data_store = Store.Chain_data.get chain_store in
  let block_store = Store.Block.get chain_store in
  Store.Configuration.History_mode.read_opt store
  >>= (function
        | Some (Archive | Full) | None ->
            return_unit
        | Some (Rolling as history_mode) ->
            if export_rolling then return_unit
            else fail (Wrong_snapshot_export (history_mode, History_mode.Full)))
  >>=? fun () ->
  ( match block with
  | Some block_hash ->
      Lwt.return (Block_hash.of_b58check block_hash)
  | None ->
      Store.Chain_data.Checkpoint.read_opt chain_data_store
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun last_checkpoint ->
      if last_checkpoint.shell.level = 0l then
        fail (Wrong_block_export (genesis, `Too_few_predecessors))
      else
        let last_checkpoint_hash = Block_header.hash last_checkpoint in
        lwt_emit (Export_unspecified_hash last_checkpoint_hash)
        >>= fun () -> return last_checkpoint_hash )
  >>=? fun checkpoint_block_hash ->
  State.Block.Header.read_opt (block_store, checkpoint_block_hash)
  >>= (function
        | None ->
            fail (Wrong_block_export (checkpoint_block_hash, `Cannot_be_found))
        | Some block_header ->
            let export_mode =
              if export_rolling then History_mode.Rolling else Full
            in
            lwt_emit
              (Export_info
                 (export_mode, checkpoint_block_hash, block_header.shell.level))
            >>= fun () ->
            (* Get block precessor's block header *)
            Store.Block.Predecessors.read
              (block_store, checkpoint_block_hash)
              0
            >>=? fun pred_block_hash ->
            State.Block.Header.read (block_store, pred_block_hash)
            >>=? fun pred_block_header ->
            (* Get operation list *)
            let validations_passes = block_header.shell.validation_passes in
            map_s
              (fun i ->
                Store.Block.Operations.read
                  (block_store, checkpoint_block_hash)
                  i)
              (0 -- (validations_passes - 1))
            >>=? fun operations ->
            compute_export_limit
              block_store
              chain_data_store
              block_header
              export_rolling
            >>=? fun export_limit ->
            let iterator =
              pruned_block_iterator context_index block_store export_limit
            in
            let block_data = {Context.Block_data.block_header; operations} in
            return (pred_block_header, block_data, export_mode, iterator))
  >>=? fun data_to_dump ->
  Context.dump_contexts context_index data_to_dump ~filename
  >>=? fun () -> lwt_emit (Export_success filename) >>= fun () -> return_unit

let check_operations_consistency block_header operations operation_hashes =
  (* Compute operations hashes and compare *)
  List.iter2
    (fun (_, op) (_, oph) ->
      let expected_op_hash = List.map Operation.hash op in
      List.iter2
        (fun expected found ->
          assert (Operation_hash.equal expected found) (* paul:here *))
        expected_op_hash
        oph)
    operations
    operation_hashes ;
  (* Check header hashes based on merkel tree *)
  let hashes =
    List.map
      (fun (_, opl) -> List.map Operation.hash opl)
      (List.rev operations)
  in
  let computed_hash =
    Operation_list_list_hash.compute
      (List.map Operation_list_hash.compute hashes)
  in
  let are_oph_equal =
    Operation_list_list_hash.equal
      computed_hash
      block_header.Block_header.shell.operations_hash
  in
  fail_unless
    are_oph_equal
    (Inconsistent_operation_hashes
       (computed_hash, block_header.Block_header.shell.operations_hash))

let compute_predecessors ~genesis_hash oldest_level block_hashes i =
  let rec step s d acc =
    if oldest_level = 1l && i - d = -1 then List.rev ((s, genesis_hash) :: acc)
    else if i - d < 0 then List.rev acc
    else step (s + 1) (d * 2) ((s, block_hashes.(i - d)) :: acc)
  in
  step 0 1 []

let check_context_hash_consistency block_validation_result block_header =
  fail_unless
    (Context_hash.equal
       block_validation_result.Tezos_validation.Block_validation.context_hash
       block_header.Block_header.shell.context)
    (Snapshot_import_failure "resulting context hash does not match")

let set_history_mode store history_mode =
  match history_mode with
  | History_mode.Full | History_mode.Rolling ->
      lwt_emit (Set_history_mode history_mode)
      >>= fun () ->
      Store.Configuration.History_mode.store store history_mode
      >>= fun () -> return_unit
  | History_mode.Archive ->
      fail (Snapshot_import_failure "cannot import an archive context")

let store_new_head chain_state chain_data ~genesis block_header operations
    block_validation_result =
  let ({validation_store; block_metadata; ops_metadata; forking_testchain}
        : Tezos_validation.Block_validation.result) =
    block_validation_result
  in
  State.Block.store
    chain_state
    block_header
    block_metadata
    operations
    ops_metadata
    ~forking_testchain
    validation_store
  >>=? fun new_head ->
  match new_head with
  | None ->
      (* Should not happen as the data-dir must be empty *)
      fail
        (Snapshot_import_failure "a chain head is already present in the store")
  | Some new_head ->
      (* New head is set*)
      Store.Chain_data.Known_heads.remove chain_data genesis
      >>= fun () ->
      Store.Chain_data.Known_heads.store chain_data (State.Block.hash new_head)
      >>= fun () ->
      Store.Chain_data.Current_head.store
        chain_data
        (State.Block.hash new_head)
      >>= fun () -> return_unit

let update_checkpoint chain_state checkpoint_header =
  let block_hash = Block_header.hash checkpoint_header in
  (* Imported block is set as the current checkpoint/save_point … *)
  let new_checkpoint =
    (checkpoint_header.Block_header.shell.level, block_hash)
  in
  State.Chain.set_checkpoint chain_state checkpoint_header
  >>= fun () -> Lwt.return new_checkpoint

let update_savepoint chain_state new_savepoint =
  State.update_chain_data chain_state (fun store data ->
      let new_data = {data with save_point = new_savepoint} in
      Store.Chain_data.Save_point.store store new_savepoint
      >>= fun () -> Lwt.return (Some new_data, ()))

let update_caboose chain_data ~genesis block_header oldest_header max_op_ttl =
  let oldest_level = oldest_header.Block_header.shell.level in
  let caboose_level = if oldest_level = 1l then 0l else oldest_level in
  let caboose_hash =
    if oldest_level = 1l then genesis else Block_header.hash oldest_header
  in
  let minimal_caboose_level =
    Int32.(sub block_header.Block_header.shell.level (of_int max_op_ttl))
  in
  fail_unless
    Compare.Int32.(caboose_level <= minimal_caboose_level)
    (Snapshot_import_failure
       (Format.sprintf "caboose level (%ld) is not valid" caboose_level))
  >>=? fun () ->
  Store.Chain_data.Caboose.store chain_data (caboose_level, caboose_hash)
  >>= fun () -> return_unit

let import_protocol_data index store block_hash_arr level_oldest_block
    (level, protocol_data) =
  (* Retrieve the original context hash of the block. *)
  let delta = Int32.(to_int (sub level level_oldest_block)) in
  let pruned_block_hash = block_hash_arr.(delta) in
  let block_store = Store.Block.get store in
  State.Block.Header.read_opt (block_store, pruned_block_hash)
  >>= (function
        | None -> assert false | Some block_header -> Lwt.return block_header)
  >>= fun block_header ->
  let expected_context_hash = block_header.Block_header.shell.context in
  (* Retrieve the input info. *)
  let info = protocol_data.Context.Protocol_data.info in
  let test_chain = protocol_data.test_chain_status in
  let data_hash = protocol_data.data_key in
  let parents = protocol_data.parents in
  let protocol_hash = protocol_data.protocol_hash in
  (* Validate the context hash consistency, and so the protocol data. *)
  Context.validate_context_hash_consistency_and_commit
    ~author:info.author
    ~timestamp:info.timestamp
    ~message:info.message
    ~data_hash
    ~parents
    ~expected_context_hash
    ~test_chain
    ~protocol_hash
    ~index
  >>= function
  | true ->
      let protocol_level = block_header.shell.proto_level in
      let block_level = block_header.shell.level in
      Store.Chain.Protocol_info.store
        store
        protocol_level
        (protocol_hash, block_level)
      >>= fun () -> return_unit
  | false ->
      fail (Wrong_protocol_hash protocol_hash)

let import_protocol_data_list index store block_hash_arr level_oldest_block
    protocol_data =
  let rec aux = function
    | [] ->
        return_unit
    | (level, protocol_data) :: xs ->
        import_protocol_data
          index
          store
          block_hash_arr
          level_oldest_block
          (level, protocol_data)
        >>=? fun () -> aux xs
  in
  aux protocol_data

let verify_predecessors header_opt pred_hash =
  match header_opt with
  | None ->
      return_unit
  | Some header ->
      fail_unless
        ( header.Block_header.shell.level >= 2l
        && Block_hash.equal header.shell.predecessor pred_hash )
        (Snapshot_import_failure "inconsistent predecessors")

let verify_oldest_header oldest_header genesis_hash =
  let oldest_level = oldest_header.Block_header.shell.level in
  fail_unless
    ( oldest_level >= 1l
    || Compare.Int32.(oldest_level = 1l)
       && Block_hash.equal
            oldest_header.Block_header.shell.predecessor
            genesis_hash )
    (Snapshot_import_failure "inconsistent oldest level")

let block_validation succ_header_opt header_hash
    {Context.Pruned_block.block_header; operations; operation_hashes} =
  verify_predecessors succ_header_opt header_hash
  >>=? fun () ->
  check_operations_consistency block_header operations operation_hashes
  >>=? fun () -> return_unit

let import ~data_dir ~dir_cleaner ~patch_context ~genesis filename block =
  lwt_emit (Import_info filename)
  >>= fun () ->
  ( match block with
  | None ->
      lwt_emit Import_unspecified_hash
  | Some _ ->
      Lwt.return_unit )
  >>= fun () ->
  lwt_emit Import_loading
  >>= fun () ->
  let context_root = context_dir data_dir in
  let store_root = store_dir data_dir in
  let chain_id = Chain_id.of_block_hash genesis.State.Chain.block in
  (* FIXME: use config value ? *)
  State.init
    ~context_root
    ~store_root
    genesis
    ~patch_context:(patch_context None)
  >>=? fun (state, chain_state, context_index, _history_mode) ->
  Store.init store_root
  >>=? fun store ->
  let chain_store = Store.Chain.get store chain_id in
  let chain_data = Store.Chain_data.get chain_store in
  let block_store = Store.Block.get chain_store in
  let open Context in
  Lwt.try_bind
    (fun () ->
      let k_store_pruned_blocks data =
        Store.with_atomic_rw store (fun () ->
            Error_monad.iter_s
              (fun (pruned_header_hash, pruned_block) ->
                Store.Block.Pruned_contents.store
                  (block_store, pruned_header_hash)
                  {header = pruned_block.Context.Pruned_block.block_header}
                >>= fun () ->
                Lwt_list.iter_s
                  (fun (i, v) ->
                    Store.Block.Operations.store
                      (block_store, pruned_header_hash)
                      i
                      v)
                  pruned_block.operations
                >>= fun () ->
                Lwt_list.iter_s
                  (fun (i, v) ->
                    Store.Block.Operation_hashes.store
                      (block_store, pruned_header_hash)
                      i
                      v)
                  pruned_block.operation_hashes
                >>= fun () -> return_unit)
              data)
      in
      (* Restore context and fetch data *)
      restore_contexts
        context_index
        ~filename
        k_store_pruned_blocks
        block_validation
      >>=? fun ( predecessor_block_header,
                 meta,
                 history_mode,
                 oldest_header_opt,
                 rev_block_hashes,
                 protocol_data ) ->
      let oldest_header = Option.unopt_assert ~loc:__POS__ oldest_header_opt in
      let block_hashes_arr = Array.of_list rev_block_hashes in
      let write_predecessors_table to_write =
        Store.with_atomic_rw store (fun () ->
            Lwt_list.iter_s
              (fun (current_hash, predecessors_list) ->
                Lwt_list.iter_s
                  (fun (l, h) ->
                    Store.Block.Predecessors.store
                      (block_store, current_hash)
                      l
                      h)
                  predecessors_list
                >>= fun () ->
                match predecessors_list with
                | (0, pred_hash) :: _ ->
                    Store.Chain_data.In_main_branch.store
                      (chain_data, pred_hash)
                      current_hash
                | [] ->
                    Lwt.return_unit
                | _ :: _ ->
                    assert false)
              to_write)
      in
      Lwt_list.fold_left_s
        (fun (cpt, to_write) current_hash ->
          Tezos_stdlib_unix.Utils.display_progress
            ~refresh_rate:(cpt, 1_000)
            "Computing predecessors table %dK elements%!"
            (cpt / 1_000) ;
          ( if (cpt + 1) mod 5_000 = 0 then
            write_predecessors_table to_write >>= fun () -> Lwt.return_nil
          else Lwt.return to_write )
          >>= fun to_write ->
          let predecessors_list =
            compute_predecessors
              ~genesis_hash:genesis.block
              oldest_header.shell.level
              block_hashes_arr
              cpt
          in
          Lwt.return (cpt + 1, (current_hash, predecessors_list) :: to_write))
        (0, [])
        rev_block_hashes
      >>= fun (_, to_write) ->
      write_predecessors_table to_write
      >>= fun () ->
      Tezos_stdlib_unix.Utils.display_progress_end () ;
      (* Process data imported from snapshot *)
      let {Block_data.block_header; operations} = meta in
      let block_hash = Block_header.hash block_header in
      (* Checks that the block hash imported by the snapshot is the expected one *)
      ( match block with
      | Some str ->
          let bh = Block_hash.of_b58check_exn str in
          fail_unless
            (Block_hash.equal bh block_hash)
            (Inconsistent_imported_block (bh, block_hash))
      | None ->
          return_unit )
      >>=? fun () ->
      lwt_emit (Set_head (Block_header.hash block_header))
      >>= fun () ->
      let pred_context_hash = predecessor_block_header.shell.context in
      checkout_exn context_index pred_context_hash
      >>= fun predecessor_context ->
      (* ... we can now call apply ... *)
      Tezos_validation.Block_validation.apply
        chain_id
        ~max_operations_ttl:(Int32.to_int predecessor_block_header.shell.level)
        ~predecessor_block_header
        ~predecessor_context
        ~block_header
        operations
      >>=? fun block_validation_result ->
      check_context_hash_consistency
        block_validation_result.validation_store
        block_header
      >>=? fun () ->
      verify_oldest_header oldest_header genesis.block
      >>=? fun () ->
      (* ... we set the history mode regarding the snapshot version hint ... *)
      set_history_mode store history_mode
      >>=? fun () ->
      (* ... and we import protocol data...*)
      import_protocol_data_list
        context_index
        chain_store
        block_hashes_arr
        oldest_header.Block_header.shell.level
        protocol_data
      >>=? fun () ->
      (* Everything is ok. We can store the new head *)
      store_new_head
        chain_state
        chain_data
        ~genesis:genesis.block
        block_header
        operations
        block_validation_result
      >>=? fun () ->
      (* Update history mode flags *)
      update_checkpoint chain_state block_header
      >>= fun new_checkpoint ->
      update_savepoint chain_state new_checkpoint
      >>= fun () ->
      update_caboose
        chain_data
        ~genesis:genesis.block
        block_header
        oldest_header
        block_validation_result.validation_store.max_operations_ttl
      >>=? fun () ->
      Store.close store ;
      State.close state >>= fun () -> return_unit)
    (function
      | Ok () ->
          lwt_emit (Import_success filename) >>= fun () -> return_unit
      | Error errors ->
          dir_cleaner data_dir >>= fun () -> Lwt.return (Error errors))
    (fun exn -> dir_cleaner data_dir >>= fun () -> Lwt.fail exn)
src/lib_shell/snapshots.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive status : Type :=
| Export_unspecified_hash : Tezos_base__TzPervasives.Block_hash.t -> status
| Export_info : Tezos_shell_services.History_mode.t ->
  Tezos_base__TzPervasives.Block_hash.t -> Stdlib.Int32.t -> status
| Export_success : string -> status
| Set_history_mode : Tezos_shell_services.History_mode.t -> status
| Import_info : string -> status
| Import_unspecified_hash : status
| Import_loading : status
| Set_head : Tezos_base__TzPervasives.Block_hash.t -> status
| Import_success : string -> status.

Definition status_pp
  (ppf : Stdlib.Format.formatter) (function_parameter : status) : unit :=
  match function_parameter with
  | Export_unspecified_hash h =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "There is no block hash specified with the `--block` option. Using " %
            string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " (last checkpoint)" % string
              CamlinternalFormatBasics.End_of_format)))
        "There is no block hash specified with the `--block` option. Using %a (last checkpoint)"
          % string) Block_hash.pp h
  | Export_info hm h l =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Exporting a snapshot in " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " mode, targeting block hash " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " at level " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))))))
        "Exporting a snapshot in %a mode, targeting block hash %a at level %a" %
          string) History_mode.pp hm Block_hash.pp h Format.pp_print_int
      (Int32.to_int l)
  | Export_success filename =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String_literal
            "Successful export: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))))
        "@[Successful export: %s@]" % string) filename
  | Set_history_mode hm =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Setting history-mode to " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Setting history-mode to %a" % string) History_mode.pp hm
  | Import_info filename =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Importing data from snapshot file " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format))
        "Importing data from snapshot file %s" % string) filename
  | Import_unspecified_hash =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "You may consider using the --block <block_hash> argument to verify that the block imported is the one you expect"
            % string CamlinternalFormatBasics.End_of_format)
        "You may consider using the --block <block_hash> argument to verify that the block imported is the one you expect"
          % string)
  | Import_loading =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Retrieving and validating data. This can take a while, please bear with us"
            % string CamlinternalFormatBasics.End_of_format)
        "Retrieving and validating data. This can take a while, please bear with us"
          % string)
  | Set_head h =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Setting current head to block " % string
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "Setting current head to block %a" % string) Block_hash.pp h
  | Import_success filename =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String_literal
            "Successful import from file " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))))
        "@[Successful import from file %s@]" % string) filename
  end.

Definition t := Tezos_base__TzPervasives.Time.System.stamped status.

Module Definition.
  Definition name : string := "snapshot" % string.
  
  Definition t := t.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.t
      (Tezos_base__TzPervasives.Time.System.stamped status) :=
    apply Time.System.stamped_encoding
      (union None
        (cons
          (case "Export_unspecified_hash" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 0) Block_hash.encoding
            (fun function_parameter =>
              match function_parameter with
              | Export_unspecified_hash h => Some h
              | _ => None
              end) (fun h => Export_unspecified_hash h))
          (cons
            (case "Export_info" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 1)
              (obj3
                (req None None "history_mode" % string History_mode.encoding)
                (req None None "block_hash" % string Block_hash.encoding)
                (req None None "level" % string int32))
              (fun function_parameter =>
                match function_parameter with
                | Export_info hm h l => Some (hm, h, l)
                | _ => None
                end)
              (fun function_parameter =>
                let '(hm, h, l) := function_parameter in
                Export_info hm h l))
            (cons
              (case "Export_success" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 2) string
                (fun function_parameter =>
                  match function_parameter with
                  | Export_success s => Some s
                  | _ => None
                  end) (fun s => Export_success s))
              (cons
                (case "Set_history_mode" % string None
                  (Tezos_base__TzPervasives.Data_encoding.Tag 3)
                  History_mode.encoding
                  (fun function_parameter =>
                    match function_parameter with
                    | Set_history_mode hm => Some hm
                    | _ => None
                    end) (fun hm => Set_history_mode hm))
                (cons
                  (case "Import_info" % string None
                    (Tezos_base__TzPervasives.Data_encoding.Tag 4) string
                    (fun function_parameter =>
                      match function_parameter with
                      | Import_info s => Some s
                      | _ => None
                      end) (fun s => Import_info s))
                  (cons
                    (case "Import_unspecified_hash" % string None
                      (Tezos_base__TzPervasives.Data_encoding.Tag 5) empty
                      (fun function_parameter =>
                        match function_parameter with
                        | Import_unspecified_hash => Some tt
                        | _ => None
                        end)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Import_unspecified_hash))
                    (cons
                      (case "Import_loading" % string None
                        (Tezos_base__TzPervasives.Data_encoding.Tag 6) empty
                        (fun function_parameter =>
                          match function_parameter with
                          | Import_loading => Some tt
                          | _ => None
                          end)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Import_loading))
                      (cons
                        (case "Set_head" % string None
                          (Tezos_base__TzPervasives.Data_encoding.Tag 7)
                          Block_hash.encoding
                          (fun function_parameter =>
                            match function_parameter with
                            | Set_head h => Some h
                            | _ => None
                            end) (fun h => Set_head h))
                        (cons
                          (case "Import_success" % string None
                            (Tezos_base__TzPervasives.Data_encoding.Tag 8)
                            string
                            (fun function_parameter =>
                              match function_parameter with
                              | Import_success s => Some s
                              | _ => None
                              end) (fun s => Import_success s)) [])))))))))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (status : t) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) status_pp (data status).
  
  Definition doc : string := "Snapshots status." % string.
  
  Definition level (status : t)
    : Tezos_base__TzPervasives.Internal_event.level :=
    let
      'Export_unspecified_hash _ | Export_info _ _ _ | Export_success _ |
        Set_history_mode _ | Import_info _ | Import_unspecified_hash |
        Import_loading | Set_head _ | Import_success _ := data status in
    Tezos_base__TzPervasives.Internal_event.Notice.
End Definition.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition lwt_emit (status : status) : Lwt.t unit :=
  let time := Systime_os.now tt in
  op_gtgteq
    (Event_snapshot.emit
      (Some
        (Internal_event.Section.make_sanitized
          (cons
            Definition.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
            [])))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Time.System.stamp time status))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => Lwt.return_unit
      | Stdlib.Error el =>
        Format.kasprintf Lwt.fail_with
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Snapshot_event.emit: " % string
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format))
            "Snapshot_event.emit: %a" % string) pp_print_error el
      end).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition op_divdiv : string -> string -> string := Filename.concat.

Definition context_dir (data_dir : string) : string :=
  op_divdiv data_dir "context" % string.

Definition store_dir (data_dir : string) : string :=
  op_divdiv data_dir "store" % string.

Definition compute_export_limit
  (block_store : Tezos_shell__Store.Block.store)
  (chain_data_store : Tezos_shell__Store.Chain_data.store)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (export_rolling : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t) :=
  let block_hash := Block_header.hash block_header in
  op_gtgteqquestion
    (op_gtgteq (Store.Block.Contents.read_opt (block_store, block_hash))
      (fun function_parameter =>
        match function_parameter with
        | Some contents => _return contents
        | None =>
          fail
            (Tezos_base__TzPervasives.Wrong_block_export block_hash
              (* ❌ Variants not supported *)
              variant)
        end))
    (fun function_parameter =>
      let '{| max_operations_ttl := max_operations_ttl |} := function_parameter
        in
      if negb export_rolling then
        op_gtgteqquestion (Store.Chain_data.Caboose.read chain_data_store)
          (fun function_parameter =>
            let '(caboose_level, _) := function_parameter in
            _return
              (OCaml.Stdlib.max
                (* ❌ Constant of type int32 is converted to int *)
                1 caboose_level))
      else
        let limit :=
          sub (level (Block_header.shell block_header))
            (of_int max_operations_ttl) in
        op_gtgteqquestion
          (fail_when
            (OCaml.Stdlib.le limit
              (* ❌ Constant of type int32 is converted to int *)
              0)
            (Tezos_base__TzPervasives.Wrong_block_export block_hash
              (* ❌ Variants not supported *)
              variant))
          (fun function_parameter =>
            let 'tt := function_parameter in
            _return limit)).

Definition pruned_block_iterator
  (index : Tezos_storage.Context.index)
  (block_store : Tezos_shell.Store.Block.store) (limit : Stdlib.Int32.t)
  (header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((option Tezos_storage.Context.Pruned_block.t) *
        (option Tezos_storage.Context.Protocol_data.t))) :=
  if OCaml.Stdlib.le (level (Block_header.shell header)) limit then
    op_gtgteq (Context.get_protocol_data_from_header index header)
      (fun protocol_data => _return (None, (Some protocol_data)))
  else
    let pred_hash := predecessor (Block_header.shell header) in
    op_gtgteqquestion (State.Block.Header.read (block_store, pred_hash))
      (fun pred_header =>
        op_gtgteq (Store.Block.Operations.bindings (block_store, pred_hash))
          (fun pred_operations =>
            op_gtgteq
              (Store.Block.Operation_hashes.bindings (block_store, pred_hash))
              (fun pred_operation_hashes =>
                let pruned_block :=
                  {| Context.Pruned_block.block_header := pred_header;
                    Context.Pruned_block.operations := pred_operations;
                    Context.Pruned_block.operation_hashes :=
                      pred_operation_hashes |} in
                let header_proto_level :=
                  proto_level (Block_header.shell header) in
                let pred_header_proto_level :=
                  proto_level (Block_header.shell pred_header) in
                if nequiv_decb header_proto_level pred_header_proto_level then
                  op_gtgteq (Context.get_protocol_data_from_header index header)
                    (fun proto_data =>
                      _return ((Some pruned_block), (Some proto_data)))
                else
                  _return ((Some pruned_block), None)))).

Definition export (op_staroptstar : option bool)
  : Tezos_storage.Context.index ->
    Tezos_shell__Store.global_store ->
      Tezos_crypto.Block_hash.t ->
        string ->
          (option string) -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let export_rolling :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun context_index =>
    fun store =>
      fun genesis =>
        fun filename =>
          fun block =>
            let chain_id := Chain_id.of_block_hash genesis in
            let chain_store := Store.Chain.get store chain_id in
            let chain_data_store := Store.Chain_data.get chain_store in
            let block_store := Store.Block.get chain_store in
            op_gtgteqquestion
              (op_gtgteq (Store.Configuration.History_mode.read_opt store)
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Some
                      (Tezos_shell_services.History_mode.Archive |
                        Tezos_shell_services.History_mode.Full) | None =>
                    return_unit
                  |
                    Some
                      (Tezos_shell_services.History_mode.Rolling as history_mode)
                    =>
                    if export_rolling then
                      return_unit
                    else
                      fail
                        (Tezos_base__TzPervasives.Wrong_snapshot_export
                          history_mode Tezos_shell_services.History_mode.Full)
                  end))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  match block with
                  | Some block_hash =>
                    Lwt._return (Block_hash.of_b58check block_hash)
                  | None =>
                    op_gtgteq
                      (op_gtpipeeq
                        (Store.Chain_data.Checkpoint.read_opt chain_data_store)
                        (Option.unopt_assert Stdlib.__POS__))
                      (fun last_checkpoint =>
                        if
                          equiv_decb (level (shell last_checkpoint))
                            (* ❌ Constant of type int32 is converted to int *)
                            0 then
                          fail
                            (Tezos_base__TzPervasives.Wrong_block_export genesis
                              (* ❌ Variants not supported *)
                              variant)
                        else
                          let last_checkpoint_hash :=
                            Block_header.hash last_checkpoint in
                          op_gtgteq
                            (lwt_emit
                              (Export_unspecified_hash last_checkpoint_hash))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              _return last_checkpoint_hash))
                  end
                  (fun checkpoint_block_hash =>
                    op_gtgteqquestion
                      (op_gtgteq
                        (State.Block.Header.read_opt
                          (block_store, checkpoint_block_hash))
                        (fun function_parameter =>
                          match function_parameter with
                          | None =>
                            fail
                              (Tezos_base__TzPervasives.Wrong_block_export
                                checkpoint_block_hash
                                (* ❌ Variants not supported *)
                                variant)
                          | Some block_header =>
                            let export_mode :=
                              if export_rolling then
                                Tezos_shell_services.History_mode.Rolling
                              else
                                Tezos_shell_services.History_mode.Full in
                            op_gtgteq
                              (lwt_emit
                                (Export_info export_mode checkpoint_block_hash
                                  (level (shell block_header))))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion
                                  (Store.Block.Predecessors.read
                                    (block_store, checkpoint_block_hash) 0)
                                  (fun pred_block_hash =>
                                    op_gtgteqquestion
                                      (State.Block.Header.read
                                        (block_store, pred_block_hash))
                                      (fun pred_block_header =>
                                        let validations_passes :=
                                          validation_passes (shell block_header)
                                          in
                                        op_gtgteqquestion
                                          (map_s
                                            (fun i =>
                                              Store.Block.Operations.read
                                                (block_store,
                                                  checkpoint_block_hash) i)
                                            (op_minusminus 0
                                              (Z.sub validations_passes 1)))
                                          (fun operations =>
                                            op_gtgteqquestion
                                              (compute_export_limit block_store
                                                chain_data_store block_header
                                                export_rolling)
                                              (fun export_limit =>
                                                let iterator :=
                                                  pruned_block_iterator
                                                    context_index block_store
                                                    export_limit in
                                                let block_data :=
                                                  {|
                                                    Context.Block_data.block_header :=
                                                      block_header;
                                                    Context.Block_data.operations :=
                                                      operations |} in
                                                _return
                                                  (pred_block_header,
                                                    block_data, export_mode,
                                                    iterator))))))
                          end))
                      (fun data_to_dump =>
                        op_gtgteqquestion
                          (Context.dump_contexts context_index data_to_dump
                            filename)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq (lwt_emit (Export_success filename))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit))))).

Definition check_operations_consistency {A B : Type}
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (A * (list Tezos_base__TzPervasives.Operation.t)))
  (operation_hashes :
    list (B * (list Tezos_base__TzPervasives.Operation_hash.t)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter2
      (fun function_parameter =>
        let '(_, op) := function_parameter in
        fun function_parameter =>
          let '(_, oph) := function_parameter in
          let expected_op_hash := List.map Operation.hash op in
          List.iter2
            (fun expected =>
              fun found =>
                (* ❌ Assert instruction is not handled. *)
                assert (Operation_hash.equal expected found)) expected_op_hash
            oph) operations operation_hashes in
  let hashes :=
    List.map
      (fun function_parameter =>
        let '(_, opl) := function_parameter in
        List.map Operation.hash opl) (List.rev operations) in
  let computed_hash :=
    Operation_list_list_hash.compute
      (List.map Operation_list_hash.compute hashes) in
  let are_oph_equal :=
    Operation_list_list_hash.equal computed_hash
      (operations_hash (Block_header.shell block_header)) in
  fail_unless are_oph_equal
    (Tezos_base__TzPervasives.Inconsistent_operation_hashes
      (computed_hash, (operations_hash (Block_header.shell block_header)))).

Definition compute_predecessors {A : Type}
  (genesis_hash : A) (oldest_level : int32) (block_hashes : array A) (i : Z)
  : list (Z * A) :=
  let fix step (s : Z) (d : Z) (acc : list (Z * A)) : list (Z * A) :=
    if
      andb
        (equiv_decb oldest_level
          (* ❌ Constant of type int32 is converted to int *)
          1) (equiv_decb (Z.sub i d) (-1)) then
      List.rev (cons (s, genesis_hash) acc)
    else
      if OCaml.Stdlib.lt (Z.sub i d) 0 then
        List.rev acc
      else
        step (Z.add s 1) (Z.mul d 2)
          (cons (s, (Array.get block_hashes (Z.sub i d))) acc) in
  step 0 1 [].

Definition check_context_hash_consistency
  (block_validation_result : Tezos_validation.Block_validation.validation_store)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  fail_unless
    (Context_hash.equal
      (Tezos_validation.Block_validation.context_hash block_validation_result)
      (context (Block_header.shell block_header)))
    (Tezos_base__TzPervasives.Snapshot_import_failure
      "resulting context hash does not match" % string).

Definition set_history_mode
  (store : Tezos_shell__Store.global_store)
  (history_mode : Tezos_shell_services.History_mode.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match history_mode with
  |
    Tezos_shell_services.History_mode.Full |
      Tezos_shell_services.History_mode.Rolling =>
    op_gtgteq (lwt_emit (Set_history_mode history_mode))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Store.Configuration.History_mode.store store history_mode)
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_unit))
  | Tezos_shell_services.History_mode.Archive =>
    fail
      (Tezos_base__TzPervasives.Snapshot_import_failure
        "cannot import an archive context" % string)
  end.

Definition store_new_head
  (chain_state : Tezos_shell__State.Chain.t)
  (chain_data : Tezos_shell__Store.Chain_data.store)
  (genesis : Tezos_base__TzPervasives.Block_hash.t)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  (block_validation_result : Tezos_validation.Block_validation.result)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    validation_store := validation_store;
      block_metadata := block_metadata;
      ops_metadata := ops_metadata;
      forking_testchain := forking_testchain
      |} := block_validation_result in
  op_gtgteqquestion
    (State.Block.store None chain_state block_header block_metadata operations
      ops_metadata validation_store forking_testchain)
    (fun new_head =>
      match new_head with
      | None =>
        fail
          (Tezos_base__TzPervasives.Snapshot_import_failure
            "a chain head is already present in the store" % string)
      | Some new_head =>
        op_gtgteq (Store.Chain_data.Known_heads.remove chain_data genesis)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (Store.Chain_data.Known_heads.store chain_data
                (State.Block.hash new_head))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Store.Chain_data.Current_head.store chain_data
                    (State.Block.hash new_head))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)))
      end).

Definition update_checkpoint
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (checkpoint_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t (Stdlib.Int32.t * Tezos_crypto.Block_hash.t) :=
  let block_hash := Block_header.hash checkpoint_header in
  let new_checkpoint :=
    ((level (Block_header.shell checkpoint_header)), block_hash) in
  op_gtgteq (State.Chain.set_checkpoint chain_state checkpoint_header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      Lwt._return new_checkpoint).

Definition update_savepoint
  (chain_state : Tezos_shell.State.Chain.t)
  (new_savepoint : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t unit :=
  State.update_chain_data chain_state
    (fun store =>
      fun data =>
        let new_data :=
          (* ❌ Record substitution not handled *)
          record_substitution in
        op_gtgteq (Store.Chain_data.Save_point.store store new_savepoint)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt._return ((Some new_data), tt))).

Definition update_caboose
  (chain_data : Tezos_shell__Store.Chain_data.store)
  (genesis : Tezos_crypto.Block_hash.t)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (oldest_header : Tezos_base__TzPervasives.Block_header.t) (max_op_ttl : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let oldest_level := level (Block_header.shell oldest_header) in
  let caboose_level :=
    if
      equiv_decb oldest_level
        (* ❌ Constant of type int32 is converted to int *)
        1 then
      (* ❌ Constant of type int32 is converted to int *)
      0
    else
      oldest_level in
  let caboose_hash :=
    if
      equiv_decb oldest_level
        (* ❌ Constant of type int32 is converted to int *)
        1 then
      genesis
    else
      Block_header.hash oldest_header in
  let minimal_caboose_level :=
    sub (level (Block_header.shell block_header)) (of_int max_op_ttl) in
  op_gtgteqquestion
    (fail_unless (op_lteq caboose_level minimal_caboose_level)
      (Tezos_base__TzPervasives.Snapshot_import_failure
        (Format.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "caboose level (" % string
              (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  ") is not valid" % string
                  CamlinternalFormatBasics.End_of_format)))
            "caboose level (%ld) is not valid" % string) caboose_level)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (Store.Chain_data.Caboose.store chain_data (caboose_level, caboose_hash))
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition import_protocol_data
  (index : Tezos_storage.Context.index) (store : Tezos_shell__Store.Chain.store)
  (block_hash_arr : array Tezos_base__TzPervasives.Block_hash.t)
  (level_oldest_block : int32)
  (function_parameter : int32 * Tezos_storage.Context.Protocol_data.data)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '(level, protocol_data) := function_parameter in
  let delta := to_int (sub level level_oldest_block) in
  let pruned_block_hash := Array.get block_hash_arr delta in
  let block_store := Store.Block.get store in
  op_gtgteq
    (op_gtgteq (State.Block.Header.read_opt (block_store, pruned_block_hash))
      (fun function_parameter =>
        match function_parameter with
        | None =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Some block_header => Lwt._return block_header
        end))
    (fun block_header =>
      let expected_context_hash := context (Block_header.shell block_header) in
      let info := Context.Protocol_data.info protocol_data in
      let test_chain := test_chain_status protocol_data in
      let data_hash := data_key protocol_data in
      let parents := parents protocol_data in
      let protocol_hash := protocol_hash protocol_data in
      op_gtgteq
        (Context.validate_context_hash_consistency_and_commit data_hash
          expected_context_hash (timestamp info) test_chain protocol_hash
          (message info) (author info) parents index)
        (fun function_parameter =>
          match function_parameter with
          | true =>
            let protocol_level := proto_level (shell block_header) in
            let block_level := level (shell block_header) in
            op_gtgteq
              (Store.Chain.Protocol_info.store store protocol_level
                (protocol_hash, block_level))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)
          | false =>
            fail (Tezos_base__TzPervasives.Wrong_protocol_hash protocol_hash)
          end)).

Definition import_protocol_data_list
  (index : Tezos_storage.Context.index) (store : Tezos_shell__Store.Chain.store)
  (block_hash_arr : array Tezos_base__TzPervasives.Block_hash.t)
  (level_oldest_block : int32)
  (protocol_data : list (int32 * Tezos_storage.Context.Protocol_data.data))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let fix aux
    (function_parameter :
    list (int32 * Tezos_storage.Context.Protocol_data.data))
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    match function_parameter with
    | [] => return_unit
    | cons (level, protocol_data) xs =>
      op_gtgteqquestion
        (import_protocol_data index store block_hash_arr level_oldest_block
          (level, protocol_data))
        (fun function_parameter =>
          let 'tt := function_parameter in
          aux xs)
    end in
  aux protocol_data.

Definition verify_predecessors
  (header_opt : option Tezos_base__TzPervasives.Block_header.t)
  (pred_hash : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match header_opt with
  | None => return_unit
  | Some header =>
    fail_unless
      (andb
        (OCaml.Stdlib.ge (level (Block_header.shell header))
          (* ❌ Constant of type int32 is converted to int *)
          2) (Block_hash.equal (predecessor (shell header)) pred_hash))
      (Tezos_base__TzPervasives.Snapshot_import_failure
        "inconsistent predecessors" % string)
  end.

Definition verify_oldest_header
  (oldest_header : Tezos_base__TzPervasives.Block_header.t)
  (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let oldest_level := level (Block_header.shell oldest_header) in
  fail_unless
    (orb
      (OCaml.Stdlib.ge oldest_level
        (* ❌ Constant of type int32 is converted to int *)
        1)
      (andb
        (op_eq oldest_level
          (* ❌ Constant of type int32 is converted to int *)
          1)
        (Block_hash.equal (predecessor (Block_header.shell oldest_header))
          genesis_hash)))
    (Tezos_base__TzPervasives.Snapshot_import_failure
      "inconsistent oldest level" % string).

Definition block_validation
  (succ_header_opt : option Tezos_base__TzPervasives.Block_header.t)
  (header_hash : Tezos_base__TzPervasives.Block_hash.t)
  (function_parameter : Tezos_storage.Context.Pruned_block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    Context.Pruned_block.block_header := block_header;
      Context.Pruned_block.operations := operations;
      Context.Pruned_block.operation_hashes := operation_hashes
      |} := function_parameter in
  op_gtgteqquestion (verify_predecessors succ_header_opt header_hash)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (check_operations_consistency block_header operations operation_hashes)
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition import {A : Type}
  (data_dir : string) (dir_cleaner : string -> Lwt.t unit)
  (patch_context :
    (option A) -> Tezos_storage.Context.t -> Lwt.t Tezos_storage.Context.t)
  (genesis : Tezos_shell.State.Chain.genesis) (filename : string)
  (block : option string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (lwt_emit (Import_info filename))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        match block with
        | None => lwt_emit Import_unspecified_hash
        | Some _ => Lwt.return_unit
        end
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (lwt_emit Import_loading)
            (fun function_parameter =>
              let 'tt := function_parameter in
              let context_root := context_dir data_dir in
              let store_root := store_dir data_dir in
              let chain_id := Chain_id.of_block_hash (State.Chain.block genesis)
                in
              op_gtgteqquestion
                (State.init (Some (patch_context None)) None None None
                  store_root context_root None genesis)
                (fun function_parameter =>
                  let '(state, chain_state, context_index, _history_mode) :=
                    function_parameter in
                  op_gtgteqquestion (Store.init None None store_root)
                    (fun store =>
                      let chain_store := Store.Chain.get store chain_id in
                      let chain_data := Store.Chain_data.get chain_store in
                      let block_store := Store.Block.get chain_store in
                      Lwt.try_bind
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          let k_store_pruned_blocks
                            (data :
                            list
                              (Tezos_base__TzPervasives.Block_hash.t *
                                Tezos_storage.Context.Pruned_block.t))
                            : Lwt.t
                              (Tezos_base__TzPervasives.Error_monad.tzresult
                                unit) :=
                            Store.with_atomic_rw store
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                Error_monad.iter_s
                                  (fun function_parameter =>
                                    let '(pruned_header_hash, pruned_block) :=
                                      function_parameter in
                                    op_gtgteq
                                      (Store.Block.Pruned_contents.store
                                        (block_store, pruned_header_hash)
                                        {|
                                          header :=
                                            Context.Pruned_block.block_header
                                              pruned_block |})
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq
                                          (Lwt_list.iter_s
                                            (fun function_parameter =>
                                              let '(i, v) := function_parameter
                                                in
                                              Store.Block.Operations.store
                                                (block_store, pruned_header_hash)
                                                i v) (operations pruned_block))
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_gtgteq
                                              (Lwt_list.iter_s
                                                (fun function_parameter =>
                                                  let '(i, v) :=
                                                    function_parameter in
                                                  Store.Block.Operation_hashes.store
                                                    (block_store,
                                                      pruned_header_hash) i v)
                                                (operation_hashes pruned_block))
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                return_unit)))) data) in
                          op_gtgteqquestion
                            (restore_contexts context_index filename
                              k_store_pruned_blocks block_validation)
                            (fun function_parameter =>
                              let
                                '(predecessor_block_header, meta, history_mode,
                                  oldest_header_opt, rev_block_hashes,
                                  protocol_data) := function_parameter in
                              let oldest_header :=
                                Option.unopt_assert Stdlib.__POS__
                                  oldest_header_opt in
                              let block_hashes_arr :=
                                Array.of_list rev_block_hashes in
                              let write_predecessors_table
                                (to_write :
                                list
                                  (Tezos_base__TzPervasives.Block_hash.t *
                                    (list
                                      (Tezos_shell.Store.Block.Predecessors.key
                                        *
                                        Tezos_shell.Store.Block.Predecessors.value))))
                                : Lwt.t unit :=
                                Store.with_atomic_rw store
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    Lwt_list.iter_s
                                      (fun function_parameter =>
                                        let
                                          '(current_hash, predecessors_list) :=
                                          function_parameter in
                                        op_gtgteq
                                          (Lwt_list.iter_s
                                            (fun function_parameter =>
                                              let '(l, h) := function_parameter
                                                in
                                              Store.Block.Predecessors.store
                                                (block_store, current_hash) l h)
                                            predecessors_list)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            match predecessors_list with
                                            | cons (0, pred_hash) _ =>
                                              Store.Chain_data.In_main_branch.store
                                                (chain_data, pred_hash)
                                                current_hash
                                            | [] => Lwt.return_unit
                                            | cons _ _ =>
                                              (* ❌ Assert instruction is not handled. *)
                                              assert false
                                            end)) to_write) in
                              op_gtgteq
                                (Lwt_list.fold_left_s
                                  (fun function_parameter =>
                                    let '(cpt, to_write) := function_parameter
                                      in
                                    fun current_hash =>
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        Tezos_stdlib_unix.Utils.display_progress
                                          (Some (cpt, 1000))
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Computing predecessors table " %
                                                string
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_d
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.String_literal
                                                  "K elements" % string
                                                  (CamlinternalFormatBasics.Flush
                                                    CamlinternalFormatBasics.End_of_format))))
                                            "Computing predecessors table %dK elements%!"
                                              % string) (Z.div cpt 1000) in
                                      op_gtgteq
                                        (if
                                          equiv_decb
                                            (Z.modulo (Z.add cpt 1) 5000) 0 then
                                          op_gtgteq
                                            (write_predecessors_table to_write)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              Lwt.return_nil)
                                        else
                                          Lwt._return to_write)
                                        (fun to_write =>
                                          let predecessors_list :=
                                            compute_predecessors (block genesis)
                                              (level (shell oldest_header))
                                              block_hashes_arr cpt in
                                          Lwt._return
                                            ((Z.add cpt 1),
                                              (cons
                                                (current_hash, predecessors_list)
                                                to_write)))) (0, [])
                                  rev_block_hashes)
                                (fun function_parameter =>
                                  let '(_, to_write) := function_parameter in
                                  op_gtgteq (write_predecessors_table to_write)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        Tezos_stdlib_unix.Utils.display_progress_end
                                          tt in
                                      let '{|
                                        Block_data.block_header := block_header;
                                          Block_data.operations := operations
                                          |} := meta in
                                      let block_hash :=
                                        Block_header.hash block_header in
                                      op_gtgteqquestion
                                        match block with
                                        | Some str =>
                                          let bh :=
                                            Block_hash.of_b58check_exn str in
                                          fail_unless
                                            (Block_hash.equal bh block_hash)
                                            (Tezos_base__TzPervasives.Inconsistent_imported_block
                                              bh block_hash)
                                        | None => return_unit
                                        end
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (lwt_emit
                                              (Set_head
                                                (Block_header.hash block_header)))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              let pred_context_hash :=
                                                context
                                                  (shell
                                                    predecessor_block_header) in
                                              op_gtgteq
                                                (checkout_exn context_index
                                                  pred_context_hash)
                                                (fun predecessor_context =>
                                                  op_gtgteqquestion
                                                    (Tezos_validation.Block_validation.apply
                                                      chain_id
                                                      (Int32.to_int
                                                        (level
                                                          (shell
                                                            predecessor_block_header)))
                                                      predecessor_block_header
                                                      predecessor_context
                                                      block_header operations)
                                                    (fun block_validation_result
                                                      =>
                                                      op_gtgteqquestion
                                                        (check_context_hash_consistency
                                                          (validation_store
                                                            block_validation_result)
                                                          block_header)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_gtgteqquestion
                                                            (verify_oldest_header
                                                              oldest_header
                                                              (block genesis))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteqquestion
                                                                (set_history_mode
                                                                  store
                                                                  history_mode)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_gtgteqquestion
                                                                    (import_protocol_data_list
                                                                      context_index
                                                                      chain_store
                                                                      block_hashes_arr
                                                                      (level
                                                                        (Block_header.shell
                                                                          oldest_header))
                                                                      protocol_data)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_gtgteqquestion
                                                                        (store_new_head
                                                                          chain_state
                                                                          chain_data
                                                                          (block
                                                                            genesis)
                                                                          block_header
                                                                          operations
                                                                          block_validation_result)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_gtgteq
                                                                            (update_checkpoint
                                                                              chain_state
                                                                              block_header)
                                                                            (fun
                                                                              new_checkpoint
                                                                              =>
                                                                              op_gtgteq
                                                                                (update_savepoint
                                                                                  chain_state
                                                                                  new_checkpoint)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  op_gtgteqquestion
                                                                                    (update_caboose
                                                                                      chain_data
                                                                                      (block
                                                                                        genesis)
                                                                                      block_header
                                                                                      oldest_header
                                                                                      (max_operations_ttl
                                                                                        (validation_store
                                                                                          block_validation_result)))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                      let
                                                                                        _
                                                                                        :=
                                                                                        Store.close
                                                                                          store
                                                                                        in
                                                                                      op_gtgteq
                                                                                        (State.close
                                                                                          state)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            'tt :=
                                                                                            function_parameter
                                                                                            in
                                                                                          return_unit)))))))))))))))))
                        (fun function_parameter =>
                          match function_parameter with
                          | Stdlib.Ok tt =>
                            op_gtgteq (lwt_emit (Import_success filename))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit)
                          | Stdlib.Error errors =>
                            op_gtgteq (dir_cleaner data_dir)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                Lwt._return (Stdlib.Error errors))
                          end)
                        (fun exn =>
                          op_gtgteq (dir_cleaner data_dir)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              Lwt.fail exn))))))).

src/lib_shell/stat_directory.ml 2 errors
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rpc_directory () =
  let dir = RPC_directory.empty in
  RPC_directory.gen_register dir Stat_services.S.gc (fun () () () ->
      RPC_answer.return @@ Gc.stat ())
  |> fun dir ->
  RPC_directory.gen_register dir Stat_services.S.memory (fun () () () ->
      Sys_info.memory_stats ()
      >>= function
      | Ok stats -> RPC_answer.return stats | Error err -> RPC_answer.fail [err])
src/lib_shell/stat_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition rpc_directory (function_parameter : unit)
  : Tezos_base__TzPervasives.RPC_directory.directory unit :=
  let 'tt := function_parameter in
  let dir := RPC_directory.empty in
  OCaml.Stdlib.reverse_apply
    (RPC_directory.gen_register dir Stat_services.S.gc
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            apply RPC_answer._return (Gc.stat tt)))
    (fun dir =>
      RPC_directory.gen_register dir Stat_services.S.memory
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Sys_info.memory_stats tt)
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok stats => RPC_answer._return stats
                  | Stdlib.Error err => RPC_answer.fail (cons err [])
                  end))).

src/lib_shell/state.ml 367 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

open State_logging
open Validation_errors

module Shared = struct
  type 'a t = {data : 'a; lock : Lwt_mutex.t}

  let create data = {data; lock = Lwt_mutex.create ()}

  let use {data; lock} f = Lwt_mutex.with_lock lock (fun () -> f data)
end

type genesis = {
  time : Time.Protocol.t;
  block : Block_hash.t;
  protocol : Protocol_hash.t;
}

type global_state = {
  global_data : global_data Shared.t;
  protocol_store : Store.Protocol.store Shared.t;
  main_chain : Chain_id.t;
  protocol_watcher : Protocol_hash.t Lwt_watcher.input;
  block_watcher : block Lwt_watcher.input;
}

and global_data = {
  chains : chain_state Chain_id.Table.t;
  global_store : Store.t;
  context_index : Context.index;
}

and chain_state = {
  (* never take the lock on 'block_store' when holding
     the lock on 'chain_data'. *)
  global_state : global_state;
  chain_id : Chain_id.t;
  genesis : genesis;
  faked_genesis_hash : Block_hash.t;
  expiration : Time.Protocol.t option;
  allow_forked_chain : bool;
  block_store : Store.Block.store Shared.t;
  context_index : Context.index Shared.t;
  block_watcher : block Lwt_watcher.input;
  chain_data : chain_data_state Shared.t;
  block_rpc_directories :
    block RPC_directory.t Protocol_hash.Map.t Protocol_hash.Table.t;
  header_rpc_directories :
    (chain_state * Block_hash.t * Block_header.t) RPC_directory.t
    Protocol_hash.Map.t
    Protocol_hash.Table.t;
}

and chain_data_state = {
  mutable data : chain_data;
  mutable checkpoint : Block_header.t;
  chain_data_store : Store.Chain_data.store;
}

and chain_data = {
  current_head : block;
  current_mempool : Mempool.t;
  live_blocks : Block_hash.Set.t;
  live_operations : Operation_hash.Set.t;
  test_chain : Chain_id.t option;
  save_point : Int32.t * Block_hash.t;
  caboose : Int32.t * Block_hash.t;
}

and block = {
  chain_state : chain_state;
  hash : Block_hash.t;
  header : Block_header.t;
}

(* Errors *)

type error += Block_not_found of Block_hash.t

type error += Block_contents_not_found of Block_hash.t

let () =
  register_error_kind
    `Permanent
    ~id:"state.block.not_found"
    ~title:"Block_not_found"
    ~description:"Block not found"
    ~pp:(fun ppf block_hash ->
      Format.fprintf ppf "@[Cannot find block %a]" Block_hash.pp block_hash)
    Data_encoding.(obj1 (req "block_not_found" @@ Block_hash.encoding))
    (function Block_not_found block_hash -> Some block_hash | _ -> None)
    (fun block_hash -> Block_not_found block_hash) ;
  register_error_kind
    `Permanent
    ~id:"state.block.contents_not_found"
    ~title:"Block_contents_not_found"
    ~description:"Block not found"
    ~pp:(fun ppf block_hash ->
      Format.fprintf
        ppf
        "@[Cannot find block contents %a]"
        Block_hash.pp
        block_hash)
    Data_encoding.(
      obj1 (req "block_contents_not_found" @@ Block_hash.encoding))
    (function
      | Block_contents_not_found block_hash -> Some block_hash | _ -> None)
    (fun block_hash -> Block_contents_not_found block_hash)

(* Abstract view over block header storage.
   This module aims to abstract over block header's [read], [read_opt] and [known]
   functions by calling the adequate function depending on the block being pruned or not.
*)

module Header = struct
  let read (store, hash) =
    Store.Block.Contents.read (store, hash)
    >>= function
    | Ok {header; _} ->
        return header
    | Error _ ->
        Store.Block.Pruned_contents.read (store, hash)
        >>=? fun {header} -> return header

  let read_opt (store, hash) =
    read (store, hash)
    >>= function
    | Ok header -> Lwt.return_some header | Error _ -> Lwt.return_none

  let known (store, hash) =
    Store.Block.Pruned_contents.known (store, hash)
    >>= function
    | true ->
        Lwt.return_true
    | false ->
        Store.Block.Contents.known (store, hash)
end

let read_chain_data {chain_data; _} f =
  Shared.use chain_data (fun state -> f state.chain_data_store state.data)

let update_chain_data {chain_data; _} f =
  Shared.use chain_data (fun state ->
      f state.chain_data_store state.data
      >>= fun (data, res) ->
      Lwt_utils.may data ~f:(fun data ->
          state.data <- data ;
          Lwt.return_unit)
      >>= fun () -> Lwt.return res)

(** The number of predecessors stored per block.
    This value chosen to compute efficiently block locators that
    can cover a chain of 2 months, at 1 block/min, which is ~86K
    blocks at the cost in space of ~72MB.
    |locator| = log2(|chain|/10) -1
*)
let stored_predecessors_size = 12

(**
   Takes a block and populates its predecessors store, under the
   assumption that all its predecessors have their store already
   populated. The precedecessors are distributed along the chain, up
   to the genesis, at a distance from [b] that grows exponentially.
   The store tabulates a function [p] from distances to block_ids such
   that if [p(b,d)=b'] then [b'] is at distance 2^d from [b].
   Example of how previous predecessors are used:
   p(n,0) = n-1
   p(n,1) = n-2  = p(n-1,0)
   p(n,2) = n-4  = p(n-2,1)
   p(n,3) = n-8  = p(n-4,2)
   p(n,4) = n-16 = p(n-8,3)
*)
let store_predecessors (store : Store.Block.store) (b : Block_hash.t) :
    unit Lwt.t =
  let rec loop pred dist =
    if dist = stored_predecessors_size then Lwt.return_unit
    else
      Store.Block.Predecessors.read_opt (store, pred) (dist - 1)
      >>= function
      | None ->
          Lwt.return_unit (* we reached the last known block *)
      | Some p ->
          Store.Block.Predecessors.store (store, b) dist p
          >>= fun () -> loop p (dist + 1)
  in
  (* the first predecessor is fetched from the header *)
  Header.read_opt (store, b)
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun header ->
  let pred = header.shell.predecessor in
  if Block_hash.equal b pred then Lwt.return_unit (* genesis *)
  else
    Store.Block.Predecessors.store (store, b) 0 pred >>= fun () -> loop pred 1

(**
   [predecessor_n_raw s b d] returns the hash of the block at distance [d] from [b].
   Returns [None] if [d] is greater than the distance of [b] from genesis or
   if [b] is genesis.
   Works in O(log|chain|) if the chain is shorter than 2^[stored_predecessors_size]
   and in O(|chain|) after that.
   @raise Invalid_argument "State.predecessors: negative distance"
*)
let predecessor_n_raw store block_hash distance =
  (* helper functions *)
  (* computes power of 2 w/o floats *)
  let power_of_2 n =
    if n < 0 then invalid_arg "negative argument"
    else
      let rec loop cnt res =
        if cnt < 1 then res else loop (cnt - 1) (res * 2)
      in
      loop n 1
  in
  (* computes the closest power of two smaller than a given
     a number and the rest w/o floats *)
  let closest_power_two_and_rest n =
    if n < 0 then invalid_arg "negative argument"
    else
      let rec loop cnt n rest =
        if n <= 1 then (cnt, rest)
        else loop (cnt + 1) (n / 2) (rest + (power_of_2 cnt * (n mod 2)))
      in
      loop 0 n 0
  in
  (* actual predecessor function *)
  if distance < 0 then
    invalid_arg ("State.predecessor: distance < 0 " ^ string_of_int distance)
  else if distance = 0 then Lwt.return_some block_hash
  else
    let rec loop block_hash distance =
      if distance = 1 then
        Store.Block.Predecessors.read_opt (store, block_hash) 0
      else
        let (power, rest) = closest_power_two_and_rest distance in
        let (power, rest) =
          if power < stored_predecessors_size then (power, rest)
          else
            let power = stored_predecessors_size - 1 in
            let rest = distance - power_of_2 power in
            (power, rest)
        in
        Store.Block.Predecessors.read_opt (store, block_hash) power
        >>= function
        | None ->
            Lwt.return_none (* reached genesis *)
        | Some pred ->
            if rest = 0 then Lwt.return_some pred
              (* landed on the requested predecessor *)
            else loop pred rest
      (* need to jump further back *)
    in
    loop block_hash distance

let predecessor_n ?(below_save_point = false) block_store block_hash distance =
  predecessor_n_raw block_store block_hash distance
  >>= function
  | None ->
      Lwt.return_none
  | Some predecessor -> (
      ( if below_save_point then Header.known (block_store, predecessor)
      else Store.Block.Contents.known (block_store, predecessor) )
      >>= function
      | false -> Lwt.return_none | true -> Lwt.return_some predecessor )

let compute_locator_from_hash chain_state ?(size = 200) head_hash seed =
  Shared.use chain_state.chain_data (fun state ->
      Lwt.return state.data.caboose)
  >>= fun (_lvl, caboose) ->
  Shared.use chain_state.block_store (fun block_store ->
      Header.read_opt (block_store, head_hash)
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun header ->
      Block_locator.compute
        ~get_predecessor:(predecessor_n ~below_save_point:true block_store)
        ~caboose
        ~size
        head_hash
        header
        seed)

let compute_locator chain ?size head seed =
  compute_locator_from_hash chain ?size head.hash seed

type t = global_state

module Locked_block = struct
  let store_genesis store genesis context =
    let shell : Block_header.shell_header =
      {
        level = 0l;
        proto_level = 0;
        predecessor = genesis.block;
        (* genesis' predecessor is genesis *)
        timestamp = genesis.time;
        fitness = [];
        validation_passes = 0;
        operations_hash = Operation_list_list_hash.empty;
        context;
      }
    in
    let header : Block_header.t = {shell; protocol_data = Bytes.create 0} in
    Store.Block.Contents.store
      (store, genesis.block)
      {
        header;
        Store.Block.message = Some "Genesis";
        max_operations_ttl = 0;
        context;
        metadata = Bytes.create 0;
        last_allowed_fork_level = 0l;
      }
    >>= fun () -> Lwt.return header

  (* Will that block is compatible with the current checkpoint. *)
  let acceptable chain_data (header : Block_header.t) =
    let checkpoint_level = chain_data.checkpoint.shell.level in
    if checkpoint_level < header.shell.level then
      (* the predecessor is assumed compatible. *)
      Lwt.return_true
    else if checkpoint_level = header.shell.level then
      Lwt.return (Block_header.equal header chain_data.checkpoint)
    else
      (* header.shell.level < level *)
      (* valid only if the current head is lower than the checkpoint. *)
      let head_level = chain_data.data.current_head.header.shell.level in
      Lwt.return (head_level < checkpoint_level)

  (* Is a block still valid for a given checkpoint ? *)
  let is_valid_for_checkpoint block_store hash (header : Block_header.t)
      (checkpoint : Block_header.t) =
    if Compare.Int32.(header.shell.level < checkpoint.shell.level) then
      Lwt.return_true
    else
      predecessor_n
        block_store
        hash
        (Int32.to_int @@ Int32.sub header.shell.level checkpoint.shell.level)
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun predecessor ->
      if Block_hash.equal predecessor (Block_header.hash checkpoint) then
        Lwt.return_true
      else Lwt.return_false
end

(* Find the branches that are still valid with a given checkpoint, i.e.
   heads with lower level, or branches that goes through the checkpoint. *)
let locked_valid_heads_for_checkpoint block_store data checkpoint =
  Store.Chain_data.Known_heads.read_all data.chain_data_store
  >>= fun heads ->
  Block_hash.Set.fold
    (fun head acc ->
      let valid_header =
        Header.read_opt (block_store, head)
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun header ->
        Locked_block.is_valid_for_checkpoint block_store head header checkpoint
        >>= fun valid -> Lwt.return (valid, header)
      in
      acc
      >>= fun (valid_heads, invalid_heads) ->
      valid_header
      >>= fun (valid, header) ->
      if valid then Lwt.return ((head, header) :: valid_heads, invalid_heads)
      else Lwt.return (valid_heads, (head, header) :: invalid_heads))
    heads
    (Lwt.return ([], []))

(* Tag as invalid all blocks in `heads` and their predecessors whose
   level strictly higher to 'level'. *)
let tag_invalid_heads block_store chain_store heads level =
  let rec tag_invalid_head (hash, header) =
    if header.Block_header.shell.level <= level then
      Store.Chain_data.Known_heads.store chain_store hash
      >>= fun () -> Lwt.return_some (hash, header)
    else
      let errors = [Validation_errors.Checkpoint_error (hash, None)] in
      Store.Block.Invalid_block.store
        block_store
        hash
        {level = header.shell.level; errors}
      >>= fun () ->
      Store.Block.Contents.remove (block_store, hash)
      >>= fun () ->
      Store.Block.Operation_hashes.remove_all (block_store, hash)
      >>= fun () ->
      Store.Block.Operations_metadata.remove_all (block_store, hash)
      >>= fun () ->
      Store.Block.Operations.remove_all (block_store, hash)
      >>= fun () ->
      Store.Block.Predecessors.remove_all (block_store, hash)
      >>= fun () ->
      Header.read_opt (block_store, header.shell.predecessor)
      >>= function
      | None ->
          Lwt.return_none
      | Some header ->
          tag_invalid_head (Block_header.hash header, header)
  in
  Lwt_list.iter_p
    (fun (hash, _header) ->
      Store.Chain_data.Known_heads.remove chain_store hash)
    heads
  >>= fun () -> Lwt_list.filter_map_s tag_invalid_head heads

let prune_block store block_hash =
  let st = (store, block_hash) in
  Store.Block.Contents.remove st
  >>= fun () ->
  Store.Block.Invalid_block.remove store block_hash
  >>= fun () -> Store.Block.Operations_metadata.remove_all st

let store_header_and_prune_block store block_hash =
  let st = (store, block_hash) in
  Store.Block.Contents.read_opt st
  >>= (function
        | Some {header; _} ->
            Store.Block.Pruned_contents.store st {header}
        | None -> (
            Store.Block.Pruned_contents.known st
            >>= function
            | true ->
                Lwt.return_unit
            | false ->
                State_logging.lwt_log_error
                  Tag.DSL.(
                    fun f ->
                      f "@[cannot find pruned contents of block %a@]"
                      -% t event "missing_pruned_contents"
                      -% a Block_hash.Logging.tag block_hash) ))
  >>= fun () -> prune_block store block_hash

let delete_block store block_hash =
  prune_block store block_hash
  >>= fun () ->
  let st = (store, block_hash) in
  Store.Block.Pruned_contents.remove st
  >>= fun () ->
  Store.Block.Operations.remove_all st
  >>= fun () ->
  Store.Block.Operation_hashes.remove_all st
  >>= fun () -> Store.Block.Predecessors.remove_all st

(* Remove all blocks that are not in the chain. *)
let cut_alternate_heads block_store chain_store heads =
  let rec cut_alternate_head hash header =
    Store.Chain_data.In_main_branch.known (chain_store, hash)
    >>= fun in_chain ->
    if in_chain then Lwt.return_unit
    else
      Header.read_opt (block_store, header.Block_header.shell.predecessor)
      >>= function
      | None ->
          delete_block block_store hash >>= fun () -> Lwt.return_unit
      | Some header ->
          delete_block block_store hash
          >>= fun () -> cut_alternate_head (Block_header.hash header) header
  in
  Lwt_list.iter_p
    (fun (hash, header) ->
      Store.Chain_data.Known_heads.remove chain_store hash
      >>= fun () -> cut_alternate_head hash header)
    heads

module Chain = struct
  type nonrec genesis = genesis = {
    time : Time.Protocol.t;
    block : Block_hash.t;
    protocol : Protocol_hash.t;
  }

  let genesis_encoding =
    let open Data_encoding in
    conv
      (fun {time; block; protocol} -> (time, block, protocol))
      (fun (time, block, protocol) -> {time; block; protocol})
      (obj3
         (req "timestamp" Time.Protocol.encoding)
         (req "block" Block_hash.encoding)
         (req "protocol" Protocol_hash.encoding))

  type t = chain_state

  type chain_state = t

  let main {main_chain; _} = main_chain

  let test chain_state =
    read_chain_data chain_state (fun _ chain_data ->
        Lwt.return chain_data.test_chain)

  let get_level_indexed_protocol chain_state header =
    let chain_id = chain_state.chain_id in
    let protocol_level = header.Block_header.shell.proto_level in
    let global_state = chain_state.global_state in
    Shared.use global_state.global_data (fun global_data ->
        let global_store = global_data.global_store in
        let chain_store = Store.Chain.get global_store chain_id in
        Store.Chain.Protocol_info.read_opt chain_store protocol_level
        >>= function
        | None ->
            Pervasives.failwith "State.Chain.get_level_index_protocol"
        | Some (p, _) ->
            Lwt.return p)

  let update_level_indexed_protocol_store chain_state chain_id protocol_level
      protocol_hash block_header =
    let global_state = chain_state.global_state in
    Shared.use chain_state.block_store (fun block_store ->
        Header.read_opt
          (block_store, block_header.Block_header.shell.predecessor)
        >>= function
        | None ->
            Lwt.return_none (* should not happen *)
        | Some header ->
            Lwt.return_some header)
    >>= function
    | None ->
        Lwt.return_unit
    | Some pred_header ->
        if pred_header.shell.proto_level <> block_header.shell.proto_level then
          Shared.use global_state.global_data (fun global_data ->
              let global_store = global_data.global_store in
              let chain_store = Store.Chain.get global_store chain_id in
              Store.Chain.Protocol_info.store
                chain_store
                protocol_level
                (protocol_hash, block_header.shell.level))
        else Lwt.return_unit

  let allocate ~genesis ~faked_genesis_hash ~save_point ~caboose ~expiration
      ~allow_forked_chain ~current_head ~checkpoint ~chain_id global_state
      context_index chain_data_store block_store =
    Header.read_opt (block_store, current_head)
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun current_block_head ->
    let rec chain_data =
      {
        data =
          {
            save_point;
            caboose;
            current_head =
              {chain_state; hash = current_head; header = current_block_head};
            current_mempool = Mempool.empty;
            live_blocks = Block_hash.Set.singleton genesis.block;
            live_operations = Operation_hash.Set.empty;
            test_chain = None;
          };
        checkpoint;
        chain_data_store;
      }
    and chain_state =
      {
        global_state;
        chain_id;
        chain_data = {Shared.data = chain_data; lock = Lwt_mutex.create ()};
        genesis;
        faked_genesis_hash;
        expiration;
        allow_forked_chain;
        block_store = Shared.create block_store;
        context_index = Shared.create context_index;
        block_watcher = Lwt_watcher.create_input ();
        block_rpc_directories = Protocol_hash.Table.create 7;
        header_rpc_directories = Protocol_hash.Table.create 7;
      }
    in
    Lwt.return chain_state

  let locked_create global_state data ?expiration ?(allow_forked_chain = false)
      chain_id genesis (genesis_header : Block_header.t) =
    let chain_store = Store.Chain.get data.global_store chain_id in
    let block_store = Store.Block.get chain_store
    and chain_data_store = Store.Chain_data.get chain_store in
    let save_point = (genesis_header.shell.level, genesis.block) in
    let caboose = (genesis_header.shell.level, genesis.block) in
    let proto_level = genesis_header.shell.proto_level in
    Store.Chain.Genesis_hash.store chain_store genesis.block
    >>= fun () ->
    Store.Chain.Genesis_time.store chain_store genesis.time
    >>= fun () ->
    Store.Chain.Genesis_protocol.store chain_store genesis.protocol
    >>= fun () ->
    Store.Chain_data.Current_head.store chain_data_store genesis.block
    >>= fun () ->
    Store.Chain_data.Known_heads.store chain_data_store genesis.block
    >>= fun () ->
    Store.Chain_data.Checkpoint.store chain_data_store genesis_header
    >>= fun () ->
    Store.Chain_data.Save_point.store chain_data_store save_point
    >>= fun () ->
    Store.Chain_data.Caboose.store chain_data_store caboose
    >>= fun () ->
    Store.Chain.Protocol_info.store
      chain_store
      proto_level
      (genesis.protocol, genesis_header.shell.level)
    >>= fun () ->
    ( match expiration with
    | None ->
        Lwt.return_unit
    | Some time ->
        Store.Chain.Expiration.store chain_store time )
    >>= fun () ->
    ( if allow_forked_chain then
      Store.Chain.Allow_forked_chain.store data.global_store chain_id
    else Lwt.return_unit )
    >>= fun () ->
    allocate
      ~genesis
      ~faked_genesis_hash:(Block_header.hash genesis_header)
      ~current_head:genesis.block
      ~expiration
      ~allow_forked_chain
      ~checkpoint:genesis_header
      ~chain_id
      ~save_point
      ~caboose
      global_state
      data.context_index
      chain_data_store
      block_store
    >>= fun chain ->
    Chain_id.Table.add data.chains chain_id chain ;
    Lwt.return chain

  let create state ?allow_forked_chain ~commit_genesis genesis chain_id =
    Shared.use state.global_data (fun data ->
        let chain_store = Store.Chain.get data.global_store chain_id in
        let block_store = Store.Block.get chain_store in
        if Chain_id.Table.mem data.chains chain_id then
          Pervasives.failwith "State.Chain.create"
        else
          commit_genesis
            ~chain_id
            ~time:genesis.time
            ~protocol:genesis.protocol
          >>=? fun commit ->
          Locked_block.store_genesis block_store genesis commit
          >>= fun genesis_header ->
          locked_create
            state
            data
            ?allow_forked_chain
            chain_id
            genesis
            genesis_header
          >>= fun chain ->
          (* in case this is a forked chain creation,
           delete its header from the temporary table*)
          Store.Forking_block_hash.remove
            data.global_store
            (Context.compute_testchain_chain_id genesis.block)
          >>= fun () -> return chain)

  let locked_read global_state data chain_id =
    let chain_store = Store.Chain.get data.global_store chain_id in
    let block_store = Store.Block.get chain_store
    and chain_data_store = Store.Chain_data.get chain_store in
    Store.Chain.Genesis_hash.read chain_store
    >>=? fun genesis_hash ->
    Store.Chain.Genesis_time.read chain_store
    >>=? fun time ->
    Store.Chain.Genesis_protocol.read chain_store
    >>=? fun protocol ->
    Store.Chain.Expiration.read_opt chain_store
    >>= fun expiration ->
    Store.Chain.Allow_forked_chain.known data.global_store chain_id
    >>= fun allow_forked_chain ->
    Header.read (block_store, genesis_hash)
    >>=? fun genesis_header ->
    let genesis = {time; protocol; block = genesis_hash} in
    Store.Chain_data.Current_head.read chain_data_store
    >>=? fun current_head ->
    Store.Chain_data.Checkpoint.read chain_data_store
    >>=? fun checkpoint ->
    Store.Chain_data.Save_point.read chain_data_store
    >>=? fun save_point ->
    Store.Chain_data.Caboose.read chain_data_store
    >>=? fun caboose ->
    try
      allocate
        ~genesis
        ~faked_genesis_hash:(Block_header.hash genesis_header)
        ~current_head
        ~expiration
        ~allow_forked_chain
        ~checkpoint
        ~chain_id
        ~save_point
        ~caboose
        global_state
        data.context_index
        chain_data_store
        block_store
      >>= return
    with Not_found -> fail Bad_data_dir

  let locked_read_all global_state data =
    Store.Chain.list data.global_store
    >>= fun ids ->
    iter_p
      (fun id ->
        locked_read global_state data id
        >>=? fun chain ->
        Chain_id.Table.add data.chains id chain ;
        return_unit)
      ids

  let read_all state =
    Shared.use state.global_data (fun data -> locked_read_all state data)

  let get_exn state id =
    Shared.use state.global_data (fun data ->
        Lwt.return (Chain_id.Table.find data.chains id))

  let get_opt state id =
    Lwt.catch
      (fun () -> get_exn state id >>= Lwt.return_some)
      (function _ -> Lwt.return_none)

  let get state id =
    Lwt.catch
      (fun () -> get_exn state id >>= return)
      (function Not_found -> fail (Unknown_chain id) | exn -> Lwt.fail exn)

  let all state =
    Shared.use state.global_data (fun {chains; _} ->
        Lwt.return
        @@ Chain_id.Table.fold (fun _ chain acc -> chain :: acc) chains [])

  let id {chain_id; _} = chain_id

  let genesis {genesis; _} = genesis

  let faked_genesis_hash {faked_genesis_hash; _} = faked_genesis_hash

  let expiration {expiration; _} = expiration

  let allow_forked_chain {allow_forked_chain; _} = allow_forked_chain

  let global_state {global_state; _} = global_state

  let checkpoint chain_state =
    Shared.use chain_state.chain_data (fun {checkpoint; _} ->
        Lwt.return checkpoint)

  let save_point chain_state =
    Shared.use chain_state.chain_data (fun state ->
        Lwt.return state.data.save_point)

  let caboose chain_state =
    Shared.use chain_state.chain_data (fun state ->
        Lwt.return state.data.caboose)

  let purge_loop_full ?(chunk_size = 4000) global_store store ~genesis_hash
      block_hash caboose_level =
    let do_prune blocks =
      Store.with_atomic_rw global_store
      @@ fun () -> Lwt_list.iter_s (store_header_and_prune_block store) blocks
    in
    let rec loop block_hash (n_blocks, blocks) =
      ( if n_blocks >= chunk_size then
        do_prune blocks >>= fun () -> Lwt.return (0, [])
      else Lwt.return (n_blocks, blocks) )
      >>= fun (n_blocks, blocks) ->
      Header.read_opt (store, block_hash)
      >|= Option.unopt_assert ~loc:__POS__
      >>= fun header ->
      if Block_hash.equal block_hash genesis_hash then do_prune blocks
      else if header.shell.level = caboose_level then
        do_prune (block_hash :: blocks)
      else loop header.shell.predecessor (n_blocks + 1, block_hash :: blocks)
    in
    Header.read_opt (store, block_hash)
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun header -> loop header.shell.predecessor (0, [])

  let purge_full chain_state (lvl, hash) =
    Shared.use chain_state.global_state.global_data (fun global_data ->
        Shared.use chain_state.block_store (fun store ->
            update_chain_data chain_state (fun _ data ->
                purge_loop_full
                  global_data.global_store
                  store
                  ~genesis_hash:chain_state.genesis.block
                  hash
                  (fst data.save_point)
                >>= fun () ->
                let new_data = {data with save_point = (lvl, hash)} in
                Lwt.return (Some new_data, ()))
            >>= fun () ->
            Shared.use chain_state.chain_data (fun data ->
                Store.Chain_data.Save_point.store
                  data.chain_data_store
                  (lvl, hash)
                >>= fun () -> return_unit)))

  let purge_loop_rolling global_store store ~genesis_hash block_hash limit =
    let do_delete blocks =
      Store.with_atomic_rw global_store
      @@ fun () -> Lwt_list.iter_s (delete_block store) blocks
    in
    let rec prune_loop block_hash limit =
      if Block_hash.equal genesis_hash block_hash then Lwt.return block_hash
      else if limit = 1 then
        Header.read_opt (store, block_hash)
        >>= function
        | None ->
            assert false (* Should not happen. *)
        | Some header ->
            store_header_and_prune_block store block_hash
            >>= fun () ->
            delete_loop header.shell.predecessor (0, [])
            >>= fun () -> Lwt.return block_hash
      else
        Header.read_opt (store, block_hash)
        >>= function
        | None ->
            assert false (* Should not happen. *)
        | Some header ->
            store_header_and_prune_block store block_hash
            >>= fun () -> prune_loop header.shell.predecessor (limit - 1)
    and delete_loop block_hash (n_blocks, blocks) =
      ( if n_blocks >= 4000 then
        do_delete blocks >>= fun () -> Lwt.return (0, [])
      else Lwt.return (n_blocks, blocks) )
      >>= fun (n_blocks, blocks) ->
      Header.read_opt (store, block_hash)
      >>= function
      | None ->
          do_delete blocks
      | Some header ->
          if Block_hash.equal genesis_hash block_hash then do_delete blocks
          else
            delete_loop
              header.shell.predecessor
              (n_blocks + 1, block_hash :: blocks)
    in
    Header.read_opt (store, block_hash)
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun header ->
    if limit = 0 then
      delete_loop header.shell.predecessor (0, [])
      >>= fun () -> Lwt.return block_hash
    else prune_loop header.shell.predecessor limit

  let purge_rolling chain_state ((lvl, hash) as checkpoint) =
    Shared.use chain_state.global_state.global_data (fun global_data ->
        Shared.use chain_state.block_store (fun store ->
            Store.Block.Contents.read_opt (store, hash)
            >>= (function
                  | None ->
                      fail (Block_contents_not_found hash)
                  | Some contents ->
                      return contents)
            >>=? fun contents ->
            let max_op_ttl = contents.max_operations_ttl in
            let limit = max_op_ttl in
            purge_loop_rolling
              ~genesis_hash:chain_state.genesis.block
              global_data.global_store
              store
              hash
              limit
            >>= fun caboose_hash ->
            let caboose_level = Int32.sub lvl (Int32.of_int max_op_ttl) in
            let caboose = (caboose_level, caboose_hash) in
            update_chain_data chain_state (fun _ data ->
                let new_data = {data with save_point = checkpoint; caboose} in
                Lwt.return (Some new_data, ()))
            >>= fun () ->
            Shared.use chain_state.chain_data (fun data ->
                Store.Chain_data.Save_point.store
                  data.chain_data_store
                  checkpoint
                >>= fun () ->
                Store.Chain_data.Caboose.store data.chain_data_store caboose
                >>= fun () -> return_unit)))

  let set_checkpoint chain_state checkpoint =
    Shared.use chain_state.block_store (fun store ->
        Shared.use chain_state.chain_data (fun data ->
            let head_header = data.data.current_head.header in
            let head_hash = data.data.current_head.hash in
            Locked_block.is_valid_for_checkpoint
              store
              head_hash
              head_header
              checkpoint
            >>= fun valid ->
            assert valid ;
            (* Remove outdated invalid blocks. *)
            Store.Block.Invalid_block.iter store ~f:(fun hash iblock ->
                if iblock.level <= checkpoint.shell.level then
                  Store.Block.Invalid_block.remove store hash
                else Lwt.return_unit)
            >>= fun () ->
            (* Remove outdated heads and tag invalid branches. *)
            locked_valid_heads_for_checkpoint store data checkpoint
            >>= (fun (valid_heads, invalid_heads) ->
                  tag_invalid_heads
                    store
                    data.chain_data_store
                    invalid_heads
                    checkpoint.shell.level
                  >>= fun outdated_invalid_heads ->
                  if head_header.shell.level < checkpoint.shell.level then
                    Lwt.return_unit
                  else
                    let outdated_valid_heads =
                      List.filter
                        (fun (hash, {Block_header.shell; _}) ->
                          shell.level <= checkpoint.shell.level
                          && not (Block_hash.equal hash head_hash))
                        valid_heads
                    in
                    cut_alternate_heads
                      store
                      data.chain_data_store
                      outdated_valid_heads
                    >>= fun () ->
                    cut_alternate_heads
                      store
                      data.chain_data_store
                      outdated_invalid_heads)
            >>= fun () ->
            (* Store the new checkpoint. *)
            Store.Chain_data.Checkpoint.store data.chain_data_store checkpoint
            >>= fun () ->
            data.checkpoint <- checkpoint ;
            (* TODO 'git fsck' in the context. *)
            Lwt.return_unit))

  let set_checkpoint_then_purge_full chain_state checkpoint =
    set_checkpoint chain_state checkpoint
    >>= fun () ->
    let lvl = checkpoint.shell.level in
    let hash = Block_header.hash checkpoint in
    purge_full chain_state (lvl, hash)

  let set_checkpoint_then_purge_rolling chain_state checkpoint =
    set_checkpoint chain_state checkpoint
    >>= fun () ->
    let lvl = checkpoint.shell.level in
    let hash = Block_header.hash checkpoint in
    purge_rolling chain_state (lvl, hash)

  let acceptable_block chain_state (header : Block_header.t) =
    Shared.use chain_state.chain_data (fun chain_data ->
        Locked_block.acceptable chain_data header)

  let destroy state chain =
    lwt_debug
      Tag.DSL.(
        fun f -> f "destroy %a" -% t event "destroy" -% a chain_id (id chain))
    >>= fun () ->
    Shared.use state.global_data (fun {global_store; chains; _} ->
        Chain_id.Table.remove chains (id chain) ;
        Store.Chain.destroy global_store (id chain))

  let store chain_state =
    Shared.use chain_state.global_state.global_data (fun global_data ->
        Lwt.return global_data.global_store)
end

module Block = struct
  type t = block = {
    chain_state : Chain.t;
    hash : Block_hash.t;
    header : Block_header.t;
  }

  type block = t

  module Header = Header

  let compare b1 b2 = Block_hash.compare b1.hash b2.hash

  let equal b1 b2 = Block_hash.equal b1.hash b2.hash

  let hash {hash; _} = hash

  let header {header; _} = header

  let read_contents block =
    Shared.use block.chain_state.block_store (fun store ->
        Store.Block.Contents.read_opt (store, block.hash)
        >>= function
        | None ->
            fail (Block_contents_not_found block.hash)
        | Some contents ->
            return contents)

  let header_of_hash chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.read_opt (store, hash))

  let metadata b = read_contents b >>=? fun {metadata; _} -> return metadata

  let chain_state {chain_state; _} = chain_state

  let chain_id {chain_state = {chain_id; _}; _} = chain_id

  let shell_header {header = {shell; _}; _} = shell

  let timestamp b = (shell_header b).timestamp

  let fitness b = (shell_header b).fitness

  let level b = (shell_header b).level

  let validation_passes b = (shell_header b).validation_passes

  let message b = read_contents b >>=? fun {message; _} -> return message

  let max_operations_ttl b =
    read_contents b
    >>=? fun {max_operations_ttl; _} -> return max_operations_ttl

  let last_allowed_fork_level b =
    read_contents b
    >>=? fun {last_allowed_fork_level; _} -> return last_allowed_fork_level

  let is_genesis b = Block_hash.equal b.hash b.chain_state.genesis.block

  let known_valid chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.known (store, hash))

  let known_invalid chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.known store hash)

  let read_invalid chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.read_opt store hash)

  let list_invalid chain_state =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.fold
          store
          ~init:[]
          ~f:(fun hash {level; errors} acc ->
            Lwt.return ((hash, level, errors) :: acc)))

  let unmark_invalid chain_state block =
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.known store block
        >>= fun mem ->
        if mem then Store.Block.Invalid_block.remove store block >>= return
        else fail (Block_not_invalid block))

  let is_valid_for_checkpoint block checkpoint =
    let chain_state = block.chain_state in
    Shared.use chain_state.block_store (fun store ->
        Locked_block.is_valid_for_checkpoint
          store
          block.hash
          block.header
          checkpoint)

  let read_predecessor chain_state ~pred ?(below_save_point = false) hash =
    Shared.use chain_state.block_store (fun store ->
        predecessor_n ~below_save_point store hash pred
        >>= fun hash_opt ->
        let new_hash_opt =
          match hash_opt with
          | Some _ as hash_opt ->
              hash_opt
          | None ->
              if Block_hash.equal hash chain_state.genesis.block then
                Some chain_state.genesis.block
              else None
        in
        match new_hash_opt with
        | None ->
            Lwt.fail Not_found
        | Some hash -> (
            Header.read_opt (store, hash)
            >>= fun header ->
            match header with
            | Some header ->
                Lwt.return_some {chain_state; hash; header}
            | None ->
                Lwt.return_none ))

  let read chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.read (store, hash)
        >>=? fun header -> return {chain_state; hash; header})

  let read_opt chain_state hash =
    read chain_state hash
    >>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v

  let predecessor {chain_state; header; hash; _} =
    if Block_hash.equal hash header.shell.predecessor then Lwt.return_none
      (* we are at genesis *)
    else read_opt chain_state header.shell.predecessor

  let predecessor_n b n =
    Shared.use b.chain_state.block_store (fun block_store ->
        predecessor_n block_store b.hash n)

  let store ?(dont_enforce_context_hash = false) chain_state block_header
      block_header_metadata operations operations_metadata
      ({context_hash; message; max_operations_ttl; last_allowed_fork_level} :
        Block_validation.validation_store) ~forking_testchain =
    let bytes = Block_header.to_bytes block_header in
    let hash = Block_header.hash_raw bytes in
    fail_unless
      (block_header.shell.validation_passes = List.length operations)
      (failure "State.Block.store: invalid operations length")
    >>=? fun () ->
    fail_unless
      (block_header.shell.validation_passes = List.length operations_metadata)
      (failure "State.Block.store: invalid operations_data length")
    >>=? fun () ->
    fail_unless
      (List.for_all2
         (fun l1 l2 -> List.length l1 = List.length l2)
         operations
         operations_metadata)
      (failure "State.Block.store: inconsistent operations and operations_data")
    >>=? fun () ->
    (* let's the validator check the consistency... of fitness, level, ... *)
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Invalid_block.known store hash
        >>= fun known_invalid ->
        fail_when known_invalid (failure "Known invalid")
        >>=? fun () ->
        Store.Block.Contents.known (store, hash)
        >>= fun known ->
        if known then return_none
        else
          (* safety check: never ever commit a block that is not compatible
           with the current checkpoint.  *)
          (let predecessor = block_header.shell.predecessor in
           Header.known (store, predecessor)
           >>= fun valid_predecessor ->
           if not valid_predecessor then Lwt.return_false
           else
             Shared.use chain_state.chain_data (fun chain_data ->
                 Locked_block.acceptable chain_data block_header))
          >>= fun acceptable_block ->
          fail_unless acceptable_block (Checkpoint_error (hash, None))
          >>=? fun () ->
          let commit = context_hash in
          Context.exists chain_state.context_index.data commit
          >>= fun exists ->
          fail_unless
            exists
            (failure "State.Block.store: context hash not found in context")
          >>=? fun _ ->
          fail_unless
            ( dont_enforce_context_hash
            || Context_hash.equal block_header.shell.context commit )
            (Inconsistent_hash (commit, block_header.shell.context))
          >>=? fun () ->
          let header =
            if dont_enforce_context_hash then
              {
                block_header with
                shell = {block_header.shell with context = commit};
              }
            else block_header
          in
          let contents =
            {
              header;
              Store.Block.message;
              max_operations_ttl;
              last_allowed_fork_level;
              context = commit;
              metadata = block_header_metadata;
            }
          in
          Store.Block.Contents.store (store, hash) contents
          >>= fun () ->
          Lwt_list.iteri_p
            (fun i ops ->
              Store.Block.Operation_hashes.store
                (store, hash)
                i
                (List.map Operation.hash ops))
            operations
          >>= fun () ->
          Lwt_list.iteri_p
            (fun i ops -> Store.Block.Operations.store (store, hash) i ops)
            operations
          >>= fun () ->
          Lwt_list.iteri_p
            (fun i ops ->
              Store.Block.Operations_metadata.store (store, hash) i ops)
            operations_metadata
          >>= fun () ->
          (* Store predecessors *)
          store_predecessors store hash
          >>= fun () ->
          (* Update the chain state. *)
          Shared.use chain_state.chain_data (fun chain_data ->
              let store = chain_data.chain_data_store in
              let predecessor = block_header.shell.predecessor in
              Store.Chain_data.Known_heads.remove store predecessor
              >>= fun () -> Store.Chain_data.Known_heads.store store hash)
          >>= fun () ->
          ( if forking_testchain then
            Shared.use chain_state.global_state.global_data (fun global_data ->
                let genesis = Context.compute_testchain_genesis hash in
                Store.Forking_block_hash.store
                  global_data.global_store
                  (Context.compute_testchain_chain_id genesis)
                  hash)
          else Lwt.return_unit )
          >>= fun () ->
          let block = {chain_state; hash; header} in
          Lwt_watcher.notify chain_state.block_watcher block ;
          Lwt_watcher.notify chain_state.global_state.block_watcher block ;
          return_some block)

  let store_invalid chain_state block_header errors =
    let bytes = Block_header.to_bytes block_header in
    let hash = Block_header.hash_raw bytes in
    Shared.use chain_state.block_store (fun store ->
        Header.known (store, hash)
        >>= fun known_valid ->
        fail_when known_valid (failure "Known valid")
        >>=? fun () ->
        Store.Block.Invalid_block.known store hash
        >>= fun known_invalid ->
        if known_invalid then return_false
        else
          Store.Block.Invalid_block.store
            store
            hash
            {level = block_header.shell.level; errors}
          >>= fun () -> return_true)

  let watcher (state : chain_state) =
    Lwt_watcher.create_stream state.block_watcher

  let compute_operation_path hashes =
    let list_hashes = List.map Operation_list_hash.compute hashes in
    Operation_list_list_hash.compute_path list_hashes

  let operation_hashes {chain_state; hash; header} i =
    if i < 0 || header.shell.validation_passes <= i then
      invalid_arg "State.Block.operations" ;
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun n ->
            Store.Block.Operation_hashes.read_opt (store, hash) n
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1))
        >>= fun hashes ->
        let path = compute_operation_path hashes in
        Lwt.return (List.nth hashes i, path i))

  let all_operation_hashes {chain_state; hash; header; _} =
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun i ->
            Store.Block.Operation_hashes.read_opt (store, hash) i
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1)))

  let operations {chain_state; hash; header; _} i =
    if i < 0 || header.shell.validation_passes <= i then
      invalid_arg "State.Block.operations" ;
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun n ->
            Store.Block.Operation_hashes.read_opt (store, hash) n
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1))
        >>= fun hashes ->
        let path = compute_operation_path hashes in
        Store.Block.Operations.read_opt (store, hash) i
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun ops -> Lwt.return (ops, path i))

  let operations_metadata {chain_state; hash; header; _} i =
    if i < 0 || header.shell.validation_passes <= i then
      invalid_arg "State.Block.operations_metadata" ;
    Shared.use chain_state.block_store (fun store ->
        Store.Block.Operations_metadata.read_opt (store, hash) i
        >|= Option.unopt_assert ~loc:__POS__)

  let all_operations {chain_state; hash; header; _} =
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun i ->
            Store.Block.Operations.read_opt (store, hash) i
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1)))

  let all_operations_metadata {chain_state; hash; header; _} =
    Shared.use chain_state.block_store (fun store ->
        Lwt_list.map_p
          (fun i ->
            Store.Block.Operations_metadata.read_opt (store, hash) i
            >|= Option.unopt_assert ~loc:__POS__)
          (0 -- (header.shell.validation_passes - 1)))

  let context_exn {chain_state; hash; _} =
    Shared.use chain_state.block_store (fun block_store ->
        Store.Block.Contents.read_opt (block_store, hash))
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun {context = commit; _} ->
    Shared.use chain_state.context_index (fun context_index ->
        Context.checkout_exn context_index commit)

  let context_opt {chain_state; hash; _} =
    Shared.use chain_state.block_store (fun block_store ->
        Store.Block.Contents.read_opt (block_store, hash))
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun {context = commit; _} ->
    Shared.use chain_state.context_index (fun context_index ->
        Context.checkout context_index commit)

  let context block =
    context_opt block
    >>= function
    | Some context ->
        return context
    | None ->
        failwith "State.Block.context failed to checkout context"

  let protocol_hash block =
    context block >>=? fun context -> Context.get_protocol context >>= return

  let protocol_hash_exn block =
    context_exn block >>= fun context -> Context.get_protocol context

  let protocol_level block = block.header.shell.proto_level

  let test_chain block =
    context_exn block
    >>= fun context ->
    Context.get_test_chain context
    >>= fun status ->
    let lookup_testchain genesis =
      let chain_id = Context.compute_testchain_chain_id genesis in
      (* otherwise, look in the temporary table *)
      Shared.use block.chain_state.global_state.global_data (fun global_data ->
          Store.Forking_block_hash.read_opt global_data.global_store chain_id)
      >>= function
      | Some forking_block_hash ->
          read_opt block.chain_state forking_block_hash
          >>= fun forking_block -> Lwt.return (status, forking_block)
      | None ->
          Lwt.return (status, None)
    in
    match status with
    | Running {genesis; _} ->
        lookup_testchain genesis
    | Forking _ ->
        Lwt.return (status, Some block)
    | Not_running ->
        Lwt.return (status, None)

  let known chain_state hash =
    Shared.use chain_state.block_store (fun store ->
        Header.known (store, hash)
        >>= fun known ->
        if known then Lwt.return_true
        else Store.Block.Invalid_block.known store hash)

  let block_validity chain_state block : Block_locator.validity Lwt.t =
    known chain_state block
    >>= function
    | false ->
        if Block_hash.equal block (Chain.faked_genesis_hash chain_state) then
          Lwt.return Block_locator.Known_valid
        else Lwt.return Block_locator.Unknown
    | true -> (
        known_invalid chain_state block
        >>= function
        | true ->
            Lwt.return Block_locator.Known_invalid
        | false ->
            Lwt.return Block_locator.Known_valid )

  let known_ancestor chain_state locator =
    Shared.use chain_state.global_state.global_data (fun {global_store; _} ->
        Store.Configuration.History_mode.read_opt global_store
        >|= Option.unopt_assert ~loc:__POS__)
    >>= fun history_mode ->
    Block_locator.unknown_prefix ~is_known:(block_validity chain_state) locator
    >>= function
    | (Known_valid, prefix_locator) ->
        Lwt.return_some prefix_locator
    | (Known_invalid, _) ->
        Lwt.return_none
    | (Unknown, _) -> (
      match history_mode with
      | Archive ->
          Lwt.return_none
      | Rolling | Full ->
          Lwt.return_some locator )

  (* Hypothesis : genesis' predecessor is itself. *)
  let get_rpc_directory ({chain_state; _} as block) =
    read_opt chain_state block.header.shell.predecessor
    >>= function
    | None ->
        Lwt.return_none (* assert false *)
    | Some pred when equal pred block ->
        Lwt.return_none (* genesis *)
    | Some pred -> (
        Chain.save_point chain_state
        >>= fun (save_point_level, _) ->
        ( if Compare.Int32.(level pred < save_point_level) then
          Chain.get_level_indexed_protocol chain_state pred.header
        else protocol_hash_exn pred )
        >>= fun protocol ->
        match
          Protocol_hash.Table.find_opt
            chain_state.block_rpc_directories
            protocol
        with
        | None ->
            Lwt.return_none
        | Some map ->
            protocol_hash_exn block
            >>= fun next_protocol ->
            Lwt.return (Protocol_hash.Map.find_opt next_protocol map) )

  let set_rpc_directory ({chain_state; _} as block) dir =
    read_opt chain_state block.header.shell.predecessor
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun pred ->
    protocol_hash_exn block
    >>= fun next_protocol ->
    Chain.save_point chain_state
    >>= fun (save_point_level, _) ->
    ( if Compare.Int32.(level pred < save_point_level) then
      Chain.get_level_indexed_protocol chain_state (header pred)
    else protocol_hash_exn pred )
    >>= fun protocol ->
    let map =
      Option.unopt
        ~default:Protocol_hash.Map.empty
        (Protocol_hash.Table.find_opt
           chain_state.block_rpc_directories
           protocol)
    in
    Protocol_hash.Table.replace
      chain_state.block_rpc_directories
      protocol
      (Protocol_hash.Map.add next_protocol dir map) ;
    Lwt.return_unit

  let get_header_rpc_directory chain_state header =
    Shared.use chain_state.block_store (fun block_store ->
        Header.read_opt (block_store, header.Block_header.shell.predecessor)
        >>= function
        | None ->
            Lwt.return_none (* caboose *)
        | Some pred when Block_header.equal pred header ->
            Lwt.return_none (* genesis *)
        | Some pred -> (
            Chain.get_level_indexed_protocol chain_state header
            >>= fun protocol ->
            match
              Protocol_hash.Table.find_opt
                chain_state.header_rpc_directories
                protocol
            with
            | None ->
                Lwt.return_none
            | Some map ->
                Chain.get_level_indexed_protocol chain_state pred
                >>= fun next_protocol ->
                Lwt.return (Protocol_hash.Map.find_opt next_protocol map) ))

  let set_header_rpc_directory chain_state header dir =
    Shared.use chain_state.block_store (fun block_store ->
        Header.read_opt (block_store, header.Block_header.shell.predecessor)
        >>= function
        | None ->
            assert false
        | Some pred ->
            Chain.get_level_indexed_protocol chain_state header
            >>= fun next_protocol ->
            Chain.get_level_indexed_protocol chain_state pred
            >>= fun protocol ->
            let map =
              Option.unopt
                ~default:Protocol_hash.Map.empty
                (Protocol_hash.Table.find_opt
                   chain_state.header_rpc_directories
                   protocol)
            in
            Protocol_hash.Table.replace
              chain_state.header_rpc_directories
              protocol
              (Protocol_hash.Map.add next_protocol dir map) ;
            Lwt.return_unit)
end

let watcher (state : global_state) =
  Lwt_watcher.create_stream state.block_watcher

let read_block {global_data; _} hash =
  Shared.use global_data (fun {chains; _} ->
      Chain_id.Table.fold
        (fun _chain_id chain_state acc ->
          acc
          >>= function
          | Some _ ->
              acc
          | None -> (
              Block.read_opt chain_state hash
              >>= function None -> acc | Some block -> Lwt.return_some block ))
        chains
        Lwt.return_none)

let read_block_exn t hash =
  read_block t hash
  >>= function None -> Lwt.fail Not_found | Some b -> Lwt.return b

let update_testchain block ~testchain_state =
  update_chain_data block.chain_state (fun _ chain_data ->
      Lwt.return
        (Some {chain_data with test_chain = Some testchain_state.chain_id}, ()))

let fork_testchain block chain_id genesis_hash genesis_header protocol
    expiration =
  Shared.use block.chain_state.global_state.global_data (fun data ->
      let chain_store = Store.Chain.get data.global_store chain_id in
      let block_store = Store.Block.get chain_store in
      Store.Block.Contents.store
        (block_store, genesis_hash)
        {
          header = genesis_header;
          Store.Block.message = Some "Genesis";
          max_operations_ttl = 0;
          context = genesis_header.shell.context;
          metadata = Bytes.create 0;
          last_allowed_fork_level = 0l;
        }
      >>= fun () ->
      let genesis =
        {block = genesis_hash; time = genesis_header.shell.timestamp; protocol}
      in
      Chain.locked_create
        block.chain_state.global_state
        data
        chain_id
        ~expiration
        genesis
        genesis_header
      >>= fun testchain_state ->
      Store.Chain.Protocol_info.store
        chain_store
        genesis_header.shell.proto_level
        (protocol, genesis_header.shell.level)
      >>= fun () ->
      update_testchain block ~testchain_state
      >>= fun () -> return testchain_state)

let best_known_head_for_checkpoint chain_state checkpoint =
  Shared.use chain_state.block_store (fun store ->
      Shared.use chain_state.chain_data (fun data ->
          let head_hash = data.data.current_head.hash in
          let head_header = data.data.current_head.header in
          Locked_block.is_valid_for_checkpoint
            store
            head_hash
            head_header
            checkpoint
          >>= fun valid ->
          if valid then Lwt.return data.data.current_head
          else
            let find_valid_predecessor hash =
              Header.read_opt (store, hash)
              >|= Option.unopt_assert ~loc:__POS__
              >>= fun header ->
              if Compare.Int32.(header.shell.level < checkpoint.shell.level)
              then Lwt.return {hash; chain_state; header}
              else
                predecessor_n
                  store
                  hash
                  ( 1
                  + ( Int32.to_int
                    @@ Int32.sub header.shell.level checkpoint.shell.level ) )
                >|= Option.unopt_assert ~loc:__POS__
                >>= fun pred ->
                Header.read_opt (store, pred)
                >|= Option.unopt_assert ~loc:__POS__
                >>= fun pred_header ->
                Lwt.return {hash = pred; chain_state; header = pred_header}
            in
            Store.Chain_data.Known_heads.read_all data.chain_data_store
            >>= fun heads ->
            Header.read_opt (store, chain_state.genesis.block)
            >|= Option.unopt_assert ~loc:__POS__
            >>= fun genesis_header ->
            let genesis =
              {
                hash = chain_state.genesis.block;
                chain_state;
                header = genesis_header;
              }
            in
            Block_hash.Set.fold
              (fun head best ->
                let valid_predecessor = find_valid_predecessor head in
                best
                >>= fun best ->
                valid_predecessor
                >>= fun pred ->
                if
                  Fitness.(
                    pred.header.shell.fitness > best.header.shell.fitness)
                then Lwt.return pred
                else Lwt.return best)
              heads
              (Lwt.return genesis)))

module Protocol = struct
  include Protocol

  let known global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.known store hash)

  let read global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.read store hash)

  let read_opt global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.read_opt store hash)

  let read_raw global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.RawContents.read (store, hash))

  let read_raw_opt global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.RawContents.read_opt (store, hash))

  let store global_state p =
    let bytes = Protocol.to_bytes p in
    let hash = Protocol.hash_raw bytes in
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.known store hash
        >>= fun known ->
        if known then Lwt.return_none
        else
          Store.Protocol.RawContents.store (store, hash) bytes
          >>= fun () ->
          Lwt_watcher.notify global_state.protocol_watcher hash ;
          Lwt.return_some hash)

  let remove global_state hash =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.known store hash
        >>= fun known ->
        if known then Lwt.return_false
        else
          Store.Protocol.Contents.remove store hash
          >>= fun () -> Lwt.return_true)

  let list global_state =
    Shared.use global_state.protocol_store (fun store ->
        Store.Protocol.Contents.fold_keys
          store
          ~init:Protocol_hash.Set.empty
          ~f:(fun x acc -> Lwt.return (Protocol_hash.Set.add x acc)))

  let watcher (state : global_state) =
    Lwt_watcher.create_stream state.protocol_watcher
end

module Current_mempool = struct
  let set chain_state ~head mempool =
    update_chain_data chain_state (fun _chain_data_store data ->
        if Block_hash.equal head (Block.hash data.current_head) then
          Lwt.return (Some {data with current_mempool = mempool}, ())
        else Lwt.return (None, ()))

  let get chain_state =
    read_chain_data chain_state (fun _chain_data_store data ->
        Lwt.return (Block.header data.current_head, data.current_mempool))
end

let may_create_chain ~commit_genesis state chain_id genesis =
  Chain.get state chain_id
  >>= function
  | Ok chain ->
      return chain
  | Error _ ->
      Chain.create
        ~commit_genesis
        ~allow_forked_chain:true
        state
        genesis
        chain_id

let read global_store context_index main_chain =
  let global_data =
    {chains = Chain_id.Table.create 17; global_store; context_index}
  in
  let state =
    {
      global_data = Shared.create global_data;
      protocol_store = Shared.create @@ Store.Protocol.get global_store;
      main_chain;
      protocol_watcher = Lwt_watcher.create_input ();
      block_watcher = Lwt_watcher.create_input ();
    }
  in
  Chain.read_all state >>=? fun () -> return state

type error +=
  | Incorrect_history_mode_switch of {
      previous_mode : History_mode.t;
      next_mode : History_mode.t;
    }

let () =
  register_error_kind
    `Permanent
    ~id:"node_config_file.incorrect_history_mode_switch"
    ~title:"Incorrect history mode switch"
    ~description:"Incorrect history mode switch."
    ~pp:(fun ppf (prev, next) ->
      Format.fprintf
        ppf
        "@[cannot switch from history mode %a mode to %a mode@]"
        History_mode.pp
        prev
        History_mode.pp
        next)
    (Data_encoding.obj2
       (Data_encoding.req "previous_mode" History_mode.encoding)
       (Data_encoding.req "next_mode" History_mode.encoding))
    (function
      | Incorrect_history_mode_switch x ->
          Some (x.previous_mode, x.next_mode)
      | _ ->
          None)
    (fun (previous_mode, next_mode) ->
      Incorrect_history_mode_switch {previous_mode; next_mode})

let init ?patch_context ?commit_genesis ?(store_mapsize = 40_960_000_000L)
    ?(context_mapsize = 409_600_000_000L) ~store_root ~context_root
    ?history_mode genesis =
  Store.init ~mapsize:store_mapsize store_root
  >>=? fun global_store ->
  ( match commit_genesis with
  | Some commit_genesis ->
      Context.init
        ~readonly:true
        ~mapsize:context_mapsize
        ?patch_context
        context_root
      >>= fun context_index -> Lwt.return (context_index, commit_genesis)
  | None ->
      Context.init
        ~readonly:false
        ~mapsize:context_mapsize
        ?patch_context
        context_root
      >>= fun context_index ->
      let commit_genesis ~chain_id ~time ~protocol =
        Context.commit_genesis context_index ~chain_id ~time ~protocol
        >>= fun res -> return res
      in
      Lwt.return (context_index, commit_genesis) )
  >>= fun (context_index, commit_genesis) ->
  let chain_id = Chain_id.of_block_hash genesis.Chain.block in
  read global_store context_index chain_id
  >>=? fun state ->
  may_create_chain ~commit_genesis state chain_id genesis
  >>=? fun main_chain_state ->
  Store.Configuration.History_mode.read_opt global_store
  >>= (function
        | None ->
            let mode = Option.unopt ~default:History_mode.Full history_mode in
            Store.Configuration.History_mode.store global_store mode
            >>= fun () -> return mode
        | Some previous_history_mode -> (
          match history_mode with
          | None ->
              return previous_history_mode
          | Some history_mode ->
              if history_mode <> previous_history_mode then
                fail
                  (Incorrect_history_mode_switch
                     {
                       previous_mode = previous_history_mode;
                       next_mode = history_mode;
                     })
              else return history_mode ))
  >>=? fun history_mode ->
  return (state, main_chain_state, context_index, history_mode)

let history_mode {global_data; _} =
  Shared.use global_data (fun {global_store; _} ->
      Store.Configuration.History_mode.read_opt global_store
      >|= Option.unopt_assert ~loc:__POS__)

let close {global_data; _} =
  Shared.use global_data (fun {global_store; _} ->
      Store.close global_store ; Lwt.return_unit)
src/lib_shell/state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import State_logging.

Import Validation_errors.

Module Shared.
  Record t {a : Type} := {
    data : a;
    lock : Lwt_mutex.t }.
  Arguments t : clear implicits.
  
  Definition create {A : Type} (data : A) : t A :=
    {| data := data; lock := Lwt_mutex.create tt |}.
  
  Definition use {A B : Type} (function_parameter : t A)
    : (A -> Lwt.t B) -> Lwt.t B :=
    let '{| data := data; lock := lock |} := function_parameter in
    fun f =>
      Lwt_mutex.with_lock lock
        (fun function_parameter =>
          let 'tt := function_parameter in
          f data).
End Shared.

Record genesis := {
  time : Tezos_base__TzPervasives.Time.Protocol.t;
  block : Tezos_base__TzPervasives.Block_hash.t;
  protocol : Tezos_base__TzPervasives.Protocol_hash.t }.

.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Module Header.
  Definition read
    (function_parameter :
      Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
    let '(store, hash) := function_parameter in
    op_gtgteq (Store.Block.Contents.read (store, hash))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok {| header := header |} => _return header
        | Stdlib.Error _ =>
          op_gtgteqquestion (Store.Block.Pruned_contents.read (store, hash))
            (fun function_parameter =>
              let '{| header := header |} := function_parameter in
              _return header)
        end).
  
  Definition read_opt
    (function_parameter :
      Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    let '(store, hash) := function_parameter in
    op_gtgteq (read (store, hash))
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok header => Lwt.return_some header
        | Stdlib.Error _ => Lwt.return_none
        end).
  
  Definition known
    (function_parameter :
      Tezos_shell__Store.Block.store * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t bool :=
    let '(store, hash) := function_parameter in
    op_gtgteq (Store.Block.Pruned_contents.known (store, hash))
      (fun function_parameter =>
        match function_parameter with
        | true => Lwt.return_true
        | false => Store.Block.Contents.known (store, hash)
        end).
End Header.

Definition read_chain_data {A : Type} (function_parameter : chain_state)
  : (Tezos_shell.Store.Chain_data.store -> chain_data -> Lwt.t A) -> Lwt.t A :=
  let '{| chain_data := chain_data |} := function_parameter in
  fun f =>
    Shared.use chain_data (fun state => f (chain_data_store state) (data state)).

Definition update_chain_data {A : Type} (function_parameter : chain_state)
  : (Tezos_shell.Store.Chain_data.store ->
    chain_data -> Lwt.t ((option chain_data) * A)) -> Lwt.t A :=
  let '{| chain_data := chain_data |} := function_parameter in
  fun f =>
    Shared.use chain_data
      (fun state =>
        op_gtgteq (f (chain_data_store state) (data state))
          (fun function_parameter =>
            let '(data, res) := function_parameter in
            op_gtgteq
              (Lwt_utils.may
                (fun data =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    (* ❌ Set record field not handled. *)
                    set_record_field state "data" % string data in
                  Lwt.return_unit) data)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt._return res))).

Definition stored_predecessors_size : Z := 12.

Definition store_predecessors
  (store : Tezos_shell.Store.Block.store)
  (b : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let fix loop (pred : Tezos_base__TzPervasives.Block_hash.t) (dist : Z)
    : Lwt.t unit :=
    if equiv_decb dist stored_predecessors_size then
      Lwt.return_unit
    else
      op_gtgteq (Store.Block.Predecessors.read_opt (store, pred) (Z.sub dist 1))
        (fun function_parameter =>
          match function_parameter with
          | None => Lwt.return_unit
          | Some p =>
            op_gtgteq (Store.Block.Predecessors.store (store, b) dist p)
              (fun function_parameter =>
                let 'tt := function_parameter in
                loop p (Z.add dist 1))
          end) in
  op_gtgteq
    (op_gtpipeeq (Header.read_opt (store, b))
      (Option.unopt_assert Stdlib.__POS__))
    (fun header =>
      let pred := predecessor (shell header) in
      if Block_hash.equal b pred then
        Lwt.return_unit
      else
        op_gtgteq (Store.Block.Predecessors.store (store, b) 0 pred)
          (fun function_parameter =>
            let 'tt := function_parameter in
            loop pred 1)).

Definition predecessor_n_raw
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
  : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  let power_of_2 (n : Z) : Z :=
    if OCaml.Stdlib.lt n 0 then
      OCaml.Stdlib.invalid_arg "negative argument" % string
    else
      let fix loop (cnt : Z) (res : Z) : Z :=
        if OCaml.Stdlib.lt cnt 1 then
          res
        else
          loop (Z.sub cnt 1) (Z.mul res 2) in
      loop n 1 in
  let closest_power_two_and_rest (n : Z) : Z * Z :=
    if OCaml.Stdlib.lt n 0 then
      OCaml.Stdlib.invalid_arg "negative argument" % string
    else
      let fix loop (cnt : Z) (n : Z) (rest : Z) : Z * Z :=
        if OCaml.Stdlib.le n 1 then
          (cnt, rest)
        else
          loop (Z.add cnt 1) (Z.div n 2)
            (Z.add rest (Z.mul (power_of_2 cnt) (Z.modulo n 2))) in
      loop 0 n 0 in
  if OCaml.Stdlib.lt distance 0 then
    OCaml.Stdlib.invalid_arg
      (String.append "State.predecessor: distance < 0 " % string
        (OCaml.Stdlib.string_of_int distance))
  else
    if equiv_decb distance 0 then
      Lwt.return_some block_hash
    else
      let fix loop
        (block_hash : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
        : Lwt.t (option Tezos_shell.Store.Block.Predecessors.value) :=
        if equiv_decb distance 1 then
          Store.Block.Predecessors.read_opt (store, block_hash) 0
        else
          let '(power, rest) := closest_power_two_and_rest distance in
          let '(power, rest) :=
            if OCaml.Stdlib.lt power stored_predecessors_size then
              (power, rest)
            else
              let power := Z.sub stored_predecessors_size 1 in
              let rest := Z.sub distance (power_of_2 power) in
              (power, rest) in
          op_gtgteq
            (Store.Block.Predecessors.read_opt (store, block_hash) power)
            (fun function_parameter =>
              match function_parameter with
              | None => Lwt.return_none
              | Some pred =>
                if equiv_decb rest 0 then
                  Lwt.return_some pred
                else
                  loop pred rest
              end) in
      loop block_hash distance.

Definition predecessor_n (op_staroptstar : option bool)
  : Tezos_shell__Store.Block.store ->
    Tezos_base__TzPervasives.Block_hash.t ->
      Z -> Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  let below_save_point :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun block_store =>
    fun block_hash =>
      fun distance =>
        op_gtgteq (predecessor_n_raw block_store block_hash distance)
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.return_none
            | Some predecessor =>
              op_gtgteq
                (if below_save_point then
                  Header.known (block_store, predecessor)
                else
                  Store.Block.Contents.known (block_store, predecessor))
                (fun function_parameter =>
                  match function_parameter with
                  | false => Lwt.return_none
                  | true => Lwt.return_some predecessor
                  end)
            end).

Definition compute_locator_from_hash
  (chain_state : chain_state) (op_staroptstar : option Z)
  : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base__TzPervasives.Block_locator.seed ->
      Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  let size :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 200
    end in
  fun head_hash =>
    fun seed =>
      op_gtgteq
        (Shared.use (chain_data chain_state)
          (fun state => Lwt._return (caboose (data state))))
        (fun function_parameter =>
          let '(_lvl, caboose) := function_parameter in
          Shared.use (block_store chain_state)
            (fun block_store =>
              op_gtgteq
                (op_gtpipeeq (Header.read_opt (block_store, head_hash))
                  (Option.unopt_assert Stdlib.__POS__))
                (fun header =>
                  Block_locator.compute (predecessor_n (Some true) block_store)
                    caboose size head_hash header seed))).

Definition compute_locator
  (chain : chain_state) (size : option Z) (head : block)
  (seed : Tezos_base__TzPervasives.Block_locator.seed)
  : Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  compute_locator_from_hash chain size (hash head) seed.

Definition t := global_state.

Module Locked_block.
  Definition store_genesis
    (store : Tezos_shell__Store.Block.store) (genesis : genesis)
    (context : Tezos_crypto.Context_hash.t)
    : Lwt.t Tezos_base__TzPervasives.Block_header.t :=
    let shell :=
      {|
        level :=
          (* ❌ Constant of type int32 is converted to int *)
          0; proto_level := 0; predecessor := block genesis;
        timestamp := time genesis; validation_passes := 0;
        operations_hash := Operation_list_list_hash.empty; fitness := [];
        context := context |} in
    let header := {| shell := shell; protocol_data := Stdlib.Bytes.create 0 |}
      in
    op_gtgteq
      (Store.Block.Contents.store (store, (block genesis))
        {| Store.Block.header := header;
          Store.Block.message := Some "Genesis" % string;
          Store.Block.max_operations_ttl := 0;
          Store.Block.last_allowed_fork_level :=
            (* ❌ Constant of type int32 is converted to int *)
            0; Store.Block.context := context;
          Store.Block.metadata := Stdlib.Bytes.create 0 |})
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt._return header).
  
  Definition acceptable
    (chain_data : chain_data_state)
    (header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
    let checkpoint_level := level (shell (checkpoint chain_data)) in
    if OCaml.Stdlib.lt checkpoint_level (level (shell header)) then
      Lwt.return_true
    else
      if equiv_decb checkpoint_level (level (shell header)) then
        Lwt._return (Block_header.equal header (checkpoint chain_data))
      else
        let head_level :=
          level (shell (header (current_head (data chain_data)))) in
        Lwt._return (OCaml.Stdlib.lt head_level checkpoint_level).
  
  Definition is_valid_for_checkpoint
    (block_store : Tezos_shell__Store.Block.store)
    (hash : Tezos_base__TzPervasives.Block_hash.t)
    (header : Tezos_base__TzPervasives.Block_header.t)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
    if op_lt (level (shell header)) (level (shell checkpoint)) then
      Lwt.return_true
    else
      op_gtgteq
        (op_gtpipeeq
          (predecessor_n None block_store hash
            (apply Int32.to_int
              (Int32.sub (level (shell header)) (level (shell checkpoint)))))
          (Option.unopt_assert Stdlib.__POS__))
        (fun predecessor =>
          if Block_hash.equal predecessor (Block_header.hash checkpoint) then
            Lwt.return_true
          else
            Lwt.return_false).
End Locked_block.

Definition locked_valid_heads_for_checkpoint
  (block_store : Tezos_shell__Store.Block.store) (data : chain_data_state)
  (checkpoint : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    ((list
      (Tezos_base__TzPervasives.Block_hash.Set.elt *
        Tezos_base__TzPervasives.Block_header.t)) *
      (list
        (Tezos_base__TzPervasives.Block_hash.Set.elt *
          Tezos_base__TzPervasives.Block_header.t))) :=
  op_gtgteq (Store.Chain_data.Known_heads.read_all (chain_data_store data))
    (fun heads =>
      Block_hash.Set.fold
        (fun head =>
          fun acc =>
            let valid_header :=
              op_gtgteq
                (op_gtpipeeq (Header.read_opt (block_store, head))
                  (Option.unopt_assert Stdlib.__POS__))
                (fun header =>
                  op_gtgteq
                    (Locked_block.is_valid_for_checkpoint block_store head
                      header checkpoint)
                    (fun valid => Lwt._return (valid, header))) in
            op_gtgteq acc
              (fun function_parameter =>
                let '(valid_heads, invalid_heads) := function_parameter in
                op_gtgteq valid_header
                  (fun function_parameter =>
                    let '(valid, header) := function_parameter in
                    if valid then
                      Lwt._return
                        ((cons (head, header) valid_heads), invalid_heads)
                    else
                      Lwt._return
                        (valid_heads, (cons (head, header) invalid_heads)))))
        heads (Lwt._return ([], []))).

Definition tag_invalid_heads
  (block_store : Tezos_shell.Store.Block.Invalid_block.t)
  (chain_store : Tezos_shell__Store.Chain_data.store)
  (heads :
    list
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) (level : Stdlib.Int32.t)
  : Lwt.t
    (list
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) :=
  let fix tag_invalid_head
    (function_parameter :
    Tezos_base__TzPervasives.Block_hash.t *
      Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t
      (option
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t)) :=
    let '(hash, header) := function_parameter in
    if OCaml.Stdlib.le (level (Block_header.shell header)) level then
      op_gtgteq (Store.Chain_data.Known_heads.store chain_store hash)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt.return_some (hash, header))
    else
      let errors :=
        cons (Tezos_base__TzPervasives.Checkpoint_error hash None) [] in
      op_gtgteq
        (Store.Block.Invalid_block.store block_store hash
          {| level := level (shell header); errors := errors |})
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Store.Block.Contents.remove (block_store, hash))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (Store.Block.Operation_hashes.remove_all (block_store, hash))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Store.Block.Operations_metadata.remove_all
                      (block_store, hash))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (Store.Block.Operations.remove_all (block_store, hash))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (Store.Block.Predecessors.remove_all
                              (block_store, hash))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (Header.read_opt
                                  (block_store, (predecessor (shell header))))
                                (fun function_parameter =>
                                  match function_parameter with
                                  | None => Lwt.return_none
                                  | Some header =>
                                    tag_invalid_head
                                      ((Block_header.hash header), header)
                                  end))))))) in
  op_gtgteq
    (Lwt_list.iter_p
      (fun function_parameter =>
        let '(hash, _header) := function_parameter in
        Store.Chain_data.Known_heads.remove chain_store hash) heads)
    (fun function_parameter =>
      let 'tt := function_parameter in
      Lwt_list.filter_map_s tag_invalid_head heads).

Definition prune_block
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let st := (store, block_hash) in
  op_gtgteq (Store.Block.Contents.remove st)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Store.Block.Invalid_block.remove store block_hash)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Store.Block.Operations_metadata.remove_all st)).

Definition store_header_and_prune_block
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let st := (store, block_hash) in
  op_gtgteq
    (op_gtgteq (Store.Block.Contents.read_opt st)
      (fun function_parameter =>
        match function_parameter with
        | Some {| header := header |} =>
          Store.Block.Pruned_contents.store st {| header := header |}
        | None =>
          op_gtgteq (Store.Block.Pruned_contents.known st)
            (fun function_parameter =>
              match function_parameter with
              | true => Lwt.return_unit
              | false =>
                State_logging.lwt_log_error
                  (fun f =>
                    op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  CamlinternalFormatBasics.End_of_format
                                  "" % string))
                              (CamlinternalFormatBasics.String_literal
                                "cannot find pruned contents of block " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))
                            "@[cannot find pruned contents of block %a@]" %
                              string))
                        (t event "missing_pruned_contents" % string))
                      (a Block_hash.Logging.tag block_hash))
              end)
        end))
    (fun function_parameter =>
      let 'tt := function_parameter in
      prune_block store block_hash).

Definition delete_block
  (store : Tezos_shell__Store.Block.store)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  op_gtgteq (prune_block store block_hash)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let st := (store, block_hash) in
      op_gtgteq (Store.Block.Pruned_contents.remove st)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Store.Block.Operations.remove_all st)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Store.Block.Operation_hashes.remove_all st)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Store.Block.Predecessors.remove_all st)))).

Definition cut_alternate_heads
  (block_store : Tezos_shell__Store.Block.store)
  (chain_store : Tezos_shell__Store.Chain_data.store)
  (heads :
    list
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t)) : Lwt.t unit :=
  let fix cut_alternate_head
    (hash : Tezos_base__TzPervasives.Block_hash.t) (header :
    Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
    op_gtgteq (Store.Chain_data.In_main_branch.known (chain_store, hash))
      (fun in_chain =>
        if in_chain then
          Lwt.return_unit
        else
          op_gtgteq
            (Header.read_opt
              (block_store, (predecessor (Block_header.shell header))))
            (fun function_parameter =>
              match function_parameter with
              | None =>
                op_gtgteq (delete_block block_store hash)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt.return_unit)
              | Some header =>
                op_gtgteq (delete_block block_store hash)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    cut_alternate_head (Block_header.hash header) header)
              end)) in
  Lwt_list.iter_p
    (fun function_parameter =>
      let '(hash, header) := function_parameter in
      op_gtgteq (Store.Chain_data.Known_heads.remove chain_store hash)
        (fun function_parameter =>
          let 'tt := function_parameter in
          cut_alternate_head hash header)) heads.

Module Chain.
  Record genesis := {
    time : Tezos_base__TzPervasives.Time.Protocol.t;
    block : Tezos_base__TzPervasives.Block_hash.t;
    protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
  
  Definition genesis_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding genesis :=
    conv
      (fun function_parameter =>
        let '{| time := time; block := block; protocol := protocol |} :=
          function_parameter in
        (time, block, protocol))
      (fun function_parameter =>
        let '(time, block, protocol) := function_parameter in
        {| time := time; block := block; protocol := protocol |}) None
      (obj3 (req None None "timestamp" % string Time.Protocol.encoding)
        (req None None "block" % string Block_hash.encoding)
        (req None None "protocol" % string Protocol_hash.encoding)).
  
  Definition t := chain_state.
  
  Definition chain_state := t.
  
  Definition main (function_parameter : global_state)
    : Tezos_base__TzPervasives.Chain_id.t :=
    let '{| main_chain := main_chain |} := function_parameter in
    main_chain.
  
  Definition test (chain_state : chain_state)
    : Lwt.t (option Tezos_base__TzPervasives.Chain_id.t) :=
    read_chain_data chain_state
      (fun function_parameter =>
        let '_ := function_parameter in
        fun chain_data => Lwt._return (test_chain chain_data)).
  
  Definition get_level_indexed_protocol
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
    let chain_id := chain_id chain_state in
    let protocol_level := proto_level (Block_header.shell header) in
    let global_state := global_state chain_state in
    Shared.use (global_data global_state)
      (fun global_data =>
        let global_store := global_store global_data in
        let chain_store := Store.Chain.get global_store chain_id in
        op_gtgteq
          (Store.Chain.Protocol_info.read_opt chain_store protocol_level)
          (fun function_parameter =>
            match function_parameter with
            | None =>
              Pervasives.failwith
                "State.Chain.get_level_index_protocol" % string
            | Some (p, _) => Lwt._return p
            end)).
  
  Definition update_level_indexed_protocol_store
    (chain_state : chain_state) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    (protocol_level : Tezos_shell.Store.Chain.Protocol_info.key)
    (protocol_hash : Tezos_base__TzPervasives.Protocol_hash.t)
    (block_header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
    let global_state := global_state chain_state in
    op_gtgteq
      (Shared.use (block_store chain_state)
        (fun block_store =>
          op_gtgteq
            (Header.read_opt
              (block_store, (predecessor (Block_header.shell block_header))))
            (fun function_parameter =>
              match function_parameter with
              | None => Lwt.return_none
              | Some header => Lwt.return_some header
              end)))
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt.return_unit
        | Some pred_header =>
          if
            nequiv_decb (proto_level (shell pred_header))
              (proto_level (shell block_header)) then
            Shared.use (global_data global_state)
              (fun global_data =>
                let global_store := global_store global_data in
                let chain_store := Store.Chain.get global_store chain_id in
                Store.Chain.Protocol_info.store chain_store protocol_level
                  (protocol_hash, (level (shell block_header))))
          else
            Lwt.return_unit
        end).
  
  Definition allocate
    (genesis : genesis)
    (faked_genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
    (save_point : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    (caboose : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    (expiration : option Tezos_base__TzPervasives.Time.Protocol.t)
    (allow_forked_chain : bool)
    (current_head : Tezos_base__TzPervasives.Block_hash.t)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    (global_state : global_state) (context_index : Tezos_storage.Context.index)
    (chain_data_store : Tezos_shell.Store.Chain_data.store)
    (block_store : Tezos_shell.Store.Block.store) : Lwt.t chain_state :=
    op_gtgteq
      (op_gtpipeeq (Header.read_opt (block_store, current_head))
        (Option.unopt_assert Stdlib.__POS__))
      (fun current_block_head =>
        let fix chain_data : chain_data_state :=
          {|
            data :=
              {|
                current_head :=
                  {| chain_state := chain_state; hash := current_head;
                    header := current_block_head |};
                current_mempool := Mempool.empty;
                live_blocks := Block_hash.Set.singleton (block genesis);
                live_operations := Operation_hash.Set.empty; test_chain := None;
                save_point := save_point; caboose := caboose |};
            checkpoint := checkpoint; chain_data_store := chain_data_store |}
        with chain_state : chain_state :=
          {| global_state := global_state; chain_id := chain_id;
            genesis := genesis; faked_genesis_hash := faked_genesis_hash;
            expiration := expiration; allow_forked_chain := allow_forked_chain;
            block_store := Shared.create block_store;
            context_index := Shared.create context_index;
            block_watcher := Lwt_watcher.create_input tt;
            chain_data :=
              {| Shared.data := chain_data; Shared.lock := Lwt_mutex.create tt
                |}; block_rpc_directories := Protocol_hash.Table.create 7;
            header_rpc_directories := Protocol_hash.Table.create 7 |} in
        Lwt._return chain_state).
  
  Definition locked_create
    (global_state : global_state) (data : global_data)
    (expiration : option Tezos_base__TzPervasives.Time.Protocol.t)
    (op_staroptstar : option bool)
    : Tezos_base__TzPervasives.Chain_id.t ->
      genesis -> Tezos_base__TzPervasives.Block_header.t -> Lwt.t chain_state :=
    let allow_forked_chain :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun chain_id =>
      fun genesis =>
        fun genesis_header =>
          let chain_store := Store.Chain.get (global_store data) chain_id in
          let block_store : Tezos_shell.Store.Block.store :=
            Store.Block.get chain_store
          with chain_data_store : Tezos_shell.Store.Chain_data.store :=
            Store.Chain_data.get chain_store in
          let save_point := ((level (shell genesis_header)), (block genesis)) in
          let caboose := ((level (shell genesis_header)), (block genesis)) in
          let proto_level := proto_level (shell genesis_header) in
          op_gtgteq (Store.Chain.Genesis_hash.store chain_store (block genesis))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (Store.Chain.Genesis_time.store chain_store (time genesis))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Store.Chain.Genesis_protocol.store chain_store
                      (protocol genesis))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (Store.Chain_data.Current_head.store chain_data_store
                          (block genesis))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (Store.Chain_data.Known_heads.store chain_data_store
                              (block genesis))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (Store.Chain_data.Checkpoint.store
                                  chain_data_store genesis_header)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (Store.Chain_data.Save_point.store
                                      chain_data_store save_point)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (Store.Chain_data.Caboose.store
                                          chain_data_store caboose)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (Store.Chain.Protocol_info.store
                                              chain_store proto_level
                                              ((protocol genesis),
                                                (level (shell genesis_header))))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                match expiration with
                                                | None => Lwt.return_unit
                                                | Some time =>
                                                  Store.Chain.Expiration.store
                                                    chain_store time
                                                end
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteq
                                                    (if allow_forked_chain then
                                                      Store.Chain.Allow_forked_chain.store
                                                        (global_store data)
                                                        chain_id
                                                    else
                                                      Lwt.return_unit)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        (allocate genesis
                                                          (Block_header.hash
                                                            genesis_header)
                                                          save_point caboose
                                                          expiration
                                                          allow_forked_chain
                                                          (block genesis)
                                                          genesis_header
                                                          chain_id global_state
                                                          (context_index data)
                                                          chain_data_store
                                                          block_store)
                                                        (fun chain =>
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            Chain_id.Table.add
                                                              (chains data)
                                                              chain_id chain in
                                                          Lwt._return chain)))))))))))).
  
  Definition create
    (state : global_state) (allow_forked_chain : option bool)
    (commit_genesis :
      Tezos_base__TzPervasives.Chain_id.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Protocol_hash.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t))
    (genesis : genesis) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
    Shared.use (global_data state)
      (fun data =>
        let chain_store := Store.Chain.get (global_store data) chain_id in
        let block_store := Store.Block.get chain_store in
        if Chain_id.Table.mem (chains data) chain_id then
          Pervasives.failwith "State.Chain.create" % string
        else
          op_gtgteqquestion
            (commit_genesis chain_id (time genesis) (protocol genesis))
            (fun commit =>
              op_gtgteq (Locked_block.store_genesis block_store genesis commit)
                (fun genesis_header =>
                  op_gtgteq
                    (locked_create state data None allow_forked_chain chain_id
                      genesis genesis_header)
                    (fun chain =>
                      op_gtgteq
                        (Store.Forking_block_hash.remove (global_store data)
                          (Context.compute_testchain_chain_id (block genesis)))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          _return chain))))).
  
  Definition locked_read
    (global_state : global_state) (data : global_data)
    (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
    let chain_store := Store.Chain.get (global_store data) chain_id in
    let block_store : Tezos_shell.Store.Block.store :=
      Store.Block.get chain_store
    with chain_data_store : Tezos_shell.Store.Chain_data.store :=
      Store.Chain_data.get chain_store in
    op_gtgteqquestion (Store.Chain.Genesis_hash.read chain_store)
      (fun genesis_hash =>
        op_gtgteqquestion (Store.Chain.Genesis_time.read chain_store)
          (fun time =>
            op_gtgteqquestion (Store.Chain.Genesis_protocol.read chain_store)
              (fun protocol =>
                op_gtgteq (Store.Chain.Expiration.read_opt chain_store)
                  (fun expiration =>
                    op_gtgteq
                      (Store.Chain.Allow_forked_chain.known (global_store data)
                        chain_id)
                      (fun allow_forked_chain =>
                        op_gtgteqquestion
                          (Header.read (block_store, genesis_hash))
                          (fun genesis_header =>
                            let genesis :=
                              {| time := time; block := genesis_hash;
                                protocol := protocol |} in
                            op_gtgteqquestion
                              (Store.Chain_data.Current_head.read
                                chain_data_store)
                              (fun current_head =>
                                op_gtgteqquestion
                                  (Store.Chain_data.Checkpoint.read
                                    chain_data_store)
                                  (fun checkpoint =>
                                    op_gtgteqquestion
                                      (Store.Chain_data.Save_point.read
                                        chain_data_store)
                                      (fun save_point =>
                                        op_gtgteqquestion
                                          (Store.Chain_data.Caboose.read
                                            chain_data_store)
                                          (fun caboose =>
                                            (* ❌ Try-with are not handled *)
                                            try
                                              (op_gtgteq
                                                (allocate genesis
                                                  (Block_header.hash
                                                    genesis_header) save_point
                                                  caboose expiration
                                                  allow_forked_chain
                                                  current_head checkpoint
                                                  chain_id global_state
                                                  (context_index data)
                                                  chain_data_store block_store)
                                                _return))))))))))).
  
  Definition locked_read_all (global_state : global_state) (data : global_data)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq (Store.Chain.list (global_store data))
      (fun ids =>
        iter_p
          (fun id =>
            op_gtgteqquestion (locked_read global_state data id)
              (fun chain =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := Chain_id.Table.add (chains data) id chain in
                return_unit)) ids).
  
  Definition read_all (state : global_state)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Shared.use (global_data state) (fun data => locked_read_all state data).
  
  Definition get_exn
    (state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
    : Lwt.t chain_state :=
    Shared.use (global_data state)
      (fun data => Lwt._return (Chain_id.Table.find (chains data) id)).
  
  Definition get_opt
    (state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
    : Lwt.t (option chain_state) :=
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (get_exn state id) Lwt.return_some)
      (fun function_parameter =>
        let '_ := function_parameter in
        Lwt.return_none).
  
  Definition get
    (state : global_state) (id : Tezos_base__TzPervasives.Chain_id.Table.key)
    : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (get_exn state id) _return)
      (fun function_parameter =>
        match function_parameter with
        | OCaml.Not_found => fail (Tezos_base__TzPervasives.Unknown_chain id)
        | exn => Lwt.fail exn
        end).
  
  Definition all (state : global_state) : Lwt.t (list chain_state) :=
    Shared.use (global_data state)
      (fun function_parameter =>
        let '{| chains := chains |} := function_parameter in
        apply Lwt._return
          (Chain_id.Table.fold
            (fun function_parameter =>
              let '_ := function_parameter in
              fun chain => fun acc => cons chain acc) chains [])).
  
  Definition id (function_parameter : chain_state)
    : Tezos_base__TzPervasives.Chain_id.t :=
    let '{| chain_id := chain_id |} := function_parameter in
    chain_id.
  
  Definition genesis (function_parameter : chain_state) : genesis :=
    let '{| genesis := genesis |} := function_parameter in
    genesis.
  
  Definition faked_genesis_hash (function_parameter : chain_state)
    : Tezos_base__TzPervasives.Block_hash.t :=
    let '{| faked_genesis_hash := faked_genesis_hash |} := function_parameter in
    faked_genesis_hash.
  
  Definition expiration (function_parameter : chain_state)
    : option Tezos_base__TzPervasives.Time.Protocol.t :=
    let '{| expiration := expiration |} := function_parameter in
    expiration.
  
  Definition allow_forked_chain (function_parameter : chain_state) : bool :=
    let '{| allow_forked_chain := allow_forked_chain |} := function_parameter in
    allow_forked_chain.
  
  Definition global_state (function_parameter : chain_state) : global_state :=
    let '{| global_state := global_state |} := function_parameter in
    global_state.
  
  Definition checkpoint (chain_state : chain_state)
    : Lwt.t Tezos_base__TzPervasives.Block_header.t :=
    Shared.use (chain_data chain_state)
      (fun function_parameter =>
        let '{| checkpoint := checkpoint |} := function_parameter in
        Lwt._return checkpoint).
  
  Definition save_point (chain_state : chain_state)
    : Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t) :=
    Shared.use (chain_data chain_state)
      (fun state => Lwt._return (save_point (data state))).
  
  Definition caboose (chain_state : chain_state)
    : Lwt.t (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t) :=
    Shared.use (chain_data chain_state)
      (fun state => Lwt._return (caboose (data state))).
  
  Definition purge_loop_full (op_staroptstar : option Z)
    : Tezos_shell.Store.t ->
      Tezos_shell__Store.Block.store ->
        Tezos_base__TzPervasives.Block_hash.t ->
          Tezos_base__TzPervasives.Block_hash.t -> Stdlib.Int32.t -> Lwt.t unit :=
    let chunk_size :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => 4000
      end in
    fun global_store =>
      fun store =>
        fun genesis_hash =>
          fun block_hash =>
            fun caboose_level =>
              let do_prune (blocks : list Tezos_base__TzPervasives.Block_hash.t)
                : Lwt.t unit :=
                apply (Store.with_atomic_rw global_store)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt_list.iter_s (store_header_and_prune_block store) blocks)
                in
              let fix loop
                (block_hash : Tezos_base__TzPervasives.Block_hash.t)
                (function_parameter :
                Z * (list Tezos_base__TzPervasives.Block_hash.t))
                : Lwt.t unit :=
                let '(n_blocks, blocks) := function_parameter in
                op_gtgteq
                  (if OCaml.Stdlib.ge n_blocks chunk_size then
                    op_gtgteq (do_prune blocks)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Lwt._return (0, []))
                  else
                    Lwt._return (n_blocks, blocks))
                  (fun function_parameter =>
                    let '(n_blocks, blocks) := function_parameter in
                    op_gtgteq
                      (op_gtpipeeq (Header.read_opt (store, block_hash))
                        (Option.unopt_assert Stdlib.__POS__))
                      (fun header =>
                        if Block_hash.equal block_hash genesis_hash then
                          do_prune blocks
                        else
                          if equiv_decb (level (shell header)) caboose_level
                            then
                            do_prune (cons block_hash blocks)
                          else
                            loop (predecessor (shell header))
                              ((Z.add n_blocks 1), (cons block_hash blocks))))
                in
              op_gtgteq
                (op_gtpipeeq (Header.read_opt (store, block_hash))
                  (Option.unopt_assert Stdlib.__POS__))
                (fun header => loop (predecessor (shell header)) (0, [])).
  
  Definition purge_full
    (chain_state : chain_state)
    (function_parameter : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let '(lvl, hash) := function_parameter in
    Shared.use (global_data (global_state chain_state))
      (fun global_data =>
        Shared.use (block_store chain_state)
          (fun store =>
            op_gtgteq
              (update_chain_data chain_state
                (fun function_parameter =>
                  let '_ := function_parameter in
                  fun data =>
                    op_gtgteq
                      (purge_loop_full None (global_store global_data) store
                        (block (genesis chain_state)) hash
                        (fst (save_point data)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        let new_data :=
                          (* ❌ Record substitution not handled *)
                          record_substitution in
                        Lwt._return ((Some new_data), tt))))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Shared.use (chain_data chain_state)
                  (fun data =>
                    op_gtgteq
                      (Store.Chain_data.Save_point.store (chain_data_store data)
                        (lvl, hash))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit))))).
  
  Definition purge_loop_rolling
    (global_store : Tezos_shell.Store.t)
    (store : Tezos_shell__Store.Block.store)
    (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
    (block_hash : Tezos_base__TzPervasives.Block_hash.t) (limit : Z)
    : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
    let do_delete (blocks : list Tezos_base__TzPervasives.Block_hash.t)
      : Lwt.t unit :=
      apply (Store.with_atomic_rw global_store)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt_list.iter_s (delete_block store) blocks) in
    let fix prune_loop
      (block_hash : Tezos_base__TzPervasives.Block_hash.t) (limit : Z)
      : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
      if Block_hash.equal genesis_hash block_hash then
        Lwt._return block_hash
      else
        if equiv_decb limit 1 then
          op_gtgteq (Header.read_opt (store, block_hash))
            (fun function_parameter =>
              match function_parameter with
              | None =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              | Some header =>
                op_gtgteq (store_header_and_prune_block store block_hash)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (delete_loop (predecessor (shell header)) (0, []))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Lwt._return block_hash))
              end)
        else
          op_gtgteq (Header.read_opt (store, block_hash))
            (fun function_parameter =>
              match function_parameter with
              | None =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              | Some header =>
                op_gtgteq (store_header_and_prune_block store block_hash)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    prune_loop (predecessor (shell header)) (Z.sub limit 1))
              end)
    with delete_loop
      (block_hash : Tezos_crypto.Block_hash.t) (function_parameter :
      Z * (list Tezos_base__TzPervasives.Block_hash.t)) : Lwt.t unit :=
      let '(n_blocks, blocks) := function_parameter in
      op_gtgteq
        (if OCaml.Stdlib.ge n_blocks 4000 then
          op_gtgteq (do_delete blocks)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt._return (0, []))
        else
          Lwt._return (n_blocks, blocks))
        (fun function_parameter =>
          let '(n_blocks, blocks) := function_parameter in
          op_gtgteq (Header.read_opt (store, block_hash))
            (fun function_parameter =>
              match function_parameter with
              | None => do_delete blocks
              | Some header =>
                if Block_hash.equal genesis_hash block_hash then
                  do_delete blocks
                else
                  delete_loop (predecessor (shell header))
                    ((Z.add n_blocks 1), (cons block_hash blocks))
              end)) in
    op_gtgteq
      (op_gtpipeeq (Header.read_opt (store, block_hash))
        (Option.unopt_assert Stdlib.__POS__))
      (fun header =>
        if equiv_decb limit 0 then
          op_gtgteq (delete_loop (predecessor (shell header)) (0, []))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt._return block_hash)
        else
          prune_loop (predecessor (shell header)) limit).
  
  Definition purge_rolling
    (chain_state : chain_state)
    (function_parameter : Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let '(lvl, hash) as checkpoint := function_parameter in
    Shared.use (global_data (global_state chain_state))
      (fun global_data =>
        Shared.use (block_store chain_state)
          (fun store =>
            op_gtgteqquestion
              (op_gtgteq (Store.Block.Contents.read_opt (store, hash))
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    fail
                      (Tezos_base__TzPervasives.Block_contents_not_found hash)
                  | Some contents => _return contents
                  end))
              (fun contents =>
                let max_op_ttl := max_operations_ttl contents in
                let limit := max_op_ttl in
                op_gtgteq
                  (purge_loop_rolling (global_store global_data) store
                    (block (genesis chain_state)) hash limit)
                  (fun caboose_hash =>
                    let caboose_level := Int32.sub lvl (Int32.of_int max_op_ttl)
                      in
                    let caboose := (caboose_level, caboose_hash) in
                    op_gtgteq
                      (update_chain_data chain_state
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          fun data =>
                            let new_data :=
                              (* ❌ Record substitution not handled *)
                              record_substitution in
                            Lwt._return ((Some new_data), tt)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Shared.use (chain_data chain_state)
                          (fun data =>
                            op_gtgteq
                              (Store.Chain_data.Save_point.store
                                (chain_data_store data) checkpoint)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  (Store.Chain_data.Caboose.store
                                    (chain_data_store data) caboose)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit)))))))).
  
  Definition set_checkpoint
    (chain_state : chain_state)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
    Shared.use (block_store chain_state)
      (fun store =>
        Shared.use (chain_data chain_state)
          (fun data =>
            let head_header := header (current_head (data data)) in
            let head_hash := hash (current_head (data data)) in
            op_gtgteq
              (Locked_block.is_valid_for_checkpoint store head_hash head_header
                checkpoint)
              (fun valid =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  (* ❌ Assert instruction is not handled. *)
                  assert valid in
                op_gtgteq
                  (Store.Block.Invalid_block.iter store
                    (fun hash =>
                      fun iblock =>
                        if
                          OCaml.Stdlib.le (level iblock)
                            (level (shell checkpoint)) then
                          Store.Block.Invalid_block.remove store hash
                        else
                          Lwt.return_unit))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      (op_gtgteq
                        (locked_valid_heads_for_checkpoint store data checkpoint)
                        (fun function_parameter =>
                          let '(valid_heads, invalid_heads) :=
                            function_parameter in
                          op_gtgteq
                            (tag_invalid_heads store (chain_data_store data)
                              invalid_heads (level (shell checkpoint)))
                            (fun outdated_invalid_heads =>
                              if
                                OCaml.Stdlib.lt (level (shell head_header))
                                  (level (shell checkpoint)) then
                                Lwt.return_unit
                              else
                                let outdated_valid_heads :=
                                  List.filter
                                    (fun function_parameter =>
                                      let
                                        '(hash, {|
                                          Block_header.shell := shell |}) :=
                                        function_parameter in
                                      andb
                                        (OCaml.Stdlib.le (level shell)
                                          (level (shell checkpoint)))
                                        (negb (Block_hash.equal hash head_hash)))
                                    valid_heads in
                                op_gtgteq
                                  (cut_alternate_heads store
                                    (chain_data_store data) outdated_valid_heads)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    cut_alternate_heads store
                                      (chain_data_store data)
                                      outdated_invalid_heads))))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq
                          (Store.Chain_data.Checkpoint.store
                            (chain_data_store data) checkpoint)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              (* ❌ Set record field not handled. *)
                              set_record_field data "checkpoint" % string
                                checkpoint in
                            Lwt.return_unit)))))).
  
  Definition set_checkpoint_then_purge_full
    (chain_state : chain_state)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq (set_checkpoint chain_state checkpoint)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let lvl := level (shell checkpoint) in
        let hash := Block_header.hash checkpoint in
        purge_full chain_state (lvl, hash)).
  
  Definition set_checkpoint_then_purge_rolling
    (chain_state : chain_state)
    (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq (set_checkpoint chain_state checkpoint)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let lvl := level (shell checkpoint) in
        let hash := Block_header.hash checkpoint in
        purge_rolling chain_state (lvl, hash)).
  
  Definition acceptable_block
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t) : Lwt.t bool :=
    Shared.use (chain_data chain_state)
      (fun chain_data => Locked_block.acceptable chain_data header).
  
  Definition destroy (state : global_state) (chain : chain_state)
    : Lwt.t unit :=
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "destroy " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "destroy %a" % string)) (t event "destroy" % string))
            (a chain_id (id chain))))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Shared.use (global_data state)
          (fun function_parameter =>
            let '{| chains := chains; global_store := global_store |} :=
              function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Chain_id.Table.remove chains (id chain) in
            Store.Chain.destroy global_store (id chain))).
  
  Definition store (chain_state : chain_state) : Lwt.t Tezos_shell.Store.t :=
    Shared.use (global_data (global_state chain_state))
      (fun global_data => Lwt._return (global_store global_data)).
End Chain.

Module Block.
  Record t := {
    chain_state : Chain.t;
    hash : Tezos_base__TzPervasives.Block_hash.t;
    header : Tezos_base__TzPervasives.Block_header.t }.
  
  Definition block := t.
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
  
  Definition compare (b1 : t) (b2 : t) : Z :=
    Block_hash.compare (hash b1) (hash b2).
  
  Definition equal (b1 : t) (b2 : t) : bool :=
    Block_hash.equal (hash b1) (hash b2).
  
  Definition hash (function_parameter : t)
    : Tezos_base__TzPervasives.Block_hash.t :=
    let '{| hash := hash |} := function_parameter in
    hash.
  
  Definition header (function_parameter : t)
    : Tezos_base__TzPervasives.Block_header.t :=
    let '{| header := header |} := function_parameter in
    header.
  
  Definition read_contents (block : t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_shell__Store.Block.contents) :=
    Shared.use (block_store (chain_state block))
      (fun store =>
        op_gtgteq (Store.Block.Contents.read_opt (store, (hash block)))
          (fun function_parameter =>
            match function_parameter with
            | None =>
              fail
                (Tezos_base__TzPervasives.Block_contents_not_found (hash block))
            | Some contents => _return contents
            end)).
  
  Definition header_of_hash
    (chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_header.t) :=
    Shared.use (block_store chain_state)
      (fun store => Header.read_opt (store, hash)).
  
  Definition metadata (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
    op_gtgteqquestion (read_contents b)
      (fun function_parameter =>
        let '{| metadata := metadata |} := function_parameter in
        _return metadata).
  
  Definition chain_state (function_parameter : t) : Chain.t :=
    let '{| chain_state := chain_state |} := function_parameter in
    chain_state.
  
  Definition chain_id (function_parameter : t)
    : Tezos_base__TzPervasives.Chain_id.t :=
    let '{| chain_state := {| chain_id := chain_id |} |} := function_parameter
      in
    chain_id.
  
  Definition shell_header (function_parameter : t)
    : Tezos_base__TzPervasives.Block_header.shell_header :=
    let '{| header := {| shell := shell |} |} := function_parameter in
    shell.
  
  Definition timestamp (b : t) : Tezos_base.Time.Protocol.t :=
    timestamp (shell_header b).
  
  Definition fitness (b : t) : Tezos_base.Fitness.t := fitness (shell_header b).
  
  Definition level (b : t) : Stdlib.Int32.t := level (shell_header b).
  
  Definition validation_passes (b : t) : Z := validation_passes (shell_header b).
  
  Definition message (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option string)) :=
    op_gtgteqquestion (read_contents b)
      (fun function_parameter =>
        let '{| message := message |} := function_parameter in
        _return message).
  
  Definition max_operations_ttl (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
    op_gtgteqquestion (read_contents b)
      (fun function_parameter =>
        let '{| max_operations_ttl := max_operations_ttl |} :=
          function_parameter in
        _return max_operations_ttl).
  
  Definition last_allowed_fork_level (b : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Int32.t) :=
    op_gtgteqquestion (read_contents b)
      (fun function_parameter =>
        let '{| last_allowed_fork_level := last_allowed_fork_level |} :=
          function_parameter in
        _return last_allowed_fork_level).
  
  Definition is_genesis (b : t) : bool :=
    Block_hash.equal (hash b) (block (genesis (chain_state b))).
  
  Definition known_valid
    (chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t bool :=
    Shared.use (block_store chain_state)
      (fun store => Header.known (store, hash)).
  
  Definition known_invalid
    (chain_state : chain_state)
    (hash : Tezos_shell.Store.Block.Invalid_block.key) : Lwt.t bool :=
    Shared.use (block_store chain_state)
      (fun store => Store.Block.Invalid_block.known store hash).
  
  Definition read_invalid
    (chain_state : chain_state)
    (hash : Tezos_shell.Store.Block.Invalid_block.key)
    : Lwt.t (option Tezos_shell.Store.Block.Invalid_block.value) :=
    Shared.use (block_store chain_state)
      (fun store => Store.Block.Invalid_block.read_opt store hash).
  
  Definition list_invalid (chain_state : chain_state)
    : Lwt.t
      (list
        (Tezos_shell.Store.Block.Invalid_block.key * int32 *
          (list Tezos_base__TzPervasives.Error_monad.error))) :=
    Shared.use (block_store chain_state)
      (fun store =>
        Store.Block.Invalid_block.fold store []
          (fun hash =>
            fun function_parameter =>
              let '{| level := level; errors := errors |} := function_parameter
                in
              fun acc => Lwt._return (cons (hash, level, errors) acc))).
  
  Definition unmark_invalid
    (chain_state : chain_state)
    (block : Tezos_shell.Store.Block.Invalid_block.key)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    Shared.use (block_store chain_state)
      (fun store =>
        op_gtgteq (Store.Block.Invalid_block.known store block)
          (fun mem =>
            if mem then
              op_gtgteq (Store.Block.Invalid_block.remove store block) _return
            else
              fail (Tezos_base__TzPervasives.Block_not_invalid block))).
  
  Definition is_valid_for_checkpoint
    (block : t) (checkpoint : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t bool :=
    let chain_state := chain_state block in
    Shared.use (block_store chain_state)
      (fun store =>
        Locked_block.is_valid_for_checkpoint store (hash block) (header block)
          checkpoint).
  
  Definition read_predecessor
    (chain_state : chain_state) (pred : Z) (op_staroptstar : option bool)
    : Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option t) :=
    let below_save_point :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun hash =>
      Shared.use (block_store chain_state)
        (fun store =>
          op_gtgteq (predecessor_n (Some below_save_point) store hash pred)
            (fun hash_opt =>
              let new_hash_opt :=
                match hash_opt with
                | (Some _) as hash_opt => hash_opt
                | None =>
                  if Block_hash.equal hash (block (genesis chain_state)) then
                    Some (block (genesis chain_state))
                  else
                    None
                end in
              match new_hash_opt with
              | None => Lwt.fail OCaml.Not_found
              | Some hash =>
                op_gtgteq (Header.read_opt (store, hash))
                  (fun header =>
                    match header with
                    | Some header =>
                      Lwt.return_some
                        {| chain_state := chain_state; hash := hash;
                          header := header |}
                    | None => Lwt.return_none
                    end)
              end)).
  
  Definition read
    (chain_state : Chain.t) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    Shared.use (block_store chain_state)
      (fun store =>
        op_gtgteqquestion (Header.read (store, hash))
          (fun header =>
            _return
              {| chain_state := chain_state; hash := hash; header := header |})).
  
  Definition read_opt
    (chain_state : Chain.t) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t (option t) :=
    op_gtgteq (read chain_state hash)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Error _ => Lwt.return_none
        | Stdlib.Ok v => Lwt.return_some v
        end).
  
  Definition predecessor (function_parameter : t) : Lwt.t (option t) :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    if Block_hash.equal hash (predecessor (shell header)) then
      Lwt.return_none
    else
      read_opt chain_state (predecessor (shell header)).
  
  Definition predecessor_n (b : t) (n : Z)
    : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
    Shared.use (block_store (chain_state b))
      (fun block_store => predecessor_n None block_store (hash b) n).
  
  Definition store (op_staroptstar : option bool)
    : chain_state ->
      Tezos_base__TzPervasives.Block_header.t ->
        Stdlib.Bytes.t ->
          (list (list Tezos_base__TzPervasives.Operation.t)) ->
            (list (list Stdlib.Bytes.t)) ->
              Tezos_validation.Block_validation.validation_store ->
                bool -> Lwt.t (Tezos_base__TzPervasives.tzresult (option t)) :=
    let dont_enforce_context_hash :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun chain_state =>
      fun block_header =>
        fun block_header_metadata =>
          fun operations =>
            fun operations_metadata =>
              fun function_parameter =>
                let '{|
                  context_hash := context_hash;
                    message := message;
                    max_operations_ttl := max_operations_ttl;
                    last_allowed_fork_level := last_allowed_fork_level
                    |} := function_parameter in
                fun forking_testchain =>
                  let bytes := Block_header.to_bytes block_header in
                  let hash := Block_header.hash_raw string in
                  op_gtgteqquestion
                    (fail_unless
                      (equiv_decb (validation_passes (shell block_header))
                        (List.length operations))
                      (failure
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "State.Block.store: invalid operations length" %
                              string CamlinternalFormatBasics.End_of_format)
                          "State.Block.store: invalid operations length" %
                            string)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (fail_unless
                          (equiv_decb (validation_passes (shell block_header))
                            (List.length operations_metadata))
                          (failure
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "State.Block.store: invalid operations_data length"
                                  % string
                                CamlinternalFormatBasics.End_of_format)
                              "State.Block.store: invalid operations_data length"
                                % string)))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (fail_unless
                              (List.for_all2
                                (fun l1 =>
                                  fun l2 =>
                                    equiv_decb (List.length l1) (List.length l2))
                                operations operations_metadata)
                              (failure
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "State.Block.store: inconsistent operations and operations_data"
                                      % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "State.Block.store: inconsistent operations and operations_data"
                                    % string)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              Shared.use (block_store chain_state)
                                (fun store =>
                                  op_gtgteq
                                    (Store.Block.Invalid_block.known store hash)
                                    (fun known_invalid =>
                                      op_gtgteqquestion
                                        (fail_when known_invalid
                                          (failure
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Known invalid" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "Known invalid" % string)))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (Store.Block.Contents.known
                                              (store, hash))
                                            (fun known =>
                                              if known then
                                                return_none
                                              else
                                                op_gtgteq
                                                  (let predecessor :=
                                                    predecessor
                                                      (shell block_header) in
                                                  op_gtgteq
                                                    (Header.known
                                                      (store, predecessor))
                                                    (fun valid_predecessor =>
                                                      if negb valid_predecessor
                                                        then
                                                        Lwt.return_false
                                                      else
                                                        Shared.use
                                                          (chain_data
                                                            chain_state)
                                                          (fun chain_data =>
                                                            Locked_block.acceptable
                                                              chain_data
                                                              block_header)))
                                                  (fun acceptable_block =>
                                                    op_gtgteqquestion
                                                      (fail_unless
                                                        acceptable_block
                                                        (Tezos_base__TzPervasives.Checkpoint_error
                                                          hash None))
                                                      (fun function_parameter =>
                                                        let 'tt :=
                                                          function_parameter in
                                                        let commit :=
                                                          context_hash in
                                                        op_gtgteq
                                                          (Context._exists
                                                            (data
                                                              (context_index
                                                                chain_state))
                                                            commit)
                                                          (fun _exists =>
                                                            op_gtgteqquestion
                                                              (fail_unless
                                                                _exists
                                                                (failure
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "State.Block.store: context hash not found in context"
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "State.Block.store: context hash not found in context"
                                                                      % string)))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let '_ :=
                                                                  function_parameter
                                                                  in
                                                                op_gtgteqquestion
                                                                  (fail_unless
                                                                    (orb
                                                                      dont_enforce_context_hash
                                                                      (Context_hash.equal
                                                                        (context
                                                                          (shell
                                                                            block_header))
                                                                        commit))
                                                                    (Tezos_base__TzPervasives.Inconsistent_hash
                                                                      commit
                                                                      (context
                                                                        (shell
                                                                          block_header))))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let 'tt :=
                                                                      function_parameter
                                                                      in
                                                                    let
                                                                      header :=
                                                                      if
                                                                        dont_enforce_context_hash
                                                                        then
                                                                        (* ❌ Record substitution not handled *)
                                                                        record_substitution
                                                                      else
                                                                        block_header
                                                                      in
                                                                    let
                                                                      contents :=
                                                                      {|
                                                                        Store.Block.header :=
                                                                          header;
                                                                        Store.Block.message :=
                                                                          message;
                                                                        Store.Block.max_operations_ttl :=
                                                                          max_operations_ttl;
                                                                        Store.Block.last_allowed_fork_level :=
                                                                          last_allowed_fork_level;
                                                                        Store.Block.context :=
                                                                          commit;
                                                                        Store.Block.metadata :=
                                                                          block_header_metadata
                                                                        |} in
                                                                    op_gtgteq
                                                                      (Store.Block.Contents.store
                                                                        (store,
                                                                          hash)
                                                                        contents)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        let
                                                                          'tt :=
                                                                          function_parameter
                                                                          in
                                                                        op_gtgteq
                                                                          (Lwt_list.iteri_p
                                                                            (fun
                                                                              i
                                                                              =>
                                                                              fun
                                                                                ops
                                                                                =>
                                                                                Store.Block.Operation_hashes.store
                                                                                  (store,
                                                                                    hash)
                                                                                  i
                                                                                  (List.map
                                                                                    Operation.hash
                                                                                    ops))
                                                                            operations)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              'tt :=
                                                                              function_parameter
                                                                              in
                                                                            op_gtgteq
                                                                              (Lwt_list.iteri_p
                                                                                (fun
                                                                                  i
                                                                                  =>
                                                                                  fun
                                                                                    ops
                                                                                    =>
                                                                                    Store.Block.Operations.store
                                                                                      (store,
                                                                                        hash)
                                                                                      i
                                                                                      ops)
                                                                                operations)
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                let
                                                                                  'tt :=
                                                                                  function_parameter
                                                                                  in
                                                                                op_gtgteq
                                                                                  (Lwt_list.iteri_p
                                                                                    (fun
                                                                                      i
                                                                                      =>
                                                                                      fun
                                                                                        ops
                                                                                        =>
                                                                                        Store.Block.Operations_metadata.store
                                                                                          (store,
                                                                                            hash)
                                                                                          i
                                                                                          ops)
                                                                                    operations_metadata)
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    let
                                                                                      'tt :=
                                                                                      function_parameter
                                                                                      in
                                                                                    op_gtgteq
                                                                                      (store_predecessors
                                                                                        store
                                                                                        hash)
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        let
                                                                                          'tt :=
                                                                                          function_parameter
                                                                                          in
                                                                                        op_gtgteq
                                                                                          (Shared.use
                                                                                            (chain_data
                                                                                              chain_state)
                                                                                            (fun
                                                                                              chain_data
                                                                                              =>
                                                                                              let
                                                                                                store :=
                                                                                                chain_data_store
                                                                                                  chain_data
                                                                                                in
                                                                                              let
                                                                                                predecessor :=
                                                                                                predecessor
                                                                                                  (shell
                                                                                                    block_header)
                                                                                                in
                                                                                              op_gtgteq
                                                                                                (Store.Chain_data.Known_heads.remove
                                                                                                  store
                                                                                                  predecessor)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  Store.Chain_data.Known_heads.store
                                                                                                    store
                                                                                                    hash)))
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              'tt :=
                                                                                              function_parameter
                                                                                              in
                                                                                            op_gtgteq
                                                                                              (if
                                                                                                forking_testchain
                                                                                                then
                                                                                                Shared.use
                                                                                                  (global_data
                                                                                                    (global_state
                                                                                                      chain_state))
                                                                                                  (fun
                                                                                                    global_data
                                                                                                    =>
                                                                                                    let
                                                                                                      genesis :=
                                                                                                      Context.compute_testchain_genesis
                                                                                                        hash
                                                                                                      in
                                                                                                    Store.Forking_block_hash.store
                                                                                                      (global_store
                                                                                                        global_data)
                                                                                                      (Context.compute_testchain_chain_id
                                                                                                        genesis)
                                                                                                      hash)
                                                                                              else
                                                                                                Lwt.return_unit)
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                let
                                                                                                  'tt :=
                                                                                                  function_parameter
                                                                                                  in
                                                                                                let
                                                                                                  block :=
                                                                                                  {|
                                                                                                    chain_state :=
                                                                                                      chain_state;
                                                                                                    hash :=
                                                                                                      hash;
                                                                                                    header :=
                                                                                                      header
                                                                                                    |}
                                                                                                  in
                                                                                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                let
                                                                                                  _
                                                                                                  :=
                                                                                                  Lwt_watcher.notify
                                                                                                    (block_watcher
                                                                                                      chain_state)
                                                                                                    block
                                                                                                  in
                                                                                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                                let
                                                                                                  _
                                                                                                  :=
                                                                                                  Lwt_watcher.notify
                                                                                                    (block_watcher
                                                                                                      (global_state
                                                                                                        chain_state))
                                                                                                    block
                                                                                                  in
                                                                                                return_some
                                                                                                  block))))))))))))))))))).
  
  Definition store_invalid
    (chain_state : chain_state)
    (block_header : Tezos_base__TzPervasives.Block_header.t)
    (errors : list Tezos_base__TzPervasives.Error_monad.error)
    : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    let bytes := Block_header.to_bytes block_header in
    let hash := Block_header.hash_raw string in
    Shared.use (block_store chain_state)
      (fun store =>
        op_gtgteq (Header.known (store, hash))
          (fun known_valid =>
            op_gtgteqquestion
              (fail_when known_valid
                (failure
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Known valid" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Known valid" % string)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Store.Block.Invalid_block.known store hash)
                  (fun known_invalid =>
                    if known_invalid then
                      return_false
                    else
                      op_gtgteq
                        (Store.Block.Invalid_block.store store hash
                          {| level := level (shell block_header);
                            errors := errors |})
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_true))))).
  
  Definition watcher (state : chain_state)
    : (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper :=
    Lwt_watcher.create_stream (block_watcher state).
  
  Definition compute_operation_path
    (hashes : list (list Tezos_base__TzPervasives.Operation_list_hash.elt))
    : Z -> Tezos_base__TzPervasives.Operation_list_list_hash.path :=
    let list_hashes := List.map Operation_list_hash.compute hashes in
    Operation_list_list_hash.compute_path list_hashes.
  
  Definition operation_hashes (function_parameter : t)
    : Z ->
      Lwt.t
        (Tezos_shell.Store.Block.Operation_hashes.value *
          Tezos_base__TzPervasives.Operation_list_list_hash.path) :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    fun i =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if
          orb (OCaml.Stdlib.lt i 0)
            (OCaml.Stdlib.le (validation_passes (shell header)) i) then
          OCaml.Stdlib.invalid_arg "State.Block.operations" % string
        else
          tt in
      Shared.use (block_store chain_state)
        (fun store =>
          op_gtgteq
            (Lwt_list.map_p
              (fun n =>
                op_gtpipeeq
                  (Store.Block.Operation_hashes.read_opt (store, hash) n)
                  (Option.unopt_assert Stdlib.__POS__))
              (op_minusminus 0 (Z.sub (validation_passes (shell header)) 1)))
            (fun hashes =>
              let path := compute_operation_path hashes in
              Lwt._return ((List.nth hashes i), (path i)))).
  
  Definition all_operation_hashes (function_parameter : t)
    : Lwt.t (list Tezos_shell.Store.Block.Operation_hashes.value) :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    Shared.use (block_store chain_state)
      (fun store =>
        Lwt_list.map_p
          (fun i =>
            op_gtpipeeq (Store.Block.Operation_hashes.read_opt (store, hash) i)
              (Option.unopt_assert Stdlib.__POS__))
          (op_minusminus 0 (Z.sub (validation_passes (shell header)) 1))).
  
  Definition operations (function_parameter : t)
    : Tezos_shell.Store.Block.Operations.key ->
      Lwt.t
        (Tezos_shell.Store.Block.Operations.value *
          Tezos_base__TzPervasives.Operation_list_list_hash.path) :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    fun i =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if
          orb (OCaml.Stdlib.lt i 0)
            (OCaml.Stdlib.le (validation_passes (shell header)) i) then
          OCaml.Stdlib.invalid_arg "State.Block.operations" % string
        else
          tt in
      Shared.use (block_store chain_state)
        (fun store =>
          op_gtgteq
            (Lwt_list.map_p
              (fun n =>
                op_gtpipeeq
                  (Store.Block.Operation_hashes.read_opt (store, hash) n)
                  (Option.unopt_assert Stdlib.__POS__))
              (op_minusminus 0 (Z.sub (validation_passes (shell header)) 1)))
            (fun hashes =>
              let path := compute_operation_path hashes in
              op_gtgteq
                (op_gtpipeeq (Store.Block.Operations.read_opt (store, hash) i)
                  (Option.unopt_assert Stdlib.__POS__))
                (fun ops => Lwt._return (ops, (path i))))).
  
  Definition operations_metadata (function_parameter : t)
    : Tezos_shell.Store.Block.Operations_metadata.key ->
      Lwt.t Tezos_shell.Store.Block.Operations_metadata.value :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    fun i =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if
          orb (OCaml.Stdlib.lt i 0)
            (OCaml.Stdlib.le (validation_passes (shell header)) i) then
          OCaml.Stdlib.invalid_arg "State.Block.operations_metadata" % string
        else
          tt in
      Shared.use (block_store chain_state)
        (fun store =>
          op_gtpipeeq (Store.Block.Operations_metadata.read_opt (store, hash) i)
            (Option.unopt_assert Stdlib.__POS__)).
  
  Definition all_operations (function_parameter : t)
    : Lwt.t (list Tezos_shell.Store.Block.Operations.value) :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    Shared.use (block_store chain_state)
      (fun store =>
        Lwt_list.map_p
          (fun i =>
            op_gtpipeeq (Store.Block.Operations.read_opt (store, hash) i)
              (Option.unopt_assert Stdlib.__POS__))
          (op_minusminus 0 (Z.sub (validation_passes (shell header)) 1))).
  
  Definition all_operations_metadata (function_parameter : t)
    : Lwt.t (list Tezos_shell.Store.Block.Operations_metadata.value) :=
    let '{| chain_state := chain_state; hash := hash; header := header |} :=
      function_parameter in
    Shared.use (block_store chain_state)
      (fun store =>
        Lwt_list.map_p
          (fun i =>
            op_gtpipeeq
              (Store.Block.Operations_metadata.read_opt (store, hash) i)
              (Option.unopt_assert Stdlib.__POS__))
          (op_minusminus 0 (Z.sub (validation_passes (shell header)) 1))).
  
  Definition context_exn (function_parameter : t)
    : Lwt.t Tezos_storage.Context.context :=
    let '{| chain_state := chain_state; hash := hash |} := function_parameter in
    op_gtgteq
      (op_gtpipeeq
        (Shared.use (block_store chain_state)
          (fun block_store => Store.Block.Contents.read_opt (block_store, hash)))
        (Option.unopt_assert Stdlib.__POS__))
      (fun function_parameter =>
        let '{| context := commit |} := function_parameter in
        Shared.use (context_index chain_state)
          (fun context_index => Context.checkout_exn context_index commit)).
  
  Definition context_opt (function_parameter : t)
    : Lwt.t (option Tezos_storage.Context.context) :=
    let '{| chain_state := chain_state; hash := hash |} := function_parameter in
    op_gtgteq
      (op_gtpipeeq
        (Shared.use (block_store chain_state)
          (fun block_store => Store.Block.Contents.read_opt (block_store, hash)))
        (Option.unopt_assert Stdlib.__POS__))
      (fun function_parameter =>
        let '{| context := commit |} := function_parameter in
        Shared.use (context_index chain_state)
          (fun context_index => Context.checkout context_index commit)).
  
  Definition context (block : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
    op_gtgteq (context_opt block)
      (fun function_parameter =>
        match function_parameter with
        | Some context => _return context
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "State.Block.context failed to checkout context" % string
                CamlinternalFormatBasics.End_of_format)
              "State.Block.context failed to checkout context" % string)
        end).
  
  Definition protocol_hash (block : t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Protocol_hash.t) :=
    op_gtgteqquestion (context block)
      (fun context => op_gtgteq (Context.get_protocol context) _return).
  
  Definition protocol_hash_exn (block : t)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
    op_gtgteq (context_exn block) (fun context => Context.get_protocol context).
  
  Definition protocol_level (block : t) : Z :=
    proto_level (shell (header block)).
  
  Definition test_chain (block : t)
    : Lwt.t (Tezos_base__TzPervasives.Test_chain_status.t * (option t)) :=
    op_gtgteq (context_exn block)
      (fun context =>
        op_gtgteq (Context.get_test_chain context)
          (fun status =>
            let lookup_testchain
              (genesis : Tezos_base__TzPervasives.Block_hash.t)
              : Lwt.t
                (Tezos_base__TzPervasives.Test_chain_status.t * (option t)) :=
              let chain_id := Context.compute_testchain_chain_id genesis in
              op_gtgteq
                (Shared.use (global_data (global_state (chain_state block)))
                  (fun global_data =>
                    Store.Forking_block_hash.read_opt (global_store global_data)
                      chain_id))
                (fun function_parameter =>
                  match function_parameter with
                  | Some forking_block_hash =>
                    op_gtgteq (read_opt (chain_state block) forking_block_hash)
                      (fun forking_block => Lwt._return (status, forking_block))
                  | None => Lwt._return (status, None)
                  end) in
            match status with
            |
              Tezos_base__TzPervasives.Test_chain_status.Running {|
                genesis := genesis |} => lookup_testchain genesis
            | Tezos_base__TzPervasives.Test_chain_status.Forking _ =>
              Lwt._return (status, (Some block))
            | Tezos_base__TzPervasives.Test_chain_status.Not_running =>
              Lwt._return (status, None)
            end)).
  
  Definition known
    (chain_state : chain_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t bool :=
    Shared.use (block_store chain_state)
      (fun store =>
        op_gtgteq (Header.known (store, hash))
          (fun known =>
            if known then
              Lwt.return_true
            else
              Store.Block.Invalid_block.known store hash)).
  
  Definition block_validity
    (chain_state : chain_state) (block : Tezos_base__TzPervasives.Block_hash.t)
    : Lwt.t Tezos_base__TzPervasives.Block_locator.validity :=
    op_gtgteq (known chain_state block)
      (fun function_parameter =>
        match function_parameter with
        | false =>
          if Block_hash.equal block (Chain.faked_genesis_hash chain_state) then
            Lwt._return Tezos_base__TzPervasives.Block_locator.Known_valid
          else
            Lwt._return Tezos_base__TzPervasives.Block_locator.Unknown
        | true =>
          op_gtgteq (known_invalid chain_state block)
            (fun function_parameter =>
              match function_parameter with
              | true =>
                Lwt._return Tezos_base__TzPervasives.Block_locator.Known_invalid
              | false =>
                Lwt._return Tezos_base__TzPervasives.Block_locator.Known_valid
              end)
        end).
  
  Definition known_ancestor
    (chain_state : chain_state)
    (locator : Tezos_base__TzPervasives.Block_locator.t)
    : Lwt.t (option Tezos_base__TzPervasives.Block_locator.t) :=
    op_gtgteq
      (Shared.use (global_data (global_state chain_state))
        (fun function_parameter =>
          let '{| global_store := global_store |} := function_parameter in
          op_gtpipeeq (Store.Configuration.History_mode.read_opt global_store)
            (Option.unopt_assert Stdlib.__POS__)))
      (fun history_mode =>
        op_gtgteq
          (Block_locator.unknown_prefix (block_validity chain_state) locator)
          (fun function_parameter =>
            match function_parameter with
            |
              (Tezos_base__TzPervasives.Block_locator.Known_valid,
                prefix_locator) => Lwt.return_some prefix_locator
            | (Tezos_base__TzPervasives.Block_locator.Known_invalid, _) =>
              Lwt.return_none
            | (Tezos_base__TzPervasives.Block_locator.Unknown, _) =>
              match history_mode with
              | Tezos_shell_services.History_mode.Archive => Lwt.return_none
              |
                Tezos_shell_services.History_mode.Rolling |
                  Tezos_shell_services.History_mode.Full =>
                Lwt.return_some locator
              end
            end)).
  
  Definition get_rpc_directory (function_parameter : t)
    : Lwt.t (option (Tezos_base__TzPervasives.RPC_directory.t block)) :=
    let '{| chain_state := chain_state |} as block := function_parameter in
    op_gtgteq (read_opt chain_state (predecessor (shell (header block))))
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt.return_none
        | Some pred => Lwt.return_none
        | Some pred =>
          op_gtgteq (Chain.save_point chain_state)
            (fun function_parameter =>
              let '(save_point_level, _) := function_parameter in
              op_gtgteq
                (if op_lt (level pred) save_point_level then
                  Chain.get_level_indexed_protocol chain_state (header pred)
                else
                  protocol_hash_exn pred)
                (fun protocol =>
                  match
                    Protocol_hash.Table.find_opt
                      (block_rpc_directories chain_state) protocol with
                  | None => Lwt.return_none
                  | Some map =>
                    op_gtgteq (protocol_hash_exn block)
                      (fun next_protocol =>
                        Lwt._return
                          (Protocol_hash.Map.find_opt next_protocol map))
                  end))
        end).
  
  Definition set_rpc_directory (function_parameter : t)
    : (Tezos_base__TzPervasives.RPC_directory.t block) -> Lwt.t unit :=
    let '{| chain_state := chain_state |} as block := function_parameter in
    fun dir =>
      op_gtgteq
        (op_gtpipeeq (read_opt chain_state (predecessor (shell (header block))))
          (Option.unopt_assert Stdlib.__POS__))
        (fun pred =>
          op_gtgteq (protocol_hash_exn block)
            (fun next_protocol =>
              op_gtgteq (Chain.save_point chain_state)
                (fun function_parameter =>
                  let '(save_point_level, _) := function_parameter in
                  op_gtgteq
                    (if op_lt (level pred) save_point_level then
                      Chain.get_level_indexed_protocol chain_state (header pred)
                    else
                      protocol_hash_exn pred)
                    (fun protocol =>
                      let map :=
                        Option.unopt Protocol_hash.Map.empty
                          (Protocol_hash.Table.find_opt
                            (block_rpc_directories chain_state) protocol) in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Protocol_hash.Table.replace
                          (block_rpc_directories chain_state) protocol
                          (Protocol_hash.Map.add next_protocol dir map) in
                      Lwt.return_unit)))).
  
  Definition get_header_rpc_directory
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t)
    : Lwt.t
      (option
        (Tezos_base__TzPervasives.RPC_directory.t
          (chain_state * Tezos_base__TzPervasives.Block_hash.t *
            Tezos_base__TzPervasives.Block_header.t))) :=
    Shared.use (block_store chain_state)
      (fun block_store =>
        op_gtgteq
          (Header.read_opt
            (block_store, (predecessor (Block_header.shell header))))
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.return_none
            | Some pred => Lwt.return_none
            | Some pred =>
              op_gtgteq (Chain.get_level_indexed_protocol chain_state header)
                (fun protocol =>
                  match
                    Protocol_hash.Table.find_opt
                      (header_rpc_directories chain_state) protocol with
                  | None => Lwt.return_none
                  | Some map =>
                    op_gtgteq
                      (Chain.get_level_indexed_protocol chain_state pred)
                      (fun next_protocol =>
                        Lwt._return
                          (Protocol_hash.Map.find_opt next_protocol map))
                  end)
            end)).
  
  Definition set_header_rpc_directory
    (chain_state : chain_state)
    (header : Tezos_base__TzPervasives.Block_header.t)
    (dir :
      Tezos_base__TzPervasives.RPC_directory.t
        (chain_state * Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Block_header.t)) : Lwt.t unit :=
    Shared.use (block_store chain_state)
      (fun block_store =>
        op_gtgteq
          (Header.read_opt
            (block_store, (predecessor (Block_header.shell header))))
          (fun function_parameter =>
            match function_parameter with
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Some pred =>
              op_gtgteq (Chain.get_level_indexed_protocol chain_state header)
                (fun next_protocol =>
                  op_gtgteq (Chain.get_level_indexed_protocol chain_state pred)
                    (fun protocol =>
                      let map :=
                        Option.unopt Protocol_hash.Map.empty
                          (Protocol_hash.Table.find_opt
                            (header_rpc_directories chain_state) protocol) in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Protocol_hash.Table.replace
                          (header_rpc_directories chain_state) protocol
                          (Protocol_hash.Map.add next_protocol dir map) in
                      Lwt.return_unit))
            end)).
End Block.

Definition watcher (state : global_state)
  : (Lwt_stream.t block) * Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  Lwt_watcher.create_stream (block_watcher state).

Definition read_block (function_parameter : global_state)
  : Tezos_base__TzPervasives.Block_hash.t -> Lwt.t (option Block.t) :=
  let '{| global_data := global_data |} := function_parameter in
  fun hash =>
    Shared.use global_data
      (fun function_parameter =>
        let '{| chains := chains |} := function_parameter in
        Chain_id.Table.fold
          (fun _chain_id =>
            fun chain_state =>
              fun acc =>
                op_gtgteq acc
                  (fun function_parameter =>
                    match function_parameter with
                    | Some _ => acc
                    | None =>
                      op_gtgteq (Block.read_opt chain_state hash)
                        (fun function_parameter =>
                          match function_parameter with
                          | None => acc
                          | Some block => Lwt.return_some block
                          end)
                    end)) chains Lwt.return_none).

Definition read_block_exn
  (t : global_state) (hash : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t Block.t :=
  op_gtgteq (read_block t hash)
    (fun function_parameter =>
      match function_parameter with
      | None => Lwt.fail OCaml.Not_found
      | Some b => Lwt._return b
      end).

Definition update_testchain (block : block) (testchain_state : chain_state)
  : Lwt.t unit :=
  update_chain_data (chain_state block)
    (fun function_parameter =>
      let '_ := function_parameter in
      fun chain_data =>
        Lwt._return
          ((Some
            (* ❌ Record substitution not handled *)
            record_substitution), tt)).

Definition fork_testchain
  (block : block) (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (genesis_hash : Tezos_base__TzPervasives.Block_hash.t)
  (genesis_header : Tezos_base__TzPervasives.Block_header.t)
  (protocol : Tezos_base__TzPervasives.Protocol_hash.t)
  (expiration : Tezos_base__TzPervasives.Time.Protocol.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
  Shared.use (global_data (global_state (chain_state block)))
    (fun data =>
      let chain_store := Store.Chain.get (global_store data) chain_id in
      let block_store := Store.Block.get chain_store in
      op_gtgteq
        (Store.Block.Contents.store (block_store, genesis_hash)
          {| Store.Block.header := genesis_header;
            Store.Block.message := Some "Genesis" % string;
            Store.Block.max_operations_ttl := 0;
            Store.Block.last_allowed_fork_level :=
              (* ❌ Constant of type int32 is converted to int *)
              0; Store.Block.context := context (shell genesis_header);
            Store.Block.metadata := Stdlib.Bytes.create 0 |})
        (fun function_parameter =>
          let 'tt := function_parameter in
          let genesis :=
            {| time := timestamp (shell genesis_header); block := genesis_hash;
              protocol := protocol |} in
          op_gtgteq
            (Chain.locked_create (global_state (chain_state block)) data
              (Some expiration) None chain_id genesis genesis_header)
            (fun testchain_state =>
              op_gtgteq
                (Store.Chain.Protocol_info.store chain_store
                  (proto_level (shell genesis_header))
                  (protocol, (level (shell genesis_header))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq (update_testchain block testchain_state)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return testchain_state))))).

Definition best_known_head_for_checkpoint
  (chain_state : chain_state)
  (checkpoint : Tezos_base__TzPervasives.Block_header.t) : Lwt.t block :=
  Shared.use (block_store chain_state)
    (fun store =>
      Shared.use (chain_data chain_state)
        (fun data =>
          let head_hash := hash (current_head (data data)) in
          let head_header := header (current_head (data data)) in
          op_gtgteq
            (Locked_block.is_valid_for_checkpoint store head_hash head_header
              checkpoint)
            (fun valid =>
              if valid then
                Lwt._return (current_head (data data))
              else
                let find_valid_predecessor
                  (hash : Tezos_base__TzPervasives.Block_hash.t)
                  : Lwt.t block :=
                  op_gtgteq
                    (op_gtpipeeq (Header.read_opt (store, hash))
                      (Option.unopt_assert Stdlib.__POS__))
                    (fun header =>
                      if op_lt (level (shell header)) (level (shell checkpoint))
                        then
                        Lwt._return
                          {| chain_state := chain_state; hash := hash;
                            header := header |}
                      else
                        op_gtgteq
                          (op_gtpipeeq
                            (predecessor_n None store hash
                              (Z.add 1
                                (apply Int32.to_int
                                  (Int32.sub (level (shell header))
                                    (level (shell checkpoint))))))
                            (Option.unopt_assert Stdlib.__POS__))
                          (fun pred =>
                            op_gtgteq
                              (op_gtpipeeq (Header.read_opt (store, pred))
                                (Option.unopt_assert Stdlib.__POS__))
                              (fun pred_header =>
                                Lwt._return
                                  {| chain_state := chain_state; hash := pred;
                                    header := pred_header |}))) in
                op_gtgteq
                  (Store.Chain_data.Known_heads.read_all (chain_data_store data))
                  (fun heads =>
                    op_gtgteq
                      (op_gtpipeeq
                        (Header.read_opt (store, (block (genesis chain_state))))
                        (Option.unopt_assert Stdlib.__POS__))
                      (fun genesis_header =>
                        let genesis :=
                          {| chain_state := chain_state;
                            hash := block (genesis chain_state);
                            header := genesis_header |} in
                        Block_hash.Set.fold
                          (fun head =>
                            fun best =>
                              let valid_predecessor :=
                                find_valid_predecessor head in
                              op_gtgteq best
                                (fun best =>
                                  op_gtgteq valid_predecessor
                                    (fun pred =>
                                      if
                                        op_gt (fitness (shell (header pred)))
                                          (fitness (shell (header best))) then
                                        Lwt._return pred
                                      else
                                        Lwt._return best))) heads
                          (Lwt._return genesis)))))).

Module Protocol.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition known
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t bool :=
    Shared.use (protocol_store global_state)
      (fun store => Store.Protocol.Contents.known store hash).
  
  Definition read
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Protocol.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Store.Protocol.Contents.read store hash).
  
  Definition read_opt
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t (option Tezos_base__TzPervasives.Protocol.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Store.Protocol.Contents.read_opt store hash).
  
  Definition read_raw
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Store.Protocol.RawContents.read (store, hash)).
  
  Definition read_raw_opt
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t)
    : Lwt.t (option Stdlib.Bytes.t) :=
    Shared.use (protocol_store global_state)
      (fun store => Store.Protocol.RawContents.read_opt (store, hash)).
  
  Definition store
    (global_state : global_state) (p : Tezos_base__TzPervasives.Protocol.t)
    : Lwt.t (option Tezos_crypto.Protocol_hash.t) :=
    let bytes := Protocol.to_bytes p in
    let hash := Protocol.hash_raw string in
    Shared.use (protocol_store global_state)
      (fun store =>
        op_gtgteq (Store.Protocol.Contents.known store hash)
          (fun known =>
            if known then
              Lwt.return_none
            else
              op_gtgteq (Store.Protocol.RawContents.store (store, hash) string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Lwt_watcher.notify (protocol_watcher global_state) hash in
                  Lwt.return_some hash))).
  
  Definition remove
    (global_state : global_state)
    (hash : Tezos_base__TzPervasives.Protocol_hash.t) : Lwt.t bool :=
    Shared.use (protocol_store global_state)
      (fun store =>
        op_gtgteq (Store.Protocol.Contents.known store hash)
          (fun known =>
            if known then
              Lwt.return_false
            else
              op_gtgteq (Store.Protocol.Contents.remove store hash)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt.return_true))).
  
  Definition list (global_state : global_state)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.Set.t :=
    Shared.use (protocol_store global_state)
      (fun store =>
        Store.Protocol.Contents.fold_keys store Protocol_hash.Set.empty
          (fun x => fun acc => Lwt._return (Protocol_hash.Set.add x acc))).
  
  Definition watcher (state : global_state)
    : (Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
      Tezos_base__TzPervasives.Lwt_watcher.stopper :=
    Lwt_watcher.create_stream (protocol_watcher state).
End Protocol.

Module Current_mempool.
  Definition set
    (chain_state : chain_state) (head : Tezos_base__TzPervasives.Block_hash.t)
    (mempool : Tezos_base__TzPervasives.Mempool.t) : Lwt.t unit :=
    update_chain_data chain_state
      (fun _chain_data_store =>
        fun data =>
          if Block_hash.equal head (Block.hash (current_head data)) then
            Lwt._return
              ((Some
                (* ❌ Record substitution not handled *)
                record_substitution), tt)
          else
            Lwt._return (None, tt)).
  
  Definition get (chain_state : chain_state)
    : Lwt.t
      (Tezos_base__TzPervasives.Block_header.t *
        Tezos_base__TzPervasives.Mempool.t) :=
    read_chain_data chain_state
      (fun _chain_data_store =>
        fun data =>
          Lwt._return
            ((Block.header (current_head data)), (current_mempool data))).
End Current_mempool.

Definition may_create_chain
  (commit_genesis :
    Tezos_base__TzPervasives.Chain_id.t ->
      Tezos_base__TzPervasives.Time.Protocol.t ->
        Tezos_base__TzPervasives.Protocol_hash.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t))
  (state : global_state)
  (chain_id : Tezos_base__TzPervasives.Chain_id.Table.key)
  (genesis : Chain.genesis)
  : Lwt.t (Tezos_base__TzPervasives.tzresult chain_state) :=
  op_gtgteq (Chain.get state chain_id)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok chain => _return chain
      | Stdlib.Error _ =>
        Chain.create state (Some true) commit_genesis genesis chain_id
      end).

Definition read
  (global_store : Tezos_shell.Store.t)
  (context_index : Tezos_storage.Context.index)
  (main_chain : Tezos_base__TzPervasives.Chain_id.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult global_state) :=
  let global_data :=
    {| chains := Chain_id.Table.create 17; global_store := global_store;
      context_index := context_index |} in
  let state :=
    {| global_data := Shared.create global_data;
      protocol_store := apply Shared.create (Store.Protocol.get global_store);
      main_chain := main_chain; protocol_watcher := Lwt_watcher.create_input tt;
      block_watcher := Lwt_watcher.create_input tt |} in
  op_gtgteqquestion (Chain.read_all state)
    (fun function_parameter =>
      let 'tt := function_parameter in
      _return state).

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition init
  (patch_context :
    option
      (Tezos_storage.Context.context -> Lwt.t Tezos_storage.Context.context))
  (commit_genesis :
    option
      (Tezos_base__TzPervasives.Chain_id.t ->
        Tezos_base__TzPervasives.Time.Protocol.t ->
          Tezos_base__TzPervasives.Protocol_hash.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult Tezos_crypto.Context_hash.t)))
  (op_staroptstar : option int64)
  : (option int64) ->
    string ->
      string ->
        (option Tezos_shell_services.History_mode.t) ->
          Chain.genesis ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (global_state * chain_state * Tezos_storage.Context.index *
                  Tezos_shell_services.History_mode.t)) :=
  let store_mapsize :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int64 is converted to int *)
      40960000000
    end in
  fun op_staroptstar =>
    let context_mapsize :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None =>
        (* ❌ Constant of type int64 is converted to int *)
        409600000000
      end in
    fun store_root =>
      fun context_root =>
        fun history_mode =>
          fun genesis =>
            op_gtgteqquestion (Store.init None (Some store_mapsize) store_root)
              (fun global_store =>
                op_gtgteq
                  match commit_genesis with
                  | Some commit_genesis =>
                    op_gtgteq
                      (Context.init patch_context (Some context_mapsize)
                        (Some true) context_root)
                      (fun context_index =>
                        Lwt._return (context_index, commit_genesis))
                  | None =>
                    op_gtgteq
                      (Context.init patch_context (Some context_mapsize)
                        (Some false) context_root)
                      (fun context_index =>
                        let commit_genesis
                          (chain_id : Tezos_base__TzPervasives.Chain_id.t) (time
                          : Tezos_base__TzPervasives.Time.Protocol.t) (protocol
                          : Tezos_base__TzPervasives.Protocol_hash.t)
                          : Lwt.t
                            (Tezos_base__TzPervasives.tzresult
                              Tezos_base__TzPervasives.Context_hash.t) :=
                          op_gtgteq
                            (Context.commit_genesis context_index chain_id time
                              protocol) (fun res => _return res) in
                        Lwt._return (context_index, commit_genesis))
                  end
                  (fun function_parameter =>
                    let '(context_index, commit_genesis) := function_parameter
                      in
                    let chain_id := Chain_id.of_block_hash (Chain.block genesis)
                      in
                    op_gtgteqquestion (read global_store context_index chain_id)
                      (fun state =>
                        op_gtgteqquestion
                          (may_create_chain commit_genesis state chain_id
                            genesis)
                          (fun main_chain_state =>
                            op_gtgteqquestion
                              (op_gtgteq
                                (Store.Configuration.History_mode.read_opt
                                  global_store)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | None =>
                                    let mode :=
                                      Option.unopt
                                        Tezos_shell_services.History_mode.Full
                                        history_mode in
                                    op_gtgteq
                                      (Store.Configuration.History_mode.store
                                        global_store mode)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        _return mode)
                                  | Some previous_history_mode =>
                                    match history_mode with
                                    | None => _return previous_history_mode
                                    | Some history_mode =>
                                      if
                                        nequiv_decb history_mode
                                          previous_history_mode then
                                        fail
                                          (Tezos_base__TzPervasives.Incorrect_history_mode_switch
                                            {|
                                              previous_mode :=
                                                previous_history_mode;
                                              next_mode := history_mode |})
                                      else
                                        _return history_mode
                                    end
                                  end))
                              (fun history_mode =>
                                _return
                                  (state, main_chain_state, context_index,
                                    history_mode)))))).

Definition history_mode (function_parameter : global_state)
  : Lwt.t Tezos_shell_services.History_mode.t :=
  let '{| global_data := global_data |} := function_parameter in
  Shared.use global_data
    (fun function_parameter =>
      let '{| global_store := global_store |} := function_parameter in
      op_gtpipeeq (Store.Configuration.History_mode.read_opt global_store)
        (Option.unopt_assert Stdlib.__POS__)).

Definition close (function_parameter : global_state) : Lwt.t unit :=
  let '{| global_data := global_data |} := function_parameter in
  Shared.use global_data
    (fun function_parameter =>
      let '{| global_store := global_store |} := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Store.close global_store in
      Lwt.return_unit).

src/lib_shell/store.ml 31 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Raw_store.t

type global_store = t

(**************************************************************************
 * Configuration setup we need to save in order to avoid wrong changes.
 **************************************************************************)

module Configuration = struct
  module History_mode =
    Store_helpers.Make_single_store
      (Raw_store)
      (struct
        let name = ["history_mode"]
      end)
      (Store_helpers.Make_value (History_mode))
end

(**************************************************************************
 * Net store under "chain/"
 **************************************************************************)

module Chain = struct
  type store = global_store * Chain_id.t

  let get s id = (s, id)

  module Indexed_store =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Raw_store)
         (struct
           let name = ["chain"]
         end))
         (Chain_id)

  let destroy = Indexed_store.remove_all

  let list t =
    Indexed_store.fold_indexes t ~init:[] ~f:(fun h acc ->
        Lwt.return (h :: acc))

  module Genesis_hash =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "hash"]
      end)
      (Store_helpers.Make_value (Block_hash))

  module Genesis_time =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "time"]
      end)
      (Store_helpers.Make_value (Time.Protocol))

  module Genesis_protocol =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "protocol"]
      end)
      (Store_helpers.Make_value (Protocol_hash))

  module Genesis_test_protocol =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["genesis"; "test_protocol"]
      end)
      (Store_helpers.Make_value (Protocol_hash))

  module Expiration =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["expiration"]
      end)
      (Store_helpers.Make_value (Time.Protocol))

  module Allow_forked_chain = Indexed_store.Make_set (struct
    let name = ["allow_forked_chain"]
  end)

  module Protocol_index =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Indexed_store.Store)
         (struct
           let name = ["protocol"]
         end))
         (Store_helpers.Integer_index)

  module Protocol_info =
    Protocol_index.Make_map
      (struct
        let name = ["info"]
      end)
      (Store_helpers.Make_value (struct
        type t = Protocol_hash.t * Int32.t

        let encoding =
          let open Data_encoding in
          tup2 Protocol_hash.encoding int32
      end))
end

(**************************************************************************
 * Temporary test chain forking block store under "forking_block_hash/"
 **************************************************************************)

module Forking_block_hash =
  Store_helpers.Make_map
    (Store_helpers.Make_substore
       (Raw_store)
       (struct
         let name = ["forking_block_hash"]
       end))
       (Chain_id)
    (Store_helpers.Make_value (Block_hash))

(**************************************************************************
 * Block_header store under "chain/<id>/blocks/"
 **************************************************************************)

module Block = struct
  type store = Chain.store

  let get x = x

  module Indexed_store =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Chain.Indexed_store.Store)
         (struct
           let name = ["blocks"]
         end))
         (Block_hash)

  type contents = {
    header : Block_header.t;
    message : string option;
    max_operations_ttl : int;
    last_allowed_fork_level : Int32.t;
    context : Context_hash.t;
    metadata : Bytes.t;
  }

  module Contents =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Make_value (struct
        type t = contents

        let encoding =
          let open Data_encoding in
          conv
            (fun { header;
                   message;
                   max_operations_ttl;
                   last_allowed_fork_level;
                   context;
                   metadata } ->
              ( message,
                max_operations_ttl,
                last_allowed_fork_level,
                context,
                metadata,
                header ))
            (fun ( message,
                   max_operations_ttl,
                   last_allowed_fork_level,
                   context,
                   metadata,
                   header ) ->
              {
                header;
                message;
                max_operations_ttl;
                last_allowed_fork_level;
                context;
                metadata;
              })
            (obj6
               (opt "message" string)
               (req "max_operations_ttl" uint16)
               (req "last_allowed_fork_level" int32)
               (req "context" Context_hash.encoding)
               (req "metadata" bytes)
               (req "header" Block_header.encoding))
      end))

  type pruned_contents = {header : Block_header.t}

  module Pruned_contents =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["pruned_contents"]
      end)
      (Store_helpers.Make_value (struct
        type t = pruned_contents

        let encoding =
          let open Data_encoding in
          conv
            (fun {header} -> header)
            (fun header -> {header})
            (obj1 (req "header" Block_header.encoding))
      end))

  module Operations_index =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Indexed_store.Store)
         (struct
           let name = ["operations"]
         end))
         (Store_helpers.Integer_index)

  module Operation_hashes =
    Operations_index.Make_map
      (struct
        let name = ["hashes"]
      end)
      (Store_helpers.Make_value (struct
        type t = Operation_hash.t list

        let encoding = Data_encoding.list Operation_hash.encoding
      end))

  module Operations =
    Operations_index.Make_map
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Make_value (struct
        type t = Operation.t list

        let encoding = Data_encoding.(list (dynamic_size Operation.encoding))
      end))

  module Operations_metadata =
    Operations_index.Make_map
      (struct
        let name = ["metadata"]
      end)
      (Store_helpers.Make_value (struct
        type t = Bytes.t list

        let encoding = Data_encoding.(list bytes)
      end))

  type invalid_block = {level : int32; errors : Error_monad.error list}

  module Invalid_block =
    Store_helpers.Make_map
      (Store_helpers.Make_substore
         (Chain.Indexed_store.Store)
         (struct
           let name = ["invalid_blocks"]
         end))
         (Block_hash)
      (Store_helpers.Make_value (struct
        type t = invalid_block

        let encoding =
          let open Data_encoding in
          conv
            (fun {level; errors} -> (level, errors))
            (fun (level, errors) -> {level; errors})
            (tup2 int32 (list Error_monad.error_encoding))
      end))

  let register s =
    Base58.register_resolver Block_hash.b58check_encoding (fun str ->
        let pstr = Block_hash.prefix_path str in
        Chain.Indexed_store.fold_indexes s ~init:[] ~f:(fun chain acc ->
            Indexed_store.resolve_index (s, chain) pstr
            >>= fun l -> Lwt.return (List.rev_append l acc)))

  module Predecessors =
    Store_helpers.Make_map
      (Store_helpers.Make_substore
         (Indexed_store.Store)
         (struct
           let name = ["predecessors"]
         end))
         (Store_helpers.Integer_index)
      (Store_helpers.Make_value (Block_hash))
end

(**************************************************************************
 * Blockchain data
 **************************************************************************)

module Chain_data = struct
  type store = Chain.store

  let get s = s

  module Known_heads =
    Store_helpers.Make_buffered_set
      (Store_helpers.Make_substore
         (Chain.Indexed_store.Store)
         (struct
           let name = ["known_heads"]
         end))
         (Block_hash)
      (Block_hash.Set)

  module Current_head =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["current_head"]
      end)
      (Store_helpers.Make_value (Block_hash))

  module In_main_branch =
    Store_helpers.Make_single_store
      (Block.Indexed_store.Store)
      (struct
        let name = ["in_chain"]
      end)
      (Store_helpers.Make_value (Block_hash))

  (* successor *)

  module Checkpoint =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["checkpoint"]
      end)
      (Store_helpers.Make_value (Block_header))

  module Save_point =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["save_point"]
      end)
      (Store_helpers.Make_value (struct
        type t = Int32.t * Block_hash.t

        let encoding =
          let open Data_encoding in
          tup2 int32 Block_hash.encoding
      end))

  module Caboose =
    Store_helpers.Make_single_store
      (Chain.Indexed_store.Store)
      (struct
        let name = ["caboose"]
      end)
      (Store_helpers.Make_value (struct
        type t = Int32.t * Block_hash.t

        let encoding =
          let open Data_encoding in
          tup2 int32 Block_hash.encoding
      end))
end

(**************************************************************************
 * Protocol store under "protocols/"
 **************************************************************************)

module Protocol = struct
  type store = global_store

  let get x = x

  module Indexed_store =
    Store_helpers.Make_indexed_substore
      (Store_helpers.Make_substore
         (Raw_store)
         (struct
           let name = ["protocols"]
         end))
         (Protocol_hash)

  module Contents =
    Indexed_store.Make_map
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Make_value (Protocol))

  module RawContents =
    Store_helpers.Make_single_store
      (Indexed_store.Store)
      (struct
        let name = ["contents"]
      end)
      (Store_helpers.Raw_value)

  let register s =
    Base58.register_resolver Protocol_hash.b58check_encoding (fun str ->
        let pstr = Protocol_hash.prefix_path str in
        Indexed_store.resolve_index s pstr)
end

let init ?readonly ?mapsize dir =
  Raw_store.init ?readonly ?mapsize dir
  >>=? fun s -> Block.register s ; Protocol.register s ; return s

let close = Raw_store.close

let open_with_atomic_rw = Raw_store.open_with_atomic_rw

let with_atomic_rw = Raw_store.with_atomic_rw
src/lib_shell/store.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_storage.Raw_store.t.

Definition global_store := t.

Module Configuration.
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Configuration.

Module Chain.
  Definition store := global_store * Tezos_base__TzPervasives.Chain_id.t.
  
  Definition get {A B : Type} (s : A) (id : B) : A * B := (s, id).
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition destroy : Indexed_store.t -> Indexed_store.key -> Lwt.t unit :=
    Indexed_store.remove_all.
  
  Definition list (t : Indexed_store.t) : Lwt.t (list Indexed_store.key) :=
    Indexed_store.fold_indexes t []
      (fun h => fun acc => Lwt._return (cons h acc)).
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Chain.

(* ❌ Applications of functors are not handled. *)
functor_application

Module Block.
  Definition store := Chain.store.
  
  Definition get {A : Type} (x : A) : A := x.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Record contents := {
    header : Tezos_base__TzPervasives.Block_header.t;
    message : option string;
    max_operations_ttl : Z;
    last_allowed_fork_level : Stdlib.Int32.t;
    context : Tezos_base__TzPervasives.Context_hash.t;
    metadata : Stdlib.Bytes.t }.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Record pruned_contents := {
    header : Tezos_base__TzPervasives.Block_header.t }.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Record invalid_block := {
    level : int32;
    errors : list Tezos_base__TzPervasives.Error_monad.error }.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition register (s : Chain.Indexed_store.t) : unit :=
    Base58.register_resolver Block_hash.b58check_encoding
      (fun str =>
        let pstr := Block_hash.prefix_path str in
        Chain.Indexed_store.fold_indexes s []
          (fun chain =>
            fun acc =>
              op_gtgteq (Indexed_store.resolve_index (s, chain) pstr)
                (fun l => Lwt._return (List.rev_append l acc)))).
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Block.

Module Chain_data.
  Definition store := Chain.store.
  
  Definition get {A : Type} (s : A) : A := s.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Chain_data.

Module Protocol.
  Definition store := global_store.
  
  Definition get {A : Type} (x : A) : A := x.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition register (s : Indexed_store.t) : unit :=
    Base58.register_resolver Protocol_hash.b58check_encoding
      (fun str =>
        let pstr := Protocol_hash.prefix_path str in
        Indexed_store.resolve_index s pstr).
End Protocol.

Definition init (readonly : option bool) (mapsize : option int64) (dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Raw_store.t) :=
  op_gtgteqquestion (Raw_store.init readonly mapsize dir)
    (fun s =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Block.register s in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Protocol.register s in
      _return s).

Definition close : Tezos_storage.Raw_store.t -> unit := Raw_store.close.

Definition open_with_atomic_rw {A : Type}
  : (option int64) ->
    string ->
      (Tezos_storage.Raw_store.t ->
        Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A)) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  Raw_store.open_with_atomic_rw.

Definition with_atomic_rw {A : Type}
  : Tezos_storage.Raw_store.t -> (unit -> Lwt.t A) -> Lwt.t A :=
  Raw_store.with_atomic_rw.

src/lib_shell/test/assert.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg ?(expected = "") ?(given = "") fmt =
  Format.kasprintf (fail expected given) fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let equal_operation ?msg op1 op2 =
  let eq op1 op2 =
    match (op1, op2) with
    | (None, None) ->
        true
    | (Some op1, Some op2) ->
        Operation.equal op1 op2
    | _ ->
        false
  in
  let prn = function
    | None ->
        "none"
    | Some op ->
        Operation_hash.to_b58check (Operation.hash op)
  in
  equal ?msg ~prn ~eq op1 op2

let equal_block ?msg st1 st2 =
  let eq st1 st2 =
    match (st1, st2) with
    | (None, None) ->
        true
    | (Some st1, Some st2) ->
        Block_header.equal st1 st2
    | _ ->
        false
  in
  let prn = function
    | None ->
        "none"
    | Some st ->
        Block_hash.to_b58check (Block_header.hash st)
  in
  equal ?msg ~prn ~eq st1 st2

let make_equal_list eq prn ?(msg = "") x y =
  let rec iter i x y =
    match (x, y) with
    | (hd_x :: tl_x, hd_y :: tl_y) ->
        if eq hd_x hd_y then iter (succ i) tl_x tl_y
        else
          fail_msg
            ~expected:(prn hd_x)
            ~given:(prn hd_y)
            "%s (at index %d)"
            msg
            i
    | (_ :: _, []) | ([], _ :: _) ->
        fail_msg
          ~expected:""
          ~given:""
          "%s (lists of different sizes %d %d)"
          msg
          (List.length x)
          (List.length y)
    | ([], []) ->
        ()
  in
  iter 0 x y

let equal_string_list ?msg l1 l2 =
  make_equal_list ?msg ( = ) (fun x -> x) l1 l2

let equal_string_list_list ?msg l1 l2 =
  let pr_persist l =
    let res =
      String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
    in
    Printf.sprintf "[%s]" res
  in
  make_equal_list ?msg ( = ) pr_persist l1 l2

let equal_block_set ?msg set1 set2 =
  let b1 = Block_hash.Set.elements set1
  and b2 = Block_hash.Set.elements set2 in
  make_equal_list
    ?msg
    (fun h1 h2 -> Block_hash.equal h1 h2)
    Block_hash.to_string
    b1
    b2

let equal_block_map ?msg ~eq map1 map2 =
  let b1 = Block_hash.Map.bindings map1
  and b2 = Block_hash.Map.bindings map2 in
  make_equal_list
    ?msg
    (fun (h1, b1) (h2, b2) -> Block_hash.equal h1 h2 && eq b1 b2)
    (fun (h1, _) -> Block_hash.to_string h1)
    b1
    b2

let equal_block_hash_list ?msg l1 l2 =
  let pr_block_hash = Block_hash.to_short_b58check in
  make_equal_list ?msg Block_hash.equal pr_block_hash l1 l2

let is_false ?(msg = "") x = if x then fail "false" "true" msg

let is_true ?(msg = "") x = if not x then fail "true" "false" msg

let equal_checkpoint ?msg cp1 cp2 =
  let eq cp1 cp2 =
    match (cp1, cp2) with
    | (None, None) ->
        true
    | (Some (x, bh1), Some (y, bh2)) ->
        Int32.equal x y && Block_hash.equal bh1 bh2
    | _ ->
        false
  in
  let prn = function
    | None ->
        "none"
    | Some (_x, bh) ->
        (*let s = Printf.sprintf "%s" x in*)
        Block_hash.to_b58check bh
  in
  equal ?msg ~prn ~eq cp1 cp2
src/lib_shell/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type} (op_staroptstar : option string)
  : (option string) -> (Stdlib.format4 A Stdlib.Format.formatter unit B) -> A :=
  let expected :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun op_staroptstar =>
    let given :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => "" % string
      end in
    fun fmt => Format.kasprintf (fail expected given) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let prn :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition equal_operation
  (msg : option string) (op1 : option Tezos_base__TzPervasives.Operation.t)
  (op2 : option Tezos_base__TzPervasives.Operation.t) : unit :=
  let eq
    (op1 : option Tezos_base__TzPervasives.Operation.t) (op2 :
    option Tezos_base__TzPervasives.Operation.t) : bool :=
    match (op1, op2) with
    | (None, None) => true
    | (Some op1, Some op2) => Operation.equal op1 op2
    | _ => false
    end in
  let prn (function_parameter : option Tezos_base__TzPervasives.Operation.t)
    : string :=
    match function_parameter with
    | None => "none" % string
    | Some op => Operation_hash.to_b58check (Operation.hash op)
    end in
  equal (Some eq) (Some prn) msg op1 op2.

Definition equal_block
  (msg : option string) (st1 : option Tezos_base__TzPervasives.Block_header.t)
  (st2 : option Tezos_base__TzPervasives.Block_header.t) : unit :=
  let eq
    (st1 : option Tezos_base__TzPervasives.Block_header.t) (st2 :
    option Tezos_base__TzPervasives.Block_header.t) : bool :=
    match (st1, st2) with
    | (None, None) => true
    | (Some st1, Some st2) => Block_header.equal st1 st2
    | _ => false
    end in
  let prn (function_parameter : option Tezos_base__TzPervasives.Block_header.t)
    : string :=
    match function_parameter with
    | None => "none" % string
    | Some st => Block_hash.to_b58check (Block_header.hash st)
    end in
  equal (Some eq) (Some prn) msg st1 st2.

Definition make_equal_list {A : Type}
  (eq : A -> A -> bool) (prn : A -> string) (op_staroptstar : option string)
  : (list A) -> (list A) -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    fun y =>
      let fix iter (i : Z) (x : list A) (y : list A) : unit :=
        match (x, y) with
        | (cons hd_x tl_x, cons hd_y tl_y) =>
          if eq hd_x hd_y then
            iter (Z.succ i) tl_x tl_y
          else
            fail_msg (Some (prn hd_x)) (Some (prn hd_y))
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (at index " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format))))
                "%s (at index %d)" % string) msg i
        | (cons _ _, []) | ([], cons _ _) =>
          fail_msg (Some "" % string) (Some "" % string)
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " (lists of different sizes " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal " " % char
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))))
              "%s (lists of different sizes %d %d)" % string) msg
            (List.length x) (List.length y)
        | ([], []) => tt
        end in
      iter 0 x y.

Definition equal_string_list
  (msg : option string) (l1 : list string) (l2 : list string) : unit :=
  make_equal_list equiv_decb (fun x => x) msg l1 l2.

Definition equal_string_list_list
  (msg : option string) (l1 : list (list string)) (l2 : list (list string))
  : unit :=
  let pr_persist (l : list string) : string :=
    let res :=
      String.concat ";" % string
        (List.map
          (fun s =>
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
      in
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
  make_equal_list equiv_decb pr_persist msg l1 l2.

Definition equal_block_set
  (msg : option string) (set1 : Tezos_base__TzPervasives.Block_hash.Set.t)
  (set2 : Tezos_base__TzPervasives.Block_hash.Set.t) : unit :=
  let b1 : list Tezos_base__TzPervasives.Block_hash.Set.elt :=
    Block_hash.Set.elements set1
  with b2 : list Tezos_base__TzPervasives.Block_hash.Set.elt :=
    Block_hash.Set.elements set2 in
  make_equal_list (fun h1 => fun h2 => Block_hash.equal h1 h2)
    Block_hash.to_string msg b1 b2.

Definition equal_block_map {A : Type}
  (msg : option string) (eq : A -> A -> bool)
  (map1 : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (map2 : Tezos_base__TzPervasives.Block_hash.Map.t A) : unit :=
  let b1 : list (Tezos_base__TzPervasives.Block_hash.Map.key * A) :=
    Block_hash.Map.bindings map1
  with b2 : list (Tezos_base__TzPervasives.Block_hash.Map.key * A) :=
    Block_hash.Map.bindings map2 in
  make_equal_list
    (fun function_parameter =>
      let '(h1, b1) := function_parameter in
      fun function_parameter =>
        let '(h2, b2) := function_parameter in
        andb (Block_hash.equal h1 h2) (eq b1 b2))
    (fun function_parameter =>
      let '(h1, _) := function_parameter in
      Block_hash.to_string h1) msg b1 b2.

Definition equal_block_hash_list
  (msg : option string) (l1 : list Tezos_base__TzPervasives.Block_hash.t)
  (l2 : list Tezos_base__TzPervasives.Block_hash.t) : unit :=
  let pr_block_hash := Block_hash.to_short_b58check in
  make_equal_list Block_hash.equal pr_block_hash msg l1 l2.

Definition is_false (op_staroptstar : option string) : bool -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    if x then
      fail "false" % string "true" % string msg
    else
      tt.

Definition is_true (op_staroptstar : option string) : bool -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    if negb x then
      fail "true" % string "false" % string msg
    else
      tt.

Definition equal_checkpoint
  (msg : option string)
  (cp1 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t))
  (cp2 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t))
  : unit :=
  let eq
    (cp1 : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)) (cp2
    : option (Stdlib.Int32.t * Tezos_base__TzPervasives.Block_hash.t)) : bool :=
    match (cp1, cp2) with
    | (None, None) => true
    | (Some (x, bh1), Some (y, bh2)) =>
      andb (Int32.equal x y) (Block_hash.equal bh1 bh2)
    | _ => false
    end in
  let prn {A : Type}
    (function_parameter : option (A * Tezos_base__TzPervasives.Block_hash.t))
    : string :=
    match function_parameter with
    | None => "none" % string
    | Some (_x, bh) => Block_hash.to_b58check bh
    end in
  equal (Some eq) (Some prn) msg cp1 cp2.

src/lib_shell/test/test.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run
    "tezos-state"
    [ ("store", Test_store.tests);
      ("state", Test_state.tests);
      ("store checkpoint", Test_store_checkpoint.tests);
      ("state checkpoint", Test_state_checkpoint.tests) ]
src/lib_shell/test/test.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/lib_shell/test/test_locator.ml 58 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_hash =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let state_genesis_block =
  {
    State.Chain.time = genesis_time;
    State.Chain.block = genesis_hash;
    State.Chain.protocol = genesis_protocol;
  }

let chain_id = Chain_id.of_block_hash genesis_hash

let proto =
  match Registered_protocol.get genesis_protocol with
  | None ->
      assert false
  | Some proto ->
      proto

module Proto = (val proto)

let incr_timestamp timestamp =
  Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))

let incr_fitness fitness =
  let new_fitness =
    match fitness with
    | [fitness] ->
        Pervasives.(
          Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
          |> Option.unopt ~default:0L |> Int64.succ
          |> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ ->
        Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
  in
  [new_fitness]

(* returns a new state with a single block, genesis *)
let init_chain base_dir : State.Chain.t Lwt.t =
  let store_root = base_dir // "store" in
  let context_root = base_dir // "context" in
  State.init
    ~store_root
    ~context_root
    ~history_mode:Archive
    state_genesis_block
  >>= function
  | Error _ ->
      Pervasives.failwith "read err"
  | Ok (_state, chain, _index, _history_mode) ->
      Lwt.return chain

let block_header ?(context = Context_hash.zero) (pred : State.Block.t) :
    Block_header.t =
  let pred_header = State.Block.shell_header pred in
  let timestamp = incr_timestamp pred_header.timestamp in
  let fitness = incr_fitness pred_header.fitness in
  {
    Block_header.shell =
      {
        level = Int32.add Int32.one (State.Block.level pred);
        proto_level = 0;
        predecessor = State.Block.hash pred;
        timestamp;
        validation_passes = 0;
        operations_hash = Operation_list_list_hash.empty;
        fitness;
        context;
      };
    Block_header.protocol_data = Bytes.of_string "";
  }

let zero = Bytes.create 0

(* adds n blocks on top of an initialized chain *)
let make_empty_chain (chain : State.Chain.t) n : Block_hash.t Lwt.t =
  State.Block.read_opt chain genesis_hash
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun genesis ->
  State.Block.context_exn genesis
  >>= fun empty_context ->
  let header = State.Block.header genesis in
  let timestamp = State.Block.timestamp genesis in
  let empty_context_hash = Context.hash ~time:timestamp empty_context in
  Context.commit ~time:header.shell.timestamp empty_context
  >>= fun context ->
  let header = {header with shell = {header.shell with context}} in
  let empty_result =
    {
      Block_validation.context_hash = empty_context_hash;
      message = None;
      max_operations_ttl = 0;
      last_allowed_fork_level = 0l;
    }
  in
  let rec loop lvl pred =
    if lvl >= n then return pred
    else
      let header =
        {
          header with
          shell =
            {header.shell with predecessor = pred; level = Int32.of_int lvl};
        }
      in
      State.Block.store
        chain
        header
        zero
        []
        []
        empty_result
        ~forking_testchain:false
      >>=? fun _ -> loop (lvl + 1) (Block_header.hash header)
  in
  loop 1 genesis_hash
  >>= function
  | Ok b ->
      Lwt.return b
  | Error err ->
      Error_monad.pp_print_error Format.err_formatter err ;
      assert false

(* helper functions ------------------------------------- *)

(* wall clock time of a unit function *)
let time1 (f : unit -> 'a) : 'a * float =
  let t = Unix.gettimeofday () in
  let res = f () in
  let wall_clock = Unix.gettimeofday () -. t in
  (res, wall_clock)

(* returns result from first run and average time of [runs] runs *)
let time ?(runs = 1) f =
  if runs < 1 then invalid_arg "time negative arg"
  else
    let rec loop cnt sum =
      if cnt = runs then sum
      else
        let (_, t) = time1 f in
        loop (cnt + 1) (sum +. t)
    in
    let (res, t) = time1 f in
    let sum = loop 1 t in
    (res, sum /. float runs)

let rec repeat f n =
  if n < 0 then invalid_arg "repeat: negative arg"
  else if n = 0 then ()
  else
    let _ = f () in
    repeat f (n - 1)

(* ----------------------------------------------------- *)

let print_block b =
  Printf.printf
    "%6i %s\n"
    (Int32.to_int (State.Block.level b))
    (Block_hash.to_b58check (State.Block.hash b))

let print_block_h chain bh =
  State.Block.read_opt chain bh
  >|= Option.unopt_assert ~loc:__POS__
  >|= fun b -> print_block b

(* returns the predecessor at distance one, reading the header *)
let linear_predecessor chain (bh : Block_hash.t) : Block_hash.t option Lwt.t =
  State.Block.read_opt chain bh
  >|= Option.unopt_assert ~loc:__POS__
  >>= fun b ->
  State.Block.predecessor b
  >|= function None -> None | Some pred -> Some (State.Block.hash pred)

let print_chain chain bh =
  let rec loop bh cnt =
    let _ = print_block_h chain bh in
    linear_predecessor chain bh
    >>= function Some pred -> loop pred (cnt + 1) | None -> Lwt.return_unit
  in
  loop bh 0

(* returns the predecessors at ditance n, traversing all n intermediate blocks *)
let linear_predecessor_n (chain : State.Chain.t) (bh : Block_hash.t)
    (distance : int) : Block_hash.t option Lwt.t =
  (* let _ = Printf.printf "LP: %4i " distance; print_block_h chain bh in *)
  if distance < 1 then invalid_arg "distance<1"
  else
    let rec loop bh distance =
      if distance = 0 then Lwt.return_some bh (* reached distance *)
      else
        linear_predecessor chain bh
        >>= function
        | None -> Lwt.return_none | Some pred -> loop pred (distance - 1)
    in
    loop bh distance

(* Tests that the linear predecessor defined above and the
   exponential predecessor implemented in State.predecessor_n
   return the same block and it is the block at the distance
   requested *)
let test_pred (base_dir : string) : unit tzresult Lwt.t =
  let size_chain = 1000 in
  init_chain base_dir
  >>= fun chain ->
  make_empty_chain chain size_chain
  >>= fun head ->
  let test_once distance =
    linear_predecessor_n chain head distance
    >>= fun lin_res ->
    State.Block.read_opt chain head
    >|= Option.unopt_assert ~loc:__POS__
    >>= fun head_block ->
    State.Block.predecessor_n head_block distance
    >>= fun exp_res ->
    match (lin_res, exp_res) with
    | (None, None) ->
        Lwt.return_unit
    | (None, Some _) | (Some _, None) ->
        Assert.fail_msg "mismatch between exponential and linear predecessor_n"
    | (Some lin_res, Some exp_res) ->
        (* check that the two results are the same *)
        assert (lin_res = exp_res) ;
        State.Block.read_opt chain lin_res
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun pred ->
        let level_pred = Int32.to_int (State.Block.level pred) in
        State.Block.read_opt chain head
        >|= Option.unopt_assert ~loc:__POS__
        >>= fun head ->
        let level_start = Int32.to_int (State.Block.level head) in
        (* check distance using the level *)
        assert (level_start - distance = level_pred) ;
        Lwt.return_unit
  in
  let _ = Random.self_init () in
  let range = size_chain + (size_chain / 10) in
  let repeats = 100 in
  return (repeat (fun () -> test_once (1 + Random.int range)) repeats)

let seed =
  let receiver_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 'r')
  in
  let sender_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 's')
  in
  {Block_locator.receiver_id; sender_id}

(* compute locator using the linear predecessor *)
let compute_linear_locator chain_state ~size block =
  let block_hash = State.Block.hash block in
  let header = State.Block.header block in
  Block_locator.compute
    ~get_predecessor:(linear_predecessor_n chain_state)
    block_hash
    header
    ~size
    seed

(* given the size of a chain, returns the size required for a locator
   to reach genesis *)
let compute_size_locator size_chain =
  let repeats = 10. in
  int_of_float ((log (float size_chain /. repeats) /. log 2.) -. 1.) * 10

(* given the size of a locator, returns the size of the chain that it
   can cover back to genesis *)
let compute_size_chain size_locator =
  let repeats = 10. in
  int_of_float (repeats *. (2. ** float (size_locator + 1)))

(* test if the linear and exponential locator are the same and outputs
   their timing.
   Run the test with:
   $ dune build @runbench_locator
   Copy the output to a file timing.dat and plot it with:
   $ test_locator_plot.sh timing.dat
*)
(*
   chain 1 year   518k   covered by locator 150
   chain 2 months 86k    covered by locator 120
*)
let test_locator base_dir =
  let size_chain = 80000 in
  (* timing locators with average over [runs] times *)
  let runs = 10 in
  let _ = Printf.printf "#runs %i\n" runs in
  (* limit after which exp should go linear *)
  let exp_limit = compute_size_chain 120 in
  let _ = Printf.printf "#exp_limit %i\n" exp_limit in
  (* size after which locator always reaches genesis *)
  let locator_limit = compute_size_locator size_chain in
  let _ = Printf.printf "#locator_limit %i\n" locator_limit in
  init_chain base_dir
  >>= fun chain ->
  time1 (fun () -> make_empty_chain chain size_chain)
  |> fun (res, t_chain) ->
  let _ =
    Printf.printf
      "#size_chain %i built in %f sec\n#      size      exp       lins\n"
      size_chain
      t_chain
  in
  res
  >>= fun head ->
  let check_locator size : unit tzresult Lwt.t =
    State.read_chain_data chain (fun _ data ->
        Lwt.return (data.caboose, data.save_point))
    >>= fun ((_, caboose), _save_point) ->
    State.Block.read chain head
    >>=? fun block ->
    time ~runs (fun () -> State.compute_locator chain ~size block seed)
    |> fun (l_exp, t_exp) ->
    time ~runs (fun () -> compute_linear_locator chain ~caboose ~size block)
    |> fun (l_lin, t_lin) ->
    l_exp
    >>= fun l_exp ->
    l_lin
    >>= fun l_lin ->
    let (_, l_exp) = (l_exp : Block_locator.t :> _ * _) in
    let (_, l_lin) = (l_lin : Block_locator.t :> _ * _) in
    let _ = Printf.printf "%10i %f %f\n" size t_exp t_lin in
    List.iter2
      (fun hn ho ->
        if not (Block_hash.equal hn ho) then
          Assert.fail_msg "Invalid locator %i" size)
      l_exp
      l_lin ;
    return_unit
  in
  let stop = locator_limit + 20 in
  let rec loop size =
    if size < stop then check_locator size >>=? fun _ -> loop (size + 5)
    else return_unit
  in
  loop 1

let wrap n f =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
          f dir
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error error ->
              Format.kasprintf Pervasives.failwith "%a" pp_print_error error))

let tests = [wrap "test pred" test_pred]

let bench = [wrap "test locator" test_locator]

let tests =
  try if Sys.argv.(1) = "--no-bench" then tests else tests @ bench
  with _ -> tests @ bench

let () = Alcotest.run ~argv:[|""|] "tezos-shell" [("locator", tests)]
src/lib_shell/test/test_locator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition genesis_hash : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.of_seconds
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition state_genesis_block : Tezos_shell.State.Chain.genesis :=
  {| State.Chain.time := genesis_time; State.Chain.block := genesis_hash;
    State.Chain.protocol := genesis_protocol |}.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Chain_id.of_block_hash genesis_hash.

Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
  match Registered_protocol.get genesis_protocol with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some proto => proto
  end.

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.add timestamp
    (Int64.add
      (* ❌ Constant of type int64 is converted to int *)
      1
      (Random.int64
        (* ❌ Constant of type int64 is converted to int *)
        10)).

Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
  let new_fitness :=
    match fitness with
    | cons fitness [] =>
      op_pipegt
        (op_pipegt
          (op_pipegt (Data_encoding.Binary.of_bytes Data_encoding.int64 fitness)
            (Option.unopt
              (* ❌ Constant of type int64 is converted to int *)
              0)) Int64.succ)
        (Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ =>
      Data_encoding.Binary.to_bytes_exn Data_encoding.int64
        (* ❌ Constant of type int64 is converted to int *)
        1
    end in
  cons new_fitness [].

Definition init_chain (base_dir : string) : Lwt.t Tezos_shell.State.Chain.t :=
  let store_root := op_divdiv base_dir "store" % string in
  let context_root := op_divdiv base_dir "context" % string in
  op_gtgteq
    (State.init None None None None store_root context_root
      (Some Tezos_shell_services.History_mode.Archive) state_genesis_block)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error _ => Pervasives.failwith "read err" % string
      | Stdlib.Ok (_state, chain, _index, _history_mode) => Lwt._return chain
      end).

Definition block_header
  (op_staroptstar : option Tezos_base__TzPervasives.Context_hash.t)
  : Tezos_shell.State.Block.t -> Tezos_base__TzPervasives.Block_header.t :=
  let context :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Context_hash.zero
    end in
  fun pred =>
    let pred_header := State.Block.shell_header pred in
    let timestamp := incr_timestamp (timestamp pred_header) in
    let fitness := incr_fitness (fitness pred_header) in
    {|
      Block_header.shell :=
        {| level := Int32.add Int32.one (State.Block.level pred);
          proto_level := 0; predecessor := State.Block.hash pred;
          timestamp := timestamp; validation_passes := 0;
          operations_hash := Operation_list_list_hash.empty; fitness := fitness;
          context := context |};
      Block_header.protocol_data := Stdlib.Bytes.of_string "" % string |}.

Definition zero : string := Stdlib.Bytes.create 0.

Definition make_empty_chain (chain : Tezos_shell.State.Chain.t) (n : Z)
  : Lwt.t Tezos_base__TzPervasives.Block_hash.t :=
  op_gtgteq
    (op_gtpipeeq (State.Block.read_opt chain genesis_hash)
      (Option.unopt_assert Stdlib.__POS__))
    (fun genesis =>
      op_gtgteq (State.Block.context_exn genesis)
        (fun empty_context =>
          let header := State.Block.header genesis in
          let timestamp := State.Block.timestamp genesis in
          let empty_context_hash := Context.hash timestamp None empty_context in
          op_gtgteq
            (Context.commit (timestamp (shell header)) None empty_context)
            (fun context =>
              let header :=
                (* ❌ Record substitution not handled *)
                record_substitution in
              let empty_result :=
                {| Block_validation.context_hash := empty_context_hash;
                  Block_validation.message := None;
                  Block_validation.max_operations_ttl := 0;
                  Block_validation.last_allowed_fork_level :=
                    (* ❌ Constant of type int32 is converted to int *)
                    0 |} in
              let fix loop (lvl : Z) (pred : Tezos_crypto.Block_hash.t)
                : Lwt.t
                  (Tezos_base__TzPervasives.tzresult Tezos_crypto.Block_hash.t) :=
                if OCaml.Stdlib.ge lvl n then
                  _return pred
                else
                  let header :=
                    (* ❌ Record substitution not handled *)
                    record_substitution in
                  op_gtgteqquestion
                    (State.Block.store None chain header zero [] [] empty_result
                      false)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      loop (Z.add lvl 1) (Block_header.hash header)) in
              op_gtgteq (loop 1 genesis_hash)
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok b => Lwt._return b
                  | Stdlib.Error err =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Error_monad.pp_print_error Format.err_formatter err
                      in
                    (* ❌ Assert instruction is not handled. *)
                    assert false
                  end)))).

Definition time1 {a : Type} (f : unit -> a) : a * Z :=
  let t := Unix.gettimeofday tt in
  let res := f tt in
  let wall_clock := Stdlib.op_minuspoint (Unix.gettimeofday tt) t in
  (res, wall_clock).

Definition time {A : Type} (op_staroptstar : option Z) : (unit -> A) -> A * Z :=
  let runs :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 1
    end in
  fun f =>
    if OCaml.Stdlib.lt runs 1 then
      OCaml.Stdlib.invalid_arg "time negative arg" % string
    else
      let fix loop (cnt : Z) (sum : Z) : Z :=
        if equiv_decb cnt runs then
          sum
        else
          let '(_, t) := time1 f in
          loop (Z.add cnt 1) (Stdlib.op_pluspoint sum t) in
      let '(res, t) := time1 f in
      let sum := loop 1 t in
      (res, (Stdlib.op_divpoint sum (Stdlib.float runs))).

Fixpoint repeat {A : Type} (f : unit -> A) (n : Z) : unit :=
  if OCaml.Stdlib.lt n 0 then
    OCaml.Stdlib.invalid_arg "repeat: negative arg" % string
  else
    if equiv_decb n 0 then
      tt
    else
      let '_ := f tt in
      repeat f (Z.sub n 1).

Definition print_block (b : Tezos_shell.State.Block.t) : unit :=
  Printf.printf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
        (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Right 6)
        CamlinternalFormatBasics.No_precision
        (CamlinternalFormatBasics.Char_literal " " % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format)))) "%6i %s
" % string)
    (Int32.to_int (State.Block.level b))
    (Block_hash.to_b58check (State.Block.hash b)).

Definition print_block_h
  (chain : Tezos_shell__State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  op_gtpipeeq
    (op_gtpipeeq (State.Block.read_opt chain bh)
      (Option.unopt_assert Stdlib.__POS__)) (fun b => print_block b).

Definition linear_predecessor
  (chain : Tezos_shell__State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  op_gtgteq
    (op_gtpipeeq (State.Block.read_opt chain bh)
      (Option.unopt_assert Stdlib.__POS__))
    (fun b =>
      op_gtpipeeq (State.Block.predecessor b)
        (fun function_parameter =>
          match function_parameter with
          | None => None
          | Some pred => Some (State.Block.hash pred)
          end)).

Definition print_chain
  (chain : Tezos_shell__State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t) : Lwt.t unit :=
  let fix loop (bh : Tezos_base__TzPervasives.Block_hash.t) (cnt : Z)
    : Lwt.t unit :=
    let '_ := print_block_h chain bh in
    op_gtgteq (linear_predecessor chain bh)
      (fun function_parameter =>
        match function_parameter with
        | Some pred => loop pred (Z.add cnt 1)
        | None => Lwt.return_unit
        end) in
  loop bh 0.

Definition linear_predecessor_n
  (chain : Tezos_shell.State.Chain.t)
  (bh : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
  : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
  if OCaml.Stdlib.lt distance 1 then
    OCaml.Stdlib.invalid_arg "distance<1" % string
  else
    let fix loop (bh : Tezos_base__TzPervasives.Block_hash.t) (distance : Z)
      : Lwt.t (option Tezos_base__TzPervasives.Block_hash.t) :=
      if equiv_decb distance 0 then
        Lwt.return_some bh
      else
        op_gtgteq (linear_predecessor chain bh)
          (fun function_parameter =>
            match function_parameter with
            | None => Lwt.return_none
            | Some pred => loop pred (Z.sub distance 1)
            end) in
    loop bh distance.

Definition test_pred (base_dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let size_chain := 1000 in
  op_gtgteq (init_chain base_dir)
    (fun chain =>
      op_gtgteq (make_empty_chain chain size_chain)
        (fun head =>
          let test_once (distance : Z) : Lwt.t unit :=
            op_gtgteq (linear_predecessor_n chain head distance)
              (fun lin_res =>
                op_gtgteq
                  (op_gtpipeeq (State.Block.read_opt chain head)
                    (Option.unopt_assert Stdlib.__POS__))
                  (fun head_block =>
                    op_gtgteq (State.Block.predecessor_n head_block distance)
                      (fun exp_res =>
                        match (lin_res, exp_res) with
                        | (None, None) => Lwt.return_unit
                        | (None, Some _) | (Some _, None) =>
                          op_startypeminuserrorstar
                            "mismatch between exponential and linear predecessor_n"
                              % string
                        | (Some lin_res, Some exp_res) =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            (* ❌ Assert instruction is not handled. *)
                            assert (equiv_decb lin_res exp_res) in
                          op_gtgteq
                            (op_gtpipeeq (State.Block.read_opt chain lin_res)
                              (Option.unopt_assert Stdlib.__POS__))
                            (fun pred =>
                              let level_pred :=
                                Int32.to_int (State.Block.level pred) in
                              op_gtgteq
                                (op_gtpipeeq (State.Block.read_opt chain head)
                                  (Option.unopt_assert Stdlib.__POS__))
                                (fun head =>
                                  let level_start :=
                                    Int32.to_int (State.Block.level head) in
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    (* ❌ Assert instruction is not handled. *)
                                    assert
                                      (equiv_decb (Z.sub level_start distance)
                                        level_pred) in
                                  Lwt.return_unit))
                        end))) in
          let '_ := Random.self_init tt in
          let range := Z.add size_chain (Z.div size_chain 10) in
          let repeats := 100 in
          _return
            (repeat
              (fun function_parameter =>
                let 'tt := function_parameter in
                test_once (Z.add 1 (Random.int range))) repeats))).

Definition seed : Tezos_base__TzPervasives.Block_locator.seed :=
  let receiver_id :=
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "r" % char) in
  let sender_id :=
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "s" % char) in
  {| Block_locator.sender_id := sender_id;
    Block_locator.receiver_id := receiver_id |}.

Definition compute_linear_locator
  (chain_state : Tezos_shell.State.Chain.t) (size : Z)
  (block : Tezos_shell.State.Block.t)
  : Tezos_crypto.Block_hash.t -> Lwt.t Tezos_base__TzPervasives.Block_locator.t :=
  let block_hash := State.Block.hash block in
  let header := State.Block.header block in
  Block_locator.compute (linear_predecessor_n chain_state)
    (* ❌ expected an argument *)
    expected_argument size block_hash header seed.

Definition compute_size_locator (size_chain : Z) : Z :=
  let repeats :=
    (* ❌ Float constant 10. is approximated by the integer 10 *)
    10 in
  Z.mul
    (Stdlib.int_of_float
      (Stdlib.op_minuspoint
        (Stdlib.op_divpoint
          (Stdlib.log (Stdlib.op_divpoint (Stdlib.float size_chain) repeats))
          (Stdlib.log
            (* ❌ Float constant 2. is approximated by the integer 2 *)
            2))
        (* ❌ Float constant 1. is approximated by the integer 1 *)
        1)) 10.

Definition compute_size_chain (size_locator : Z) : Z :=
  let repeats :=
    (* ❌ Float constant 10. is approximated by the integer 10 *)
    10 in
  Stdlib.int_of_float
    (Stdlib.op_starpoint repeats
      (Stdlib.op_starstar
        (* ❌ Float constant 2. is approximated by the integer 2 *)
        2 (Stdlib.float (Z.add size_locator 1)))).

Definition test_locator (base_dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let size_chain := 80000 in
  let runs := 10 in
  let '_ :=
    Printf.printf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "#runs " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format))) "#runs %i
" % string)
      runs in
  let exp_limit := compute_size_chain 120 in
  let '_ :=
    Printf.printf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "#exp_limit " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format)))
        "#exp_limit %i
" % string) exp_limit in
  let locator_limit := compute_size_locator size_chain in
  let '_ :=
    Printf.printf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "#locator_limit " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "010" % char
              CamlinternalFormatBasics.End_of_format)))
        "#locator_limit %i
" % string) locator_limit in
  op_gtgteq (init_chain base_dir)
    (fun chain =>
      OCaml.Stdlib.reverse_apply
        (time1
          (fun function_parameter =>
            let 'tt := function_parameter in
            make_empty_chain chain size_chain))
        (fun function_parameter =>
          let '(res, t_chain) := function_parameter in
          let '_ :=
            Printf.printf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "#size_chain " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_i
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      " built in " % string
                      (CamlinternalFormatBasics.Float
                        CamlinternalFormatBasics.Float_f
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " sec
#      size      exp       lins
" % string
                          CamlinternalFormatBasics.End_of_format)))))
                "#size_chain %i built in %f sec
#      size      exp       lins
"
                  % string) size_chain t_chain in
          op_gtgteq res
            (fun head =>
              let check_locator (size : Z)
                : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                op_gtgteq
                  (State.read_chain_data chain
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      fun data =>
                        Lwt._return ((caboose data), (save_point data))))
                  (fun function_parameter =>
                    let '((_, caboose), _save_point) := function_parameter in
                    op_gtgteqquestion (State.Block.read chain head)
                      (fun block =>
                        OCaml.Stdlib.reverse_apply
                          (time (Some runs)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              State.compute_locator chain (Some size) block seed))
                          (fun function_parameter =>
                            let '(l_exp, t_exp) := function_parameter in
                            OCaml.Stdlib.reverse_apply
                              (time (Some runs)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  compute_linear_locator chain size block
                                    caboose))
                              (fun function_parameter =>
                                let '(l_lin, t_lin) := function_parameter in
                                op_gtgteq l_exp
                                  (fun l_exp =>
                                    op_gtgteq l_lin
                                      (fun l_lin =>
                                        let '(_, l_exp) := l_exp in
                                        let '(_, l_lin) := l_lin in
                                        let '_ :=
                                          Printf.printf
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_i
                                                (CamlinternalFormatBasics.Lit_padding
                                                  CamlinternalFormatBasics.Right
                                                  10)
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.Char_literal
                                                  " " % char
                                                  (CamlinternalFormatBasics.Float
                                                    CamlinternalFormatBasics.Float_f
                                                    CamlinternalFormatBasics.No_padding
                                                    CamlinternalFormatBasics.No_precision
                                                    (CamlinternalFormatBasics.Char_literal
                                                      " " % char
                                                      (CamlinternalFormatBasics.Float
                                                        CamlinternalFormatBasics.Float_f
                                                        CamlinternalFormatBasics.No_padding
                                                        CamlinternalFormatBasics.No_precision
                                                        (CamlinternalFormatBasics.Char_literal
                                                          "010" % char
                                                          CamlinternalFormatBasics.End_of_format))))))
                                              "%10i %f %f
" % string) size t_exp
                                            t_lin in
                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                        let _ :=
                                          List.iter2
                                            (fun hn =>
                                              fun ho =>
                                                if negb (Block_hash.equal hn ho)
                                                  then
                                                  op_startypeminuserrorstar
                                                    "Invalid locator %i" %
                                                      string size
                                                else
                                                  tt) l_exp l_lin in
                                        return_unit)))))) in
              let stop := Z.add locator_limit 20 in
              let fix loop (size : Z)
                : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                if OCaml.Stdlib.lt size stop then
                  op_gtgteqquestion (check_locator size)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      loop (Z.add size 5))
                else
                  return_unit in
              loop 1))).

Definition wrap {A B : Type}
  (n : A) (f : string -> Lwt.t (sum unit Tezos_base__TzPervasives.trace)) : B :=
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun dir =>
            op_gtgteq (f dir)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => Lwt.return_unit
                | Stdlib.Error error =>
                  Format.kasprintf Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    pp_print_error error
                end))).

Definition tests {A : Type} : list A :=
  cons (wrap "test pred" % string test_pred) [].

Definition bench {A : Type} : list A :=
  cons (wrap "test locator" % string test_locator) [].

Definition tests {A : Type} : list A :=
  (* ❌ Try-with are not handled *)
  try
    (if equiv_decb (Array.get Sys.argv 1) "--no-bench" % string then
      tests
    else
      OCaml.Stdlib.app tests bench).



src/lib_shell/test/test_state.ml 208 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let proto =
  match Registered_protocol.get genesis_protocol with
  | None ->
      assert false
  | Some proto ->
      proto

module Proto = (val proto)

let genesis : State.Chain.genesis =
  {time = genesis_time; block = genesis_block; protocol = genesis_protocol}

let chain_id = Chain_id.of_block_hash genesis_block

let incr_fitness fitness =
  let new_fitness =
    match fitness with
    | [fitness] ->
        Pervasives.(
          Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
          |> Option.unopt ~default:0L |> Int64.succ
          |> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ ->
        Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
  in
  [new_fitness]

let incr_timestamp timestamp =
  Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))

let operation op =
  let op : Operation.t =
    {shell = {branch = genesis_block}; proto = Bytes.of_string op}
  in
  (Operation.hash op, op, Data_encoding.Binary.to_bytes Operation.encoding op)

let block_header_data_encoding =
  Data_encoding.(obj1 (req "proto_block_header" string))

let block _state ?(context = Context_hash.zero) ?(operations = [])
    (pred : State.Block.t) name : Block_header.t =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let pred_header = State.Block.shell_header pred in
  let fitness = incr_fitness pred_header.fitness in
  let timestamp = incr_timestamp pred_header.timestamp in
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn block_header_data_encoding name
  in
  {
    shell =
      {
        level = Int32.succ pred_header.level;
        proto_level = pred_header.proto_level;
        predecessor = State.Block.hash pred;
        validation_passes = 1;
        timestamp;
        operations_hash;
        fitness;
        context;
      };
    protocol_data;
  }

let parsed_block ({shell; protocol_data} : Block_header.t) =
  let protocol_data =
    Data_encoding.Binary.of_bytes_exn
      Proto.block_header_data_encoding
      protocol_data
  in
  ({shell; protocol_data} : Proto.block_header)

let zero = Bytes.create 0

let build_valid_chain state vtbl pred names =
  Lwt_list.fold_left_s
    (fun pred name ->
      State.Block.context_exn pred
      >>= fun predecessor_context ->
      let max_trials = 100 in
      let rec attempt trials context =
        (let (oph, op, _bytes) = operation name in
         let block = block ?context state ~operations:[oph] pred name in
         let hash = Block_header.hash block in
         let pred_header = State.Block.header pred in
         (let predecessor_context =
            Shell_context.wrap_disk_context predecessor_context
          in
          Proto.begin_application
            ~chain_id:Chain_id.zero
            ~predecessor_context
            ~predecessor_timestamp:pred_header.shell.timestamp
            ~predecessor_fitness:pred_header.shell.fitness
            (parsed_block block)
          >>=? fun vstate ->
          (* no operations *)
          Proto.finalize_block vstate)
         >>=? fun (result, _metadata) ->
         let context = Shell_context.unwrap_disk_context result.context in
         Context.commit ~time:block.shell.timestamp context
         >>= fun context_hash ->
         let validation_store =
           ( {
               context_hash;
               message = result.message;
               max_operations_ttl = 1;
               last_allowed_fork_level = result.last_allowed_fork_level;
             }
             : Block_validation.validation_store )
         in
         State.Block.store
           state
           block
           zero
           [[op]]
           [[zero]]
           ( {
               context_hash;
               message = validation_store.message;
               max_operations_ttl = 1;
               last_allowed_fork_level =
                 validation_store.last_allowed_fork_level;
             }
             : Block_validation.validation_store )
           ~forking_testchain:false
         >>=? fun _vblock ->
         State.Block.read state hash
         >>=? fun vblock ->
         Hashtbl.add vtbl name vblock ;
         return vblock)
        >>= function
        | Ok v ->
            if trials < max_trials then
              Format.eprintf
                "Took %d trials to build valid chain"
                (max_trials - trials + 1) ;
            Lwt.return v
        | Error (Validation_errors.Inconsistent_hash (got, _) :: _) ->
            (* Kind of a hack, but at least it tests idempotence to some extent. *)
            if trials <= 0 then assert false
            else (
              Format.eprintf
                "Inconsistent context hash: got %a, retrying (%d)\n"
                Context_hash.pp
                got
                trials ;
              attempt (trials - 1) (Some got) )
        | Error err ->
            Format.eprintf "Error: %a\n" Error_monad.pp_print_error err ;
            assert false
      in
      attempt max_trials None)
    pred
    names
  >>= fun _ -> Lwt.return_unit

type state = {
  vblock : (string, State.Block.t) Hashtbl.t;
  state : State.t;
  chain : State.Chain.t;
}

let vblock s = Hashtbl.find s.vblock

exception Found of string

let vblocks s =
  Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.vblock []
  |> List.sort Pervasives.compare

(*******************************************************)
(*

    Genesis - A1 - A2 - A3 - A4 - A5 - A6 - A7 - A8
                         \
                          B1 - B2 - B3 - B4 - B5 - B6 - B7 - B8
*)

let build_example_tree chain =
  let vtbl = Hashtbl.create 23 in
  Chain.genesis chain
  >>= fun genesis ->
  Hashtbl.add vtbl "Genesis" genesis ;
  let c = ["A1"; "A2"; "A3"; "A4"; "A5"; "A6"; "A7"; "A8"] in
  build_valid_chain chain vtbl genesis c
  >>= fun () ->
  let a3 = Hashtbl.find vtbl "A3" in
  let c = ["B1"; "B2"; "B3"; "B4"; "B5"; "B6"; "B7"; "B8"] in
  build_valid_chain chain vtbl a3 c >>= fun () -> Lwt.return vtbl

let wrap_state_init f base_dir =
  let store_root = base_dir // "store" in
  let context_root = base_dir // "context" in
  State.init
    ~store_mapsize:4_096_000_000L
    ~context_mapsize:4_096_000_000L
    ~store_root
    ~context_root
    genesis
  >>=? fun (state, chain, _index, _history_mode) ->
  build_example_tree chain >>= fun vblock -> f {state; chain; vblock}

let test_init (_ : state) = return_unit

(** State.Block.read *)

let test_read_block (s : state) =
  Lwt_list.iter_s
    (fun (name, vblock) ->
      let hash = State.Block.hash vblock in
      State.Block.read s.chain hash
      >>= function
      | Error _ ->
          Assert.fail_msg "Error while reading valid block %s" name
      | Ok _vblock' ->
          (* FIXME COMPARE read operations ??? *)
          Lwt.return_unit)
    (vblocks s)
  >>= fun () -> return_unit

(****************************************************************************)

(** Chain.set_checkpoint_then_purge_full *)

let test_set_checkpoint_then_purge_full (s : state) =
  State.Chain.checkpoint s.chain
  >>= fun checkpoint ->
  let checkpoint_lvl = checkpoint.shell.level in
  let checkpoint_hash = Block_header.hash checkpoint in
  (* At the beginning the checkpoint is the genesis. *)
  State.Block.read s.chain genesis_block
  >>=? fun read_genesis ->
  let read_genesis_hash =
    Block_header.hash (State.Block.header read_genesis)
  in
  assert (Block_hash.equal checkpoint_hash read_genesis_hash) ;
  assert (checkpoint_lvl = Int32.zero) ;
  let a1 = vblock s "A1" in
  let ha1 = State.Block.hash a1 in
  let b1 = vblock s "B1" in
  let hb1 = State.Block.hash b1 in
  let b2 = vblock s "B2" in
  let hb2 = State.Block.hash b2 in
  let la1 = State.Block.level a1 in
  let lb1 = State.Block.level b1 in
  let lb2 = State.Block.level b2 in
  assert (Int32.compare checkpoint_lvl la1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb2 = -1) ;
  State.Chain.store s.chain
  >>= fun chain_store ->
  let chain_store = Store.Chain.get chain_store (State.Chain.id s.chain) in
  let block_store = Store.Block.get chain_store in
  (* Let us set a new checkpoint "B1" whose level is greater than the genesis. *)
  State.Chain.set_checkpoint_then_purge_full s.chain (State.Block.header b2)
  >>=? fun () ->
  (* Assert b2 does still exist and is the new checkpoint. *)
  State.Block.known s.chain hb2
  >|= (fun b -> assert b)
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >|= (fun b ->
        assert (Block_hash.equal (Block_header.hash b) hb2) ;
        assert (Int32.equal b.shell.level lb2))
  >>= fun () ->
  (* Assert b1 has been pruned.. *)
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* pruned, so we can still access its header. *)
  State.Block.read_opt s.chain hb1
  >|= (function Some _header -> assert true | None -> assert false)
  >>= fun () ->
  (* Assert a1 has also been pruned .. *)
  Store.Block.Contents.known (block_store, ha1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* and we can also access its header. *)
  State.Block.read_opt s.chain ha1
  >|= (function Some _header -> assert true | None -> assert false)
  >>= fun () ->
  (* and is accesible in Store.Block.Header *)
  Store.Block.Pruned_contents.known (block_store, ha1)
  >|= (fun b -> assert b)
  >>= fun () -> return_unit

(** Chain.set_checkpoint_then_purge_rolling *)

let test_set_checkpoint_then_purge_rolling (s : state) =
  State.Chain.checkpoint s.chain
  >>= fun checkpoint ->
  let checkpoint_lvl = checkpoint.shell.level in
  let checkpoint_hash = Block_header.hash checkpoint in
  (* At the beginning the checkpoint is the genesis. *)
  State.Block.read s.chain genesis_block
  >>=? fun read_genesis ->
  let read_genesis_hash =
    Block_header.hash (State.Block.header read_genesis)
  in
  assert (Block_hash.equal checkpoint_hash read_genesis_hash) ;
  assert (checkpoint_lvl = Int32.zero) ;
  let a1 = vblock s "A1" in
  let ha1 = State.Block.hash a1 in
  let b1 = vblock s "B1" in
  let hb1 = State.Block.hash b1 in
  let b2 = vblock s "B2" in
  let hb2 = State.Block.hash b2 in
  let la1 = State.Block.level a1 in
  let lb1 = State.Block.level b1 in
  let lb2 = State.Block.level b2 in
  assert (Int32.compare checkpoint_lvl la1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb1 = -1) ;
  assert (Int32.compare checkpoint_lvl lb2 = -1) ;
  State.Block.max_operations_ttl b2
  >>=? fun max_op_ttl ->
  assert (max_op_ttl > 0) ;
  let ilb1 = Int32.to_int lb1 in
  let ilb2 = Int32.to_int lb2 in
  (* Assert b1 is in the to-prune range. *)
  assert (ilb2 - ilb1 <= min max_op_ttl ilb2) ;
  (* Assert a1 is in the to-delete range. *)
  let ila1 = Int32.to_int la1 in
  assert (ilb2 - ila1 > min max_op_ttl ilb2) ;
  (* Assert b1 is not yet in Store.Block.Header since not pruned *)
  State.Chain.store s.chain
  >>= fun chain_store ->
  let chain_store = Store.Chain.get chain_store (State.Chain.id s.chain) in
  let block_store = Store.Block.get chain_store in
  Store.Block.Pruned_contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* But accessible with State.Block.Header *)
  State.Block.known s.chain hb1
  >|= (fun b -> assert b)
  (* And Store.Block.Contents *)
  >>= fun () ->
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert b)
  (* Let us set a new checkpoint "B1" whose level is greater than the genesis. *)
  >>= fun () ->
  State.Chain.set_checkpoint_then_purge_rolling s.chain (State.Block.header b2)
  >>=? fun () ->
  (* Assert b2 does still exist and is the new checkpoint. *)
  State.Block.known s.chain hb2
  >|= (fun b -> assert b)
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >|= (fun b ->
        assert (Block_hash.equal (Block_header.hash b) hb2) ;
        assert (Int32.equal b.shell.level lb2))
  >>= fun () ->
  (* Assert b1 has been pruned.. *)
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* pruned, so we can still access its header. *)
  State.Block.read_opt s.chain hb1
  >|= (function Some _block -> assert true | None -> assert false)
  >>= fun () ->
  (* Assert b1 is now in Store.Block.Header since it has been pruned *)
  Store.Block.Pruned_contents.known (block_store, hb1)
  >|= (fun b -> assert b)
  >>= fun () ->
  (* And also accessible with State.Block.Header *)
  State.Block.Header.known (block_store, hb1)
  >|= (fun b -> assert b)
  (* But not in Store.Block.Contents *)
  >>= fun () ->
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* Assert a1 has been deleted.. *)
  State.Block.known s.chain ha1
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* deleted, so we can not access its header anymore. *)
  State.Block.read_opt s.chain ha1
  >|= (function Some _header -> assert false | None -> assert true)
  >>= fun () ->
  (* Assert b1 is now in Store.Block.Header since it has been pruned *)
  Store.Block.Pruned_contents.known (block_store, ha1)
  >|= (fun b -> assert (not b))
  >>= fun () ->
  (* And not in State.Block.Header *)
  State.Block.Header.known (block_store, ha1)
  >|= (fun b -> assert (not b))
  (* Neither in Store.Block.Contents *)
  >>= fun () ->
  Store.Block.Contents.known (block_store, hb1)
  >|= (fun b -> assert (not b))
  (*  *)
  >>= fun () -> return_unit

(****************************************************************************)

(** Chain_traversal.path *)

let rec compare_path p1 p2 =
  match (p1, p2) with
  | ([], []) ->
      true
  | (h1 :: p1, h2 :: p2) ->
      Block_hash.equal h1 h2 && compare_path p1 p2
  | _ ->
      false

let test_path (s : state) =
  let check_path h1 h2 p2 =
    Chain_traversal.path (vblock s h1) (vblock s h2)
    >>= function
    | None ->
        Assert.fail_msg "cannot compute path %s -> %s" h1 h2
    | Some (p : State.Block.t list) ->
        let p = List.map State.Block.hash p in
        let p2 = List.map (fun b -> State.Block.hash (vblock s b)) p2 in
        if not (compare_path p p2) then
          Assert.fail_msg "bad path %s -> %s" h1 h2 ;
        Lwt.return_unit
  in
  check_path "Genesis" "Genesis" []
  >>= fun () ->
  check_path "A1" "A1" []
  >>= fun () ->
  check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"]
  >>= fun () ->
  check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"]
  >>= fun () ->
  check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () -> return_unit

(****************************************************************************)

(** Chain_traversal.common_ancestor *)

let test_ancestor s =
  let check_ancestor h1 h2 expected =
    Chain_traversal.common_ancestor (vblock s h1) (vblock s h2)
    >>= fun a ->
    if not (Block_hash.equal (State.Block.hash a) (State.Block.hash expected))
    then Assert.fail_msg "bad ancestor %s %s" h1 h2 ;
    Lwt.return_unit
  in
  check_ancestor "Genesis" "Genesis" (vblock s "Genesis")
  >>= fun () ->
  check_ancestor "Genesis" "A3" (vblock s "Genesis")
  >>= fun () ->
  check_ancestor "A3" "Genesis" (vblock s "Genesis")
  >>= fun () ->
  check_ancestor "A1" "A1" (vblock s "A1")
  >>= fun () ->
  check_ancestor "A1" "A3" (vblock s "A1")
  >>= fun () ->
  check_ancestor "A3" "A1" (vblock s "A1")
  >>= fun () ->
  check_ancestor "A6" "B6" (vblock s "A3")
  >>= fun () ->
  check_ancestor "B6" "A6" (vblock s "A3")
  >>= fun () ->
  check_ancestor "A4" "B1" (vblock s "A3")
  >>= fun () ->
  check_ancestor "B1" "A4" (vblock s "A3")
  >>= fun () ->
  check_ancestor "A3" "B1" (vblock s "A3")
  >>= fun () ->
  check_ancestor "B1" "A3" (vblock s "A3")
  >>= fun () ->
  check_ancestor "A2" "B1" (vblock s "A2")
  >>= fun () ->
  check_ancestor "B1" "A2" (vblock s "A2") >>= fun () -> return_unit

(****************************************************************************)

let seed =
  let receiver_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 'r')
  in
  let sender_id =
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size 's')
  in
  {Block_locator.receiver_id; sender_id}

(** Chain_traversal.block_locator *)

let test_locator s =
  let check_locator length h1 expected =
    State.compute_locator s.chain ~size:length (vblock s h1) seed
    >>= fun l ->
    let (_, l) = (l : Block_locator.t :> _ * _) in
    if List.length l <> List.length expected then
      Assert.fail_msg
        "Invalid locator length %s (found: %d, expected: %d)"
        h1
        (List.length l)
        (List.length expected) ;
    List.iter2
      (fun h h2 ->
        if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then
          Assert.fail_msg "Invalid locator %s (expected: %s)" h1 h2)
      l
      expected ;
    Lwt.return_unit
  in
  check_locator 6 "A8" ["A7"; "A6"; "A5"; "A4"; "A3"; "A2"]
  >>= fun () ->
  check_locator 8 "B8" ["B7"; "B6"; "B5"; "B4"; "B3"; "B2"; "B1"; "A3"]
  >>= fun () ->
  check_locator 4 "B8" ["B7"; "B6"; "B5"; "B4"]
  >>= fun () ->
  check_locator 0 "A5" []
  >>= fun () ->
  check_locator 100 "A5" ["A4"; "A3"; "A2"; "A1"; "Genesis"]
  >>= fun () -> return_unit

(****************************************************************************)

(** Chain.known_heads *)

let compare s name heads l =
  if List.length heads <> List.length l then
    Assert.fail_msg
      "unexpected known_heads size (%s: %d %d)"
      name
      (List.length heads)
      (List.length l) ;
  List.iter
    (fun bname ->
      let hash = State.Block.hash (vblock s bname) in
      if
        not
          (List.exists
             (fun b -> Block_hash.equal hash (State.Block.hash b))
             heads)
      then Assert.fail_msg "missing block in known_heads (%s: %s)" name bname)
    l

let test_known_heads s =
  Chain.known_heads s.chain
  >>= fun heads ->
  compare s "initial" heads ["A8"; "B8"] ;
  return_unit

(****************************************************************************)

(** Chain.head/set_head *)

let test_head s =
  Chain.head s.chain
  >>= fun head ->
  if not (Block_hash.equal (State.Block.hash head) genesis_block) then
    Assert.fail_msg "unexpected head" ;
  Chain.set_head s.chain (vblock s "A6")
  >>= fun _ ->
  Chain.head s.chain
  >>= fun head ->
  if
    not
      (Block_hash.equal
         (State.Block.hash head)
         (State.Block.hash @@ vblock s "A6"))
  then Assert.fail_msg "unexpected head" ;
  return_unit

(****************************************************************************)

(** Chain.mem *)

let test_mem s =
  let mem s x = Chain.mem s.chain (State.Block.hash @@ vblock s x) in
  let test_mem s x =
    mem s x
    >>= function
    | true -> Lwt.return_unit | false -> Assert.fail_msg "mem %s" x
  in
  let test_not_mem s x =
    mem s x
    >>= function
    | false -> Lwt.return_unit | true -> Assert.fail_msg "not (mem %s)" x
  in
  test_not_mem s "A3"
  >>= fun () ->
  test_not_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_not_mem s "B1"
  >>= fun () ->
  test_not_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "A8")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_mem s "A6"
  >>= fun () ->
  test_mem s "A8"
  >>= fun () ->
  test_not_mem s "B1"
  >>= fun () ->
  test_not_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "A6")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_not_mem s "B1"
  >>= fun () ->
  test_not_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "B6")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_not_mem s "A4"
  >>= fun () ->
  test_not_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_mem s "B1"
  >>= fun () ->
  test_mem s "B6"
  >>= fun () ->
  test_not_mem s "B8"
  >>= fun () ->
  Chain.set_head s.chain (vblock s "B8")
  >>= fun _ ->
  test_mem s "A3"
  >>= fun () ->
  test_not_mem s "A4"
  >>= fun () ->
  test_not_mem s "A6"
  >>= fun () ->
  test_not_mem s "A8"
  >>= fun () ->
  test_mem s "B1"
  >>= fun () ->
  test_mem s "B6" >>= fun () -> test_mem s "B8" >>= fun () -> return_unit

(****************************************************************************)

(** Chain_traversal.new_blocks *)

let test_new_blocks s =
  let test s head h expected_ancestor expected =
    let to_block = vblock s head and from_block = vblock s h in
    Chain_traversal.new_blocks ~from_block ~to_block
    >>= fun (ancestor, blocks) ->
    if
      not
        (Block_hash.equal
           (State.Block.hash ancestor)
           (State.Block.hash @@ vblock s expected_ancestor))
    then
      Assert.fail_msg
        "Invalid ancestor %s -> %s (expected: %s)"
        head
        h
        expected_ancestor ;
    if List.length blocks <> List.length expected then
      Assert.fail_msg
        "Invalid locator length %s (found: %d, expected: %d)"
        h
        (List.length blocks)
        (List.length expected) ;
    List.iter2
      (fun h1 h2 ->
        if
          not
            (Block_hash.equal
               (State.Block.hash h1)
               (State.Block.hash @@ vblock s h2))
        then
          Assert.fail_msg
            "Invalid new blocks %s -> %s (expected: %s)"
            head
            h
            h2)
      blocks
      expected ;
    Lwt.return_unit
  in
  test s "A6" "A6" "A6" []
  >>= fun () ->
  test s "A8" "A6" "A6" ["A7"; "A8"]
  >>= fun () ->
  test s "A8" "B7" "A3" ["A4"; "A5"; "A6"; "A7"; "A8"]
  >>= fun () -> return_unit

(****************************************************************************)

let tests : (string * (state -> unit tzresult Lwt.t)) list =
  [ ("init", test_init);
    ("read_block", test_read_block);
    ("path", test_path);
    ("ancestor", test_ancestor);
    ("locator", test_locator);
    ("known_heads", test_known_heads);
    ("head", test_head);
    ("mem", test_mem);
    ("new_blocks", test_new_blocks);
    ( "set_checkpoint_then_purge_rolling",
      test_set_checkpoint_then_purge_rolling );
    ("set_checkpoint_then_purge_full", test_set_checkpoint_then_purge_full) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
          wrap_state_init f dir
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error error ->
              Format.kasprintf Pervasives.failwith "%a" pp_print_error error))

let tests = List.map wrap tests
src/lib_shell/test/test_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.of_seconds
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
  match Registered_protocol.get genesis_protocol with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some proto => proto
  end.

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition genesis : Tezos_shell.State.Chain.genesis :=
  {| time := genesis_time; block := genesis_block; protocol := genesis_protocol
    |}.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Chain_id.of_block_hash genesis_block.

Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
  let new_fitness :=
    match fitness with
    | cons fitness [] =>
      op_pipegt
        (op_pipegt
          (op_pipegt (Data_encoding.Binary.of_bytes Data_encoding.int64 fitness)
            (Option.unopt
              (* ❌ Constant of type int64 is converted to int *)
              0)) Int64.succ)
        (Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ =>
      Data_encoding.Binary.to_bytes_exn Data_encoding.int64
        (* ❌ Constant of type int64 is converted to int *)
        1
    end in
  cons new_fitness [].

Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.add timestamp
    (Int64.add
      (* ❌ Constant of type int64 is converted to int *)
      1
      (Random.int64
        (* ❌ Constant of type int64 is converted to int *)
        10)).

Definition operation (op : string)
  : Tezos_crypto.Operation_hash.t * Tezos_base__TzPervasives.Operation.t *
    (option Stdlib.Bytes.t) :=
  let op :=
    {| shell := {| branch := genesis_block |};
      proto := Stdlib.Bytes.of_string op |} in
  ((Operation.hash op), op,
    (Data_encoding.Binary.to_bytes Operation.encoding op)).

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  obj1 (req None None "proto_block_header" % string string).

Definition block {A : Type}
  (_state : A) (op_staroptstar : option Tezos_base__TzPervasives.Context_hash.t)
  : (option (list Tezos_base__TzPervasives.Operation_list_hash.elt)) ->
    Tezos_shell.State.Block.t ->
      string -> Tezos_base__TzPervasives.Block_header.t :=
  let context :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Context_hash.zero
    end in
  fun op_staroptstar =>
    let operations :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun pred =>
      fun name =>
        let operations_hash :=
          Operation_list_list_hash.compute
            (cons (Operation_list_hash.compute operations) []) in
        let pred_header := State.Block.shell_header pred in
        let fitness := incr_fitness (fitness pred_header) in
        let timestamp := incr_timestamp (timestamp pred_header) in
        let protocol_data :=
          Data_encoding.Binary.to_bytes_exn block_header_data_encoding name in
        {|
          shell :=
            {| level := Int32.succ (level pred_header);
              proto_level := proto_level pred_header;
              predecessor := State.Block.hash pred; timestamp := timestamp;
              validation_passes := 1; operations_hash := operations_hash;
              fitness := fitness; context := context |};
          protocol_data := protocol_data |}.

Definition parsed_block
  (function_parameter : Tezos_base__TzPervasives.Block_header.t)
  : Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header) :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  let protocol_data :=
    Data_encoding.Binary.of_bytes_exn
      Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
      protocol_data in
  {| shell := shell; protocol_data := protocol_data |}.

Definition zero : string := Stdlib.Bytes.create 0.

Definition build_valid_chain
  (state : Tezos_shell__State.Chain.t)
  (vtbl : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t)
  (pred : Tezos_shell.State.Block.t) (names : list string) : Lwt.t unit :=
  op_gtgteq
    (Lwt_list.fold_left_s
      (fun pred =>
        fun name =>
          op_gtgteq (State.Block.context_exn pred)
            (fun predecessor_context =>
              let max_trials := 100 in
              let fix attempt
                (trials : Z) (context :
                option Tezos_base__TzPervasives.Context_hash.t)
                : Lwt.t Tezos_shell.State.Block.t :=
                op_gtgteq
                  (let '(oph, op, _bytes) := operation name in
                  let block :=
                    block state context (Some (cons oph [])) pred name in
                  let hash := Block_header.hash block in
                  let pred_header := State.Block.header pred in
                  op_gtgteqquestion
                    (let predecessor_context :=
                      Shell_context.wrap_disk_context predecessor_context in
                    op_gtgteqquestion
                      (Proto.(Tezos_protocol_updater__Registered_protocol.T.begin_application)
                        Chain_id.zero predecessor_context
                        (timestamp (shell pred_header))
                        (fitness (shell pred_header)) (parsed_block block))
                      (fun vstate =>
                        Proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
                          vstate))
                    (fun function_parameter =>
                      let '(result, _metadata) := function_parameter in
                      let context :=
                        Shell_context.unwrap_disk_context (context result) in
                      op_gtgteq
                        (Context.commit (timestamp (shell block)) None context)
                        (fun context_hash =>
                          let validation_store :=
                            {| context_hash := context_hash;
                              message := message result;
                              max_operations_ttl := 1;
                              last_allowed_fork_level :=
                                last_allowed_fork_level result |} in
                          op_gtgteqquestion
                            (State.Block.store None state block zero
                              (cons (cons op []) []) (cons (cons zero []) [])
                              {| context_hash := context_hash;
                                message := message validation_store;
                                max_operations_ttl := 1;
                                last_allowed_fork_level :=
                                  last_allowed_fork_level validation_store |}
                              false)
                            (fun _vblock =>
                              op_gtgteqquestion (State.Block.read state hash)
                                (fun vblock =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ := Hashtbl.add vtbl name vblock in
                                  _return vblock)))))
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Ok v =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        if OCaml.Stdlib.lt trials max_trials then
                          Format.eprintf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Took " % string
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " trials to build valid chain" % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Took %d trials to build valid chain" % string)
                            (Z.add (Z.sub max_trials trials) 1)
                        else
                          tt in
                      Lwt._return v
                    |
                      Stdlib.Error
                        (cons (Tezos_base__TzPervasives.Inconsistent_hash got _)
                          _) =>
                      if OCaml.Stdlib.le trials 0 then
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      else
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          Format.eprintf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Inconsistent context hash: got " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    ", retrying (" % string
                                    (CamlinternalFormatBasics.Int
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      (CamlinternalFormatBasics.String_literal
                                        ")
" % string
                                        CamlinternalFormatBasics.End_of_format)))))
                              "Inconsistent context hash: got %a, retrying (%d)
"
                                % string) Context_hash.pp got trials in
                        attempt (Z.sub trials 1) (Some got)
                    | Stdlib.Error err =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Format.eprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Error: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  "010" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "Error: %a
" % string) Error_monad.pp_print_error
                          err in
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    end) in
              attempt max_trials None)) pred names)
    (fun function_parameter =>
      let '_ := function_parameter in
      Lwt.return_unit).

Record state := {
  vblock : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t;
  state : Tezos_shell.State.t;
  chain : Tezos_shell.State.Chain.t }.

Definition vblock (s : state) : string -> Tezos_shell.State.Block.t :=
  Hashtbl.find (vblock s).

(* ❌ The definition of exceptions is not handled. *)
exception

Definition vblocks (s : state) : list (string * Tezos_shell.State.Block.t) :=
  OCaml.Stdlib.reverse_apply
    (Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) (vblock s) [])
    (List.sort Pervasives.compare).

Definition build_example_tree (chain : Tezos_shell.State.Chain.t)
  : Lwt.t (Stdlib.Hashtbl.t string Tezos_shell.State.Block.t) :=
  let vtbl := Hashtbl.create None 23 in
  op_gtgteq (Chain.genesis chain)
    (fun genesis =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Hashtbl.add vtbl "Genesis" % string genesis in
      let c :=
        cons "A1" % string
          (cons "A2" % string
            (cons "A3" % string
              (cons "A4" % string
                (cons "A5" % string
                  (cons "A6" % string
                    (cons "A7" % string (cons "A8" % string []))))))) in
      op_gtgteq (build_valid_chain chain vtbl genesis c)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let a3 := Hashtbl.find vtbl "A3" % string in
          let c :=
            cons "B1" % string
              (cons "B2" % string
                (cons "B3" % string
                  (cons "B4" % string
                    (cons "B5" % string
                      (cons "B6" % string
                        (cons "B7" % string (cons "B8" % string []))))))) in
          op_gtgteq (build_valid_chain chain vtbl a3 c)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt._return vtbl))).

Definition wrap_state_init {A : Type}
  (f : state -> Lwt.t (Tezos_base__TzPervasives.tzresult A)) (base_dir : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  let store_root := op_divdiv base_dir "store" % string in
  let context_root := op_divdiv base_dir "context" % string in
  op_gtgteqquestion
    (State.init None None
      (Some
        (* ❌ Constant of type int64 is converted to int *)
        4096000000)
      (Some
        (* ❌ Constant of type int64 is converted to int *)
        4096000000) store_root context_root None genesis)
    (fun function_parameter =>
      let '(state, chain, _index, _history_mode) := function_parameter in
      op_gtgteq (build_example_tree chain)
        (fun vblock => f {| vblock := vblock; state := state; chain := chain |})).

Definition test_init (function_parameter : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '_ := function_parameter in
  return_unit.

Definition test_read_block (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    (Lwt_list.iter_s
      (fun function_parameter =>
        let '(name, vblock) := function_parameter in
        let hash := State.Block.hash vblock in
        op_gtgteq (State.Block.read (chain s) hash)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error _ =>
              op_startypeminuserrorstar
                "Error while reading valid block %s" % string name
            | Stdlib.Ok _vblock' => Lwt.return_unit
            end)) (vblocks s))
    (fun function_parameter =>
      let 'tt := function_parameter in
      return_unit).

Definition test_set_checkpoint_then_purge_full (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (State.Chain.checkpoint (chain s))
    (fun checkpoint =>
      let checkpoint_lvl := level (shell checkpoint) in
      let checkpoint_hash := Block_header.hash checkpoint in
      op_gtgteqquestion (State.Block.read (chain s) genesis_block)
        (fun read_genesis =>
          let read_genesis_hash :=
            Block_header.hash (State.Block.header read_genesis) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (Block_hash.equal checkpoint_hash read_genesis_hash) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb checkpoint_lvl Int32.zero) in
          let a1 := vblock s "A1" % string in
          let ha1 := State.Block.hash a1 in
          let b1 := vblock s "B1" % string in
          let hb1 := State.Block.hash b1 in
          let b2 := vblock s "B2" % string in
          let hb2 := State.Block.hash b2 in
          let la1 := State.Block.level a1 in
          let lb1 := State.Block.level b1 in
          let lb2 := State.Block.level b2 in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (Int32.compare checkpoint_lvl la1) (-1)) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (Int32.compare checkpoint_lvl lb1) (-1)) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (Int32.compare checkpoint_lvl lb2) (-1)) in
          op_gtgteq (State.Chain.store (chain s))
            (fun chain_store =>
              let chain_store :=
                Store.Chain.get chain_store (State.Chain.id (chain s)) in
              let block_store := Store.Block.get chain_store in
              op_gtgteqquestion
                (State.Chain.set_checkpoint_then_purge_full (chain s)
                  (State.Block.header b2))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (op_gtpipeeq (State.Block.known (chain s) hb2)
                      (fun b =>
                        (* ❌ Assert instruction is not handled. *)
                        assert b))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (op_gtpipeeq (State.Chain.checkpoint (chain s))
                          (fun b =>
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              (* ❌ Assert instruction is not handled. *)
                              assert
                                (Block_hash.equal (Block_header.hash b) hb2) in
                            (* ❌ Assert instruction is not handled. *)
                            assert (Int32.equal (level (shell b)) lb2)))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (op_gtpipeeq
                              (Store.Block.Contents.known (block_store, hb1))
                              (fun b =>
                                (* ❌ Assert instruction is not handled. *)
                                assert (negb b)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (op_gtpipeeq
                                  (State.Block.read_opt (chain s) hb1)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Some _header =>
                                      (* ❌ Assert instruction is not handled. *)
                                      assert true
                                    | None =>
                                      (* ❌ Assert instruction is not handled. *)
                                      assert false
                                    end))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (op_gtpipeeq
                                      (Store.Block.Contents.known
                                        (block_store, ha1))
                                      (fun b =>
                                        (* ❌ Assert instruction is not handled. *)
                                        assert (negb b)))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (op_gtpipeeq
                                          (State.Block.read_opt (chain s) ha1)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | Some _header =>
                                              (* ❌ Assert instruction is not handled. *)
                                              assert true
                                            | None =>
                                              (* ❌ Assert instruction is not handled. *)
                                              assert false
                                            end))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (op_gtpipeeq
                                              (Store.Block.Pruned_contents.known
                                                (block_store, ha1))
                                              (fun b =>
                                                (* ❌ Assert instruction is not handled. *)
                                                assert b))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              return_unit))))))))))).

Definition test_set_checkpoint_then_purge_rolling (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (State.Chain.checkpoint (chain s))
    (fun checkpoint =>
      let checkpoint_lvl := level (shell checkpoint) in
      let checkpoint_hash := Block_header.hash checkpoint in
      op_gtgteqquestion (State.Block.read (chain s) genesis_block)
        (fun read_genesis =>
          let read_genesis_hash :=
            Block_header.hash (State.Block.header read_genesis) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (Block_hash.equal checkpoint_hash read_genesis_hash) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb checkpoint_lvl Int32.zero) in
          let a1 := vblock s "A1" % string in
          let ha1 := State.Block.hash a1 in
          let b1 := vblock s "B1" % string in
          let hb1 := State.Block.hash b1 in
          let b2 := vblock s "B2" % string in
          let hb2 := State.Block.hash b2 in
          let la1 := State.Block.level a1 in
          let lb1 := State.Block.level b1 in
          let lb2 := State.Block.level b2 in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (Int32.compare checkpoint_lvl la1) (-1)) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (Int32.compare checkpoint_lvl lb1) (-1)) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb (Int32.compare checkpoint_lvl lb2) (-1)) in
          op_gtgteqquestion (State.Block.max_operations_ttl b2)
            (fun max_op_ttl =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Assert instruction is not handled. *)
                assert (OCaml.Stdlib.gt max_op_ttl 0) in
              let ilb1 := Int32.to_int lb1 in
              let ilb2 := Int32.to_int lb2 in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Assert instruction is not handled. *)
                assert
                  (OCaml.Stdlib.le (Z.sub ilb2 ilb1)
                    (OCaml.Stdlib.min max_op_ttl ilb2)) in
              let ila1 := Int32.to_int la1 in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Assert instruction is not handled. *)
                assert
                  (OCaml.Stdlib.gt (Z.sub ilb2 ila1)
                    (OCaml.Stdlib.min max_op_ttl ilb2)) in
              op_gtgteq (State.Chain.store (chain s))
                (fun chain_store =>
                  let chain_store :=
                    Store.Chain.get chain_store (State.Chain.id (chain s)) in
                  let block_store := Store.Block.get chain_store in
                  op_gtgteq
                    (op_gtpipeeq
                      (Store.Block.Pruned_contents.known (block_store, hb1))
                      (fun b =>
                        (* ❌ Assert instruction is not handled. *)
                        assert (negb b)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (op_gtpipeeq (State.Block.known (chain s) hb1)
                          (fun b =>
                            (* ❌ Assert instruction is not handled. *)
                            assert b))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (op_gtpipeeq
                              (Store.Block.Contents.known (block_store, hb1))
                              (fun b =>
                                (* ❌ Assert instruction is not handled. *)
                                assert b))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (State.Chain.set_checkpoint_then_purge_rolling
                                  (chain s) (State.Block.header b2))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (op_gtpipeeq
                                      (State.Block.known (chain s) hb2)
                                      (fun b =>
                                        (* ❌ Assert instruction is not handled. *)
                                        assert b))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (op_gtpipeeq
                                          (State.Chain.checkpoint (chain s))
                                          (fun b =>
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            let _ :=
                                              (* ❌ Assert instruction is not handled. *)
                                              assert
                                                (Block_hash.equal
                                                  (Block_header.hash b) hb2) in
                                            (* ❌ Assert instruction is not handled. *)
                                            assert
                                              (Int32.equal (level (shell b)) lb2)))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (op_gtpipeeq
                                              (Store.Block.Contents.known
                                                (block_store, hb1))
                                              (fun b =>
                                                (* ❌ Assert instruction is not handled. *)
                                                assert (negb b)))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                (op_gtpipeeq
                                                  (State.Block.read_opt
                                                    (chain s) hb1)
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | Some _block =>
                                                      (* ❌ Assert instruction is not handled. *)
                                                      assert true
                                                    | None =>
                                                      (* ❌ Assert instruction is not handled. *)
                                                      assert false
                                                    end))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteq
                                                    (op_gtpipeeq
                                                      (Store.Block.Pruned_contents.known
                                                        (block_store, hb1))
                                                      (fun b =>
                                                        (* ❌ Assert instruction is not handled. *)
                                                        assert b))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        (op_gtpipeeq
                                                          (State.Block.Header.known
                                                            (block_store, hb1))
                                                          (fun b =>
                                                            (* ❌ Assert instruction is not handled. *)
                                                            assert b))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_gtgteq
                                                            (op_gtpipeeq
                                                              (Store.Block.Contents.known
                                                                (block_store,
                                                                  hb1))
                                                              (fun b =>
                                                                (* ❌ Assert instruction is not handled. *)
                                                                assert (negb b)))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteq
                                                                (op_gtpipeeq
                                                                  (State.Block.known
                                                                    (chain s)
                                                                    ha1)
                                                                  (fun b =>
                                                                    (* ❌ Assert instruction is not handled. *)
                                                                    assert
                                                                      (negb b)))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_gtgteq
                                                                    (op_gtpipeeq
                                                                      (State.Block.read_opt
                                                                        (chain s)
                                                                        ha1)
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        match
                                                                          function_parameter
                                                                          with
                                                                        |
                                                                          Some
                                                                            _header
                                                                          =>
                                                                          (* ❌ Assert instruction is not handled. *)
                                                                          assert
                                                                            false
                                                                        | None
                                                                          =>
                                                                          (* ❌ Assert instruction is not handled. *)
                                                                          assert
                                                                            true
                                                                        end))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_gtgteq
                                                                        (op_gtpipeeq
                                                                          (Store.Block.Pruned_contents.known
                                                                            (block_store,
                                                                              ha1))
                                                                          (fun b
                                                                            =>
                                                                            (* ❌ Assert instruction is not handled. *)
                                                                            assert
                                                                              (negb
                                                                                b)))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_gtgteq
                                                                            (op_gtpipeeq
                                                                              (State.Block.Header.known
                                                                                (block_store,
                                                                                  ha1))
                                                                              (fun
                                                                                b
                                                                                =>
                                                                                (* ❌ Assert instruction is not handled. *)
                                                                                assert
                                                                                  (negb
                                                                                    b)))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_gtgteq
                                                                                (op_gtpipeeq
                                                                                  (Store.Block.Contents.known
                                                                                    (block_store,
                                                                                      hb1))
                                                                                  (fun
                                                                                    b
                                                                                    =>
                                                                                    (* ❌ Assert instruction is not handled. *)
                                                                                    assert
                                                                                      (negb
                                                                                        b)))
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  return_unit)))))))))))))))))))).

Fixpoint compare_path
  (p1 : list Tezos_base__TzPervasives.Block_hash.t)
  (p2 : list Tezos_base__TzPervasives.Block_hash.t) : bool :=
  match (p1, p2) with
  | ([], []) => true
  | (cons h1 p1, cons h2 p2) =>
    andb (Block_hash.equal h1 h2) (compare_path p1 p2)
  | _ => false
  end.

Definition test_path (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let check_path (h1 : string) (h2 : string) (p2 : list string) : Lwt.t unit :=
    op_gtgteq (Chain_traversal.path (vblock s h1) (vblock s h2))
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_startypeminuserrorstar "cannot compute path %s -> %s" % string h1
            h2
        | Some (_ as p) =>
          let p := List.map State.Block.hash p in
          let p2 := List.map (fun b => State.Block.hash (vblock s b)) p2 in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if negb (compare_path p p2) then
              op_startypeminuserrorstar "bad path %s -> %s" % string h1 h2
            else
              tt in
          Lwt.return_unit
        end) in
  op_gtgteq (check_path "Genesis" % string "Genesis" % string [])
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (check_path "A1" % string "A1" % string [])
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (check_path "A2" % string "A6" % string
              (cons "A3" % string
                (cons "A4" % string (cons "A5" % string (cons "A6" % string [])))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (check_path "B2" % string "B6" % string
                  (cons "B3" % string
                    (cons "B4" % string
                      (cons "B5" % string (cons "B6" % string [])))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (check_path "A1" % string "B3" % string
                      (cons "A2" % string
                        (cons "A3" % string
                          (cons "B1" % string
                            (cons "B2" % string (cons "B3" % string []))))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit))))).

Definition test_ancestor (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let check_ancestor
    (h1 : string) (h2 : string) (expected : Tezos_shell.State.Block.t)
    : Lwt.t unit :=
    op_gtgteq (Chain_traversal.common_ancestor (vblock s h1) (vblock s h2))
      (fun a =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if
            negb
              (Block_hash.equal (State.Block.hash a) (State.Block.hash expected))
            then
            op_startypeminuserrorstar "bad ancestor %s %s" % string h1 h2
          else
            tt in
        Lwt.return_unit) in
  op_gtgteq
    (check_ancestor "Genesis" % string "Genesis" % string
      (vblock s "Genesis" % string))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (check_ancestor "Genesis" % string "A3" % string
          (vblock s "Genesis" % string))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (check_ancestor "A3" % string "Genesis" % string
              (vblock s "Genesis" % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (check_ancestor "A1" % string "A1" % string
                  (vblock s "A1" % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (check_ancestor "A1" % string "A3" % string
                      (vblock s "A1" % string))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (check_ancestor "A3" % string "A1" % string
                          (vblock s "A1" % string))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (check_ancestor "A6" % string "B6" % string
                              (vblock s "A3" % string))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (check_ancestor "B6" % string "A6" % string
                                  (vblock s "A3" % string))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (check_ancestor "A4" % string "B1" % string
                                      (vblock s "A3" % string))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (check_ancestor "B1" % string
                                          "A4" % string (vblock s "A3" % string))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (check_ancestor "A3" % string
                                              "B1" % string
                                              (vblock s "A3" % string))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                (check_ancestor "B1" % string
                                                  "A3" % string
                                                  (vblock s "A3" % string))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteq
                                                    (check_ancestor
                                                      "A2" % string
                                                      "B1" % string
                                                      (vblock s "A2" % string))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        (check_ancestor
                                                          "B1" % string
                                                          "A2" % string
                                                          (vblock s
                                                            "A2" % string))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          return_unit)))))))))))))).

Definition seed : Tezos_base__TzPervasives.Block_locator.seed :=
  let receiver_id :=
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "r" % char) in
  let sender_id :=
    P2p_peer.Id.of_string_exn (String.make P2p_peer.Id.size "s" % char) in
  {| Block_locator.sender_id := sender_id;
    Block_locator.receiver_id := receiver_id |}.

Definition test_locator (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let check_locator (length : Z) (h1 : string) (expected : list string)
    : Lwt.t unit :=
    op_gtgteq (State.compute_locator (chain s) (Some length) (vblock s h1) seed)
      (fun l =>
        let '(_, l) := l in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if nequiv_decb (List.length l) (List.length expected) then
            op_startypeminuserrorstar
              "Invalid locator length %s (found: %d, expected: %d)" % string h1
              (List.length l) (List.length expected)
          else
            tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          List.iter2
            (fun h =>
              fun h2 =>
                if
                  negb
                    (Block_hash.equal h (apply State.Block.hash (vblock s h2)))
                  then
                  op_startypeminuserrorstar
                    "Invalid locator %s (expected: %s)" % string h1 h2
                else
                  tt) l expected in
        Lwt.return_unit) in
  op_gtgteq
    (check_locator 6 "A8" % string
      (cons "A7" % string
        (cons "A6" % string
          (cons "A5" % string
            (cons "A4" % string (cons "A3" % string (cons "A2" % string [])))))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (check_locator 8 "B8" % string
          (cons "B7" % string
            (cons "B6" % string
              (cons "B5" % string
                (cons "B4" % string
                  (cons "B3" % string
                    (cons "B2" % string
                      (cons "B1" % string (cons "A3" % string [])))))))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (check_locator 4 "B8" % string
              (cons "B7" % string
                (cons "B6" % string (cons "B5" % string (cons "B4" % string [])))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (check_locator 0 "A5" % string [])
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (check_locator 100 "A5" % string
                      (cons "A4" % string
                        (cons "A3" % string
                          (cons "A2" % string
                            (cons "A1" % string (cons "Genesis" % string []))))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit))))).

Definition compare {A : Type}
  (s : state) (name : A) (heads : list Tezos_shell.State.Block.t)
  (l : list string) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if nequiv_decb (List.length heads) (List.length l) then
      op_startypeminuserrorstar
        "unexpected known_heads size (%s: %d %d)" % string name
        (List.length heads) (List.length l)
    else
      tt in
  List.iter
    (fun bname =>
      let hash := State.Block.hash (vblock s bname) in
      if
        negb
          (List._exists (fun b => Block_hash.equal hash (State.Block.hash b))
            heads) then
        op_startypeminuserrorstar
          "missing block in known_heads (%s: %s)" % string name bname
      else
        tt) l.

Definition test_known_heads (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (Chain.known_heads (chain s))
    (fun heads =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        compare s "initial" % string heads
          (cons "A8" % string (cons "B8" % string [])) in
      return_unit).

Definition test_head (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (Chain.head (chain s))
    (fun head =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if negb (Block_hash.equal (State.Block.hash head) genesis_block) then
          op_startypeminuserrorstar "unexpected head" % string
        else
          tt in
      op_gtgteq (Chain.set_head (chain s) (vblock s "A6" % string))
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteq (Chain.head (chain s))
            (fun head =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                if
                  negb
                    (Block_hash.equal (State.Block.hash head)
                      (apply State.Block.hash (vblock s "A6" % string))) then
                  op_startypeminuserrorstar "unexpected head" % string
                else
                  tt in
              return_unit))).

Definition test_mem (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let mem (s : state) (x : string) : Lwt.t bool :=
    Chain.mem (chain s) (apply State.Block.hash (vblock s x)) in
  let test_mem (s : state) (x : string) : Lwt.t unit :=
    op_gtgteq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | true => Lwt.return_unit
        | false => op_startypeminuserrorstar "mem %s" % string x
        end) in
  let test_not_mem (s : state) (x : string) : Lwt.t unit :=
    op_gtgteq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | false => Lwt.return_unit
        | true => op_startypeminuserrorstar "not (mem %s)" % string x
        end) in
  op_gtgteq (test_not_mem s "A3" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (test_not_mem s "A6" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (test_not_mem s "A8" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (test_not_mem s "B1" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq (test_not_mem s "B6" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq (test_not_mem s "B8" % string)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (Chain.set_head (chain s) (vblock s "A8" % string))
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              op_gtgteq (test_mem s "A3" % string)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq (test_mem s "A6" % string)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq (test_mem s "A8" % string)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (test_not_mem s "B1" % string)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                (test_not_mem s "B6" % string)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteq
                                                    (test_not_mem s
                                                      "B8" % string)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        (Chain.set_head
                                                          (chain s)
                                                          (vblock s
                                                            "A6" % string))
                                                        (fun function_parameter
                                                          =>
                                                          let '_ :=
                                                            function_parameter
                                                            in
                                                          op_gtgteq
                                                            (test_mem s
                                                              "A3" % string)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteq
                                                                (test_mem s
                                                                  "A6" % string)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_gtgteq
                                                                    (test_not_mem
                                                                      s
                                                                      "A8" %
                                                                        string)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_gtgteq
                                                                        (test_not_mem
                                                                          s
                                                                          "B1" %
                                                                            string)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_gtgteq
                                                                            (test_not_mem
                                                                              s
                                                                              "B6"
                                                                                %
                                                                                string)
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                'tt :=
                                                                                function_parameter
                                                                                in
                                                                              op_gtgteq
                                                                                (test_not_mem
                                                                                  s
                                                                                  "B8"
                                                                                    %
                                                                                    string)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  op_gtgteq
                                                                                    (Chain.set_head
                                                                                      (chain
                                                                                        s)
                                                                                      (vblock
                                                                                        s
                                                                                        "B6"
                                                                                          %
                                                                                          string))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        '_ :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_gtgteq
                                                                                        (test_mem
                                                                                          s
                                                                                          "A3"
                                                                                            %
                                                                                            string)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            'tt :=
                                                                                            function_parameter
                                                                                            in
                                                                                          op_gtgteq
                                                                                            (test_not_mem
                                                                                              s
                                                                                              "A4"
                                                                                                %
                                                                                                string)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                'tt :=
                                                                                                function_parameter
                                                                                                in
                                                                                              op_gtgteq
                                                                                                (test_not_mem
                                                                                                  s
                                                                                                  "A6"
                                                                                                    %
                                                                                                    string)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  op_gtgteq
                                                                                                    (test_not_mem
                                                                                                      s
                                                                                                      "A8"
                                                                                                        %
                                                                                                        string)
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        'tt :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      op_gtgteq
                                                                                                        (test_mem
                                                                                                          s
                                                                                                          "B1"
                                                                                                            %
                                                                                                            string)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_gtgteq
                                                                                                            (test_mem
                                                                                                              s
                                                                                                              "B6"
                                                                                                                %
                                                                                                                string)
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                'tt :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_gtgteq
                                                                                                                (test_not_mem
                                                                                                                  s
                                                                                                                  "B8"
                                                                                                                    %
                                                                                                                    string)
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_gtgteq
                                                                                                                    (Chain.set_head
                                                                                                                      (chain
                                                                                                                        s)
                                                                                                                      (vblock
                                                                                                                        s
                                                                                                                        "B8"
                                                                                                                          %
                                                                                                                          string))
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        '_ :=
                                                                                                                        function_parameter
                                                                                                                        in
                                                                                                                      op_gtgteq
                                                                                                                        (test_mem
                                                                                                                          s
                                                                                                                          "A3"
                                                                                                                            %
                                                                                                                            string)
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          let
                                                                                                                            'tt :=
                                                                                                                            function_parameter
                                                                                                                            in
                                                                                                                          op_gtgteq
                                                                                                                            (test_not_mem
                                                                                                                              s
                                                                                                                              "A4"
                                                                                                                                %
                                                                                                                                string)
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              let
                                                                                                                                'tt :=
                                                                                                                                function_parameter
                                                                                                                                in
                                                                                                                              op_gtgteq
                                                                                                                                (test_not_mem
                                                                                                                                  s
                                                                                                                                  "A6"
                                                                                                                                    %
                                                                                                                                    string)
                                                                                                                                (fun
                                                                                                                                  function_parameter
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    'tt :=
                                                                                                                                    function_parameter
                                                                                                                                    in
                                                                                                                                  op_gtgteq
                                                                                                                                    (test_not_mem
                                                                                                                                      s
                                                                                                                                      "A8"
                                                                                                                                        %
                                                                                                                                        string)
                                                                                                                                    (fun
                                                                                                                                      function_parameter
                                                                                                                                      =>
                                                                                                                                      let
                                                                                                                                        'tt :=
                                                                                                                                        function_parameter
                                                                                                                                        in
                                                                                                                                      op_gtgteq
                                                                                                                                        (test_mem
                                                                                                                                          s
                                                                                                                                          "B1"
                                                                                                                                            %
                                                                                                                                            string)
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          let
                                                                                                                                            'tt :=
                                                                                                                                            function_parameter
                                                                                                                                            in
                                                                                                                                          op_gtgteq
                                                                                                                                            (test_mem
                                                                                                                                              s
                                                                                                                                              "B6"
                                                                                                                                                %
                                                                                                                                                string)
                                                                                                                                            (fun
                                                                                                                                              function_parameter
                                                                                                                                              =>
                                                                                                                                              let
                                                                                                                                                'tt :=
                                                                                                                                                function_parameter
                                                                                                                                                in
                                                                                                                                              op_gtgteq
                                                                                                                                                (test_mem
                                                                                                                                                  s
                                                                                                                                                  "B8"
                                                                                                                                                    %
                                                                                                                                                    string)
                                                                                                                                                (fun
                                                                                                                                                  function_parameter
                                                                                                                                                  =>
                                                                                                                                                  let
                                                                                                                                                    'tt :=
                                                                                                                                                    function_parameter
                                                                                                                                                    in
                                                                                                                                                  return_unit)))))))))))))))))))))))))))))))))))).

Definition test_new_blocks (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let test
    (s : state) (head : string) (h : string) (expected_ancestor : string)
    (expected : list string) : Lwt.t unit :=
    let to_block : Tezos_shell.State.Block.t :=
      vblock s head
    with from_block : Tezos_shell.State.Block.t :=
      vblock s h in
    op_gtgteq (Chain_traversal.new_blocks from_block to_block)
      (fun function_parameter =>
        let '(ancestor, blocks) := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if
            negb
              (Block_hash.equal (State.Block.hash ancestor)
                (apply State.Block.hash (vblock s expected_ancestor))) then
            op_startypeminuserrorstar
              "Invalid ancestor %s -> %s (expected: %s)" % string head h
              expected_ancestor
          else
            tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          if nequiv_decb (List.length blocks) (List.length expected) then
            op_startypeminuserrorstar
              "Invalid locator length %s (found: %d, expected: %d)" % string h
              (List.length blocks) (List.length expected)
          else
            tt in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          List.iter2
            (fun h1 =>
              fun h2 =>
                if
                  negb
                    (Block_hash.equal (State.Block.hash h1)
                      (apply State.Block.hash (vblock s h2))) then
                  op_startypeminuserrorstar
                    "Invalid new blocks %s -> %s (expected: %s)" % string head h
                    h2
                else
                  tt) blocks expected in
        Lwt.return_unit) in
  op_gtgteq (test s "A6" % string "A6" % string "A6" % string [])
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (test s "A8" % string "A6" % string "A6" % string
          (cons "A7" % string (cons "A8" % string [])))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (test s "A8" % string "B7" % string "A3" % string
              (cons "A4" % string
                (cons "A5" % string
                  (cons "A6" % string
                    (cons "A7" % string (cons "A8" % string []))))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit))).

Definition tests
  : list (string * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  cons ("init" % string, test_init)
    (cons ("read_block" % string, test_read_block)
      (cons ("path" % string, test_path)
        (cons ("ancestor" % string, test_ancestor)
          (cons ("locator" % string, test_locator)
            (cons ("known_heads" % string, test_known_heads)
              (cons ("head" % string, test_head)
                (cons ("mem" % string, test_mem)
                  (cons ("new_blocks" % string, test_new_blocks)
                    (cons
                      ("set_checkpoint_then_purge_rolling" % string,
                        test_set_checkpoint_then_purge_rolling)
                      (cons
                        ("set_checkpoint_then_purge_full" % string,
                          test_set_checkpoint_then_purge_full) [])))))))))).

Definition wrap {A B : Type}
  (function_parameter :
    A * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) : B :=
  let '(n, f) := function_parameter in
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun dir =>
            op_gtgteq (wrap_state_init f dir)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => Lwt.return_unit
                | Stdlib.Error error =>
                  Format.kasprintf Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    pp_print_error error
                end))).

Definition tests {A : Type} : list A := List.map wrap tests.

src/lib_shell/test/test_state_checkpoint.ml 107 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let proto =
  match Registered_protocol.get genesis_protocol with
  | None ->
      assert false
  | Some proto ->
      proto

module Proto = (val proto)

let genesis : State.Chain.genesis =
  {time = genesis_time; block = genesis_block; protocol = genesis_protocol}

let incr_fitness fitness =
  let new_fitness =
    match fitness with
    | [fitness] ->
        Pervasives.(
          Data_encoding.Binary.of_bytes Data_encoding.int64 fitness
          |> Option.unopt ~default:0L |> Int64.succ
          |> Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ ->
        Data_encoding.Binary.to_bytes_exn Data_encoding.int64 1L
  in
  [new_fitness]

let incr_timestamp timestamp =
  Time.Protocol.add timestamp (Int64.add 1L (Random.int64 10L))

let operation op =
  let op : Operation.t =
    {shell = {branch = genesis_block}; proto = Bytes.of_string op}
  in
  (Operation.hash op, op, Data_encoding.Binary.to_bytes Operation.encoding op)

let block_header_data_encoding =
  Data_encoding.(obj1 (req "proto_block_header" string))

let block _state ?(context = Context_hash.zero) ?(operations = [])
    (pred : State.Block.t) name : Block_header.t =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let pred_header = State.Block.shell_header pred in
  let fitness = incr_fitness pred_header.fitness in
  let timestamp = incr_timestamp pred_header.timestamp in
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn block_header_data_encoding name
  in
  {
    shell =
      {
        level = Int32.succ pred_header.level;
        proto_level = pred_header.proto_level;
        predecessor = State.Block.hash pred;
        validation_passes = 1;
        timestamp;
        operations_hash;
        fitness;
        context;
      };
    protocol_data;
  }

let parsed_block ({shell; protocol_data} : Block_header.t) =
  let protocol_data =
    Data_encoding.Binary.of_bytes_exn
      Proto.block_header_data_encoding
      protocol_data
  in
  ({shell; protocol_data} : Proto.block_header)

let zero = Bytes.create 0

let block_header_data_encoding =
  Data_encoding.(obj1 (req "proto_block_header" string))

let build_valid_chain state vtbl pred names =
  Lwt_list.fold_left_s
    (fun pred name ->
      State.Block.context_exn pred
      >>= fun predecessor_context ->
      let max_trials = 100 in
      let rec attempt trials context =
        (let (oph, op, _bytes) = operation name in
         let block = block ?context state ~operations:[oph] pred name in
         let hash = Block_header.hash block in
         let pred_header = State.Block.header pred in
         (let predecessor_context =
            Shell_context.wrap_disk_context predecessor_context
          in
          Proto.begin_application
            ~chain_id:Chain_id.zero
            ~predecessor_context
            ~predecessor_timestamp:pred_header.shell.timestamp
            ~predecessor_fitness:pred_header.shell.fitness
            (parsed_block block)
          >>=? fun vstate ->
          (* no operations *)
          Proto.finalize_block vstate)
         >>=? fun (result, _metadata) ->
         let context = Shell_context.unwrap_disk_context result.context in
         Context.commit
           ~time:(Time.System.to_protocol (Systime_os.now ()))
           ?message:result.message
           context
         >>= fun context_hash ->
         let validation_store =
           ( {
               context_hash;
               message = result.message;
               max_operations_ttl = result.max_operations_ttl;
               last_allowed_fork_level = result.last_allowed_fork_level;
             }
             : Tezos_validation.Block_validation.validation_store )
         in
         State.Block.store
           state
           block
           zero
           [[op]]
           [[zero]]
           validation_store
           ~forking_testchain:false
         >>=? fun _vblock ->
         State.Block.read state hash
         >>=? fun vblock ->
         Hashtbl.add vtbl name vblock ;
         return vblock)
        >>= function
        | Ok v ->
            if trials < max_trials then
              Format.eprintf
                "Took %d trials to build valid chain"
                (max_trials - trials + 1) ;
            Lwt.return v
        | Error (Validation_errors.Inconsistent_hash (got, _) :: _) ->
            (* Kind of a hack, but at least it tests idempotence to some extent. *)
            if trials <= 0 then assert false
            else (
              Format.eprintf
                "Inconsistent context hash: got %a, retrying (%d)\n"
                Context_hash.pp
                got
                trials ;
              attempt (trials - 1) (Some got) )
        | Error err ->
            Format.eprintf "Error: %a\n" Error_monad.pp_print_error err ;
            assert false
      in
      attempt max_trials None)
    pred
    names
  >>= fun _ -> Lwt.return_unit

type state = {
  vblock : (string, State.Block.t) Hashtbl.t;
  state : State.t;
  chain : State.Chain.t;
}

let vblock s = Hashtbl.find s.vblock

exception Found of string

let vblocks s =
  Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.vblock []
  |> List.sort Pervasives.compare

(*******************************************************)
(*

    Genesis - A1 - A2 - A3 - A4 - A5
                    \
                     B1 - B2 - B3 - B4 - B5
*)

let build_example_tree chain =
  let vtbl = Hashtbl.create 23 in
  Chain.genesis chain
  >>= fun genesis ->
  Hashtbl.add vtbl "Genesis" genesis ;
  let c = ["A1"; "A2"; "A3"; "A4"; "A5"] in
  build_valid_chain chain vtbl genesis c
  >>= fun () ->
  let a2 = Hashtbl.find vtbl "A2" in
  let c = ["B1"; "B2"; "B3"; "B4"; "B5"] in
  build_valid_chain chain vtbl a2 c >>= fun () -> Lwt.return vtbl

let wrap_state_init f base_dir =
  let store_root = base_dir // "store" in
  let context_root = base_dir // "context" in
  State.init
    ~store_mapsize:4_096_000_000L
    ~context_mapsize:4_096_000_000L
    ~store_root
    ~context_root
    genesis
  >>=? fun (state, chain, _index, _history_mode) ->
  build_example_tree chain
  >>= fun vblock -> f {state; chain; vblock} >>=? fun () -> return_unit

(** State.Chain.checkpoint *)

(*
- Valid branch are kept after setting a checkpoint. Bad branch are cut
- Setting a checkpoint in the future does not remove anything
- Reaching a checkpoint in the future with the right block keeps that
block and remove any concurrent branch
- Reaching a checkpoint in the future with a bad block remove that block and
does not prevent a future good block from correctly being reached
- There are no bad quadratic behaviours *)

let test_basic_checkpoint s =
  let block = vblock s "A1" in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let c_level = checkpoint_header.shell.level in
  let c_block = Block_header.hash checkpoint_header in
  if
    (not (Block_hash.equal c_block (State.Block.hash block)))
    && Int32.equal c_level (State.Block.level block)
  then Assert.fail_msg "unexpected checkpoint"
  else return_unit

(*
   - cp: checkpoint

  Genesis - A1 - A2 (cp) - A3 - A4 - A5
                  \
                   B1 - B2 - B3 - B4 - B5
  *)

(* State.Chain.acceptable_block:
   will the block is compatible with the current checkpoint? *)

let test_acceptable_block s =
  let block = vblock s "A2" in
  let header = State.Block.header block in
  (* let level = State.Block.level block in
   * let block_hash = State.Block.hash block  in *)
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  (* it is accepted only if the current head is lower than the checkpoint *)
  let block_1 = vblock s "A1" in
  Chain.set_head s.chain block_1
  >>=? fun head ->
  let header = State.Block.header head in
  State.Chain.acceptable_block s.chain header
  >>= fun is_accepted_block ->
  if is_accepted_block then return_unit
  else Assert.fail_msg "unacceptable block"

(*
  Genesis - A1 - A2 (cp) - A3 - A4 - A5
                  \
                   B1 - B2 - B3 - B4 - B5
  *)

(* State.Block.is_valid_for_checkpoint :
   is the block still valid for a given checkpoint ? *)

let test_is_valid_checkpoint s =
  let block = vblock s "A2" in
  let header = State.Block.header block in
  (* let block_hash = State.Block.hash block in
   * let level = State.Block.level block in *)
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  (* "b3" is valid because:
     a1 - a2 (checkpoint) - b1 - b2 - b3
     it is not valid when the checkpoint change to a pick different than a2.
  *)
  State.Block.is_valid_for_checkpoint (vblock s "B3") checkpoint_header
  >>= fun is_valid ->
  if is_valid then return_unit else Assert.fail_msg "invalid checkpoint"

(* return a block with the best fitness amongst the known blocks which
    are compatible with the given checkpoint *)

let test_best_know_head_for_checkpoint s =
  let block = vblock s "A2" in
  let checkpoint = State.Block.header block in
  State.Chain.set_checkpoint s.chain checkpoint
  >>= fun () ->
  Chain.set_head s.chain (vblock s "B3")
  >>= fun _head ->
  State.best_known_head_for_checkpoint s.chain checkpoint
  >>= fun _block ->
  (* the block returns with the best fitness is B3 at level 5 *)
  return_unit

(*
   setting checkpoint in the future does not remove anything

   Genesis - A1 - A2(cp) - A3 - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5
*)

let test_future_checkpoint s =
  let block = vblock s "A2" in
  let block_hash = State.Block.hash block in
  let level = State.Block.level block in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let c_level = checkpoint_header.shell.level in
  let c_block = Block_header.hash checkpoint_header in
  if Int32.equal c_level level && not (Block_hash.equal c_block block_hash)
  then Assert.fail_msg "unexpected checkpoint"
  else return_unit

(*
   setting checkpoint in the future does not remove anything
   - iv = invalid
  - (0): level of this block in the chain

  Two exammples:
    * Genesis (0)- A1 (1) - A2(2) - A3(3) - A4(4) - A5(5) (invalid)
                            \
                            B1(3) - B2(4) - B3 (5)(cp) - B4(6) - B5(7)

    * Genesis - A1 - A2 - A3 - A4 - A5 (cp)
                      \
                      B1 - B2 - B3 (iv)- B4 (iv) - B5 (iv)
*)

let test_future_checkpoint_bad_good_block s =
  let block = vblock s "A5" in
  let block_hash = State.Block.hash block in
  let level = State.Block.level block in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let c_level = checkpoint_header.shell.level in
  let c_block = Block_header.hash checkpoint_header in
  if Int32.equal c_level level && not (Block_hash.equal c_block block_hash)
  then Assert.fail_msg "unexpected checkpoint"
  else
    State.Block.is_valid_for_checkpoint (vblock s "B2") checkpoint_header
    >>= fun is_valid ->
    if is_valid then return_unit else Assert.fail_msg "invalid checkpoint"

(* check if the checkpoint can be reached

   Genesis - A1 (cp) - A2 (head) - A3 - A4 - A5
                        \
                        B1 - B2 - B3 - B4 - B5

*)

let test_reach_checkpoint s =
  let mem s x = Chain.mem s.chain (State.Block.hash @@ vblock s x) in
  let test_mem s x =
    mem s x
    >>= function
    | true -> Lwt.return_unit | false -> Assert.fail_msg "mem %s" x
  in
  let test_not_mem s x =
    mem s x
    >>= function
    | false -> Lwt.return_unit | true -> Assert.fail_msg "not (mem %s)" x
  in
  let block = vblock s "A1" in
  let block_hash = State.Block.hash block in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun checkpoint_header ->
  let time_now = Time.System.to_protocol (Systime_os.now ()) in
  if
    Time.Protocol.compare
      (Time.Protocol.add time_now 15L)
      header.shell.timestamp
    >= 0
  then
    let checkpoint_hash = Block_header.hash checkpoint_header in
    if
      Int32.equal header.shell.level checkpoint_header.shell.level
      && not (Block_hash.equal checkpoint_hash block_hash)
    then Assert.fail_msg "checkpoint error"
    else
      Chain.set_head s.chain (vblock s "A2")
      >>= fun _ ->
      Chain.head s.chain
      >>= fun head ->
      let checkpoint_reached =
        (State.Block.header head).shell.level >= checkpoint_header.shell.level
      in
      if checkpoint_reached then
        (* if reached the checkpoint, every block before the checkpoint
           must be the part of the chain *)
        if header.shell.level <= checkpoint_header.shell.level then
          test_mem s "Genesis"
          >>= fun () ->
          test_mem s "A1"
          >>= fun () ->
          test_mem s "A2"
          >>= fun () ->
          test_not_mem s "A3"
          >>= fun () -> test_not_mem s "B1" >>= fun () -> return_unit
        else Assert.fail_msg "checkpoint error"
      else Assert.fail_msg "checkpoint error"
  else Assert.fail_msg "fail future block header"

(*
   Chain.Validator function may_update_checkpoint

   - ncp: new checkpoint

   Genesis - A1 - A2 - A3 (cp) - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5

   Genesis - A1 (ncp) - A2 - A3 (cp) - A4 (ncp) - A5
                       \
                       B1 - B2 - B3 - B4 - B5
*)

let may_update_checkpoint chain_state new_head =
  State.Chain.checkpoint chain_state
  >>= fun checkpoint_header ->
  (* FIXME: the new level is always return 0l even
     if the new_head is A4 at level 4l
     Or TODO: set a level where allow to have a fork
  *)
  let old_level = checkpoint_header.shell.level in
  State.Block.last_allowed_fork_level new_head
  >>=? fun new_level ->
  if new_level <= old_level then return_unit
  else
    let head_level = State.Block.level new_head in
    State.Block.predecessor_n
      new_head
      (Int32.to_int (Int32.sub head_level new_level))
    >>= function
    | None ->
        return @@ Assert.fail_msg "Unexpected None in predecessor query"
    | Some hash -> (
        State.Block.read_opt chain_state hash
        >>= function
        | None ->
            assert false
        | Some b ->
            State.Chain.set_checkpoint chain_state (State.Block.header b)
            >>= fun () -> return_unit )

let test_may_update_checkpoint s =
  let block = vblock s "A3" in
  let checkpoint = State.Block.header block in
  State.Chain.set_checkpoint s.chain checkpoint
  >>= fun () ->
  State.Chain.checkpoint s.chain
  >>= fun _ ->
  Chain.set_head s.chain (vblock s "A4")
  >>= fun _ ->
  Chain.head s.chain
  >>= fun head -> may_update_checkpoint s.chain head >>=? fun () -> return ()

(* Check function may_update_checkpoint in Node.ml

   Genesis - A1 - A2 (cp) - A3 - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5

   chain after update:
   Genesis - A1 - A2 - A3(cp) - A4 - A5
                  \
                  B1 - B2 - B3 - B4 - B5
*)

let note_may_update_checkpoint chain_state checkpoint =
  match checkpoint with
  | None ->
      Lwt.return_unit
  | Some checkpoint ->
      State.best_known_head_for_checkpoint chain_state checkpoint
      >>= fun new_head ->
      Chain.set_head chain_state new_head
      >>= fun _ -> State.Chain.set_checkpoint chain_state checkpoint

let test_note_may_update_checkpoint s =
  (* set checkpoint at (2l, A2) *)
  let block = vblock s "A2" in
  let header = State.Block.header block in
  State.Chain.set_checkpoint s.chain header
  >>= fun () ->
  (* set new checkpoint at (3l, A3) *)
  let block = vblock s "A3" in
  let checkpoint = State.Block.header block in
  note_may_update_checkpoint s.chain (Some checkpoint)
  >>= fun () -> return_unit

(****************************************************************************)

let tests : (string * (state -> unit tzresult Lwt.t)) list =
  [ ("basic checkpoint", test_basic_checkpoint);
    ("is valid checkpoint", test_is_valid_checkpoint);
    ("acceptable block", test_acceptable_block);
    ("best know head", test_best_know_head_for_checkpoint);
    ("future checkpoint", test_future_checkpoint);
    ("future checkpoint bad/good block", test_future_checkpoint_bad_good_block);
    ("test_reach_checkpoint", test_reach_checkpoint);
    ("update checkpoint", test_may_update_checkpoint);
    ("update checkpoint in node", test_note_may_update_checkpoint) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      Lwt_utils_unix.with_tempdir "tezos_test_" (fun dir ->
          wrap_state_init f dir
          >>= function
          | Ok () ->
              Lwt.return_unit
          | Error error ->
              Format.kasprintf Pervasives.failwith "%a" pp_print_error error))

let tests = List.map wrap tests
src/lib_shell/test/test_state_checkpoint.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.of_seconds
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition proto : Tezos_protocol_updater.Registered_protocol.t :=
  match Registered_protocol.get genesis_protocol with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some proto => proto
  end.

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition genesis : Tezos_shell.State.Chain.genesis :=
  {| time := genesis_time; block := genesis_block; protocol := genesis_protocol
    |}.

Definition incr_fitness (fitness : list Stdlib.Bytes.t) : list Stdlib.Bytes.t :=
  let new_fitness :=
    match fitness with
    | cons fitness [] =>
      op_pipegt
        (op_pipegt
          (op_pipegt (Data_encoding.Binary.of_bytes Data_encoding.int64 fitness)
            (Option.unopt
              (* ❌ Constant of type int64 is converted to int *)
              0)) Int64.succ)
        (Data_encoding.Binary.to_bytes_exn Data_encoding.int64)
    | _ =>
      Data_encoding.Binary.to_bytes_exn Data_encoding.int64
        (* ❌ Constant of type int64 is converted to int *)
        1
    end in
  cons new_fitness [].

Definition incr_timestamp (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.add timestamp
    (Int64.add
      (* ❌ Constant of type int64 is converted to int *)
      1
      (Random.int64
        (* ❌ Constant of type int64 is converted to int *)
        10)).

Definition operation (op : string)
  : Tezos_crypto.Operation_hash.t * Tezos_base__TzPervasives.Operation.t *
    (option Stdlib.Bytes.t) :=
  let op :=
    {| shell := {| branch := genesis_block |};
      proto := Stdlib.Bytes.of_string op |} in
  ((Operation.hash op), op,
    (Data_encoding.Binary.to_bytes Operation.encoding op)).

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  obj1 (req None None "proto_block_header" % string string).

Definition block {A : Type}
  (_state : A) (op_staroptstar : option Tezos_base__TzPervasives.Context_hash.t)
  : (option (list Tezos_base__TzPervasives.Operation_list_hash.elt)) ->
    Tezos_shell.State.Block.t ->
      string -> Tezos_base__TzPervasives.Block_header.t :=
  let context :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Context_hash.zero
    end in
  fun op_staroptstar =>
    let operations :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun pred =>
      fun name =>
        let operations_hash :=
          Operation_list_list_hash.compute
            (cons (Operation_list_hash.compute operations) []) in
        let pred_header := State.Block.shell_header pred in
        let fitness := incr_fitness (fitness pred_header) in
        let timestamp := incr_timestamp (timestamp pred_header) in
        let protocol_data :=
          Data_encoding.Binary.to_bytes_exn block_header_data_encoding name in
        {|
          shell :=
            {| level := Int32.succ (level pred_header);
              proto_level := proto_level pred_header;
              predecessor := State.Block.hash pred; timestamp := timestamp;
              validation_passes := 1; operations_hash := operations_hash;
              fitness := fitness; context := context |};
          protocol_data := protocol_data |}.

Definition parsed_block
  (function_parameter : Tezos_base__TzPervasives.Block_header.t)
  : Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header) :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  let protocol_data :=
    Data_encoding.Binary.of_bytes_exn
      Proto.(Tezos_protocol_updater__Registered_protocol.T.block_header_data_encoding)
      protocol_data in
  {| shell := shell; protocol_data := protocol_data |}.

Definition zero : string := Stdlib.Bytes.create 0.

Definition block_header_data_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding string :=
  obj1 (req None None "proto_block_header" % string string).

Definition build_valid_chain
  (state : Tezos_shell__State.Chain.t)
  (vtbl : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t)
  (pred : Tezos_shell.State.Block.t) (names : list string) : Lwt.t unit :=
  op_gtgteq
    (Lwt_list.fold_left_s
      (fun pred =>
        fun name =>
          op_gtgteq (State.Block.context_exn pred)
            (fun predecessor_context =>
              let max_trials := 100 in
              let fix attempt
                (trials : Z) (context :
                option Tezos_base__TzPervasives.Context_hash.t)
                : Lwt.t Tezos_shell.State.Block.t :=
                op_gtgteq
                  (let '(oph, op, _bytes) := operation name in
                  let block :=
                    block state context (Some (cons oph [])) pred name in
                  let hash := Block_header.hash block in
                  let pred_header := State.Block.header pred in
                  op_gtgteqquestion
                    (let predecessor_context :=
                      Shell_context.wrap_disk_context predecessor_context in
                    op_gtgteqquestion
                      (Proto.(Tezos_protocol_updater__Registered_protocol.T.begin_application)
                        Chain_id.zero predecessor_context
                        (timestamp (shell pred_header))
                        (fitness (shell pred_header)) (parsed_block block))
                      (fun vstate =>
                        Proto.(Tezos_protocol_updater__Registered_protocol.T.finalize_block)
                          vstate))
                    (fun function_parameter =>
                      let '(result, _metadata) := function_parameter in
                      let context :=
                        Shell_context.unwrap_disk_context (context result) in
                      op_gtgteq
                        (Context.commit
                          (Time.System.to_protocol (Systime_os.now tt))
                          (message result) context)
                        (fun context_hash =>
                          let validation_store :=
                            {| context_hash := context_hash;
                              message := message result;
                              max_operations_ttl := max_operations_ttl result;
                              last_allowed_fork_level :=
                                last_allowed_fork_level result |} in
                          op_gtgteqquestion
                            (State.Block.store None state block zero
                              (cons (cons op []) []) (cons (cons zero []) [])
                              validation_store false)
                            (fun _vblock =>
                              op_gtgteqquestion (State.Block.read state hash)
                                (fun vblock =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ := Hashtbl.add vtbl name vblock in
                                  _return vblock)))))
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Ok v =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        if OCaml.Stdlib.lt trials max_trials then
                          Format.eprintf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Took " % string
                                (CamlinternalFormatBasics.Int
                                  CamlinternalFormatBasics.Int_d
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.No_precision
                                  (CamlinternalFormatBasics.String_literal
                                    " trials to build valid chain" % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Took %d trials to build valid chain" % string)
                            (Z.add (Z.sub max_trials trials) 1)
                        else
                          tt in
                      Lwt._return v
                    |
                      Stdlib.Error
                        (cons (Tezos_base__TzPervasives.Inconsistent_hash got _)
                          _) =>
                      if OCaml.Stdlib.le trials 0 then
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      else
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          Format.eprintf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Inconsistent context hash: got " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    ", retrying (" % string
                                    (CamlinternalFormatBasics.Int
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      (CamlinternalFormatBasics.String_literal
                                        ")
" % string
                                        CamlinternalFormatBasics.End_of_format)))))
                              "Inconsistent context hash: got %a, retrying (%d)
"
                                % string) Context_hash.pp got trials in
                        attempt (Z.sub trials 1) (Some got)
                    | Stdlib.Error err =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        Format.eprintf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Error: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  "010" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "Error: %a
" % string) Error_monad.pp_print_error
                          err in
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    end) in
              attempt max_trials None)) pred names)
    (fun function_parameter =>
      let '_ := function_parameter in
      Lwt.return_unit).

Record state := {
  vblock : Stdlib.Hashtbl.t string Tezos_shell.State.Block.t;
  state : Tezos_shell.State.t;
  chain : Tezos_shell.State.Chain.t }.

Definition vblock (s : state) : string -> Tezos_shell.State.Block.t :=
  Hashtbl.find (vblock s).

(* ❌ The definition of exceptions is not handled. *)
exception

Definition vblocks (s : state) : list (string * Tezos_shell.State.Block.t) :=
  OCaml.Stdlib.reverse_apply
    (Hashtbl.fold (fun k => fun v => fun acc => cons (k, v) acc) (vblock s) [])
    (List.sort Pervasives.compare).

Definition build_example_tree (chain : Tezos_shell.State.Chain.t)
  : Lwt.t (Stdlib.Hashtbl.t string Tezos_shell.State.Block.t) :=
  let vtbl := Hashtbl.create None 23 in
  op_gtgteq (Chain.genesis chain)
    (fun genesis =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Hashtbl.add vtbl "Genesis" % string genesis in
      let c :=
        cons "A1" % string
          (cons "A2" % string
            (cons "A3" % string (cons "A4" % string (cons "A5" % string []))))
        in
      op_gtgteq (build_valid_chain chain vtbl genesis c)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let a2 := Hashtbl.find vtbl "A2" % string in
          let c :=
            cons "B1" % string
              (cons "B2" % string
                (cons "B3" % string (cons "B4" % string (cons "B5" % string []))))
            in
          op_gtgteq (build_valid_chain chain vtbl a2 c)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt._return vtbl))).

Definition wrap_state_init
  (f : state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (base_dir : string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let store_root := op_divdiv base_dir "store" % string in
  let context_root := op_divdiv base_dir "context" % string in
  op_gtgteqquestion
    (State.init None None
      (Some
        (* ❌ Constant of type int64 is converted to int *)
        4096000000)
      (Some
        (* ❌ Constant of type int64 is converted to int *)
        4096000000) store_root context_root None genesis)
    (fun function_parameter =>
      let '(state, chain, _index, _history_mode) := function_parameter in
      op_gtgteq (build_example_tree chain)
        (fun vblock =>
          op_gtgteqquestion
            (f {| vblock := vblock; state := state; chain := chain |})
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit))).

Definition test_basic_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A1" % string in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint (chain s))
        (fun checkpoint_header =>
          let c_level := level (shell checkpoint_header) in
          let c_block := Block_header.hash checkpoint_header in
          if
            andb (negb (Block_hash.equal c_block (State.Block.hash block)))
              (Int32.equal c_level (State.Block.level block)) then
            op_startypeminuserrorstar "unexpected checkpoint" % string
          else
            return_unit)).

Definition test_acceptable_block (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let block_1 := vblock s "A1" % string in
      op_gtgteqquestion (Chain.set_head (chain s) block_1)
        (fun head =>
          let header := State.Block.header head in
          op_gtgteq (State.Chain.acceptable_block (chain s) header)
            (fun is_accepted_block =>
              if is_accepted_block then
                return_unit
              else
                op_startypeminuserrorstar "unacceptable block" % string))).

Definition test_is_valid_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint (chain s))
        (fun checkpoint_header =>
          op_gtgteq
            (State.Block.is_valid_for_checkpoint (vblock s "B3" % string)
              checkpoint_header)
            (fun is_valid =>
              if is_valid then
                return_unit
              else
                op_startypeminuserrorstar "invalid checkpoint" % string))).

Definition test_best_know_head_for_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let checkpoint := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) checkpoint)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Chain.set_head (chain s) (vblock s "B3" % string))
        (fun _head =>
          op_gtgteq (State.best_known_head_for_checkpoint (chain s) checkpoint)
            (fun _block => return_unit))).

Definition test_future_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let block_hash := State.Block.hash block in
  let level := State.Block.level block in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint (chain s))
        (fun checkpoint_header =>
          let c_level := level (shell checkpoint_header) in
          let c_block := Block_header.hash checkpoint_header in
          if
            andb (Int32.equal c_level level)
              (negb (Block_hash.equal c_block block_hash)) then
            op_startypeminuserrorstar "unexpected checkpoint" % string
          else
            return_unit)).

Definition test_future_checkpoint_bad_good_block (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A5" % string in
  let block_hash := State.Block.hash block in
  let level := State.Block.level block in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint (chain s))
        (fun checkpoint_header =>
          let c_level := level (shell checkpoint_header) in
          let c_block := Block_header.hash checkpoint_header in
          if
            andb (Int32.equal c_level level)
              (negb (Block_hash.equal c_block block_hash)) then
            op_startypeminuserrorstar "unexpected checkpoint" % string
          else
            op_gtgteq
              (State.Block.is_valid_for_checkpoint (vblock s "B2" % string)
                checkpoint_header)
              (fun is_valid =>
                if is_valid then
                  return_unit
                else
                  op_startypeminuserrorstar "invalid checkpoint" % string))).

Definition test_reach_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let mem (s : state) (x : string) : Lwt.t bool :=
    Chain.mem (chain s) (apply State.Block.hash (vblock s x)) in
  let test_mem (s : state) (x : string) : Lwt.t unit :=
    op_gtgteq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | true => Lwt.return_unit
        | false => op_startypeminuserrorstar "mem %s" % string x
        end) in
  let test_not_mem (s : state) (x : string) : Lwt.t unit :=
    op_gtgteq (mem s x)
      (fun function_parameter =>
        match function_parameter with
        | false => Lwt.return_unit
        | true => op_startypeminuserrorstar "not (mem %s)" % string x
        end) in
  let block := vblock s "A1" % string in
  let block_hash := State.Block.hash block in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint (chain s))
        (fun checkpoint_header =>
          let time_now := Time.System.to_protocol (Systime_os.now tt) in
          if
            OCaml.Stdlib.ge
              (Time.Protocol.compare
                (Time.Protocol.add time_now
                  (* ❌ Constant of type int64 is converted to int *)
                  15) (timestamp (shell header))) 0 then
            let checkpoint_hash := Block_header.hash checkpoint_header in
            if
              andb
                (Int32.equal (level (shell header))
                  (level (shell checkpoint_header)))
                (negb (Block_hash.equal checkpoint_hash block_hash)) then
              op_startypeminuserrorstar "checkpoint error" % string
            else
              op_gtgteq (Chain.set_head (chain s) (vblock s "A2" % string))
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_gtgteq (Chain.head (chain s))
                    (fun head =>
                      let checkpoint_reached :=
                        OCaml.Stdlib.ge
                          (level (shell (State.Block.header head)))
                          (level (shell checkpoint_header)) in
                      if checkpoint_reached then
                        if
                          OCaml.Stdlib.le (level (shell header))
                            (level (shell checkpoint_header)) then
                          op_gtgteq (test_mem s "Genesis" % string)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq (test_mem s "A1" % string)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq (test_mem s "A2" % string)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq (test_not_mem s "A3" % string)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (test_not_mem s "B1" % string)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              return_unit)))))
                        else
                          op_startypeminuserrorstar "checkpoint error" % string
                      else
                        op_startypeminuserrorstar "checkpoint error" % string))
          else
            op_startypeminuserrorstar "fail future block header" % string)).

Definition may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.chain_state)
  (new_head : Tezos_shell.State.Block.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq (State.Chain.checkpoint chain_state)
    (fun checkpoint_header =>
      let old_level := level (shell checkpoint_header) in
      op_gtgteqquestion (State.Block.last_allowed_fork_level new_head)
        (fun new_level =>
          if OCaml.Stdlib.le new_level old_level then
            return_unit
          else
            let head_level := State.Block.level new_head in
            op_gtgteq
              (State.Block.predecessor_n new_head
                (Int32.to_int (Int32.sub head_level new_level)))
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  apply _return
                    (op_startypeminuserrorstar
                      "Unexpected None in predecessor query" % string)
                | Some hash =>
                  op_gtgteq (State.Block.read_opt chain_state hash)
                    (fun function_parameter =>
                      match function_parameter with
                      | None =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      | Some b =>
                        op_gtgteq
                          (State.Chain.set_checkpoint chain_state
                            (State.Block.header b))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)
                      end)
                end))).

Definition test_may_update_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A3" % string in
  let checkpoint := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) checkpoint)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (State.Chain.checkpoint (chain s))
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteq (Chain.set_head (chain s) (vblock s "A4" % string))
            (fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteq (Chain.head (chain s))
                (fun head =>
                  op_gtgteqquestion (may_update_checkpoint (chain s) head)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return tt))))).

Definition note_may_update_checkpoint
  (chain_state : Tezos_shell.State.Chain.t)
  (checkpoint : option Tezos_base__TzPervasives.Block_header.t) : Lwt.t unit :=
  match checkpoint with
  | None => Lwt.return_unit
  | Some checkpoint =>
    op_gtgteq (State.best_known_head_for_checkpoint chain_state checkpoint)
      (fun new_head =>
        op_gtgteq (Chain.set_head chain_state new_head)
          (fun function_parameter =>
            let '_ := function_parameter in
            State.Chain.set_checkpoint chain_state checkpoint))
  end.

Definition test_note_may_update_checkpoint (s : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let block := vblock s "A2" % string in
  let header := State.Block.header block in
  op_gtgteq (State.Chain.set_checkpoint (chain s) header)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let block := vblock s "A3" % string in
      let checkpoint := State.Block.header block in
      op_gtgteq (note_may_update_checkpoint (chain s) (Some checkpoint))
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition tests
  : list (string * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  cons ("basic checkpoint" % string, test_basic_checkpoint)
    (cons ("is valid checkpoint" % string, test_is_valid_checkpoint)
      (cons ("acceptable block" % string, test_acceptable_block)
        (cons ("best know head" % string, test_best_know_head_for_checkpoint)
          (cons ("future checkpoint" % string, test_future_checkpoint)
            (cons
              ("future checkpoint bad/good block" % string,
                test_future_checkpoint_bad_good_block)
              (cons ("test_reach_checkpoint" % string, test_reach_checkpoint)
                (cons ("update checkpoint" % string, test_may_update_checkpoint)
                  (cons
                    ("update checkpoint in node" % string,
                      test_note_may_update_checkpoint) [])))))))).

Definition wrap {A B : Type}
  (function_parameter :
    A * (state -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) : B :=
  let '(n, f) := function_parameter in
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_utils_unix.with_tempdir "tezos_test_" % string
          (fun dir =>
            op_gtgteq (wrap_state_init f dir)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => Lwt.return_unit
                | Stdlib.Error error =>
                  Format.kasprintf Pervasives.failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format) "%a" % string)
                    pp_print_error error
                end))).

Definition tests {A : Type} : list A := List.map wrap tests.

src/lib_shell/test/test_store.ml 144 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store

let ( >>= ) = Lwt.bind

let ( >|= ) = Lwt.( >|= )

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

(** *)

let mapsize = 4_096_000_000L (* ~4 GiB *)

let wrap_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      Store.init ~mapsize root
      >>= function
      | Ok store ->
          Lwt.finalize
            (fun () -> f store)
            (fun () -> Store.close store ; Lwt.return_unit)
      | Error err ->
          Format.kasprintf
            Pervasives.failwith
            "@[Cannot initialize store:@ %a@]"
            pp_print_error
            err)

let wrap_raw_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      Raw_store.init ~mapsize root
      >>= function
      | Ok store ->
          Lwt.finalize
            (fun () -> f store)
            (fun () -> Raw_store.close store ; Lwt.return_unit)
      | Error err ->
          Format.kasprintf
            Pervasives.failwith
            "@[Cannot initialize store:@ %a@]"
            pp_print_error
            err)

let test_init _ = Lwt.return_unit

let chain_id = Chain_id.of_block_hash genesis_block

(** Operation store *)

let make proto : Operation.t = {shell = {branch = genesis_block}; proto}

let op1 = make (Bytes.of_string "Capadoce")

let oph1 = Operation.hash op1

let op2 = make (Bytes.of_string "Kivu")

let oph2 = Operation.hash op2

(** Block store *)

let lolblock ?(operations = []) header =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let block_header =
    {
      Block_header.shell =
        {
          timestamp = Time.Protocol.of_seconds (Random.int64 1500L);
          level = 0l;
          (* dummy *)
          proto_level = 0;
          (* dummy *)
          validation_passes = Random.int 32;
          predecessor = genesis_block;
          operations_hash;
          fitness =
            [ Bytes.of_string @@ string_of_int @@ String.length header;
              Bytes.of_string @@ string_of_int @@ 12 ];
          context = Context_hash.zero;
        };
      protocol_data = Bytes.of_string header;
    }
  in
  let block_contents =
    {
      header = block_header;
      Store.Block.metadata = Bytes.create 0;
      max_operations_ttl = 0;
      message = None;
      context = Context_hash.zero;
      last_allowed_fork_level = 0l;
    }
  in
  (block_header, block_contents)

let ((b1_header, b1_contents) as b1) = lolblock "Blop !"

let bh1 = Block_header.hash b1_header

let ((b2_header, b2_contents) as b2) = lolblock "Tacatlopo"

let bh2 = Block_header.hash b2_header

let ((b3_header, b3_contents) as b3) =
  lolblock ~operations:[oph1; oph2] "Persil"

let bh3 = Block_header.hash b3_header

let bh3' =
  let raw = Bytes.of_string @@ Block_hash.to_string bh3 in
  Bytes.set raw 31 '\000' ;
  Bytes.set raw 30 '\000' ;
  Block_hash.of_string_exn @@ Bytes.to_string raw

let equal ((b1_header, b1_contents) : Block_header.t * Store.Block.contents)
    ((b2_header, b2_contents) : Block_header.t * Store.Block.contents) =
  Block_header.equal b1_header b2_header
  && b1_contents.message = b2_contents.message

let check_block s h b =
  Store.Block.Contents.read (s, h)
  >>= function
  | Ok bc' -> (
      Store.Block.Pruned_contents.read (s, h)
      >>= function
      | Ok {header} when equal b (header, bc') ->
          Lwt.return_unit
      | Ok _ ->
          Format.eprintf
            "Error while reading block %a\n%!"
            Block_hash.pp_short
            h ;
          exit 1
      | Error err ->
          Format.eprintf
            "@[Error while reading block header %a:@ %a\n@]"
            Block_hash.pp_short
            h
            pp_print_error
            err ;
          exit 1 )
  | Error err ->
      Format.eprintf
        "@[Error while reading block %a:@ %a\n@]"
        Block_hash.pp_short
        h
        pp_print_error
        err ;
      exit 1

let test_block s =
  let s = Store.Chain.get s chain_id in
  let s = Store.Block.get s in
  Block.Contents.store (s, bh1) b1_contents
  >>= fun () ->
  Block.Contents.store (s, bh2) b2_contents
  >>= fun () ->
  Block.Contents.store (s, bh3) b3_contents
  >>= fun () ->
  Block.Pruned_contents.store (s, bh1) {header = b1_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh2) {header = b2_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh3) {header = b3_header}
  >>= fun () ->
  check_block s bh1 b1
  >>= fun () -> check_block s bh2 b2 >>= fun () -> check_block s bh3 b3

let test_expand s =
  let s = Store.Chain.get s chain_id in
  let s = Store.Block.get s in
  Block.Contents.store (s, bh1) b1_contents
  >>= fun () ->
  Block.Contents.store (s, bh2) b2_contents
  >>= fun () ->
  Block.Contents.store (s, bh3) b3_contents
  >>= fun () ->
  Block.Contents.store (s, bh3') b3_contents
  >>= fun () ->
  Block.Pruned_contents.store (s, bh1) {header = b1_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh2) {header = b2_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh3) {header = b3_header}
  >>= fun () ->
  Block.Pruned_contents.store (s, bh3') {header = b3_header}
  >>= fun () ->
  Base58.complete (Block_hash.to_short_b58check bh1)
  >>= fun res ->
  Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh1] ;
  Base58.complete (Block_hash.to_short_b58check bh2)
  >>= fun res ->
  Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh2] ;
  Base58.complete (Block_hash.to_short_b58check bh3)
  >>= fun res ->
  Assert.equal_string_list
    ~msg:__LOC__
    (List.sort String.compare res)
    [Block_hash.to_b58check bh3'; Block_hash.to_b58check bh3] ;
  Lwt.return_unit

(** Generic store *)

let check (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) k d =
  Store.read_opt s k
  >|= function
  | Some d' when Bytes.equal d d' ->
      ()
  | Some d' ->
      Assert.fail_msg
        ~expected:(Bytes.to_string d)
        ~given:(Bytes.to_string d')
        "Error while reading key %d %S\n%!"
        Bytes.(compare d d')
        (String.concat Filename.dir_sep k)
  | None ->
      Assert.fail_msg
        ~expected:(Bytes.to_string d)
        ~given:""
        "Error while reading key %S\n%!"
        (String.concat Filename.dir_sep k)

let check_none (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) k =
  Store.read_opt s k
  >|= function
  | None ->
      ()
  | Some _ ->
      Assert.fail_msg
        "Error while reading non-existent key %S\n%!"
        (String.concat Filename.dir_sep k)

let test_generic (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  Store.store s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () ->
  Store.store s ["day"; "next"] (Bytes.of_string "Jeudi")
  >>= fun () ->
  Store.store s ["day"; "truc"; "chose"] (Bytes.of_string "Vendredi")
  >>= fun () ->
  check (module Store) s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () ->
  check (module Store) s ["day"; "next"] (Bytes.of_string "Jeudi")
  >>= fun () -> check_none (module Store) s ["day"]

let list (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) k =
  Store.keys s k

let test_generic_list (type t)
    (module Store : Store_sigs.STORE with type t = t) (s : Store.t) =
  Store.store s ["a"; "b"] (Bytes.of_string "Novembre")
  >>= fun () ->
  Store.store s ["a"; "c"] (Bytes.of_string "Juin")
  >>= fun () ->
  Store.store s ["a"; "d"; "e"] (Bytes.of_string "Septembre")
  >>= fun () ->
  Store.store s ["f"] (Bytes.of_string "Avril")
  >>= fun () ->
  Store.store s ["g"; "h"] (Bytes.of_string "Avril")
  >>= fun () ->
  list (module Store) s []
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
    (List.sort compare l) ;
  list (module Store) s ["a"]
  >>= fun l ->
  Assert.equal_string_list_list
    ~msg:__LOC__
    [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
    (List.sort compare l) ;
  list (module Store) s ["f"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  list (module Store) s ["g"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] (List.sort compare l) ;
  list (module Store) s ["i"]
  >>= fun l ->
  Assert.equal_string_list_list ~msg:__LOC__ [] l ;
  Lwt.return_unit

(** HashSet *)

open Store_helpers

let test_hashset (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module BlockSet = Block_hash.Set in
  let module StoreSet =
    Make_buffered_set
      (Make_substore
         (Store)
         (struct
           let name = ["test_set"]
         end))
         (Block_hash)
      (BlockSet)
  in
  let bhset = BlockSet.(add bh2 (add bh1 empty)) in
  StoreSet.store_all s bhset
  >>= fun () ->
  StoreSet.read_all s
  >>= fun bhset' ->
  Assert.equal_block_set ~msg:__LOC__ bhset bhset' ;
  let bhset2 = BlockSet.(bhset |> add bh3 |> remove bh1) in
  StoreSet.store_all s bhset2
  >>= fun () ->
  StoreSet.read_all s
  >>= fun bhset2' ->
  Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2' ;
  StoreSet.fold s ~init:BlockSet.empty ~f:(fun bh acc ->
      Lwt.return (BlockSet.add bh acc))
  >>= fun bhset2'' ->
  Assert.equal_block_set ~msg:__LOC__ bhset2 bhset2'' ;
  Store.store s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () ->
  StoreSet.remove_all s
  >>= fun () ->
  StoreSet.read_all s
  >>= fun empty ->
  Assert.equal_block_set ~msg:__LOC__ BlockSet.empty empty ;
  check (module Store) s ["day"; "current"] (Bytes.of_string "Mercredi")
  >>= fun () -> Lwt.return_unit

(** HashMap *)

let test_hashmap (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module BlockMap = Block_hash.Map in
  let module StoreMap =
    Make_buffered_map
      (Make_substore
         (Store)
         (struct
           let name = ["test_map"]
         end))
         (Block_hash)
      (Make_value (struct
        type t = int * char

        let encoding =
          Data_encoding.(tup2 int31 (conv int_of_char char_of_int int8))
      end))
      (BlockMap)
  in
  let eq = ( = ) in
  let map = BlockMap.(empty |> add bh1 (1, 'a') |> add bh2 (2, 'b')) in
  StoreMap.store_all s map
  >>= fun () ->
  StoreMap.read_all s
  >>= fun map' ->
  Assert.equal_block_map ~msg:__LOC__ ~eq map map' ;
  let map2 = map |> BlockMap.add bh3 (3, 'c') |> BlockMap.remove bh1 in
  StoreMap.store_all s map2
  >>= fun () ->
  StoreMap.read_all s
  >>= fun map2' ->
  Assert.equal_block_map ~msg:__LOC__ ~eq map2 map2' ;
  Lwt.return_unit

(** Functors *)

let test_single (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module Single =
    Make_single_store
      (Store)
      (struct
        let name = ["plop"]
      end)
      (Make_value (struct
        type t = int * string

        let encoding = Data_encoding.(tup2 int31 string)
      end))
  in
  Single.known s
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  Single.read_opt s
  >>= fun v' ->
  Assert.equal ~msg:__LOC__ None v' ;
  let v = (3, "Non!") in
  Single.store s v
  >>= fun () ->
  Single.known s
  >>= fun known ->
  Assert.is_true ~msg:__LOC__ known ;
  Single.read_opt s
  >>= fun v' ->
  Assert.equal ~msg:__LOC__ (Some v) v' ;
  Single.remove s
  >>= fun () ->
  Single.known s
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  Single.read_opt s
  >>= fun v' ->
  Assert.equal ~msg:__LOC__ None v' ;
  Lwt.return_unit

module Sub =
  Make_substore
    (Raw_store)
    (struct
      let name = ["plop"; "plip"]
    end)

module SubBlocks =
  Make_indexed_substore
    (Make_substore
       (Raw_store)
       (struct
         let name = ["blocks"]
       end))
       (Block_hash)

module SubBlocksSet =
  SubBlocks.Make_buffered_set
    (struct
      let name = ["test_set"]
    end)
    (Block_hash.Set)

module SubBlocksMap =
  SubBlocks.Make_buffered_map
    (struct
      let name = ["test_map"]
    end)
    (Make_value (struct
      type t = int * string

      let encoding = Data_encoding.(tup2 int31 string)
    end))
    (Block_hash.Map)

let test_subblock s =
  SubBlocksSet.known s bh1
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  SubBlocksSet.store s bh1
  >>= fun () ->
  SubBlocksSet.store s bh2
  >>= fun () ->
  SubBlocksSet.known s bh2
  >>= fun known ->
  Assert.is_true ~msg:__LOC__ known ;
  SubBlocksSet.read_all s
  >>= fun set ->
  let set' = Block_hash.Set.(empty |> add bh1 |> add bh2) in
  Assert.equal_block_set ~msg:__LOC__ set set' ;
  SubBlocksSet.remove s bh2
  >>= fun () ->
  let set = Block_hash.Set.(empty |> add bh3' |> add bh3) in
  SubBlocksSet.store_all s set
  >>= fun () ->
  SubBlocksSet.elements s
  >>= fun elts ->
  Assert.equal_block_hash_list
    ~msg:__LOC__
    (List.sort Block_hash.compare elts)
    (List.sort Block_hash.compare [bh3; bh3']) ;
  SubBlocksSet.store s bh2
  >>= fun () ->
  SubBlocksSet.remove s bh3
  >>= fun () ->
  SubBlocksSet.elements s
  >>= fun elts ->
  Assert.equal_block_hash_list
    ~msg:__LOC__
    (List.sort Block_hash.compare elts)
    (List.sort Block_hash.compare [bh2; bh3']) ;
  SubBlocksMap.known s bh1
  >>= fun known ->
  Assert.is_false ~msg:__LOC__ known ;
  let v1 = (3, "Non!") and v2 = (12, "Beurk.") in
  SubBlocksMap.store s bh1 v1
  >>= fun () ->
  SubBlocksMap.store s bh2 v2
  >>= fun () ->
  SubBlocksMap.known s bh1
  >>= fun known ->
  SubBlocksMap.read_opt s bh1
  >>= fun v1' ->
  Assert.equal ~msg:__LOC__ (Some v1) v1' ;
  Assert.is_true ~msg:__LOC__ known ;
  let map = Block_hash.Map.(empty |> add bh1 v1 |> add bh2 v2) in
  SubBlocksMap.read_all s
  >>= fun map' ->
  Assert.equal_block_map ~eq:( = ) ~msg:__LOC__ map map' ;
  SubBlocksSet.remove_all s
  >>= fun () ->
  SubBlocksSet.elements s
  >>= fun elts ->
  Assert.equal_block_hash_list ~msg:__LOC__ elts [] ;
  SubBlocksMap.read_all s
  >>= fun map' ->
  Assert.equal_block_map ~eq:( = ) ~msg:__LOC__ map map' ;
  SubBlocksSet.store s bh3
  >>= fun () ->
  SubBlocks.indexes s
  >>= fun keys ->
  Assert.equal_block_hash_list
    ~msg:__LOC__
    (List.sort Block_hash.compare keys)
    (List.sort Block_hash.compare [bh1; bh2; bh3]) ;
  Lwt.return_unit

module SubSubBlocks =
  Make_indexed_substore
    (Make_substore
       (SubBlocks.Store)
       (struct
         let name = ["sub_blocks"]
       end))
       (Block_hash)

(** *)

let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list =
  [ ("init", test_init);
    ("generic", test_generic (module Raw_store));
    ("generic_substore", test_generic (module Sub));
    ( "generic_indexedstore",
      fun s -> test_generic (module SubBlocks.Store) (s, bh1) );
    ( "generic_indexedsubstore",
      fun s -> test_generic (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("single", test_single (module Raw_store));
    ("single_substore", test_single (module Sub));
    ( "single_indexedstore",
      fun s -> test_single (module SubBlocks.Store) (s, bh1) );
    ( "single_indexedsubstore",
      fun s -> test_single (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("generic_list", test_generic_list (module Raw_store));
    ("generic_substore_list", test_generic_list (module Sub));
    ( "generic_indexedstore_list",
      fun s -> test_generic_list (module SubBlocks.Store) (s, bh1) );
    ( "generic_indexedsubstore_list",
      fun s -> test_generic_list (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("hashset", test_hashset (module Raw_store));
    ("hashset_substore", test_hashset (module Sub));
    ( "hashset_indexedstore",
      fun s -> test_hashset (module SubBlocks.Store) (s, bh1) );
    ( "hashset_indexedsubstore",
      fun s -> test_hashset (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("hashmap", test_hashmap (module Raw_store));
    ("hashmap_substore", test_hashmap (module Sub));
    ( "hashmap_indexedstore",
      fun s -> test_hashmap (module SubBlocks.Store) (s, bh1) );
    ( "hashmap_indexedsubstore",
      fun s -> test_hashmap (module SubSubBlocks.Store) ((s, bh1), bh2) );
    ("subblock", test_subblock) ]

let tests : (string * (Store.t -> unit Lwt.t)) list =
  [("expand", test_expand); ("block", test_block)]

let tests =
  List.map
    (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_raw_store_init f))
    tests_raw
  @ List.map
      (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_store_init f))
      tests
src/lib_shell/test/test_store.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Store.

Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition op_gtpipeeq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
  Lwt.op_gtpipeeq.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.of_seconds
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition mapsize : int64 :=
  (* ❌ Constant of type int64 is converted to int *)
  4096000000.

Definition wrap_store_init {A B : Type}
  (f : Tezos_shell.Store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  let '_ := function_parameter in
  fun function_parameter =>
    let 'tt := function_parameter in
    Lwt_utils_unix.with_tempdir "tezos_test_" % string
      (fun base_dir =>
        let root := op_divdiv base_dir "store" % string in
        op_gtgteq (Store.init None (Some mapsize) root)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok store =>
              Lwt.finalize
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  f store)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := Store.close store in
                  Lwt.return_unit)
            | Stdlib.Error err =>
              Format.kasprintf Pervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Cannot initialize store:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))
                  "@[Cannot initialize store:@ %a@]" % string) pp_print_error
                err
            end)).

Definition wrap_raw_store_init {A B : Type}
  (f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  let '_ := function_parameter in
  fun function_parameter =>
    let 'tt := function_parameter in
    Lwt_utils_unix.with_tempdir "tezos_test_" % string
      (fun base_dir =>
        let root := op_divdiv base_dir "store" % string in
        op_gtgteq (Raw_store.init None (Some mapsize) root)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok store =>
              Lwt.finalize
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  f store)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := Raw_store.close store in
                  Lwt.return_unit)
            | Stdlib.Error err =>
              Format.kasprintf Pervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Cannot initialize store:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))
                  "@[Cannot initialize store:@ %a@]" % string) pp_print_error
                err
            end)).

Definition test_init {A : Type} (function_parameter : A) : Lwt.t unit :=
  let '_ := function_parameter in
  Lwt.return_unit.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Chain_id.of_block_hash genesis_block.

Definition make (proto : Stdlib.Bytes.t)
  : Tezos_base__TzPervasives.Operation.t :=
  {| shell := {| branch := genesis_block |}; proto := proto |}.

Definition op1 : Tezos_base__TzPervasives.Operation.t :=
  make (Stdlib.Bytes.of_string "Capadoce" % string).

Definition oph1 : Tezos_crypto.Operation_hash.t := Operation.hash op1.

Definition op2 : Tezos_base__TzPervasives.Operation.t :=
  make (Stdlib.Bytes.of_string "Kivu" % string).

Definition oph2 : Tezos_crypto.Operation_hash.t := Operation.hash op2.

Definition lolblock
  (op_staroptstar :
    option (list Tezos_base__TzPervasives.Operation_list_hash.elt))
  : string ->
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents :=
  let operations :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun header =>
    let operations_hash :=
      Operation_list_list_hash.compute
        (cons (Operation_list_hash.compute operations) []) in
    let block_header :=
      {|
        Block_header.shell :=
          {|
            level :=
              (* ❌ Constant of type int32 is converted to int *)
              0; proto_level := 0; predecessor := genesis_block;
            timestamp :=
              Time.Protocol.of_seconds
                (Random.int64
                  (* ❌ Constant of type int64 is converted to int *)
                  1500); validation_passes := Random.int 32;
            operations_hash := operations_hash;
            fitness :=
              cons
                (apply Stdlib.Bytes.of_string
                  (apply OCaml.Stdlib.string_of_int (String.length header)))
                (cons
                  (apply Stdlib.Bytes.of_string
                    (apply OCaml.Stdlib.string_of_int 12)) []);
            context := Context_hash.zero |};
        Block_header.protocol_data := Stdlib.Bytes.of_string header |} in
    let block_contents :=
      {| Store.Block.header := block_header; Store.Block.message := None;
        Store.Block.max_operations_ttl := 0;
        Store.Block.last_allowed_fork_level :=
          (* ❌ Constant of type int32 is converted to int *)
          0; Store.Block.context := Context_hash.zero;
        Store.Block.metadata := Stdlib.Bytes.create 0 |} in
    (block_header, block_contents).



Definition bh1 : Tezos_crypto.Block_hash.t := Block_header.hash b1_header.



Definition bh2 : Tezos_crypto.Block_hash.t := Block_header.hash b2_header.



Definition bh3 : Tezos_crypto.Block_hash.t := Block_header.hash b3_header.

Definition bh3' : Tezos_base__TzPervasives.Block_hash.t :=
  let raw := apply Stdlib.Bytes.of_string (Block_hash.to_string bh3) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.Bytes.set raw 31 "000" % char in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.Bytes.set raw 30 "000" % char in
  apply Block_hash.of_string_exn (Stdlib.Bytes.to_string raw).

Definition equal
  (function_parameter :
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
  : (Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
    -> bool :=
  let '(b1_header, b1_contents) := function_parameter in
  fun function_parameter =>
    let '(b2_header, b2_contents) := function_parameter in
    andb (Block_header.equal b1_header b2_header)
      (equiv_decb (message b1_contents) (message b2_contents)).

Definition check_block
  (s : Tezos_shell__Store.Block.store)
  (h : Tezos_base__TzPervasives.Block_hash.t)
  (b :
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents)
  : Lwt.t unit :=
  op_gtgteq (Store.Block.Contents.read (s, h))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok bc' =>
        op_gtgteq (Store.Block.Pruned_contents.read (s, h))
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok {| header := header |} => Lwt.return_unit
            | Stdlib.Ok _ =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Format.eprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Error while reading block " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal "010" % char
                          (CamlinternalFormatBasics.Flush
                            CamlinternalFormatBasics.End_of_format))))
                    "Error while reading block %a
%!" % string)
                  Block_hash.pp_short h in
              Stdlib.exit 1
            | Stdlib.Error err =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                Format.eprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Error while reading block header " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal ":" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  "010" % char
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))
                    "@[Error while reading block header %a:@ %a
@]" % string)
                  Block_hash.pp_short h pp_print_error err in
              Stdlib.exit 1
            end)
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.String_literal
                  "Error while reading block " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal ":" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "010" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format))))))))
              "@[Error while reading block %a:@ %a
@]" % string)
            Block_hash.pp_short h pp_print_error err in
        Stdlib.exit 1
      end).

Definition test_block (s : Tezos_shell__Store.global_store) : Lwt.t unit :=
  let s := Store.Chain.get s chain_id in
  let s := Store.Block.get s in
  op_gtgteq (Block.Contents.store (s, bh1) b1_contents)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Block.Contents.store (s, bh2) b2_contents)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Block.Contents.store (s, bh3) b3_contents)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (Block.Pruned_contents.store (s, bh1) {| header := b1_header |})
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Block.Pruned_contents.store (s, bh2)
                      {| header := b2_header |})
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (Block.Pruned_contents.store (s, bh3)
                          {| header := b3_header |})
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq (check_block s bh1 b1)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq (check_block s bh2 b2)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  check_block s bh3 b3)))))))).

Definition test_expand (s : Tezos_shell__Store.global_store) : Lwt.t unit :=
  let s := Store.Chain.get s chain_id in
  let s := Store.Block.get s in
  op_gtgteq (Block.Contents.store (s, bh1) b1_contents)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Block.Contents.store (s, bh2) b2_contents)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Block.Contents.store (s, bh3) b3_contents)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Block.Contents.store (s, bh3') b3_contents)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Block.Pruned_contents.store (s, bh1)
                      {| header := b1_header |})
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (Block.Pruned_contents.store (s, bh2)
                          {| header := b2_header |})
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (Block.Pruned_contents.store (s, bh3)
                              {| header := b3_header |})
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (Block.Pruned_contents.store (s, bh3')
                                  {| header := b3_header |})
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteq
                                    (Base58.complete None
                                      (Block_hash.to_short_b58check bh1))
                                    (fun res =>
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        op_startypeminuserrorstar Stdlib.__LOC__
                                          res
                                          (cons (Block_hash.to_b58check bh1) [])
                                        in
                                      op_gtgteq
                                        (Base58.complete None
                                          (Block_hash.to_short_b58check bh2))
                                        (fun res =>
                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                          let _ :=
                                            op_startypeminuserrorstar
                                              Stdlib.__LOC__ res
                                              (cons (Block_hash.to_b58check bh2)
                                                []) in
                                          op_gtgteq
                                            (Base58.complete None
                                              (Block_hash.to_short_b58check bh3))
                                            (fun res =>
                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                              let _ :=
                                                op_startypeminuserrorstar
                                                  Stdlib.__LOC__
                                                  (List.sort String.compare res)
                                                  (cons
                                                    (Block_hash.to_b58check bh3')
                                                    (cons
                                                      (Block_hash.to_b58check
                                                        bh3) [])) in
                                              Lwt.return_unit))))))))))).

Definition check {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> (list string) -> Stdlib.Bytes.t -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    fun k =>
      fun d =>
        op_gtpipeeq (Store.(Tezos_storage__Store_sigs.STORE.read_opt) s k)
          (fun function_parameter =>
            match function_parameter with
            | Some d' => tt
            | Some d' =>
              op_startypeminuserrorstar (Stdlib.Bytes.to_string d)
                (Stdlib.Bytes.to_string d')
                "Error while reading key %d %S
%!" % string
                (Stdlib.Bytes.compare d d') (String.concat Filename.dir_sep k)
            | None =>
              op_startypeminuserrorstar (Stdlib.Bytes.to_string d) "" % string
                "Error while reading key %S
%!" % string
                (String.concat Filename.dir_sep k)
            end).

Definition check_none {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> (list string) -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    fun k =>
      op_gtpipeeq (Store.(Tezos_storage__Store_sigs.STORE.read_opt) s k)
        (fun function_parameter =>
          match function_parameter with
          | None => tt
          | Some _ =>
            op_startypeminuserrorstar
              "Error while reading non-existent key %S
%!" % string
              (String.concat Filename.dir_sep k)
          end).

Definition test_generic {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    op_gtgteq
      (Store.(Tezos_storage__Store_sigs.STORE.store) s
        (cons "day" % string (cons "current" % string []))
        (Stdlib.Bytes.of_string "Mercredi" % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (Store.(Tezos_storage__Store_sigs.STORE.store) s
            (cons "day" % string (cons "next" % string []))
            (Stdlib.Bytes.of_string "Jeudi" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (Store.(Tezos_storage__Store_sigs.STORE.store) s
                (cons "day" % string
                  (cons "truc" % string (cons "chose" % string [])))
                (Stdlib.Bytes.of_string "Vendredi" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (check Store s
                    (cons "day" % string (cons "current" % string []))
                    (Stdlib.Bytes.of_string "Mercredi" % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      (check Store s
                        (cons "day" % string (cons "next" % string []))
                        (Stdlib.Bytes.of_string "Jeudi" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        check_none Store s (cons "day" % string [])))))).

Definition list {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> (list string) -> Lwt.t (list (list string)) :=
  let Store := projT2 Store in
  fun s => fun k => Store.(Tezos_storage__Store_sigs.STORE.keys) s k.

Definition test_generic_list {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    op_gtgteq
      (Store.(Tezos_storage__Store_sigs.STORE.store) s
        (cons "a" % string (cons "b" % string []))
        (Stdlib.Bytes.of_string "Novembre" % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (Store.(Tezos_storage__Store_sigs.STORE.store) s
            (cons "a" % string (cons "c" % string []))
            (Stdlib.Bytes.of_string "Juin" % string))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (Store.(Tezos_storage__Store_sigs.STORE.store) s
                (cons "a" % string (cons "d" % string (cons "e" % string [])))
                (Stdlib.Bytes.of_string "Septembre" % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Store.(Tezos_storage__Store_sigs.STORE.store) s
                    (cons "f" % string [])
                    (Stdlib.Bytes.of_string "Avril" % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq
                      (Store.(Tezos_storage__Store_sigs.STORE.store) s
                        (cons "g" % string (cons "h" % string []))
                        (Stdlib.Bytes.of_string "Avril" % string))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (list Store s [])
                          (fun l =>
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              op_startypeminuserrorstar Stdlib.__LOC__
                                (cons (cons "a" % string (cons "b" % string []))
                                  (cons
                                    (cons "a" % string (cons "c" % string []))
                                    (cons
                                      (cons "a" % string
                                        (cons "d" % string
                                          (cons "e" % string [])))
                                      (cons (cons "f" % string [])
                                        (cons
                                          (cons "g" % string
                                            (cons "h" % string [])) [])))))
                                (List.sort OCaml.Stdlib.compare l) in
                            op_gtgteq (list Store s (cons "a" % string []))
                              (fun l =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  op_startypeminuserrorstar Stdlib.__LOC__
                                    (cons
                                      (cons "a" % string (cons "b" % string []))
                                      (cons
                                        (cons "a" % string
                                          (cons "c" % string []))
                                        (cons
                                          (cons "a" % string
                                            (cons "d" % string
                                              (cons "e" % string []))) [])))
                                    (List.sort OCaml.Stdlib.compare l) in
                                op_gtgteq (list Store s (cons "f" % string []))
                                  (fun l =>
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      op_startypeminuserrorstar Stdlib.__LOC__
                                        [] l in
                                    op_gtgteq
                                      (list Store s (cons "g" % string []))
                                      (fun l =>
                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                        let _ :=
                                          op_startypeminuserrorstar
                                            Stdlib.__LOC__
                                            (cons
                                              (cons "g" % string
                                                (cons "h" % string [])) [])
                                            (List.sort OCaml.Stdlib.compare l)
                                          in
                                        op_gtgteq
                                          (list Store s (cons "i" % string []))
                                          (fun l =>
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            let _ :=
                                              op_startypeminuserrorstar
                                                Stdlib.__LOC__ [] l in
                                            Lwt.return_unit)))))))))).

Import Store_helpers.

Definition test_hashset {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let BlockSet := Block_hash.Set in
    let StoreSet :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    let bhset := add bh2 (add bh1 empty) in
    op_gtgteq
      (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all) s bhset)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all) s)
          (fun bhset' =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := op_startypeminuserrorstar Stdlib.__LOC__ bhset bhset' in
            let bhset2 :=
              OCaml.Stdlib.reverse_apply
                (OCaml.Stdlib.reverse_apply bhset (add bh3)) (remove bh1) in
            op_gtgteq
              (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all)
                s bhset2)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
                    s)
                  (fun bhset2' =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar Stdlib.__LOC__ bhset2 bhset2' in
                    op_gtgteq
                      (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.fold)
                        s BlockSet.empty
                        (fun bh => fun acc => Lwt._return (BlockSet.add bh acc)))
                      (fun bhset2'' =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          op_startypeminuserrorstar Stdlib.__LOC__ bhset2
                            bhset2'' in
                        op_gtgteq
                          (Store.(Tezos_storage__Store_sigs.STORE.store) s
                            (cons "day" % string (cons "current" % string []))
                            (Stdlib.Bytes.of_string "Mercredi" % string))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove_all)
                                s)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  (StoreSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
                                    s)
                                  (fun empty =>
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      op_startypeminuserrorstar Stdlib.__LOC__
                                        BlockSet.empty empty in
                                    op_gtgteq
                                      (check Store s
                                        (cons "day" % string
                                          (cons "current" % string []))
                                        (Stdlib.Bytes.of_string
                                          "Mercredi" % string))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        Lwt.return_unit))))))))).

Definition test_hashmap {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let BlockMap := Block_hash.Map in
    let StoreMap :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    let eq := equiv_decb in
    let map :=
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply empty (add bh1 (1, "a" % char)))
        (add bh2 (2, "b" % char)) in
    op_gtgteq
      (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store_all) s map)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all) s)
          (fun map' =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := op_startypeminuserrorstar Stdlib.__LOC__ eq map map' in
            let map2 :=
              OCaml.Stdlib.reverse_apply
                (OCaml.Stdlib.reverse_apply map
                  (BlockMap.add bh3 (3, "c" % char))) (BlockMap.remove bh1) in
            op_gtgteq
              (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store_all)
                s map2)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (StoreMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
                    s)
                  (fun map2' =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar Stdlib.__LOC__ eq map2 map2' in
                    Lwt.return_unit)))).

Definition test_single {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let Single :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
      (fun known =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
        op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt) s)
          (fun v' =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := op_startypeminuserrorstar Stdlib.__LOC__ None v' in
            let v := (3, "Non!" % string) in
            op_gtgteq
              (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.store) s v)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
                  (fun known =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
                    op_gtgteq
                      (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                        s)
                      (fun v' =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          op_startypeminuserrorstar Stdlib.__LOC__ (Some v) v'
                          in
                        op_gtgteq
                          (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.remove)
                            s)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known)
                                s)
                              (fun known =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  op_startypeminuserrorstar Stdlib.__LOC__ known
                                  in
                                op_gtgteq
                                  (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                                    s)
                                  (fun v' =>
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      op_startypeminuserrorstar Stdlib.__LOC__
                                        None v' in
                                    Lwt.return_unit)))))))).

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Definition test_subblock
  (s : SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.t))
  : Lwt.t unit :=
  op_gtgteq
    (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.known) s bh1)
    (fun known =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
      op_gtgteq
        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store) s bh1)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store) s
              bh2)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.known)
                  s bh2)
                (fun known =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := op_startypeminuserrorstar Stdlib.__LOC__ known in
                  op_gtgteq
                    (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.read_all)
                      s)
                    (fun set =>
                      let set' :=
                        OCaml.Stdlib.reverse_apply
                          (OCaml.Stdlib.reverse_apply empty (add bh1)) (add bh2)
                        in
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ := op_startypeminuserrorstar Stdlib.__LOC__ set set'
                        in
                      op_gtgteq
                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove)
                          s bh2)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          let set :=
                            OCaml.Stdlib.reverse_apply
                              (OCaml.Stdlib.reverse_apply empty (add bh3'))
                              (add bh3) in
                          op_gtgteq
                            (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store_all)
                              s set)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
                                  s)
                                (fun elts =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    op_startypeminuserrorstar Stdlib.__LOC__
                                      (List.sort Block_hash.compare elts)
                                      (List.sort Block_hash.compare
                                        (cons bh3 (cons bh3' []))) in
                                  op_gtgteq
                                    (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
                                      s bh2)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteq
                                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove)
                                          s bh3)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteq
                                            (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
                                              s)
                                            (fun elts =>
                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                              let _ :=
                                                op_startypeminuserrorstar
                                                  Stdlib.__LOC__
                                                  (List.sort Block_hash.compare
                                                    elts)
                                                  (List.sort Block_hash.compare
                                                    (cons bh2 (cons bh3' [])))
                                                in
                                              op_gtgteq
                                                (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.known)
                                                  s bh1)
                                                (fun known =>
                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                  let _ :=
                                                    op_startypeminuserrorstar
                                                      Stdlib.__LOC__ known in
                                                  let v1 : Z * string :=
                                                    (3, "Non!" % string)
                                                  with v2 : Z * string :=
                                                    (12, "Beurk." % string) in
                                                  op_gtgteq
                                                    (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store)
                                                      s bh1 v1)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteq
                                                        (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.store)
                                                          s bh2 v2)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_gtgteq
                                                            (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.known)
                                                              s bh1)
                                                            (fun known =>
                                                              op_gtgteq
                                                                (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_opt)
                                                                  s bh1)
                                                                (fun v1' =>
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    op_startypeminuserrorstar
                                                                      Stdlib.__LOC__
                                                                      (Some v1)
                                                                      v1' in
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    op_startypeminuserrorstar
                                                                      Stdlib.__LOC__
                                                                      known in
                                                                  let map :=
                                                                    OCaml.Stdlib.reverse_apply
                                                                      (OCaml.Stdlib.reverse_apply
                                                                        empty
                                                                        (add bh1
                                                                          v1))
                                                                      (add bh2
                                                                        v2) in
                                                                  op_gtgteq
                                                                    (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
                                                                      s)
                                                                    (fun map' =>
                                                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                      let _ :=
                                                                        op_startypeminuserrorstar
                                                                          equiv_decb
                                                                          Stdlib.__LOC__
                                                                          map
                                                                          map'
                                                                        in
                                                                      op_gtgteq
                                                                        (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.remove_all)
                                                                          s)
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          op_gtgteq
                                                                            (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.elements)
                                                                              s)
                                                                            (fun
                                                                              elts
                                                                              =>
                                                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                              let
                                                                                _
                                                                                :=
                                                                                op_startypeminuserrorstar
                                                                                  Stdlib.__LOC__
                                                                                  elts
                                                                                  []
                                                                                in
                                                                              op_gtgteq
                                                                                (SubBlocksMap.(Tezos_storage__Store_sigs.BUFFERED_MAP_STORE.read_all)
                                                                                  s)
                                                                                (fun
                                                                                  map'
                                                                                  =>
                                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                  let
                                                                                    _
                                                                                    :=
                                                                                    op_startypeminuserrorstar
                                                                                      equiv_decb
                                                                                      Stdlib.__LOC__
                                                                                      map
                                                                                      map'
                                                                                    in
                                                                                  op_gtgteq
                                                                                    (SubBlocksSet.(Tezos_storage__Store_sigs.BUFFERED_SET_STORE.store)
                                                                                      s
                                                                                      bh3)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_gtgteq
                                                                                        (SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.indexes)
                                                                                          s)
                                                                                        (fun
                                                                                          keys
                                                                                          =>
                                                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                                          let
                                                                                            _
                                                                                            :=
                                                                                            op_startypeminuserrorstar
                                                                                              Stdlib.__LOC__
                                                                                              (List.sort
                                                                                                Block_hash.compare
                                                                                                keys)
                                                                                              (List.sort
                                                                                                Block_hash.compare
                                                                                                (cons
                                                                                                  bh1
                                                                                                  (cons
                                                                                                    bh2
                                                                                                    (cons
                                                                                                      bh3
                                                                                                      []))))
                                                                                            in
                                                                                          Lwt.return_unit)))))))))))))))))))))).

(* ❌ Applications of functors are not handled. *)
functor_application

Definition tests_raw
  : list (string * (Tezos_storage.Raw_store.t -> Lwt.t unit)) :=
  cons ("init" % string, test_init)
    (cons ("generic" % string, (test_generic Raw_store))
      (cons ("generic_substore" % string, (test_generic Sub))
        (cons
          ("generic_indexedstore" % string,
            (fun s =>
              test_generic
                SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                (s, bh1)))
          (cons
            ("generic_indexedsubstore" % string,
              (fun s =>
                test_generic
                  SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                  ((s, bh1), bh2)))
            (cons ("single" % string, (test_single Raw_store))
              (cons ("single_substore" % string, (test_single Sub))
                (cons
                  ("single_indexedstore" % string,
                    (fun s =>
                      test_single
                        SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                        (s, bh1)))
                  (cons
                    ("single_indexedsubstore" % string,
                      (fun s =>
                        test_single
                          SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                          ((s, bh1), bh2)))
                    (cons
                      ("generic_list" % string, (test_generic_list Raw_store))
                      (cons
                        ("generic_substore_list" % string,
                          (test_generic_list Sub))
                        (cons
                          ("generic_indexedstore_list" % string,
                            (fun s =>
                              test_generic_list
                                SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                (s, bh1)))
                          (cons
                            ("generic_indexedsubstore_list" % string,
                              (fun s =>
                                test_generic_list
                                  SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                  ((s, bh1), bh2)))
                            (cons ("hashset" % string, (test_hashset Raw_store))
                              (cons
                                ("hashset_substore" % string, (test_hashset Sub))
                                (cons
                                  ("hashset_indexedstore" % string,
                                    (fun s =>
                                      test_hashset
                                        SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                        (s, bh1)))
                                  (cons
                                    ("hashset_indexedsubstore" % string,
                                      (fun s =>
                                        test_hashset
                                          SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                          ((s, bh1), bh2)))
                                    (cons
                                      ("hashmap" % string,
                                        (test_hashmap Raw_store))
                                      (cons
                                        ("hashmap_substore" % string,
                                          (test_hashmap Sub))
                                        (cons
                                          ("hashmap_indexedstore" % string,
                                            (fun s =>
                                              test_hashmap
                                                SubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                                (s, bh1)))
                                          (cons
                                            ("hashmap_indexedsubstore" % string,
                                              (fun s =>
                                                test_hashmap
                                                  SubSubBlocks.(Tezos_storage__Store_sigs.INDEXED_STORE.Store)
                                                  ((s, bh1), bh2)))
                                            (cons
                                              ("subblock" % string,
                                                test_subblock) []))))))))))))))))))))).

Definition tests : list (string * (Tezos_shell.Store.t -> Lwt.t unit)) :=
  cons ("expand" % string, test_expand) (cons ("block" % string, test_block) []).

Definition tests {A : Type} : list A :=
  OCaml.Stdlib.app
    (List.map
      (fun function_parameter =>
        let '(s, f) := function_parameter in
        op_startypeminuserrorstar s
          (* ❌ Variants not supported *)
          variant (wrap_raw_store_init f)) tests_raw)
    (List.map
      (fun function_parameter =>
        let '(s, f) := function_parameter in
        op_startypeminuserrorstar s
          (* ❌ Variants not supported *)
          variant (wrap_store_init f)) tests).

src/lib_shell/test/test_store_checkpoint.ml 20 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let mapsize = 4_096_000_000L (* ~4 GiB *)

let ( // ) = Filename.concat

let wrap_raw_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      Raw_store.init ~mapsize root
      >>= function
      | Ok store ->
          Lwt.finalize
            (fun () -> f store)
            (fun () -> Raw_store.close store ; Lwt.return_unit)
      | Error err ->
          Format.kasprintf
            Pervasives.failwith
            "@[Cannot initialize store:@ %a@]"
            pp_print_error
            err)

(**************************************************************************)
(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

(**************************************************************************)
(** Block store *)

let lolblock ?(operations = []) header =
  let operations_hash =
    Operation_list_list_hash.compute [Operation_list_hash.compute operations]
  in
  let block_header =
    {
      Block_header.shell =
        {
          timestamp = Time.Protocol.of_seconds (Random.int64 1500L);
          level = 0l;
          (* dummy *)
          proto_level = 0;
          (* dummy *)
          validation_passes = Random.int 32;
          predecessor = genesis_block;
          operations_hash;
          fitness =
            [ Bytes.of_string @@ string_of_int @@ String.length header;
              Bytes.of_string @@ string_of_int @@ 12 ];
          context = Context_hash.zero;
        };
      protocol_data = Bytes.of_string header;
    }
  in
  let block_contents =
    {
      header = block_header;
      Store.Block.metadata = Bytes.create 0;
      max_operations_ttl = 0;
      message = None;
      context = Context_hash.zero;
      last_allowed_fork_level = 0l;
    }
  in
  (block_header, block_contents)

let (block_header, _) = lolblock "A1"

let block_hash = Block_header.hash block_header

(****************************************************)

open Store_helpers

let test_single (type t) (module Store : Store_sigs.STORE with type t = t)
    (s : Store.t) =
  let module Single =
    Make_single_store
      (Store)
      (struct
        let name = ["checkpoint"]
      end)
      (Store_helpers.Make_value (struct
        type t = Int32.t * Block_hash.t

        let encoding = Data_encoding.(tup2 int32 Block_hash.encoding)
      end))
  in
  (* is there any checkpoint in store *)
  Single.known s
  >>= fun is_known ->
  Assert.is_false ~msg:__LOC__ is_known ;
  Single.read_opt s
  >>= fun checkpoint' ->
  Assert.equal_checkpoint ~msg:__LOC__ None checkpoint' ;
  (* store new checkpoint: (1, A1) *)
  let checkpoint = (1l, block_hash) in
  Single.store s checkpoint
  >>= fun () ->
  Single.known s
  >>= fun is_known ->
  Assert.is_true ~msg:__LOC__ is_known ;
  Single.read_opt s
  >>= fun checkpoint' ->
  Assert.equal_checkpoint ~msg:__LOC__ (Some checkpoint) checkpoint' ;
  (* remove the checkpoint just store *)
  Single.remove s
  >>= fun () ->
  Single.known s
  >>= fun is_known ->
  Assert.is_false ~msg:__LOC__ is_known ;
  Single.read_opt s
  >>= fun checkpoint' ->
  Assert.equal_checkpoint ~msg:__LOC__ None checkpoint' ;
  Lwt.return_unit

(**************************************************************************)

let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list =
  [("single", test_single (module Raw_store))]

let tests =
  List.map
    (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_raw_store_init f))
    tests_raw
src/lib_shell/test/test_store_checkpoint.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition mapsize : int64 :=
  (* ❌ Constant of type int64 is converted to int *)
  4096000000.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition wrap_raw_store_init {A B : Type}
  (f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  let '_ := function_parameter in
  fun function_parameter =>
    let 'tt := function_parameter in
    Lwt_utils_unix.with_tempdir "tezos_test_" % string
      (fun base_dir =>
        let root := op_divdiv base_dir "store" % string in
        op_gtgteq (Raw_store.init None (Some mapsize) root)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok store =>
              Lwt.finalize
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  f store)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := Raw_store.close store in
                  Lwt.return_unit)
            | Stdlib.Error err =>
              Format.kasprintf Pervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        CamlinternalFormatBasics.End_of_format "" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Cannot initialize store:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))
                  "@[Cannot initialize store:@ %a@]" % string) pp_print_error
                err
            end)).

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition lolblock
  (op_staroptstar :
    option (list Tezos_base__TzPervasives.Operation_list_hash.elt))
  : string ->
    Tezos_base__TzPervasives.Block_header.t * Tezos_shell.Store.Block.contents :=
  let operations :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun header =>
    let operations_hash :=
      Operation_list_list_hash.compute
        (cons (Operation_list_hash.compute operations) []) in
    let block_header :=
      {|
        Block_header.shell :=
          {|
            level :=
              (* ❌ Constant of type int32 is converted to int *)
              0; proto_level := 0; predecessor := genesis_block;
            timestamp :=
              Time.Protocol.of_seconds
                (Random.int64
                  (* ❌ Constant of type int64 is converted to int *)
                  1500); validation_passes := Random.int 32;
            operations_hash := operations_hash;
            fitness :=
              cons
                (apply Stdlib.Bytes.of_string
                  (apply OCaml.Stdlib.string_of_int (String.length header)))
                (cons
                  (apply Stdlib.Bytes.of_string
                    (apply OCaml.Stdlib.string_of_int 12)) []);
            context := Context_hash.zero |};
        Block_header.protocol_data := Stdlib.Bytes.of_string header |} in
    let block_contents :=
      {| Store.Block.header := block_header; Store.Block.message := None;
        Store.Block.max_operations_ttl := 0;
        Store.Block.last_allowed_fork_level :=
          (* ❌ Constant of type int32 is converted to int *)
          0; Store.Block.context := Context_hash.zero;
        Store.Block.metadata := Stdlib.Bytes.create 0 |} in
    (block_header, block_contents).



Definition block_hash : Tezos_crypto.Block_hash.t :=
  Block_header.hash block_header.

Import Store_helpers.

Definition test_single {A : Type}
  (Store : {_ : unit & Tezos_storage.Store_sigs.STORE.signature A})
  : A -> Lwt.t unit :=
  let Store := projT2 Store in
  fun s =>
    let Single :=
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application in
    op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
      (fun is_known =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := op_startypeminuserrorstar Stdlib.__LOC__ is_known in
        op_gtgteq (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt) s)
          (fun checkpoint' =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := op_startypeminuserrorstar Stdlib.__LOC__ None checkpoint'
              in
            let checkpoint :=
              ((* ❌ Constant of type int32 is converted to int *)
              1, block_hash) in
            op_gtgteq
              (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.store) s
                checkpoint)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known) s)
                  (fun is_known =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := op_startypeminuserrorstar Stdlib.__LOC__ is_known
                      in
                    op_gtgteq
                      (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                        s)
                      (fun checkpoint' =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          op_startypeminuserrorstar Stdlib.__LOC__
                            (Some checkpoint) checkpoint' in
                        op_gtgteq
                          (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.remove)
                            s)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.known)
                                s)
                              (fun is_known =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  op_startypeminuserrorstar Stdlib.__LOC__
                                    is_known in
                                op_gtgteq
                                  (Single.(Tezos_storage__Store_sigs.SINGLE_STORE.read_opt)
                                    s)
                                  (fun checkpoint' =>
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      op_startypeminuserrorstar Stdlib.__LOC__
                                        None checkpoint' in
                                    Lwt.return_unit)))))))).

Definition tests_raw
  : list (string * (Tezos_storage.Raw_store.t -> Lwt.t unit)) :=
  cons ("single" % string, (test_single Raw_store)) [].

Definition tests {A : Type} : list A :=
  List.map
    (fun function_parameter =>
      let '(s, f) := function_parameter in
      op_startypeminuserrorstar s
        (* ❌ Variants not supported *)
        variant (wrap_raw_store_init f)) tests_raw.

src/lib_shell/validator.ml 30 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.validator"
end)

type t = {
  state : State.t;
  db : Distributed_db.t;
  block_validator : Block_validator.t;
  chain_validator_limits : Chain_validator.limits;
  peer_validator_limits : Peer_validator.limits;
  block_validator_limits : Block_validator.limits;
  prevalidator_limits : Prevalidator.limits;
  start_testchain : bool;
  valid_block_input : State.Block.t Lwt_watcher.input;
  chains_input : (Chain_id.t * bool) Lwt_watcher.input;
  active_chains : Chain_validator.t Chain_id.Table.t;
}

let create state db peer_validator_limits block_validator_limits
    block_validator_kind prevalidator_limits chain_validator_limits
    ~start_testchain =
  Block_validator.create
    block_validator_limits
    db
    block_validator_kind
    ~start_testchain
  >>=? fun block_validator ->
  let valid_block_input = Lwt_watcher.create_input () in
  let chains_input = Lwt_watcher.create_input () in
  return
    {
      state;
      db;
      start_testchain;
      block_validator;
      block_validator_limits;
      prevalidator_limits;
      peer_validator_limits;
      chain_validator_limits;
      valid_block_input;
      chains_input;
      active_chains = Chain_id.Table.create 7;
    }

let activate v ~start_prevalidator ~validator_process chain_state =
  let chain_id = State.Chain.id chain_state in
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f "activate chain %a" -% t event "active_chain"
        -% a State_logging.chain_id chain_id)
  >>= fun () ->
  match Chain_id.Table.find_opt v.active_chains chain_id with
  | Some chain ->
      return chain
  | None ->
      Chain_validator.create
        ~start_prevalidator
        ~start_testchain:v.start_testchain
        ~active_chains:v.active_chains
        ~block_validator_process:validator_process
        v.peer_validator_limits
        v.prevalidator_limits
        v.block_validator
        v.valid_block_input
        v.chains_input
        v.db
        chain_state
        v.chain_validator_limits

let get_exn {active_chains; _} chain_id =
  Chain_id.Table.find active_chains chain_id

let get {active_chains; _} chain_id =
  match Chain_id.Table.find_opt active_chains chain_id with
  | Some nv ->
      Ok nv
  | None ->
      error (Validation_errors.Inactive_chain chain_id)

let get_active_chains {active_chains; _} =
  let l = Chain_id.Table.fold (fun c _ acc -> c :: acc) active_chains [] in
  List.rev l

let validate_block v ?(force = false) ?chain_id bytes operations =
  let hash = Block_hash.hash_bytes [bytes] in
  match Block_header.of_bytes bytes with
  | None ->
      failwith "Cannot parse block header."
  | Some block ->
      ( match chain_id with
      | None -> (
          Distributed_db.read_block_header v.db block.shell.predecessor
          >>= function
          | None ->
              failwith
                "Unknown predecessor (%a), cannot inject the block."
                Block_hash.pp_short
                block.shell.predecessor
          | Some (chain_id, _bh) ->
              Lwt.return (get v chain_id) )
      | Some chain_id -> (
          Lwt.return (get v chain_id)
          >>=? fun nv ->
          if force then return nv
          else
            Distributed_db.Block_header.known
              (Chain_validator.chain_db nv)
              block.shell.predecessor
            >>= function
            | true ->
                return nv
            | false ->
                failwith
                  "Unknown predecessor (%a), cannot inject the block."
                  Block_hash.pp_short
                  block.shell.predecessor ) )
      >>=? fun nv ->
      let validation =
        Chain_validator.validate_block nv ~force hash block operations
      in
      return (hash, validation)

let shutdown {active_chains; block_validator; _} =
  let block_validator_job =
    lwt_log_notice
      Tag.DSL.(
        fun f -> f "Shutting down the block validator..." -% t event "shutdown")
    >>= fun () -> Block_validator.shutdown block_validator
  in
  let chain_validator_jobs =
    List.of_seq
    @@ Seq.map
         (fun (id, nv) ->
           lwt_log_notice
             Tag.DSL.(
               fun f ->
                 f "Shutting down the chain validator %a..."
                 -% t event "shutdown"
                 -% a State_logging.chain_id id)
           >>= fun () -> Chain_validator.shutdown nv)
         (Chain_id.Table.to_seq active_chains)
  in
  Lwt.join (block_validator_job :: chain_validator_jobs)

let watcher {valid_block_input; _} =
  Lwt_watcher.create_stream valid_block_input

let chains_watcher {chains_input; _} = Lwt_watcher.create_stream chains_input

let inject_operation v ?chain_id op =
  ( match chain_id with
  | None -> (
      Distributed_db.read_block_header v.db op.Operation.shell.branch
      >>= function
      | None ->
          failwith
            "Unknown branch (%a), cannot inject the operation."
            Block_hash.pp_short
            op.shell.branch
      | Some (chain_id, _bh) ->
          Lwt.return (get v chain_id) )
  | Some chain_id -> (
      Lwt.return (get v chain_id)
      >>=? fun nv ->
      Distributed_db.Block_header.known
        (Chain_validator.chain_db nv)
        op.shell.branch
      >>= function
      | true ->
          return nv
      | false ->
          failwith
            "Unknown branch (%a), cannot inject the operation."
            Block_hash.pp_short
            op.shell.branch ) )
  >>=? fun nv ->
  let pv_opt = Chain_validator.prevalidator nv in
  match pv_opt with
  | Some pv ->
      Prevalidator.inject_operation pv op
  | None ->
      failwith "Prevalidator is not running, cannot inject the operation."

let distributed_db {db; _} = db
src/lib_shell/validator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Record t := {
  state : Tezos_shell.State.t;
  db : Tezos_shell.Distributed_db.t;
  block_validator : Tezos_shell.Block_validator.t;
  chain_validator_limits : Tezos_shell.Chain_validator.limits;
  peer_validator_limits : Tezos_shell.Peer_validator.limits;
  block_validator_limits : Tezos_shell.Block_validator.limits;
  prevalidator_limits : Tezos_shell.Prevalidator.limits;
  start_testchain : bool;
  valid_block_input :
    Tezos_base__TzPervasives.Lwt_watcher.input Tezos_shell.State.Block.t;
  chains_input :
    Tezos_base__TzPervasives.Lwt_watcher.input
      (Tezos_base__TzPervasives.Chain_id.t * bool);
  active_chains :
    Tezos_base__TzPervasives.Chain_id.Table.t Tezos_shell.Chain_validator.t }.

Definition create
  (state : Tezos_shell.State.t) (db : Tezos_shell.Distributed_db.t)
  (peer_validator_limits : Tezos_shell.Peer_validator.limits)
  (block_validator_limits : Tezos_shell.Block_validator.limits)
  (block_validator_kind : Tezos_shell.Block_validator_process.t)
  (prevalidator_limits : Tezos_shell.Prevalidator.limits)
  (chain_validator_limits : Tezos_shell.Chain_validator.limits)
  (start_testchain : bool) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  op_gtgteqquestion
    (Block_validator.create block_validator_limits db block_validator_kind
      start_testchain)
    (fun block_validator =>
      let valid_block_input := Lwt_watcher.create_input tt in
      let chains_input := Lwt_watcher.create_input tt in
      _return
        {| state := state; db := db; block_validator := block_validator;
          chain_validator_limits := chain_validator_limits;
          peer_validator_limits := peer_validator_limits;
          block_validator_limits := block_validator_limits;
          prevalidator_limits := prevalidator_limits;
          start_testchain := start_testchain;
          valid_block_input := valid_block_input; chains_input := chains_input;
          active_chains := Chain_id.Table.create 7 |}).

Definition activate
  (v : t) (start_prevalidator : bool)
  (validator_process : Tezos_shell.Block_validator_process.t)
  (chain_state : Tezos_shell.State.Chain.chain_state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_shell.Chain_validator.t) :=
  let chain_id := State.Chain.id chain_state in
  op_gtgteq
    (lwt_log_notice
      (fun f =>
        op_minuspercent
          (op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "activate chain " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))
                "activate chain %a" % string)) (t event "active_chain" % string))
          (a State_logging.chain_id chain_id)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      match Chain_id.Table.find_opt (active_chains v) chain_id with
      | Some chain => _return chain
      | None =>
        Chain_validator.create start_prevalidator (start_testchain v)
          (active_chains v) validator_process (peer_validator_limits v)
          (prevalidator_limits v) (block_validator v) (valid_block_input v)
          (chains_input v) (db v) chain_state (chain_validator_limits v)
      end).

Definition get_exn (function_parameter : t)
  : Tezos_base__TzPervasives.Chain_id.Table.key -> Tezos_shell.Chain_validator.t :=
  let '{| active_chains := active_chains |} := function_parameter in
  fun chain_id => Chain_id.Table.find active_chains chain_id.

Definition get (function_parameter : t)
  : Tezos_base__TzPervasives.Chain_id.Table.key ->
    sum Tezos_shell.Chain_validator.t Tezos_base__TzPervasives.trace :=
  let '{| active_chains := active_chains |} := function_parameter in
  fun chain_id =>
    match Chain_id.Table.find_opt active_chains chain_id with
    | Some nv => Stdlib.Ok nv
    | None => error (Tezos_base__TzPervasives.Inactive_chain chain_id)
    end.

Definition get_active_chains (function_parameter : t)
  : list Tezos_base__TzPervasives.Chain_id.Table.key :=
  let '{| active_chains := active_chains |} := function_parameter in
  let l :=
    Chain_id.Table.fold
      (fun c =>
        fun function_parameter =>
          let '_ := function_parameter in
          fun acc => cons c acc) active_chains [] in
  List.rev l.

Definition validate_block (v : t) (op_staroptstar : option bool)
  : (option Tezos_base__TzPervasives.Chain_id.Table.key) ->
    Stdlib.Bytes.t ->
      (list (list Tezos_base__TzPervasives.Operation.t)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Block_hash.t *
              (Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  (option Tezos_shell.State.Block.t))))) :=
  let force :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun chain_id =>
    fun bytes =>
      fun operations =>
        let hash := Block_hash.hash_bytes None (cons string []) in
        match Block_header.of_bytes string with
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot parse block header." % string
                CamlinternalFormatBasics.End_of_format)
              "Cannot parse block header." % string)
        | Some block =>
          op_gtgteqquestion
            match chain_id with
            | None =>
              op_gtgteq
                (Distributed_db.read_block_header (db v)
                  (predecessor (shell block)))
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Unknown predecessor (" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              "), cannot inject the block." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Unknown predecessor (%a), cannot inject the block." %
                          string) Block_hash.pp_short
                      (predecessor (shell block))
                  | Some (chain_id, _bh) => Lwt._return (get v chain_id)
                  end)
            | Some chain_id =>
              op_gtgteqquestion (Lwt._return (get v chain_id))
                (fun nv =>
                  if force then
                    _return nv
                  else
                    op_gtgteq
                      (Distributed_db.Block_header.known
                        (Chain_validator.chain_db nv)
                        (predecessor (shell block)))
                      (fun function_parameter =>
                        match function_parameter with
                        | true => _return nv
                        | false =>
                          failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Unknown predecessor (" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    "), cannot inject the block." % string
                                    CamlinternalFormatBasics.End_of_format)))
                              "Unknown predecessor (%a), cannot inject the block."
                                % string) Block_hash.pp_short
                            (predecessor (shell block))
                        end))
            end
            (fun nv =>
              let validation :=
                Chain_validator.validate_block nv (Some force) hash block
                  operations in
              _return (hash, validation))
        end.

Definition shutdown (function_parameter : t) : Lwt.t unit :=
  let '{|
    block_validator := block_validator; active_chains := active_chains |} :=
    function_parameter in
  let block_validator_job :=
    op_gtgteq
      (lwt_log_notice
        (fun f =>
          op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Shutting down the block validator..." % string
                  CamlinternalFormatBasics.End_of_format)
                "Shutting down the block validator..." % string))
            (t event "shutdown" % string)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Block_validator.shutdown block_validator) in
  let chain_validator_jobs :=
    apply List.of_seq
      (Seq.map
        (fun function_parameter =>
          let '(id, nv) := function_parameter in
          op_gtgteq
            (lwt_log_notice
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Shutting down the chain validator " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              "..." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Shutting down the chain validator %a..." % string))
                    (t event "shutdown" % string)) (a State_logging.chain_id id)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Chain_validator.shutdown nv))
        (Chain_id.Table.to_seq active_chains)) in
  Lwt.join (cons block_validator_job chain_validator_jobs).

Definition watcher (function_parameter : t)
  : (Lwt_stream.t Tezos_shell.State.Block.t) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  let '{| valid_block_input := valid_block_input |} := function_parameter in
  Lwt_watcher.create_stream valid_block_input.

Definition chains_watcher (function_parameter : t)
  : (Lwt_stream.t (Tezos_base__TzPervasives.Chain_id.t * bool)) *
    Tezos_base__TzPervasives.Lwt_watcher.stopper :=
  let '{| chains_input := chains_input |} := function_parameter in
  Lwt_watcher.create_stream chains_input.

Definition inject_operation
  (v : t) (chain_id : option Tezos_base__TzPervasives.Chain_id.Table.key)
  (op : Tezos_base__TzPervasives.Operation.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    match chain_id with
    | None =>
      op_gtgteq
        (Distributed_db.read_block_header (db v) (branch (Operation.shell op)))
        (fun function_parameter =>
          match function_parameter with
          | None =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Unknown branch (" % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "), cannot inject the operation." % string
                      CamlinternalFormatBasics.End_of_format)))
                "Unknown branch (%a), cannot inject the operation." % string)
              Block_hash.pp_short (branch (shell op))
          | Some (chain_id, _bh) => Lwt._return (get v chain_id)
          end)
    | Some chain_id =>
      op_gtgteqquestion (Lwt._return (get v chain_id))
        (fun nv =>
          op_gtgteq
            (Distributed_db.Block_header.known (Chain_validator.chain_db nv)
              (branch (shell op)))
            (fun function_parameter =>
              match function_parameter with
              | true => _return nv
              | false =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Unknown branch (" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          "), cannot inject the operation." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "Unknown branch (%a), cannot inject the operation." % string)
                  Block_hash.pp_short (branch (shell op))
              end))
    end
    (fun nv =>
      let pv_opt := Chain_validator.prevalidator nv in
      match pv_opt with
      | Some pv => Prevalidator.inject_operation pv op
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Prevalidator is not running, cannot inject the operation." %
                string CamlinternalFormatBasics.End_of_format)
            "Prevalidator is not running, cannot inject the operation." % string)
      end).

Definition distributed_db (function_parameter : t)
  : Tezos_shell.Distributed_db.t :=
  let '{| db := db |} := function_parameter in
  db.

src/lib_shell/worker.ml 39 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type NAME = sig
  val base : string list

  type t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module type EVENT = sig
  type t

  val level : t -> Internal_event.level

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module type REQUEST = sig
  type 'a t

  type view

  val view : 'a t -> view

  val encoding : view Data_encoding.t

  val pp : Format.formatter -> view -> unit
end

module type TYPES = sig
  type state

  type parameters

  type view

  val view : state -> parameters -> view

  val encoding : view Data_encoding.t

  val pp : Format.formatter -> view -> unit
end

module type LOGGER = sig
  module Event : EVENT

  module Request : REQUEST

  type status =
    | WorkerEvent of Event.t
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Terminated
    | Timeout
    | Crashed of error list
    | Started of string option
    | Triggering_shutdown
    | Duplicate of string

  type t = status Time.System.stamped

  module MakeDefinition (Static : sig
    val worker_name : string
  end) : Internal_event.EVENT_DEFINITION with type t = t
end

(** An error returned when trying to communicate with a worker that
    has been closed.*)
type worker_name = {base : string; name : string}

type Error_monad.error += Closed of worker_name

let () =
  register_error_kind
    `Permanent
    ~id:"worker.closed"
    ~title:"Worker closed"
    ~description:
      "An operation on a worker could not complete before it was shut down."
    ~pp:(fun ppf w ->
      Format.fprintf ppf "Worker %s[%s] has been shut down." w.base w.name)
    Data_encoding.(
      conv
        (fun {base; name} -> (base, name))
        (fun (name, base) -> {base; name})
        (obj1 (req "worker" (tup2 string string))))
    (function Closed w -> Some w | _ -> None)
    (fun w -> Closed w)

module type T = sig
  module Name : NAME

  module Event : EVENT

  module Request : REQUEST

  module Types : TYPES

  (** A handle to a specific worker, parameterized by the type of
      internal message buffer. *)
  type 'kind t

  (** A handle to a table of workers. *)
  type 'kind table

  (** Internal buffer kinds used as parameters to {!t}. *)
  type 'a queue

  and bounded

  and infinite

  type dropbox

  (** Supported kinds of internal buffers. *)
  type _ buffer_kind =
    | Queue : infinite queue buffer_kind
    | Bounded : {size : int} -> bounded queue buffer_kind
    | Dropbox : {
        merge :
          dropbox t -> any_request -> any_request option -> any_request option;
      }
        -> dropbox buffer_kind

  and any_request = Any_request : _ Request.t -> any_request

  (** Create a table of workers. *)
  val create_table : 'kind buffer_kind -> 'kind table

  (** The callback handlers specific to each worker instance. *)
  module type HANDLERS = sig
    (** Placeholder replaced with {!t} with the right parameters
        provided by the type of buffer chosen at {!launch}.*)
    type self

    (** Builds the initial internal state of a worker at launch.
        It is possible to initialize the message queue.
        Of course calling {!state} will fail at that point. *)
    val on_launch :
      self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t

    (** The main request processor, i.e. the body of the event loop. *)
    val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t

    (** Called when no request has been made before the timeout, if
        the parameter has been passed to {!launch}. *)
    val on_no_request : self -> unit tzresult Lwt.t

    (** A function called when terminating a worker. *)
    val on_close : self -> unit Lwt.t

    (** A function called at the end of the worker loop in case of an
        abnormal error. This function can handle the error by
        returning [Ok ()], or leave the default unexpected error
        behaviour by returning its parameter. A possibility is to
        handle the error for ad-hoc logging, and still use
        {!trigger_shutdown} to kill the worker. *)
    val on_error :
      self ->
      Request.view ->
      Worker_types.request_status ->
      error list ->
      unit tzresult Lwt.t

    (** A function called at the end of the worker loop in case of a
        successful treatment of the current request. *)
    val on_completion :
      self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
  end

  (** Creates a new worker instance.
      Parameter [queue_size] not passed means unlimited queue. *)
  val launch :
    'kind table ->
    ?timeout:Time.System.Span.t ->
    Worker_types.limits ->
    Name.t ->
    Types.parameters ->
    (module HANDLERS with type self = 'kind t) ->
    'kind t tzresult Lwt.t

  (** Triggers a worker termination and waits for its completion.
      Cannot be called from within the handlers.  *)
  val shutdown : _ t -> unit Lwt.t

  module type BOX = sig
    type t

    val put_request : t -> 'a Request.t -> unit

    val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
  end

  module type QUEUE = sig
    type 'a t

    val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t

    val push_request : 'q t -> 'a Request.t -> unit Lwt.t

    val pending_requests : 'a t -> (Time.System.t * Request.view) list

    val pending_requests_length : 'a t -> int
  end

  module type BOUNDED_QUEUE = sig
    type t

    val try_push_request_now : t -> 'a Request.t -> bool
  end

  module Dropbox : sig
    include BOX with type t := dropbox t
  end

  module Queue : sig
    include QUEUE with type 'a t := 'a queue t

    include BOUNDED_QUEUE with type t := bounded queue t

    (** Adds a message to the queue immediately. *)
    val push_request_now : infinite queue t -> 'a Request.t -> unit
  end

  (** Detects cancellation from within the request handler to stop
      asynchronous operations. *)
  val protect :
    _ t ->
    ?on_error:(error list -> 'b tzresult Lwt.t) ->
    (unit -> 'b tzresult Lwt.t) ->
    'b tzresult Lwt.t

  (** Exports the canceler to allow cancellation of other tasks when this
      worker is shutdowned or when it dies. *)
  val canceler : _ t -> Lwt_canceler.t

  (** Triggers a worker termination. *)
  val trigger_shutdown : _ t -> unit

  (** Recod an event in the backlog. *)
  val record_event : _ t -> Event.t -> unit

  (** Record an event and make sure it is logged. *)
  val log_event : _ t -> Event.t -> unit Lwt.t

  (** Access the internal state, once initialized. *)
  val state : _ t -> Types.state

  (** Access the event backlog. *)
  val last_events : _ t -> (Internal_event.level * Event.t list) list

  (** Introspect the message queue, gives the times requests were pushed. *)
  val pending_requests : _ queue t -> (Time.System.t * Request.view) list

  (** Get the running status of a worker. *)
  val status : _ t -> Worker_types.worker_status

  (** Get the request being treated by a worker.
      Gives the time the request was pushed, and the time its
      treatment started. *)
  val current_request :
    _ t -> (Time.System.t * Time.System.t * Request.view) option

  val information : _ t -> Worker_types.worker_information

  (** Introspect the state of a worker. *)
  val view : _ t -> Types.view

  (** Lists the running workers in this group. *)
  val list : 'a table -> (Name.t * 'a t) list

  (** [find_opt table n] is [Some worker] if the [worker] is in the [table] and
      has name [n]. *)
  val find_opt : 'a table -> Name.t -> 'a t option
end

module Make
    (Name : NAME)
    (Event : EVENT)
    (Request : REQUEST)
    (Types : TYPES)
    (Logger : LOGGER with module Event = Event and module Request = Request) =
struct
  module Name = Name
  module Event = Event
  module Request = Request
  module Types = Types
  module Logger = Logger

  let base_name = String.concat "-" Name.base

  type message = Message : 'a Request.t * 'a tzresult Lwt.u option -> message

  type 'a queue

  and bounded

  and infinite

  type dropbox

  type _ buffer_kind =
    | Queue : infinite queue buffer_kind
    | Bounded : {size : int} -> bounded queue buffer_kind
    | Dropbox : {
        merge :
          dropbox t -> any_request -> any_request option -> any_request option;
      }
        -> dropbox buffer_kind

  and any_request = Any_request : _ Request.t -> any_request

  and _ buffer =
    | Queue_buffer :
        (Time.System.t * message) Lwt_pipe.t
        -> infinite queue buffer
    | Bounded_buffer :
        (Time.System.t * message) Lwt_pipe.t
        -> bounded queue buffer
    | Dropbox_buffer :
        (Time.System.t * message) Lwt_dropbox.t
        -> dropbox buffer

  and 'kind t = {
    limits : Worker_types.limits;
    timeout : Time.System.Span.t option;
    parameters : Types.parameters;
    mutable (* only for init *) worker : unit Lwt.t;
    mutable (* only for init *) state : Types.state option;
    buffer : 'kind buffer;
    event_log : (Internal_event.level * Event.t Ring.t) list;
    canceler : Lwt_canceler.t;
    name : Name.t;
    id : int;
    mutable status : Worker_types.worker_status;
    mutable current_request :
      (Time.System.t * Time.System.t * Request.view) option;
    logEvent : (module Internal_event.EVENT with type t = Logger.t);
    table : 'kind table;
  }

  and 'kind table = {
    buffer_kind : 'kind buffer_kind;
    mutable last_id : int;
    instances : (Name.t, 'kind t) Hashtbl.t;
  }

  let queue_item ?u r = (Systime_os.now (), Message (r, u))

  let drop_request w merge message_box request =
    try
      match
        match Lwt_dropbox.peek message_box with
        | None ->
            merge w (Any_request request) None
        | Some (_, Message (old, _)) ->
            Lwt.ignore_result (Lwt_dropbox.take message_box) ;
            merge w (Any_request request) (Some (Any_request old))
      with
      | None ->
          ()
      | Some (Any_request neu) ->
          Lwt_dropbox.put message_box (Systime_os.now (), Message (neu, None))
    with Lwt_dropbox.Closed -> ()

  let push_request_and_wait w message_queue request =
    let (t, u) = Lwt.wait () in
    Lwt.catch
      (fun () ->
        Lwt_pipe.push message_queue (queue_item ~u request) >>= fun () -> t)
      (function
        | Lwt_pipe.Closed ->
            let name = Format.asprintf "%a" Name.pp w.name in
            fail (Closed {base = base_name; name})
        | exn ->
            fail (Exn exn))

  let drop_request_and_wait w message_box request =
    let (t, u) = Lwt.wait () in
    Lwt.catch
      (fun () ->
        Lwt_dropbox.put message_box (queue_item ~u request) ;
        t)
      (function
        | Lwt_pipe.Closed ->
            let name = Format.asprintf "%a" Name.pp w.name in
            fail (Closed {base = base_name; name})
        | exn ->
            fail (Exn exn))

  module type BOX = sig
    type t

    val put_request : t -> 'a Request.t -> unit

    val put_request_and_wait : t -> 'a Request.t -> 'a tzresult Lwt.t
  end

  module type QUEUE = sig
    type 'a t

    val push_request_and_wait : 'q t -> 'a Request.t -> 'a tzresult Lwt.t

    val push_request : 'q t -> 'a Request.t -> unit Lwt.t

    val pending_requests : 'a t -> (Time.System.t * Request.view) list

    val pending_requests_length : 'a t -> int
  end

  module type BOUNDED_QUEUE = sig
    type t

    val try_push_request_now : t -> 'a Request.t -> bool
  end

  module Dropbox = struct
    let put_request (w : dropbox t) request =
      let (Dropbox {merge}) = w.table.buffer_kind in
      let (Dropbox_buffer message_box) = w.buffer in
      drop_request w merge message_box request

    let put_request_and_wait (w : dropbox t) request =
      let (Dropbox_buffer message_box) = w.buffer in
      drop_request_and_wait w message_box request
  end

  module Queue = struct
    let push_request (type a) (w : a queue t) request =
      match w.buffer with
      | Queue_buffer message_queue ->
          Lwt_pipe.push message_queue (queue_item request)
      | Bounded_buffer message_queue ->
          Lwt_pipe.push message_queue (queue_item request)

    let push_request_now (w : infinite queue t) request =
      let (Queue_buffer message_queue) = w.buffer in
      Lwt_pipe.push_now_exn message_queue (queue_item request)

    let try_push_request_now (w : bounded queue t) request =
      let (Bounded_buffer message_queue) = w.buffer in
      Lwt_pipe.push_now message_queue (queue_item request)

    let push_request_and_wait (type a) (w : a queue t) request =
      let message_queue =
        match w.buffer with
        | Queue_buffer message_queue ->
            message_queue
        | Bounded_buffer message_queue ->
            message_queue
      in
      push_request_and_wait w message_queue request

    let pending_requests (type a) (w : a queue t) =
      let message_queue =
        match w.buffer with
        | Queue_buffer message_queue ->
            message_queue
        | Bounded_buffer message_queue ->
            message_queue
      in
      List.map
        (function (t, Message (req, _)) -> (t, Request.view req))
        (Lwt_pipe.peek_all message_queue)

    let pending_requests_length (type a) (w : a queue t) =
      let pipe_length (type a) (q : a buffer) =
        match q with
        | Queue_buffer queue ->
            Lwt_pipe.length queue
        | Bounded_buffer queue ->
            Lwt_pipe.length queue
        | Dropbox_buffer _ ->
            1
      in
      pipe_length w.buffer
  end

  let close (type a) (w : a t) =
    let wakeup = function
      | (_, Message (_, Some u)) ->
          let name = Format.asprintf "%a" Name.pp w.name in
          Lwt.wakeup_later u (error (Closed {base = base_name; name}))
      | (_, Message (_, None)) ->
          ()
    in
    let close_queue message_queue =
      let messages = Lwt_pipe.pop_all_now message_queue in
      List.iter wakeup messages ;
      Lwt_pipe.close message_queue
    in
    match w.buffer with
    | Queue_buffer message_queue ->
        close_queue message_queue
    | Bounded_buffer message_queue ->
        close_queue message_queue
    | Dropbox_buffer message_box ->
        Option.iter ~f:wakeup (Lwt_dropbox.peek message_box) ;
        Lwt_dropbox.close message_box

  let pop (type a) (w : a t) =
    let pop_queue message_queue =
      match w.timeout with
      | None ->
          Lwt_pipe.pop message_queue >>= fun m -> return_some m
      | Some timeout ->
          Lwt_pipe.pop_with_timeout (Systime_os.sleep timeout) message_queue
          >>= fun m -> return m
    in
    match w.buffer with
    | Queue_buffer message_queue ->
        pop_queue message_queue
    | Bounded_buffer message_queue ->
        pop_queue message_queue
    | Dropbox_buffer message_box -> (
      match w.timeout with
      | None ->
          Lwt_dropbox.take message_box >>= fun m -> return_some m
      | Some timeout ->
          Lwt_dropbox.take_with_timeout (Systime_os.sleep timeout) message_box
          >>= fun m -> return m )

  let trigger_shutdown w = Lwt.ignore_result (Lwt_canceler.cancel w.canceler)

  let canceler {canceler; _} = canceler

  let lwt_emit w (status : Logger.status) =
    let (module LogEvent) = w.logEvent in
    let time = Systime_os.now () in
    LogEvent.emit
      ~section:(Internal_event.Section.make_sanitized Name.base)
      (fun () -> Time.System.stamp ~time status)
    >>= function
    | Ok () ->
        Lwt.return_unit
    | Error el ->
        Format.kasprintf
          Lwt.fail_with
          "Worker_event.emit: %a"
          pp_print_error
          el

  let log_event w evt =
    lwt_emit w (Logger.WorkerEvent evt)
    >>= fun () ->
    if Event.level evt >= w.limits.backlog_level then
      Ring.add (List.assoc (Event.level evt) w.event_log) evt ;
    Lwt.return_unit

  let record_event w evt = Lwt.ignore_result (log_event w evt)

  module type HANDLERS = sig
    type self

    val on_launch :
      self -> Name.t -> Types.parameters -> Types.state tzresult Lwt.t

    val on_request : self -> 'a Request.t -> 'a tzresult Lwt.t

    val on_no_request : self -> unit tzresult Lwt.t

    val on_close : self -> unit Lwt.t

    val on_error :
      self ->
      Request.view ->
      Worker_types.request_status ->
      error list ->
      unit tzresult Lwt.t

    val on_completion :
      self -> 'a Request.t -> 'a -> Worker_types.request_status -> unit Lwt.t
  end

  let create_table buffer_kind =
    {buffer_kind; last_id = 0; instances = Hashtbl.create 10}

  let worker_loop (type kind) handlers (w : kind t) =
    let (module Handlers : HANDLERS with type self = kind t) = handlers in
    let do_close errs =
      let t0 =
        match w.status with
        | Running t0 ->
            t0
        | Launching _ | Closing _ | Closed _ ->
            assert false
      in
      w.status <- Closing (t0, Systime_os.now ()) ;
      close w ;
      Lwt_canceler.cancel w.canceler
      >>= fun () ->
      w.status <- Closed (t0, Systime_os.now (), errs) ;
      Hashtbl.remove w.table.instances w.name ;
      Handlers.on_close w
      >>= fun () ->
      w.state <- None ;
      Lwt.ignore_result
        ( List.iter (fun (_, ring) -> Ring.clear ring) w.event_log ;
          Lwt.return_unit ) ;
      Lwt.return_unit
    in
    let rec loop () =
      protect ~canceler:w.canceler (fun () -> pop w)
      >>=? (function
             | None ->
                 Handlers.on_no_request w
             | Some (pushed, Message (request, u)) -> (
                 let current_request = Request.view request in
                 let treated = Systime_os.now () in
                 w.current_request <- Some (pushed, treated, current_request) ;
                 match u with
                 | None ->
                     Handlers.on_request w request
                     >>=? fun res ->
                     let completed = Systime_os.now () in
                     w.current_request <- None ;
                     let status = Worker_types.{pushed; treated; completed} in
                     Handlers.on_completion w request res status
                     >>= fun () ->
                     lwt_emit w (Request (current_request, status, None))
                     >>= fun () -> return_unit
                 | Some u ->
                     Handlers.on_request w request
                     >>= fun res ->
                     Lwt.wakeup_later u res ;
                     Lwt.return res
                     >>=? fun res ->
                     let completed = Systime_os.now () in
                     let status = Worker_types.{pushed; treated; completed} in
                     w.current_request <- None ;
                     Handlers.on_completion w request res status
                     >>= fun () ->
                     lwt_emit w (Request (current_request, status, None))
                     >>= fun () -> return_unit ))
      >>= function
      | Ok () ->
          loop ()
      | Error (Canceled :: _)
      | Error (Exn Lwt.Canceled :: _)
      | Error (Exn Lwt_pipe.Closed :: _)
      | Error (Exn Lwt_dropbox.Closed :: _) ->
          lwt_emit w Terminated >>= fun () -> do_close None
      | Error errs -> (
          ( match w.current_request with
          | Some (pushed, treated, request) ->
              let completed = Systime_os.now () in
              w.current_request <- None ;
              Handlers.on_error
                w
                request
                Worker_types.{pushed; treated; completed}
                errs
          | None ->
              assert false )
          >>= function
          | Ok () ->
              loop ()
          | Error (Timeout :: _ as errs) ->
              lwt_emit w Terminated >>= fun () -> do_close (Some errs)
          | Error errs ->
              lwt_emit w (Crashed errs) >>= fun () -> do_close (Some errs) )
    in
    loop ()

  let launch :
      type kind.
      kind table ->
      ?timeout:Time.System.Span.t ->
      Worker_types.limits ->
      Name.t ->
      Types.parameters ->
      (module HANDLERS with type self = kind t) ->
      kind t tzresult Lwt.t =
   fun table ?timeout limits name parameters (module Handlers) ->
    let name_s = Format.asprintf "%a" Name.pp name in
    let full_name =
      if name_s = "" then base_name
      else Format.asprintf "%s_%s" base_name name_s
    in
    if Hashtbl.mem table.instances name then
      invalid_arg
        (Format.asprintf "Worker.launch: duplicate worker %s" full_name)
    else
      let id =
        table.last_id <- table.last_id + 1 ;
        table.last_id
      in
      let id_name =
        if name_s = "" then base_name else Format.asprintf "%s_%d" base_name id
      in
      let canceler = Lwt_canceler.create () in
      let buffer : kind buffer =
        match table.buffer_kind with
        | Queue ->
            Queue_buffer (Lwt_pipe.create ())
        | Bounded {size} ->
            Bounded_buffer (Lwt_pipe.create ~size:(size, fun _ -> 1) ())
        | Dropbox _ ->
            Dropbox_buffer (Lwt_dropbox.create ())
      in
      let event_log =
        let levels =
          Internal_event.[Debug; Info; Notice; Warning; Error; Fatal]
        in
        List.map (fun l -> (l, Ring.create limits.backlog_size)) levels
      in
      let module Definition = Logger.MakeDefinition (struct
        let worker_name = id_name
      end) in
      let module LogEvent = Internal_event.Make (Definition) in
      let w =
        {
          limits;
          parameters;
          name;
          canceler;
          table;
          buffer;
          state = None;
          id;
          worker = Lwt.return_unit;
          event_log;
          timeout;
          current_request = None;
          logEvent = (module LogEvent);
          status = Launching (Systime_os.now ());
        }
      in
      Hashtbl.add table.instances name w ;
      ( if id_name = base_name then lwt_emit w (Started None)
      else lwt_emit w (Started (Some name_s)) )
      >>= fun () ->
      Handlers.on_launch w name parameters
      >>=? fun state ->
      w.status <- Running (Systime_os.now ()) ;
      w.state <- Some state ;
      w.worker <-
        Lwt_utils.worker
          full_name
          ~on_event:Internal_event.Lwt_worker_event.on_event
          ~run:(fun () -> worker_loop (module Handlers) w)
          ~cancel:(fun () -> Lwt_canceler.cancel w.canceler) ;
      return w

  let shutdown w =
    lwt_emit w Triggering_shutdown
    >>= fun () -> Lwt_canceler.cancel w.canceler >>= fun () -> w.worker

  let state w =
    match (w.state, w.status) with
    | (None, Launching _) ->
        invalid_arg
          (Format.asprintf
             "Worker.state (%s[%a]): state called before worker was initialized"
             base_name
             Name.pp
             w.name)
    | (None, (Closing _ | Closed _)) ->
        invalid_arg
          (Format.asprintf
             "Worker.state (%s[%a]): state called after worker was terminated"
             base_name
             Name.pp
             w.name)
    | (None, _) ->
        assert false
    | (Some state, _) ->
        state

  let pending_requests q = Queue.pending_requests q

  let last_events w =
    List.map (fun (level, ring) -> (level, Ring.elements ring)) w.event_log

  let status {status; _} = status

  let current_request {current_request; _} = current_request

  let information (type a) (w : a t) =
    {
      Worker_types.instances_number = Hashtbl.length w.table.instances;
      wstatus = w.status;
      queue_length =
        ( match w.buffer with
        | Queue_buffer pipe ->
            Lwt_pipe.length pipe
        | Bounded_buffer pipe ->
            Lwt_pipe.length pipe
        | Dropbox_buffer _ ->
            1 );
    }

  let view w = Types.view (state w) w.parameters

  let list {instances; _} =
    Hashtbl.fold (fun n w acc -> (n, w) :: acc) instances []

  let find_opt {instances; _} = Hashtbl.find_opt instances

  (* TODO? add a list of cancelers for nested protection ? *)
  let protect {canceler; _} ?on_error f = protect ?on_error ~canceler f
end
src/lib_shell/worker.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module NAME.
  Record signature {t : Type} := {
    base : list string;
    t := t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
    pp : Stdlib.Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End NAME.

Module EVENT.
  Record signature {t : Type} := {
    t := t;
    level : t -> Tezos_base__TzPervasives.Internal_event.level;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
    pp : Stdlib.Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End EVENT.

Module REQUEST.
  Record signature {t view : Type} := {
    polymorphic_abstract_type;
    view := view;
    view : forall {a : Type}, (t a) -> view;
    encoding : Tezos_base__TzPervasives.Data_encoding.t view;
    pp : Stdlib.Format.formatter -> view -> unit;
  }.
  Arguments signature : clear implicits.
End REQUEST.

Module TYPES.
  Record signature {state parameters view : Type} := {
    state := state;
    parameters := parameters;
    view := view;
    view : state -> parameters -> view;
    encoding : Tezos_base__TzPervasives.Data_encoding.t view;
    pp : Stdlib.Format.formatter -> view -> unit;
  }.
  Arguments signature : clear implicits.
End TYPES.

Module LOGGER.
  Record signature {Event_t Request_t Request_view status : Type} := {
    Event : EVENT.signature Event_t;
    Request : REQUEST.signature Request_t Request_view;
    status := status;
    t := Tezos_base__TzPervasives.Time.System.stamped status;
    MakeDefinition : functor;
  }.
  Arguments signature : clear implicits.
End LOGGER.

Record worker_name := {
  base : string;
  name : string }.

(* ❌ Structure item `typext` not handled. *)
type_extension



Module T.
  Record signature {Name_t Event_t Request_t Request_view Types_state
    Types_parameters Types_view t table queue bounded infinite dropbox
    buffer_kind any_request : Type} := {
    Name : NAME.signature Name_t;
    Event : EVENT.signature Event_t;
    Request : REQUEST.signature Request_t Request_view;
    Types : TYPES.signature Types_state Types_parameters Types_view;
    polymorphic_abstract_type;
    polymorphic_abstract_type;
    mutual_type;
    dropbox := dropbox;
    mutual_type;
    create_table : forall {kind : Type}, (buffer_kind kind) -> table kind;
    module_type;
    launch : forall {kind : Type}, (table kind) ->
      (option Tezos_base__TzPervasives.Time.System.Span.t) ->
        Tezos_shell_services.Worker_types.limits ->
          Name.(NAME.t) ->
            Types.(TYPES.parameters) ->
              {_ : unit & HANDLERS.signature (t kind)} ->
                Lwt.t (Tezos_base__TzPervasives.tzresult (t kind));
    shutdown : forall {_ : Type}, (t _) -> Lwt.t unit;
    module_type;
    module_type;
    module_type;
    Dropbox : signature;
    Queue : signature;
    protect : forall {_ b : Type}, (t _) ->
      (option
        ((list Tezos_base__TzPervasives.error) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult b))) ->
        (unit -> Lwt.t (Tezos_base__TzPervasives.tzresult b)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult b);
    canceler : forall {_ : Type}, (t _) ->
      Tezos_base__TzPervasives.Lwt_canceler.t;
    trigger_shutdown : forall {_ : Type}, (t _) -> unit;
    record_event : forall {_ : Type}, (t _) -> Event.(EVENT.t) -> unit;
    log_event : forall {_ : Type}, (t _) -> Event.(EVENT.t) -> Lwt.t unit;
    state : forall {_ : Type}, (t _) -> Types.(TYPES.state);
    last_events : forall {_ : Type}, (t _) ->
      list
        (Tezos_base__TzPervasives.Internal_event.level * (list Event.(EVENT.t)));
    pending_requests : forall {_ : Type}, (t (queue _)) ->
      list (Tezos_base__TzPervasives.Time.System.t * Request.(REQUEST.view));
    status : forall {_ : Type}, (t _) ->
      Tezos_shell_services.Worker_types.worker_status;
    current_request : forall {_ : Type}, (t _) ->
      option
        (Tezos_base__TzPervasives.Time.System.t *
          Tezos_base__TzPervasives.Time.System.t * Request.(REQUEST.view));
    information : forall {_ : Type}, (t _) ->
      Tezos_shell_services.Worker_types.worker_information;
    view : forall {_ : Type}, (t _) -> Types.(TYPES.view);
    list : forall {a : Type}, (table a) -> list (Name.(NAME.t) * (t a));
    find_opt : forall {a : Type}, (table a) -> Name.(NAME.t) -> option (t a);
  }.
  Arguments signature : clear implicits.
End T.

(* ❌ Functors are not handled. *)
functor

src/lib_shell/worker_directory.ml 27 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let build_rpc_directory state =
  let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
  let register0 s f =
    dir := RPC_directory.register !dir s (fun () p q -> f p q)
  in
  let register1 s f =
    dir := RPC_directory.register !dir s (fun ((), a) p q -> f a p q)
  in
  let register2 s f =
    dir := RPC_directory.register !dir s (fun (((), a), b) p q -> f a b p q)
  in
  (* Workers : Prevalidators *)
  register0 Worker_services.Prevalidators.S.list (fun () () ->
      let workers = Prevalidator.running_workers () in
      let statuses =
        List.map
          (fun (chain_id, _, t) ->
            ( chain_id,
              Prevalidator.status t,
              Prevalidator.information t,
              Prevalidator.pipeline_length t ))
          workers
      in
      return statuses) ;
  register1 Worker_services.Prevalidators.S.state (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let workers = Prevalidator.running_workers () in
      let (_, _, t) =
        (* NOTE: it is technically possible to use the Prevalidator interface to
         * register multiple Prevalidator for a single chain (using distinct
         * protocols). However, this is never done. *)
        List.find (fun (c, _, _) -> Chain_id.equal c chain_id) workers
      in
      let status = Prevalidator.status t in
      let pending_requests = Prevalidator.pending_requests t in
      let backlog = Prevalidator.last_events t in
      let current_request = Prevalidator.current_request t in
      return {Worker_types.status; pending_requests; backlog; current_request}) ;
  (* Workers : Block_validator *)
  register0 Worker_services.Block_validator.S.state (fun () () ->
      let w = Block_validator.running_worker () in
      return
        {
          Worker_types.status = Block_validator.status w;
          pending_requests = Block_validator.pending_requests w;
          backlog = Block_validator.last_events w;
          current_request = Block_validator.current_request w;
        }) ;
  (* Workers : Peer validators *)
  register1 Worker_services.Peer_validators.S.list (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      return
        (List.filter_map
           (fun ((id, peer_id), w) ->
             if Chain_id.equal id chain_id then
               Some
                 ( peer_id,
                   Peer_validator.status w,
                   Peer_validator.information w,
                   Peer_validator.pipeline_length w )
             else None)
           (Peer_validator.running_workers ()))) ;
  register2 Worker_services.Peer_validators.S.state (fun chain peer_id () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let w =
        List.assoc (chain_id, peer_id) (Peer_validator.running_workers ())
      in
      return
        {
          Worker_types.status = Peer_validator.status w;
          pending_requests = [];
          backlog = Peer_validator.last_events w;
          current_request = Peer_validator.current_request w;
        }) ;
  (* Workers : Net validators *)
  register0 Worker_services.Chain_validators.S.list (fun () () ->
      return
        (List.map
           (fun (id, w) ->
             ( id,
               Chain_validator.status w,
               Chain_validator.information w,
               Chain_validator.pending_requests_length w ))
           (Chain_validator.running_workers ()))) ;
  register1 Worker_services.Chain_validators.S.state (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let w = List.assoc chain_id (Chain_validator.running_workers ()) in
      return
        {
          Worker_types.status = Chain_validator.status w;
          pending_requests = Chain_validator.pending_requests w;
          backlog = Chain_validator.last_events w;
          current_request = Chain_validator.current_request w;
        }) ;
  (* DistributedDB *)
  register1 Worker_services.Chain_validators.S.ddb_state (fun chain () () ->
      Chain_directory.get_chain_id state chain
      >>= fun chain_id ->
      let w = List.assoc chain_id (Chain_validator.running_workers ()) in
      return (Chain_validator.ddb_information w)) ;
  !dir
src/lib_shell/worker_directory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition build_rpc_directory (state : Tezos_shell.State.t)
  : Tezos_base__TzPervasives.RPC_directory.t unit :=
  let dir := Stdlib.ref RPC_directory.empty in
  let register0 {A B C : Type}
    (s : Tezos_rpc.RPC_service.t variant unit unit A B C) (f :
    A -> B -> Lwt.t (Tezos_error_monad.Error_monad.tzresult C)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun p => fun q => f p q)) in
  let register1 {A B C D : Type}
    (s : Tezos_rpc.RPC_service.t variant unit (unit * A) B C D) (f :
    A -> B -> C -> Lwt.t (Tezos_error_monad.Error_monad.tzresult D)) : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let '(tt, a) := function_parameter in
          fun p => fun q => f a p q)) in
  let register2 {A B C D E : Type}
    (s : Tezos_rpc.RPC_service.t variant unit ((unit * A) * B) C D E) (f :
    A -> B -> C -> D -> Lwt.t (Tezos_error_monad.Error_monad.tzresult E))
    : unit :=
    Stdlib.op_coloneq dir
      (RPC_directory.register (Stdlib.op_exclamation dir) s
        (fun function_parameter =>
          let '((tt, a), b) := function_parameter in
          fun p => fun q => f a b p q)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 Worker_services.Prevalidators.S.list
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let workers := Prevalidator.running_workers tt in
          let statuses :=
            List.map
              (fun function_parameter =>
                let '(chain_id, _, t) := function_parameter in
                (chain_id, (Prevalidator.status t),
                  (Prevalidator.information t), (Prevalidator.pipeline_length t)))
              workers in
          _return statuses) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 Worker_services.Prevalidators.S.state
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Chain_directory.get_chain_id state chain)
              (fun chain_id =>
                let workers := Prevalidator.running_workers tt in
                let '(_, _, t) :=
                  List.find
                    (fun function_parameter =>
                      let '(c, _, _) := function_parameter in
                      Chain_id.equal c chain_id) workers in
                let status := Prevalidator.status t in
                let pending_requests := Prevalidator.pending_requests t in
                let backlog := Prevalidator.last_events t in
                let current_request := Prevalidator.current_request t in
                _return
                  {| Worker_types.status := status;
                    Worker_types.pending_requests := pending_requests;
                    Worker_types.backlog := backlog;
                    Worker_types.current_request := current_request |})) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 Worker_services.Block_validator.S.state
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          let w := Block_validator.running_worker tt in
          _return
            {| Worker_types.status := Block_validator.status w;
              Worker_types.pending_requests :=
                Block_validator.pending_requests w;
              Worker_types.backlog := Block_validator.last_events w;
              Worker_types.current_request := Block_validator.current_request w
              |}) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 Worker_services.Peer_validators.S.list
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Chain_directory.get_chain_id state chain)
              (fun chain_id =>
                _return
                  (List.filter_map
                    (fun function_parameter =>
                      let '((id, peer_id), w) := function_parameter in
                      if Chain_id.equal id chain_id then
                        Some
                          (peer_id, (Peer_validator.status w),
                            (Peer_validator.information w),
                            (Peer_validator.pipeline_length w))
                      else
                        None) (Peer_validator.running_workers tt)))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register2 Worker_services.Peer_validators.S.state
      (fun chain =>
        fun peer_id =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Chain_directory.get_chain_id state chain)
                (fun chain_id =>
                  let w :=
                    List.assoc (chain_id, peer_id)
                      (Peer_validator.running_workers tt) in
                  _return
                    {| Worker_types.status := Peer_validator.status w;
                      Worker_types.pending_requests := [];
                      Worker_types.backlog := Peer_validator.last_events w;
                      Worker_types.current_request :=
                        Peer_validator.current_request w |})) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 Worker_services.Chain_validators.S.list
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return
            (List.map
              (fun function_parameter =>
                let '(id, w) := function_parameter in
                (id, (Chain_validator.status w),
                  (Chain_validator.information w),
                  (Chain_validator.pending_requests_length w)))
              (Chain_validator.running_workers tt))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 Worker_services.Chain_validators.S.state
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Chain_directory.get_chain_id state chain)
              (fun chain_id =>
                let w :=
                  List.assoc chain_id (Chain_validator.running_workers tt) in
                _return
                  {| Worker_types.status := Chain_validator.status w;
                    Worker_types.pending_requests :=
                      Chain_validator.pending_requests w;
                    Worker_types.backlog := Chain_validator.last_events w;
                    Worker_types.current_request :=
                      Chain_validator.current_request w |})) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 Worker_services.Chain_validators.S.ddb_state
      (fun chain =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Chain_directory.get_chain_id state chain)
              (fun chain_id =>
                let w :=
                  List.assoc chain_id (Chain_validator.running_workers tt) in
                _return (Chain_validator.ddb_information w))) in
  Stdlib.op_exclamation dir.

src/lib_shell/worker_logger.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Worker

module Make (Event : EVENT) (Request : REQUEST) = struct
  module Event = Event
  module Request = Request

  type status =
    | WorkerEvent of Event.t
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Terminated
    | Timeout
    | Crashed of error list
    | Started of string option
    | Triggering_shutdown
    | Duplicate of string

  type t = status Time.System.stamped

  let status_encoding =
    let open Data_encoding in
    Time.System.stamped_encoding
    @@ union
         [ case
             (Tag 0)
             ~title:"Event"
             Event.encoding
             (function WorkerEvent e -> Some e | _ -> None)
             (fun e -> WorkerEvent e);
           case
             (Tag 1)
             ~title:"Request"
             (obj3
                (req "request_view" (dynamic_size Request.encoding))
                (req "request_status" Worker_types.request_status_encoding)
                (req "errors" (option (list error_encoding))))
             (function Request (v, s, e) -> Some (v, s, e) | _ -> None)
             (fun (v, s, e) -> Request (v, s, e));
           case
             (Tag 2)
             ~title:"Terminated"
             Data_encoding.empty
             (function Terminated -> Some () | _ -> None)
             (fun () -> Terminated);
           case
             (Tag 3)
             ~title:"Timeout"
             Data_encoding.empty
             (function Timeout -> Some () | _ -> None)
             (fun () -> Timeout);
           case
             (Tag 4)
             ~title:"Crashed"
             (list error_encoding)
             (function Crashed errs -> Some errs | _ -> None)
             (fun errs -> Crashed errs);
           case
             (Tag 5)
             ~title:"Started"
             (option string)
             (function Started n -> Some n | _ -> None)
             (fun n -> Started n);
           case
             (Tag 6)
             ~title:"Triggering_shutdown"
             Data_encoding.empty
             (function Triggering_shutdown -> Some () | _ -> None)
             (fun () -> Triggering_shutdown);
           case
             (Tag 7)
             ~title:"Duplicate"
             string
             (function Duplicate n -> Some n | _ -> None)
             (fun n -> Duplicate n) ]

  let pp base_name ppf = function
    | WorkerEvent evt ->
        Format.fprintf ppf "%a" Event.pp evt
    | Request (view, {pushed; treated; completed}, None) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
    | Request (view, {pushed; treated; completed}, Some errors) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errors
    | Terminated ->
        Format.fprintf ppf "@[Worker terminated [%s] @]" base_name
    | Timeout ->
        Format.fprintf ppf "@[Worker terminated with timeout [%s] @]" base_name
    | Crashed errs ->
        Format.fprintf
          ppf
          "@[<v 0>Worker crashed [%s]:@,%a@]"
          base_name
          (Format.pp_print_list Error_monad.pp)
          errs
    | Started None ->
        Format.fprintf ppf "Worker started"
    | Started (Some n) ->
        Format.fprintf ppf "Worker started for %s" n
    | Triggering_shutdown ->
        Format.fprintf ppf "Triggering shutdown"
    | Duplicate name ->
        let full_name =
          if name = "" then base_name
          else Format.asprintf "%s_%s" base_name name
        in
        Format.fprintf ppf "Worker.launch: duplicate worker %s" full_name

  module MakeDefinition (Static : sig
    val worker_name : string
  end) : Internal_event.EVENT_DEFINITION with type t = t = struct
    let name = Static.worker_name

    type nonrec t = t

    let encoding =
      let open Data_encoding in
      let v0_encoding = status_encoding in
      With_version.(encoding ~name (first_version v0_encoding))

    let pp ppf (status : t) =
      Format.fprintf ppf "%a" (pp Static.worker_name) status.data

    let doc = "Worker status."

    let level (status : t) =
      match status.data with
      | WorkerEvent evt ->
          Event.level evt
      | Request _ ->
          Internal_event.Debug
      | Terminated | Timeout | Started _ ->
          Internal_event.Notice
      | Crashed _ ->
          Internal_event.Error
      | Triggering_shutdown ->
          Internal_event.Debug
      | Duplicate _ ->
          Internal_event.Error
  end
end
src/lib_shell/worker_logger.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Worker.

(* ❌ Functors are not handled. *)
functor

src/lib_shell_services/block_services.ml 64 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

type chain = [`Main | `Test | `Hash of Chain_id.t]

let parse_chain s =
  try
    match s with
    | "main" ->
        Ok `Main
    | "test" ->
        Ok `Test
    | h ->
        Ok (`Hash (Chain_id.of_b58check_exn h))
  with _ -> Error "Cannot parse chain identifier."

let chain_to_string = function
  | `Main ->
      "main"
  | `Test ->
      "test"
  | `Hash h ->
      Chain_id.to_b58check h

let chain_arg =
  let name = "chain_id" in
  let descr =
    "A chain identifier. This is either a chain hash in Base58Check notation \
     or a one the predefined aliases: 'main', 'test'."
  in
  let construct = chain_to_string in
  let destruct = parse_chain in
  RPC_arg.make ~name ~descr ~construct ~destruct ()

type block =
  [ `Genesis
  | `Head of int
  | `Alias of [`Caboose | `Checkpoint | `Save_point] * int
  | `Hash of Block_hash.t * int
  | `Level of Int32.t ]

let parse_block s =
  let delims = ['~'; '-'; '+'] in
  let count_delims s =
    List.map
      (fun d ->
        (String.fold_left (fun i c -> if c = d then i + 1 else i) 0 s, d))
      delims
  in
  let split_on_delim counts =
    match List.fold_left (fun i (v, _) -> i + v) 0 counts with
    | 0 ->
        ([s], ' ')
    | 1 ->
        let delim = List.assoc 1 counts in
        (String.split delim s, delim)
    | _ ->
        raise Exit
  in
  try
    match split_on_delim (count_delims s) with
    | (["genesis"], _) ->
        Ok `Genesis
    | (["genesis"; n], '+') ->
        Ok (`Level (Int32.of_string n))
    | (["head"], _) ->
        Ok (`Head 0)
    | (["head"; n], '~') | (["head"; n], '-') ->
        Ok (`Head (int_of_string n))
    | (["checkpoint"], _) ->
        Ok (`Alias (`Checkpoint, 0))
    | (["checkpoint"; n], '~') | (["checkpoint"; n], '-') ->
        Ok (`Alias (`Checkpoint, int_of_string n))
    | (["checkpoint"; n], '+') ->
        Ok (`Alias (`Checkpoint, -int_of_string n))
    | (["save_point"], _) ->
        Ok (`Alias (`Save_point, 0))
    | (["save_point"; n], '~') | (["save_point"; n], '-') ->
        Ok (`Alias (`Save_point, int_of_string n))
    | (["save_point"; n], '+') ->
        Ok (`Alias (`Save_point, -int_of_string n))
    | (["caboose"], _) ->
        Ok (`Alias (`Caboose, 0))
    | (["caboose"; n], '~') | (["caboose"; n], '-') ->
        Ok (`Alias (`Caboose, int_of_string n))
    | (["caboose"; n], '+') ->
        Ok (`Alias (`Caboose, -int_of_string n))
    | ([hol], _) -> (
      match Block_hash.of_b58check_opt hol with
      | Some h ->
          Ok (`Hash (h, 0))
      | None ->
          let l = Int32.of_string s in
          if Compare.Int32.(l < 0l) then raise Exit
          else if Compare.Int32.(l = 0l) then Ok `Genesis
          else Ok (`Level (Int32.of_string s)) )
    | ([h; n], '~') | ([h; n], '-') ->
        Ok (`Hash (Block_hash.of_b58check_exn h, int_of_string n))
    | ([h; n], '+') ->
        Ok (`Hash (Block_hash.of_b58check_exn h, -int_of_string n))
    | _ ->
        raise Exit
  with _ -> Error "Cannot parse block identifier."

let alias_to_string = function
  | `Checkpoint ->
      "checkpoint"
  | `Save_point ->
      "save_point"
  | `Caboose ->
      "caboose"

let to_string = function
  | `Genesis ->
      "genesis"
  | `Alias (a, 0) ->
      alias_to_string a
  | `Alias (a, n) when n < 0 ->
      Printf.sprintf "%s+%d" (alias_to_string a) (-n)
  | `Alias (a, n) ->
      Printf.sprintf "%s~%d" (alias_to_string a) n
  | `Head 0 ->
      "head"
  | `Head n when n < 0 ->
      Printf.sprintf "head+%d" (-n)
  | `Head n ->
      Printf.sprintf "head~%d" n
  | `Hash (h, 0) ->
      Block_hash.to_b58check h
  | `Hash (h, n) when n < 0 ->
      Printf.sprintf "%s+%d" (Block_hash.to_b58check h) (-n)
  | `Hash (h, n) ->
      Printf.sprintf "%s~%d" (Block_hash.to_b58check h) n
  | `Level i ->
      Printf.sprintf "%d" (Int32.to_int i)

let blocks_arg =
  let name = "block_id" in
  let descr =
    "A block identifier. This is either a block hash in Base58Check notation, \
     one the predefined aliases: 'genesis', 'head' or a block level (index in \
     the chain). One might also use 'head~N' or '<hash>~N' where N is an \
     integer to denote the Nth predecessor of the designated block.Also, \
     '<hash>+N' denotes the Nth successor of a block."
  in
  let construct = to_string in
  let destruct = parse_block in
  RPC_arg.make ~name ~descr ~construct ~destruct ()

type chain_prefix = unit * chain

type prefix = chain_prefix * block

let chain_path = RPC_path.(root / "chains" /: chain_arg)

let mempool_path p = RPC_path.(p / "mempool")

let live_blocks_path p = RPC_path.(p / "live_blocks")

let dir_path : (chain_prefix, chain_prefix) RPC_path.t =
  RPC_path.(open_root / "blocks")

let path = RPC_path.(dir_path /: blocks_arg)

type operation_list_quota = {max_size : int; max_op : int option}

let operation_list_quota_encoding =
  conv
    (fun {max_size; max_op} -> (max_size, max_op))
    (fun (max_size, max_op) -> {max_size; max_op})
    (obj2 (req "max_size" int31) (opt "max_op" int31))

type raw_context = Key of Bytes.t | Dir of (string * raw_context) list | Cut

let rec pp_raw_context ppf = function
  | Cut ->
      Format.fprintf ppf "..."
  | Key v ->
      Hex.pp ppf (Hex.of_bytes v)
  | Dir l ->
      Format.fprintf
        ppf
        "{@[<v 1>@,%a@]@,}"
        (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf (s, t) ->
             Format.fprintf ppf "%s : %a" s pp_raw_context t))
        l

let raw_context_encoding =
  mu "raw_context" (fun encoding ->
      union
        [ case
            (Tag 0)
            bytes
            ~title:"Key"
            (function Key k -> Some k | _ -> None)
            (fun k -> Key k);
          case
            (Tag 1)
            (assoc encoding)
            ~title:"Dir"
            (function Dir k -> Some k | _ -> None)
            (fun k -> Dir k);
          case
            (Tag 2)
            null
            ~title:"Cut"
            (function Cut -> Some () | _ -> None)
            (fun () -> Cut) ])

type error += Invalid_depth_arg of int

let () =
  register_error_kind
    `Permanent
    ~id:"raw_context.invalid_depth"
    ~title:"Invalid depth argument"
    ~description:"The raw context extraction depth argument must be positive."
    ~pp:(fun ppf depth ->
      Format.fprintf ppf "Extraction depth %d is invalid" depth)
    Data_encoding.(obj1 (req "depth" int31))
    (function Invalid_depth_arg depth -> Some depth | _ -> None)
    (fun depth -> Invalid_depth_arg depth)

module type PROTO = sig
  val hash : Protocol_hash.t

  type block_header_data

  val block_header_data_encoding : block_header_data Data_encoding.t

  type block_header_metadata

  val block_header_metadata_encoding : block_header_metadata Data_encoding.t

  type operation_data

  type operation_receipt

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  val operation_data_encoding : operation_data Data_encoding.t

  val operation_receipt_encoding : operation_receipt Data_encoding.t

  val operation_data_and_receipt_encoding :
    (operation_data * operation_receipt) Data_encoding.t
end

type protocols = {
  current_protocol : Protocol_hash.t;
  next_protocol : Protocol_hash.t;
}

let raw_protocol_encoding =
  conv
    (fun {current_protocol; next_protocol} ->
      ((current_protocol, next_protocol), ()))
    (fun ((current_protocol, next_protocol), ()) ->
      {current_protocol; next_protocol})
    (merge_objs
       (obj2
          (req "protocol" Protocol_hash.encoding)
          (req "next_protocol" Protocol_hash.encoding))
       unit)

module Make (Proto : PROTO) (Next_proto : PROTO) = struct
  let protocol_hash = Protocol_hash.to_b58check Proto.hash

  let next_protocol_hash = Protocol_hash.to_b58check Next_proto.hash

  type raw_block_header = {
    shell : Block_header.shell_header;
    protocol_data : Proto.block_header_data;
  }

  let raw_block_header_encoding =
    def "raw_block_header"
    @@ conv
         (fun {shell; protocol_data} -> (shell, protocol_data))
         (fun (shell, protocol_data) -> {shell; protocol_data})
         (merge_objs
            Block_header.shell_header_encoding
            Proto.block_header_data_encoding)

  type block_header = {
    chain_id : Chain_id.t;
    hash : Block_hash.t;
    shell : Block_header.shell_header;
    protocol_data : Proto.block_header_data;
  }

  let block_header_encoding =
    def "block_header"
    @@ conv
         (fun {chain_id; hash; shell; protocol_data} ->
           (((), chain_id, hash), {shell; protocol_data}))
         (fun (((), chain_id, hash), {shell; protocol_data}) ->
           {chain_id; hash; shell; protocol_data})
         (merge_objs
            (obj3
               (req "protocol" (constant protocol_hash))
               (req "chain_id" Chain_id.encoding)
               (req "hash" Block_hash.encoding))
            raw_block_header_encoding)

  type block_metadata = {
    protocol_data : Proto.block_header_metadata;
    test_chain_status : Test_chain_status.t;
    (* for the next block: *)
    max_operations_ttl : int;
    max_operation_data_length : int;
    max_block_header_length : int;
    operation_list_quota : operation_list_quota list;
  }

  let block_metadata_encoding =
    def "block_header_metadata"
    @@ conv
         (fun { protocol_data;
                test_chain_status;
                max_operations_ttl;
                max_operation_data_length;
                max_block_header_length;
                operation_list_quota } ->
           ( ( (),
               (),
               test_chain_status,
               max_operations_ttl,
               max_operation_data_length,
               max_block_header_length,
               operation_list_quota ),
             protocol_data ))
         (fun ( ( (),
                  (),
                  test_chain_status,
                  max_operations_ttl,
                  max_operation_data_length,
                  max_block_header_length,
                  operation_list_quota ),
                protocol_data ) ->
           {
             protocol_data;
             test_chain_status;
             max_operations_ttl;
             max_operation_data_length;
             max_block_header_length;
             operation_list_quota;
           })
         (merge_objs
            (obj7
               (req "protocol" (constant protocol_hash))
               (req "next_protocol" (constant next_protocol_hash))
               (req "test_chain_status" Test_chain_status.encoding)
               (req "max_operations_ttl" int31)
               (req "max_operation_data_length" int31)
               (req "max_block_header_length" int31)
               (req
                  "max_operation_list_length"
                  (dynamic_size (list operation_list_quota_encoding))))
            Proto.block_header_metadata_encoding)

  let next_operation_encoding =
    let open Data_encoding in
    def "next_operation"
    @@ conv
         (fun Next_proto.{shell; protocol_data} ->
           ((), (shell, protocol_data)))
         (fun ((), (shell, protocol_data)) -> {shell; protocol_data})
         (merge_objs
            (obj1 (req "protocol" (constant next_protocol_hash)))
            (merge_objs
               (dynamic_size Operation.shell_header_encoding)
               (dynamic_size Next_proto.operation_data_encoding)))

  type operation = {
    chain_id : Chain_id.t;
    hash : Operation_hash.t;
    shell : Operation.shell_header;
    protocol_data : Proto.operation_data;
    receipt : Proto.operation_receipt;
  }

  let operation_encoding =
    def "operation"
    @@
    let open Data_encoding in
    conv
      (fun {chain_id; hash; shell; protocol_data; receipt} ->
        (((), chain_id, hash), (shell, (protocol_data, receipt))))
      (fun (((), chain_id, hash), (shell, (protocol_data, receipt))) ->
        {chain_id; hash; shell; protocol_data; receipt})
      (merge_objs
         (obj3
            (req "protocol" (constant protocol_hash))
            (req "chain_id" Chain_id.encoding)
            (req "hash" Operation_hash.encoding))
         (merge_objs
            (dynamic_size Operation.shell_header_encoding)
            (dynamic_size Proto.operation_data_and_receipt_encoding)))

  type block_info = {
    chain_id : Chain_id.t;
    hash : Block_hash.t;
    header : raw_block_header;
    metadata : block_metadata;
    operations : operation list list;
  }

  let block_info_encoding =
    conv
      (fun {chain_id; hash; header; metadata; operations} ->
        ((), chain_id, hash, header, metadata, operations))
      (fun ((), chain_id, hash, header, metadata, operations) ->
        {chain_id; hash; header; metadata; operations})
      (obj6
         (req "protocol" (constant protocol_hash))
         (req "chain_id" Chain_id.encoding)
         (req "hash" Block_hash.encoding)
         (req "header" (dynamic_size raw_block_header_encoding))
         (req "metadata" (dynamic_size block_metadata_encoding))
         (req "operations" (list (dynamic_size (list operation_encoding)))))

  module S = struct
    let path : prefix RPC_path.context = RPC_path.open_root

    let hash =
      RPC_service.get_service
        ~description:"The block's hash, its unique identifier."
        ~query:RPC_query.empty
        ~output:Block_hash.encoding
        RPC_path.(path / "hash")

    let header =
      RPC_service.get_service
        ~description:"The whole block header."
        ~query:RPC_query.empty
        ~output:block_header_encoding
        RPC_path.(path / "header")

    let raw_header =
      RPC_service.get_service
        ~description:"The whole block header (unparsed)."
        ~query:RPC_query.empty
        ~output:bytes
        RPC_path.(path / "header" / "raw")

    let metadata =
      RPC_service.get_service
        ~description:"All the metadata associated to the block."
        ~query:RPC_query.empty
        ~output:block_metadata_encoding
        RPC_path.(path / "metadata")

    let protocols =
      RPC_service.get_service
        ~description:"Current and next protocol."
        ~query:RPC_query.empty
        ~output:raw_protocol_encoding
        RPC_path.(path / "protocols")

    module Header = struct
      let path = RPC_path.(path / "header")

      let shell_header =
        RPC_service.get_service
          ~description:"The shell-specific fragment of the block header."
          ~query:RPC_query.empty
          ~output:Block_header.shell_header_encoding
          RPC_path.(path / "shell")

      let protocol_data =
        RPC_service.get_service
          ~description:"The version-specific fragment of the block header."
          ~query:RPC_query.empty
          ~output:
            (conv
               (fun h -> ((), h))
               (fun ((), h) -> h)
               (merge_objs
                  (obj1 (req "protocol" (constant protocol_hash)))
                  Proto.block_header_data_encoding))
          RPC_path.(path / "protocol_data")

      let raw_protocol_data =
        RPC_service.get_service
          ~description:
            "The version-specific fragment of the block header (unparsed)."
          ~query:RPC_query.empty
          ~output:bytes
          RPC_path.(path / "protocol_data" / "raw")
    end

    module Operations = struct
      let path = RPC_path.(path / "operations")

      let operations =
        RPC_service.get_service
          ~description:"All the operations included in the block."
          ~query:RPC_query.empty
          ~output:(list (dynamic_size (list operation_encoding)))
          path

      let list_arg =
        let name = "list_offset" in
        let descr = "Index `n` of the requested validation pass." in
        let construct = string_of_int in
        let destruct s =
          try Ok (int_of_string s)
          with _ -> Error (Format.sprintf "Invalid list offset (%s)" s)
        in
        RPC_arg.make ~name ~descr ~construct ~destruct ()

      let offset_arg =
        let name = "operation_offset" in
        let descr =
          "Index `m` of the requested operation in its validation pass."
        in
        let construct = string_of_int in
        let destruct s =
          try Ok (int_of_string s)
          with _ -> Error (Format.sprintf "Invalid operation offset (%s)" s)
        in
        RPC_arg.make ~name ~descr ~construct ~destruct ()

      let operations_in_pass =
        RPC_service.get_service
          ~description:
            "All the operations included in `n-th` validation pass of the \
             block."
          ~query:RPC_query.empty
          ~output:(list operation_encoding)
          RPC_path.(path /: list_arg)

      let operation =
        RPC_service.get_service
          ~description:
            "The `m-th` operation in the `n-th` validation pass of the block."
          ~query:RPC_query.empty
          ~output:operation_encoding
          RPC_path.(path /: list_arg /: offset_arg)
    end

    module Operation_hashes = struct
      let path = RPC_path.(path / "operation_hashes")

      let operation_hashes =
        RPC_service.get_service
          ~description:
            "The hashes of all the operations included in the block."
          ~query:RPC_query.empty
          ~output:(list (list Operation_hash.encoding))
          path

      let operation_hashes_in_pass =
        RPC_service.get_service
          ~description:
            "All the operations included in `n-th` validation pass of the \
             block."
          ~query:RPC_query.empty
          ~output:(list Operation_hash.encoding)
          RPC_path.(path /: Operations.list_arg)

      let operation_hash =
        RPC_service.get_service
          ~description:
            "The hash of then `m-th` operation in the `n-th` validation pass \
             of the block."
          ~query:RPC_query.empty
          ~output:Operation_hash.encoding
          RPC_path.(path /: Operations.list_arg /: Operations.offset_arg)
    end

    module Helpers = struct
      let path = RPC_path.(path / "helpers")

      module Forge = struct
        let block_header =
          RPC_service.post_service
            ~description:"Forge a block header"
            ~query:RPC_query.empty
            ~input:Block_header.encoding
            ~output:(obj1 (req "block" bytes))
            RPC_path.(path / "forge_block_header")
      end

      module Preapply = struct
        let path = RPC_path.(path / "preapply")

        let block_result_encoding =
          obj2
            (req "shell_header" Block_header.shell_header_encoding)
            (req
               "operations"
               (list (Preapply_result.encoding RPC_error.encoding)))

        type block_param = {
          protocol_data : Next_proto.block_header_data;
          operations : Next_proto.operation list list;
        }

        let block_param_encoding =
          conv
            (fun {protocol_data; operations} -> (protocol_data, operations))
            (fun (protocol_data, operations) -> {protocol_data; operations})
            (obj2
               (req
                  "protocol_data"
                  (conv
                     (fun h -> ((), h))
                     (fun ((), h) -> h)
                     (merge_objs
                        (obj1 (req "protocol" (constant next_protocol_hash)))
                        (dynamic_size Next_proto.block_header_data_encoding))))
               (req
                  "operations"
                  (list (dynamic_size (list next_operation_encoding)))))

        let block_query =
          let open RPC_query in
          query (fun sort timestamp ->
              object
                method sort_operations = sort

                method timestamp = timestamp
              end)
          |+ flag "sort" (fun t -> t#sort_operations)
          |+ opt_field "timestamp" Time.Protocol.rpc_arg (fun t -> t#timestamp)
          |> seal

        let block =
          RPC_service.post_service
            ~description:
              "Simulate the validation of a block that would contain the \
               given operations and return the resulting fitness and context \
               hash."
            ~query:block_query
            ~input:block_param_encoding
            ~output:block_result_encoding
            RPC_path.(path / "block")

        let operations =
          RPC_service.post_service
            ~description:"Simulate the validation of an operation."
            ~query:RPC_query.empty
            ~input:(list next_operation_encoding)
            ~output:
              (list
                 (dynamic_size Next_proto.operation_data_and_receipt_encoding))
            RPC_path.(path / "operations")
      end

      let complete =
        let prefix_arg =
          let destruct s = Ok s and construct s = s in
          RPC_arg.make ~name:"prefix" ~destruct ~construct ()
        in
        RPC_service.get_service
          ~description:
            "Try to complete a prefix of a Base58Check-encoded data. This RPC \
             is actually able to complete hashes of block, operations, \
             public_keys and contracts."
          ~query:RPC_query.empty
          ~output:(list string)
          RPC_path.(path / "complete" /: prefix_arg)
    end

    module Context = struct
      let path = RPC_path.(path / "context" / "raw" / "bytes")

      let context_path_arg : string RPC_arg.t =
        let name = "context_path" in
        let descr = "A path inside the context" in
        let construct s = s in
        let destruct s = Ok s in
        RPC_arg.make ~name ~descr ~construct ~destruct ()

      let raw_context_query : < depth : int option > RPC_query.t =
        let open RPC_query in
        query (fun depth ->
            object
              method depth = depth
            end)
        |+ opt_field "depth" RPC_arg.int (fun t -> t#depth)
        |> seal

      let read =
        RPC_service.get_service
          ~description:"Returns the raw context."
          ~query:raw_context_query
          ~output:raw_context_encoding
          RPC_path.(path /:* context_path_arg)
    end

    let info =
      RPC_service.get_service
        ~description:"All the information about a block."
        ~query:RPC_query.empty
        ~output:block_info_encoding
        path

    module Mempool = struct
      type t = {
        applied : (Operation_hash.t * Next_proto.operation) list;
        refused : (Next_proto.operation * error list) Operation_hash.Map.t;
        branch_refused :
          (Next_proto.operation * error list) Operation_hash.Map.t;
        branch_delayed :
          (Next_proto.operation * error list) Operation_hash.Map.t;
        unprocessed : Next_proto.operation Operation_hash.Map.t;
      }

      let encoding =
        conv
          (fun {applied; refused; branch_refused; branch_delayed; unprocessed} ->
            (applied, refused, branch_refused, branch_delayed, unprocessed))
          (fun (applied, refused, branch_refused, branch_delayed, unprocessed) ->
            {applied; refused; branch_refused; branch_delayed; unprocessed})
          (obj5
             (req
                "applied"
                (list
                   (conv
                      (fun (hash, (op : Next_proto.operation)) ->
                        ((hash, op.shell), op.protocol_data))
                      (fun ((hash, shell), protocol_data) ->
                        (hash, {shell; protocol_data}))
                      (merge_objs
                         (merge_objs
                            (obj1 (req "hash" Operation_hash.encoding))
                            (dynamic_size Operation.shell_header_encoding))
                         (dynamic_size Next_proto.operation_data_encoding)))))
             (req
                "refused"
                (Operation_hash.Map.encoding
                   (merge_objs
                      (dynamic_size next_operation_encoding)
                      (obj1 (req "error" RPC_error.encoding)))))
             (req
                "branch_refused"
                (Operation_hash.Map.encoding
                   (merge_objs
                      (dynamic_size next_operation_encoding)
                      (obj1 (req "error" RPC_error.encoding)))))
             (req
                "branch_delayed"
                (Operation_hash.Map.encoding
                   (merge_objs
                      (dynamic_size next_operation_encoding)
                      (obj1 (req "error" RPC_error.encoding)))))
             (req
                "unprocessed"
                (Operation_hash.Map.encoding
                   (dynamic_size next_operation_encoding))))

      let pending_operations path =
        (* TODO: branch_delayed/... *)
        RPC_service.get_service
          ~description:"List the prevalidated operations."
          ~query:RPC_query.empty
          ~output:encoding
          RPC_path.(path / "pending_operations")

      let mempool_query =
        let open RPC_query in
        query (fun applied refused branch_refused branch_delayed ->
            object
              method applied = applied

              method refused = refused

              method branch_refused = branch_refused

              method branch_delayed = branch_delayed
            end)
        |+ field
             ~descr:"Include applied operations (set by default)"
             "applied"
             RPC_arg.bool
             true
             (fun t -> t#applied)
        |+ field
             ~descr:"Include refused operations"
             "refused"
             RPC_arg.bool
             false
             (fun t -> t#refused)
        |+ field
             ~descr:"Include branch refused operations"
             "branch_refused"
             RPC_arg.bool
             false
             (fun t -> t#branch_refused)
        |+ field
             ~descr:"Include branch delayed operations (set by default)"
             "branch_delayed"
             RPC_arg.bool
             true
             (fun t -> t#branch_delayed)
        |> seal

      let monitor_operations path =
        RPC_service.get_service
          ~description:"Monitor the mempool operations."
          ~query:mempool_query
          ~output:(list next_operation_encoding)
          RPC_path.(path / "monitor_operations")

      let request_operations path =
        RPC_service.post_service
          ~description:"Request the operations of your peers."
          ~input:Data_encoding.empty
          ~query:RPC_query.empty
          ~output:Data_encoding.empty
          RPC_path.(path / "request_operations")
    end

    let live_blocks =
      RPC_service.get_service
        ~description:
          "List the ancestors of the given block which, if referred to as the \
           branch in an operation header, are recent enough for that \
           operation to be included in the current block."
        ~query:RPC_query.empty
        ~output:Block_hash.Set.encoding
        RPC_path.(live_blocks_path open_root)
  end

  let path = RPC_path.prefix chain_path path

  let make_call0 s ctxt a b q p =
    let s = RPC_service.prefix path s in
    RPC_context.make_call2 s ctxt a b q p

  let make_call1 s ctxt a b c q p =
    let s = RPC_service.prefix path s in
    RPC_context.make_call3 s ctxt a b c q p

  let make_call2 s ctxt a b c d q p =
    let s = RPC_service.prefix path s in
    RPC_context.make_call s ctxt (((((), a), b), c), d) q p

  let hash ctxt =
    let f = make_call0 S.hash ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () ->
      match block with `Hash (h, 0) -> return h | _ -> f chain block () ()

  let header ctxt =
    let f = make_call0 S.header ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  let raw_header ctxt =
    let f = make_call0 S.raw_header ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  let metadata ctxt =
    let f = make_call0 S.metadata ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  let protocols ctxt =
    let f = make_call0 S.protocols ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  module Header = struct
    module S = S.Header

    let shell_header ctxt =
      let f = make_call0 S.shell_header ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let protocol_data ctxt =
      let f = make_call0 S.protocol_data ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let raw_protocol_data ctxt =
      let f = make_call0 S.raw_protocol_data ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
  end

  module Operations = struct
    module S = S.Operations

    let operations ctxt =
      let f = make_call0 S.operations ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let operations_in_pass ctxt =
      let f = make_call1 S.operations_in_pass ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n -> f chain block n () ()

    let operation ctxt =
      let f = make_call2 S.operation ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n m -> f chain block n m () ()
  end

  module Operation_hashes = struct
    module S = S.Operation_hashes

    let operation_hashes ctxt =
      let f = make_call0 S.operation_hashes ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

    let operation_hashes_in_pass ctxt =
      let f = make_call1 S.operation_hashes_in_pass ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n -> f chain block n () ()

    let operation_hash ctxt =
      let f = make_call2 S.operation_hash ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) n m -> f chain block n m () ()
  end

  module Context = struct
    module S = S.Context

    let read ctxt =
      let f = make_call1 S.read ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) ?depth path ->
        f
          chain
          block
          path
          (object
             method depth = depth
          end)
          ()
  end

  module Helpers = struct
    module S = S.Helpers

    module Forge = struct
      module S = S.Forge

      let block_header ctxt =
        let f = make_call0 S.block_header ctxt in
        fun ?(chain = `Main) ?(block = `Head 0) header ->
          f chain block () header
    end

    module Preapply = struct
      module S = S.Preapply

      let block ctxt =
        let f = make_call0 S.block ctxt in
        fun ?(chain = `Main)
            ?(block = `Head 0)
            ?(sort = false)
            ?timestamp
            ~protocol_data
            operations ->
          f
            chain
            block
            (object
               method sort_operations = sort

               method timestamp = timestamp
            end)
            {protocol_data; operations}

      let operations ctxt =
        let f = make_call0 S.operations ctxt in
        fun ?(chain = `Main) ?(block = `Head 0) operations ->
          f chain block () operations
    end

    let complete ctxt =
      let f = make_call1 S.complete ctxt in
      fun ?(chain = `Main) ?(block = `Head 0) s -> f chain block s () ()
  end

  let info ctxt =
    let f = make_call0 S.info ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()

  module Mempool = struct
    type t = S.Mempool.t = {
      applied : (Operation_hash.t * Next_proto.operation) list;
      refused : (Next_proto.operation * error list) Operation_hash.Map.t;
      branch_refused :
        (Next_proto.operation * error list) Operation_hash.Map.t;
      branch_delayed :
        (Next_proto.operation * error list) Operation_hash.Map.t;
      unprocessed : Next_proto.operation Operation_hash.Map.t;
    }

    let pending_operations ctxt ?(chain = `Main) () =
      let s = S.Mempool.pending_operations (mempool_path chain_path) in
      RPC_context.make_call1 s ctxt chain () ()

    let monitor_operations ctxt ?(chain = `Main) ?(applied = true)
        ?(branch_delayed = true) ?(branch_refused = false) ?(refused = false)
        () =
      let s = S.Mempool.monitor_operations (mempool_path chain_path) in
      RPC_context.make_streamed_call
        s
        ctxt
        ((), chain)
        (object
           method applied = applied

           method refused = refused

           method branch_refused = branch_refused

           method branch_delayed = branch_delayed
        end)
        ()

    let request_operations ctxt ?(chain = `Main) () =
      let s = S.Mempool.request_operations (mempool_path chain_path) in
      RPC_context.make_call1 s ctxt chain () ()
  end

  let live_blocks ctxt =
    let f = make_call0 S.live_blocks ctxt in
    fun ?(chain = `Main) ?(block = `Head 0) () -> f chain block () ()
end

module Fake_protocol = struct
  let hash = Protocol_hash.zero

  type block_header_data = unit

  let block_header_data_encoding = Data_encoding.empty

  type block_header_metadata = unit

  let block_header_metadata_encoding = Data_encoding.empty

  type operation_data = unit

  type operation_receipt = unit

  type operation = {
    shell : Operation.shell_header;
    protocol_data : operation_data;
  }

  let operation_data_encoding = Data_encoding.empty

  let operation_receipt_encoding = Data_encoding.empty

  let operation_data_and_receipt_encoding =
    Data_encoding.conv
      (fun ((), ()) -> ())
      (fun () -> ((), ()))
      Data_encoding.empty
end

module Empty = Make (Fake_protocol) (Fake_protocol)

let () =
  Printexc.register_printer (function
      | ( Json_schema.Cannot_parse _
        | Json_schema.Dangling_reference _
        | Json_schema.Bad_reference _
        | Json_schema.Unexpected _
        | Json_schema.Duplicate_definition _ ) as exn ->
          Some
            (Format.asprintf "%a" (fun ppf -> Json_schema.print_error ppf) exn)
      | _ ->
          None)

let protocols = Empty.protocols
src/lib_shell_services/block_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition chain := variant.

Definition parse_chain (s : string) : sum variant string :=
  (* ❌ Try-with are not handled *)
  try
    match s with
    | "main" % string =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | "test" % string =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | h =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    end.

Definition chain_to_string (function_parameter : variant) : string :=
  match function_parameter with
  | Main => "main" % string
  | Test => "test" % string
  | Hash h => Chain_id.to_b58check h
  end.

Definition chain_arg : Tezos_base__TzPervasives.RPC_arg.arg variant :=
  let name := "chain_id" % string in
  let descr :=
    "A chain identifier. This is either a chain hash in Base58Check notation or a one the predefined aliases: 'main', 'test'."
      % string in
  let construct := chain_to_string in
  let destruct := parse_chain in
  RPC_arg.make (Some descr) name destruct construct tt.

Definition block := variant.

Definition parse_block (s : string) : sum variant string :=
  let delims := cons "~" % char (cons "-" % char (cons "+" % char [])) in
  let count_delims (s : string) : list (Z * ascii) :=
    List.map
      (fun d =>
        ((String.fold_left
          (fun i =>
            fun c =>
              if equiv_decb c d then
                Z.add i 1
              else
                i) 0 s), d)) delims in
  let split_on_delim (counts : list (Z * ascii)) : (list string) * ascii :=
    match
      List.fold_left
        (fun i =>
          fun function_parameter =>
            let '(v, _) := function_parameter in
            Z.add i v) 0 counts with
    | 0 => ((cons s []), " " % char)
    | 1 =>
      let delim := List.assoc 1 counts in
      ((String.split delim None None s), delim)
    | _ => Stdlib.raise Exit
    end in
  (* ❌ Try-with are not handled *)
  try
    match split_on_delim (count_delims s) with
    | (cons "genesis" % string [], _) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "genesis" % string (cons n []), "+" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "head" % string [], _) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    |
      (cons "head" % string (cons n []), "~" % char) |
        (cons "head" % string (cons n []), "-" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "checkpoint" % string [], _) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    |
      (cons "checkpoint" % string (cons n []), "~" % char) |
        (cons "checkpoint" % string (cons n []), "-" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "checkpoint" % string (cons n []), "+" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "save_point" % string [], _) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    |
      (cons "save_point" % string (cons n []), "~" % char) |
        (cons "save_point" % string (cons n []), "-" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "save_point" % string (cons n []), "+" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "caboose" % string [], _) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    |
      (cons "caboose" % string (cons n []), "~" % char) |
        (cons "caboose" % string (cons n []), "-" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons "caboose" % string (cons n []), "+" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons hol [], _) =>
      match Block_hash.of_b58check_opt hol with
      | Some h =>
        Stdlib.Ok
          (* ❌ Variants not supported *)
          variant
      | None =>
        let l := Int32.of_string s in
        if
          op_lt l
            (* ❌ Constant of type int32 is converted to int *)
            0 then
          Stdlib.raise Exit
        else
          if
            op_eq l
              (* ❌ Constant of type int32 is converted to int *)
              0 then
            Stdlib.Ok
              (* ❌ Variants not supported *)
              variant
          else
            Stdlib.Ok
              (* ❌ Variants not supported *)
              variant
      end
    | (cons h (cons n []), "~" % char) | (cons h (cons n []), "-" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | (cons h (cons n []), "+" % char) =>
      Stdlib.Ok
        (* ❌ Variants not supported *)
        variant
    | _ => Stdlib.raise Exit
    end.

Definition alias_to_string (function_parameter : variant) : string :=
  match function_parameter with
  | Checkpoint => "checkpoint" % string
  | Save_point => "save_point" % string
  | Caboose => "caboose" % string
  end.

Definition to_string (function_parameter : variant) : string :=
  match function_parameter with
  | Genesis => "genesis" % string
  | Alias (a, 0) => alias_to_string a
  | Alias (a, n) =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "+" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s+%d" % string)
      (alias_to_string a) (Z.opp n)
  | Alias (a, n) =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "~" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s~%d" % string)
      (alias_to_string a) n
  | Head 0 => "head" % string
  | Head n =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "head+" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "head+%d" % string)
      (Z.opp n)
  | Head n =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "head~" % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format)) "head~%d" % string) n
  | Hash (h, 0) => Block_hash.to_b58check h
  | Hash (h, n) =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "+" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s+%d" % string)
      (Block_hash.to_b58check h) (Z.opp n)
  | Hash (h, n) =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "~" % char
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%s~%d" % string)
      (Block_hash.to_b58check h) n
  | Level i =>
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.No_precision
          CamlinternalFormatBasics.End_of_format) "%d" % string)
      (Int32.to_int i)
  end.

Definition blocks_arg : Tezos_base__TzPervasives.RPC_arg.arg variant :=
  let name := "block_id" % string in
  let descr :=
    "A block identifier. This is either a block hash in Base58Check notation, one the predefined aliases: 'genesis', 'head' or a block level (index in the chain). One might also use 'head~N' or '<hash>~N' where N is an integer to denote the Nth predecessor of the designated block.Also, '<hash>+N' denotes the Nth successor of a block."
      % string in
  let construct := to_string in
  let destruct := parse_block in
  RPC_arg.make (Some descr) name destruct construct tt.

Definition chain_prefix := unit * chain.

Definition prefix := chain_prefix * block.

Definition chain_path
  : Tezos_base__TzPervasives.RPC_path.path unit (unit * variant) :=
  op_divcolon (op_div root "chains" % string) chain_arg.

Definition mempool_path {A B : Type}
  (p : Tezos_base__TzPervasives.RPC_path.path A B)
  : Tezos_base__TzPervasives.RPC_path.path A B := op_div p "mempool" % string.

Definition live_blocks_path {A B : Type}
  (p : Tezos_base__TzPervasives.RPC_path.path A B)
  : Tezos_base__TzPervasives.RPC_path.path A B :=
  op_div p "live_blocks" % string.

Definition dir_path
  : Tezos_base__TzPervasives.RPC_path.t chain_prefix chain_prefix :=
  op_div open_root "blocks" % string.

Definition path
  : Tezos_base__TzPervasives.RPC_path.path chain_prefix (chain_prefix * variant) :=
  op_divcolon dir_path blocks_arg.

Record operation_list_quota := {
  max_size : Z;
  max_op : option Z }.

Definition operation_list_quota_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding operation_list_quota :=
  conv
    (fun function_parameter =>
      let '{| max_size := max_size; max_op := max_op |} := function_parameter in
      (max_size, max_op))
    (fun function_parameter =>
      let '(max_size, max_op) := function_parameter in
      {| max_size := max_size; max_op := max_op |}) None
    (obj2 (req None None "max_size" % string int31)
      (opt None None "max_op" % string int31)).

Inductive raw_context : Type :=
| Key : Stdlib.Bytes.t -> raw_context
| Dir : (list (string * raw_context)) -> raw_context
| Cut : raw_context.

Fixpoint pp_raw_context
  (ppf : Stdlib.Format.formatter) (function_parameter : raw_context) : unit :=
  match function_parameter with
  | Cut =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "..." % string
          CamlinternalFormatBasics.End_of_format) "..." % string)
  | Key v => Hex.pp ppf (Hex.of_bytes None v)
  | Dir l =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "{" % char
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 1>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 1>" % string))
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Char_literal "}" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "{@[<v 1>@,%a@]@,}" % string)
      (Format.pp_print_list (Some Format.pp_print_cut)
        (fun ppf =>
          fun function_parameter =>
            let '(s, t) := function_parameter in
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " : " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format)))
                "%s : %a" % string) s pp_raw_context t)) l
  end.

Definition raw_context_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding raw_context :=
  mu "raw_context" % string None None
    (fun encoding =>
      union None
        (cons
          (case "Key" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 0) bytes
            (fun function_parameter =>
              match function_parameter with
              | Key k => Some k
              | _ => None
              end) (fun k => Key k))
          (cons
            (case "Dir" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 1) (assoc encoding)
              (fun function_parameter =>
                match function_parameter with
                | Dir k => Some k
                | _ => None
                end) (fun k => Dir k))
            (cons
              (case "Cut" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 2) null
                (fun function_parameter =>
                  match function_parameter with
                  | Cut => Some tt
                  | _ => None
                  end)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Cut)) [])))).

(* ❌ Structure item `typext` not handled. *)
type_extension



Module PROTO.
  Record signature {block_header_data block_header_metadata operation_data
    operation_receipt operation : Type} := {
    hash : Tezos_base__TzPervasives.Protocol_hash.t;
    block_header_data := block_header_data;
    block_header_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_data;
    block_header_metadata := block_header_metadata;
    block_header_metadata_encoding : Tezos_base__TzPervasives.Data_encoding.t
      block_header_metadata;
    operation_data := operation_data;
    operation_receipt := operation_receipt;
    operation := operation;
    operation_data_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_data;
    operation_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      operation_receipt;
    operation_data_and_receipt_encoding : Tezos_base__TzPervasives.Data_encoding.t
      (operation_data * operation_receipt);
  }.
  Arguments signature : clear implicits.
End PROTO.

Record protocols := {
  current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.

Definition raw_protocol_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding protocols :=
  conv
    (fun function_parameter =>
      let '{|
        current_protocol := current_protocol;
          next_protocol := next_protocol
          |} := function_parameter in
      ((current_protocol, next_protocol), tt))
    (fun function_parameter =>
      let '((current_protocol, next_protocol), tt) := function_parameter in
      {| current_protocol := current_protocol; next_protocol := next_protocol |})
    None
    (merge_objs
      (obj2 (req None None "protocol" % string Protocol_hash.encoding)
        (req None None "next_protocol" % string Protocol_hash.encoding)) unit).

(* ❌ Functors are not handled. *)
functor

Module Fake_protocol.
  Definition hash : Tezos_base__TzPervasives.Protocol_hash.t :=
    Protocol_hash.zero.
  
  Definition block_header_data := unit.
  
  Definition block_header_data_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Data_encoding.empty.
  
  Definition block_header_metadata := unit.
  
  Definition block_header_metadata_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Data_encoding.empty.
  
  Definition operation_data := unit.
  
  Definition operation_receipt := unit.
  
  Record operation := {
    shell : Tezos_base__TzPervasives.Operation.shell_header;
    protocol_data : operation_data }.
  
  Definition operation_data_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Data_encoding.empty.
  
  Definition operation_receipt_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Data_encoding.empty.
  
  Definition operation_data_and_receipt_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding (unit * unit) :=
    Data_encoding.conv
      (fun function_parameter =>
        let '(tt, tt) := function_parameter in
        tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        (tt, tt)) None Data_encoding.empty.
End Fake_protocol.

(* ❌ Applications of functors are not handled. *)
functor_application



Definition protocols {E F i o p q : Type}
  : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
    p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
    (E * p * q * i * o)) * F) * F) ->
    (option variant) ->
      (option variant) ->
        unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult protocols) :=
  Empty.protocols.

src/lib_shell_services/block_validator_errors.ml 18 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type block_error =
  | Cannot_parse_operation of Operation_hash.t
  | Invalid_fitness of {expected : Fitness.t; found : Fitness.t}
  | Non_increasing_timestamp
  | Non_increasing_fitness
  | Invalid_level of {expected : Int32.t; found : Int32.t}
  | Invalid_proto_level of {expected : int; found : int}
  | Replayed_operation of Operation_hash.t
  | Outdated_operation of {
      operation : Operation_hash.t;
      originating_block : Block_hash.t;
    }
  | Expired_chain of {
      chain_id : Chain_id.t;
      expiration : Time.Protocol.t;
      timestamp : Time.Protocol.t;
    }
  | Unexpected_number_of_validation_passes of int (* uint8 *)
  | Too_many_operations of {pass : int; found : int; max : int}
  | Oversized_operation of {
      operation : Operation_hash.t;
      size : int;
      max : int;
    }
  | Unallowed_pass of {
      operation : Operation_hash.t;
      pass : int;
      allowed_pass : int list;
    }
  | Cannot_parse_block_header
  | Economic_protocol_error of error list

let block_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Cannot_parse_operation"
        (obj2
           (req "error" (constant "cannot_parse_operation"))
           (req "operation" Operation_hash.encoding))
        (function
          | Cannot_parse_operation operation ->
              Some ((), operation)
          | _ ->
              None)
        (fun ((), operation) -> Cannot_parse_operation operation);
      case
        (Tag 1)
        ~title:"Invalid_fitness"
        (obj3
           (req "error" (constant "invalid_fitness"))
           (req "expected" Fitness.encoding)
           (req "found" Fitness.encoding))
        (function
          | Invalid_fitness {expected; found} ->
              Some ((), expected, found)
          | _ ->
              None)
        (fun ((), expected, found) -> Invalid_fitness {expected; found});
      case
        (Tag 2)
        ~title:"Non_increasing_timestamp"
        (obj1 (req "error" (constant "non_increasing_timestamp")))
        (function Non_increasing_timestamp -> Some () | _ -> None)
        (fun () -> Non_increasing_timestamp);
      case
        (Tag 3)
        ~title:"Non_increasing_fitness"
        (obj1 (req "error" (constant "non_increasing_fitness")))
        (function Non_increasing_fitness -> Some () | _ -> None)
        (fun () -> Non_increasing_fitness);
      case
        (Tag 4)
        ~title:"Invalid_level"
        (obj3
           (req "error" (constant "invalid_level"))
           (req "expected" int32)
           (req "found" int32))
        (function
          | Invalid_level {expected; found} ->
              Some ((), expected, found)
          | _ ->
              None)
        (fun ((), expected, found) -> Invalid_level {expected; found});
      case
        (Tag 5)
        ~title:"Invalid_proto_level"
        (obj3
           (req "error" (constant "invalid_proto_level"))
           (req "expected" uint8)
           (req "found" uint8))
        (function
          | Invalid_proto_level {expected; found} ->
              Some ((), expected, found)
          | _ ->
              None)
        (fun ((), expected, found) -> Invalid_proto_level {expected; found});
      case
        (Tag 6)
        ~title:"Replayed_operation"
        (obj2
           (req "error" (constant "replayed_operation"))
           (req "operation" Operation_hash.encoding))
        (function
          | Replayed_operation operation -> Some ((), operation) | _ -> None)
        (fun ((), operation) -> Replayed_operation operation);
      case
        (Tag 7)
        ~title:"Outdated_operation"
        (obj3
           (req "error" (constant "outdated_operation"))
           (req "operation" Operation_hash.encoding)
           (req "originating_block" Block_hash.encoding))
        (function
          | Outdated_operation {operation; originating_block} ->
              Some ((), operation, originating_block)
          | _ ->
              None)
        (fun ((), operation, originating_block) ->
          Outdated_operation {operation; originating_block});
      case
        (Tag 8)
        ~title:"Expired_chain"
        (obj4
           (req "error" (constant "expired_chain"))
           (req "chain_id" Chain_id.encoding)
           (req "expiration" Time.Protocol.encoding)
           (req "timestamp" Time.Protocol.encoding))
        (function
          | Expired_chain {chain_id; expiration; timestamp} ->
              Some ((), chain_id, expiration, timestamp)
          | _ ->
              None)
        (fun ((), chain_id, expiration, timestamp) ->
          Expired_chain {chain_id; expiration; timestamp});
      case
        (Tag 9)
        ~title:"Unexpected_number_of_validation_passes"
        (obj2
           (req "error" (constant "unexpected_number_of_passes"))
           (req "found" uint8))
        (function
          | Unexpected_number_of_validation_passes n ->
              Some ((), n)
          | _ ->
              None)
        (fun ((), n) -> Unexpected_number_of_validation_passes n);
      case
        (Tag 10)
        ~title:"Too_many_operations"
        (obj4
           (req "error" (constant "too_many_operations"))
           (req "validation_pass" uint8)
           (req "found" uint16)
           (req "max" uint16))
        (function
          | Too_many_operations {pass; found; max} ->
              Some ((), pass, found, max)
          | _ ->
              None)
        (fun ((), pass, found, max) -> Too_many_operations {pass; found; max});
      case
        (Tag 11)
        ~title:"Oversized_operation"
        (obj4
           (req "error" (constant "oversized_operation"))
           (req "operation" Operation_hash.encoding)
           (req "found" int31)
           (req "max" int31))
        (function
          | Oversized_operation {operation; size; max} ->
              Some ((), operation, size, max)
          | _ ->
              None)
        (fun ((), operation, size, max) ->
          Oversized_operation {operation; size; max});
      case
        (Tag 12)
        ~title:"Unallowed_pass"
        (obj4
           (req "error" (constant "invalid_pass"))
           (req "operation" Operation_hash.encoding)
           (req "pass" uint8)
           (req "allowed_pass" (list uint8)))
        (function
          | Unallowed_pass {operation; pass; allowed_pass} ->
              Some ((), operation, pass, allowed_pass)
          | _ ->
              None)
        (fun ((), operation, pass, allowed_pass) ->
          Unallowed_pass {operation; pass; allowed_pass});
      case
        (Tag 13)
        ~title:"Cannot_parse_block_header"
        (obj1 (req "error" (constant "cannot_parse_bock_header")))
        (function Cannot_parse_block_header -> Some () | _ -> None)
        (fun () -> Cannot_parse_block_header) ]

let pp_block_error ppf = function
  | Cannot_parse_operation oph ->
      Format.fprintf
        ppf
        "Failed to parse the operation %a."
        Operation_hash.pp_short
        oph
  | Invalid_fitness {expected; found} ->
      Format.fprintf
        ppf
        "@[<v 2>Invalid fitness:@  expected %a@  found %a@]"
        Fitness.pp
        expected
        Fitness.pp
        found
  | Non_increasing_timestamp ->
      Format.fprintf ppf "Non increasing timestamp"
  | Non_increasing_fitness ->
      Format.fprintf ppf "Non increasing fitness"
  | Invalid_level {expected; found} ->
      Format.fprintf
        ppf
        "Invalid level:@  expected %ld@  found %ld"
        expected
        found
  | Invalid_proto_level {expected; found} ->
      Format.fprintf
        ppf
        "Invalid protocol level:@  expected %d@  found %d"
        expected
        found
  | Replayed_operation oph ->
      Format.fprintf
        ppf
        "The operation %a was previously included in the chain."
        Operation_hash.pp_short
        oph
  | Outdated_operation {operation; originating_block} ->
      Format.fprintf
        ppf
        "The operation %a is outdated (originated in block: %a)"
        Operation_hash.pp_short
        operation
        Block_hash.pp_short
        originating_block
  | Expired_chain {chain_id; expiration; timestamp} ->
      Format.fprintf
        ppf
        "The block timestamp (%a) is later than its chain expiration date: %a \
         (chain: %a)."
        Time.System.pp_hum
        (Time.System.of_protocol_exn timestamp)
        Time.System.pp_hum
        (Time.System.of_protocol_exn expiration)
        Chain_id.pp_short
        chain_id
  | Unexpected_number_of_validation_passes n ->
      Format.fprintf ppf "Invalid number of validation passes (found: %d)" n
  | Too_many_operations {pass; found; max} ->
      Format.fprintf
        ppf
        "Too many operations in validation pass %d (found: %d, max: %d)"
        pass
        found
        max
  | Oversized_operation {operation; size; max} ->
      Format.fprintf
        ppf
        "Oversized operation %a (size: %d, max: %d)"
        Operation_hash.pp_short
        operation
        size
        max
  | Unallowed_pass {operation; pass; allowed_pass} ->
      Format.fprintf
        ppf
        "Operation %a included in validation pass %d,  while only the \
         following passes are allowed: @[<h>%a@]"
        Operation_hash.pp_short
        operation
        pass
        Format.(pp_print_list pp_print_int)
        allowed_pass
  | Cannot_parse_block_header ->
      Format.fprintf ppf "Failed to parse the block header."
  | Economic_protocol_error err ->
      Format.fprintf
        ppf
        "Failed to validate the economic-protocol content of the block: %a."
        Error_monad.pp_print_error
        err

type validation_process_error =
  | Missing_handshake
  | Inconsistent_handshake of string
  | Protocol_dynlink_failure of string

let validation_process_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Missing_handshake"
        (obj1 (req "constant" (constant "missing_handshake")))
        (function Missing_handshake -> Some () | _ -> None)
        (fun () -> Missing_handshake);
      case
        (Tag 1)
        ~title:"Inconsistent_handshake"
        (obj1 (req "inconsistent_handshake" string))
        (function Inconsistent_handshake msg -> Some msg | _ -> None)
        (fun msg -> Inconsistent_handshake msg);
      case
        (Tag 2)
        ~title:"Protocol_dynlink_failure"
        (obj1 (req "pretocol_dynlink_failure" string))
        (function Protocol_dynlink_failure msg -> Some msg | _ -> None)
        (fun msg -> Protocol_dynlink_failure msg) ]

let pp_validation_process_error ppf = function
  | Missing_handshake ->
      Format.fprintf
        ppf
        "Missing handshake while initializing validation process."
  | Protocol_dynlink_failure msg ->
      Format.fprintf ppf "%s" msg
  | Inconsistent_handshake msg ->
      Format.fprintf ppf "Inconsistent handshake: %s." msg

type error +=
  | Invalid_block of {block : Block_hash.t; error : block_error}
  | Unavailable_protocol of {block : Block_hash.t; protocol : Protocol_hash.t}
  | Inconsistent_operations_hash of {
      block : Block_hash.t;
      expected : Operation_list_list_hash.t;
      found : Operation_list_list_hash.t;
    }
  | Failed_to_checkout_context of Context_hash.t
  | System_error of {errno : string; fn : string; msg : string}
  | Missing_test_protocol of Protocol_hash.t
  | Validation_process_failed of validation_process_error

let () =
  Error_monad.register_error_kind
    `Permanent
    ~id:"validator.invalid_block"
    ~title:"Invalid block"
    ~description:"Invalid block."
    ~pp:(fun ppf (block, error) ->
      Format.fprintf
        ppf
        "@[<v 2>Invalid block %a@ %a@]"
        Block_hash.pp_short
        block
        pp_block_error
        error)
    Data_encoding.(
      merge_objs
        (obj1 (req "invalid_block" Block_hash.encoding))
        block_error_encoding)
    (function
      | Invalid_block {block; error} -> Some (block, error) | _ -> None)
    (fun (block, error) -> Invalid_block {block; error}) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.unavailable_protocol"
    ~title:"Missing protocol"
    ~description:"The protocol required for validating a block is missing."
    ~pp:(fun ppf (block, protocol) ->
      Format.fprintf
        ppf
        "Missing protocol (%a) when validating the block %a."
        Protocol_hash.pp_short
        protocol
        Block_hash.pp_short
        block)
    Data_encoding.(
      obj2
        (req "block" Block_hash.encoding)
        (req "missing_protocol" Protocol_hash.encoding))
    (function
      | Unavailable_protocol {block; protocol} ->
          Some (block, protocol)
      | _ ->
          None)
    (fun (block, protocol) -> Unavailable_protocol {block; protocol}) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.inconsistent_operations_hash"
    ~title:"Invalid merkle tree"
    ~description:
      "The provided list of operations is inconsistent with the block header."
    ~pp:(fun ppf (block, expected, found) ->
      Format.fprintf
        ppf
        "@[<v 2>The provided list of operations for block %a  is inconsistent \
         with the block header@  expected: %a@  found: %a@]"
        Block_hash.pp_short
        block
        Operation_list_list_hash.pp_short
        expected
        Operation_list_list_hash.pp_short
        found)
    Data_encoding.(
      obj3
        (req "block" Block_hash.encoding)
        (req "expected" Operation_list_list_hash.encoding)
        (req "found" Operation_list_list_hash.encoding))
    (function
      | Inconsistent_operations_hash {block; expected; found} ->
          Some (block, expected, found)
      | _ ->
          None)
    (fun (block, expected, found) ->
      Inconsistent_operations_hash {block; expected; found}) ;
  Error_monad.register_error_kind
    `Permanent
    ~id:"Block_validator_process.failed_to_checkout_context"
    ~title:"Fail during checkout context"
    ~description:"The context checkout failed using a given hash"
    ~pp:(fun ppf (hash : Context_hash.t) ->
      Format.fprintf
        ppf
        "@[Failed to checkout the context with hash %a@]"
        Context_hash.pp_short
        hash)
    Data_encoding.(obj1 (req "hash" Context_hash.encoding))
    (function Failed_to_checkout_context h -> Some h | _ -> None)
    (fun h -> Failed_to_checkout_context h) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"Validator_process.system_error_while_validating"
    ~title:"Failed to validate block because of a system error"
    ~description:"The validator failed because of a system error"
    ~pp:(fun ppf (errno, fn, msg) ->
      Format.fprintf
        ppf
        "System error while validating a block (in function %s(%s)):@ %s"
        fn
        msg
        errno)
    Data_encoding.(
      obj3 (req "errno" string) (req "function" string) (req "msg" string))
    (function
      | System_error {errno; fn; msg} -> Some (errno, fn, msg) | _ -> None)
    (fun (errno, fn, msg) -> System_error {errno; fn; msg}) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.missing_test_protocol"
    ~title:"Missing test protocol"
    ~description:"Missing test protocol when forking the test chain"
    ~pp:(fun ppf protocol ->
      Format.fprintf
        ppf
        "Missing test protocol %a when forking the test chain."
        Protocol_hash.pp
        protocol)
    Data_encoding.(obj1 (req "test_protocol" Protocol_hash.encoding))
    (function Missing_test_protocol protocol -> Some protocol | _ -> None)
    (fun protocol -> Missing_test_protocol protocol) ;
  Error_monad.register_error_kind
    `Temporary
    ~id:"validator.validation_process_failed"
    ~title:"Validation process failed"
    ~description:"Failed to validate block using exteranl validation process."
    ~pp:(fun ppf error ->
      Format.fprintf
        ppf
        "Failed to validate block using exteranl validation process. %a"
        pp_validation_process_error
        error)
    Data_encoding.(obj1 (req "error" validation_process_error_encoding))
    (function Validation_process_failed error -> Some error | _ -> None)
    (fun error -> Validation_process_failed error)

let invalid_block block error = Invalid_block {block; error}
src/lib_shell_services/block_validator_errors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive block_error : Type :=
| Cannot_parse_operation : Tezos_base__TzPervasives.Operation_hash.t ->
  block_error
| Invalid_fitness : Tezos_base__TzPervasives.Fitness.t ->
  Tezos_base__TzPervasives.Fitness.t -> block_error
| Non_increasing_timestamp : block_error
| Non_increasing_fitness : block_error
| Invalid_level : Stdlib.Int32.t -> Stdlib.Int32.t -> block_error
| Invalid_proto_level : Z -> Z -> block_error
| Replayed_operation : Tezos_base__TzPervasives.Operation_hash.t -> block_error
| Outdated_operation : Tezos_base__TzPervasives.Operation_hash.t ->
  Tezos_base__TzPervasives.Block_hash.t -> block_error
| Expired_chain : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
  Tezos_base__TzPervasives.Time.Protocol.t -> block_error
| Unexpected_number_of_validation_passes : Z -> block_error
| Too_many_operations : Z -> Z -> Z -> block_error
| Oversized_operation : Tezos_base__TzPervasives.Operation_hash.t -> Z -> Z ->
  block_error
| Unallowed_pass : Tezos_base__TzPervasives.Operation_hash.t -> Z -> (list Z) ->
  block_error
| Cannot_parse_block_header : block_error
| Economic_protocol_error : (list Tezos_base__TzPervasives.error) -> block_error.

Definition block_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding block_error :=
  union None
    (cons
      (case "Cannot_parse_operation" % string None
        (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (obj2
          (req None None "error" % string
            (constant "cannot_parse_operation" % string))
          (req None None "operation" % string Operation_hash.encoding))
        (fun function_parameter =>
          match function_parameter with
          | Cannot_parse_operation operation => Some (tt, operation)
          | _ => None
          end)
        (fun function_parameter =>
          let '(tt, operation) := function_parameter in
          Cannot_parse_operation operation))
      (cons
        (case "Invalid_fitness" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj3
            (req None None "error" % string
              (constant "invalid_fitness" % string))
            (req None None "expected" % string Fitness.encoding)
            (req None None "found" % string Fitness.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Invalid_fitness {| expected := expected; found := found |} =>
              Some (tt, expected, found)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, expected, found) := function_parameter in
            Invalid_fitness {| expected := expected; found := found |}))
        (cons
          (case "Non_increasing_timestamp" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 2)
            (obj1
              (req None None "error" % string
                (constant "non_increasing_timestamp" % string)))
            (fun function_parameter =>
              match function_parameter with
              | Non_increasing_timestamp => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Non_increasing_timestamp))
          (cons
            (case "Non_increasing_fitness" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 3)
              (obj1
                (req None None "error" % string
                  (constant "non_increasing_fitness" % string)))
              (fun function_parameter =>
                match function_parameter with
                | Non_increasing_fitness => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Non_increasing_fitness))
            (cons
              (case "Invalid_level" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 4)
                (obj3
                  (req None None "error" % string
                    (constant "invalid_level" % string))
                  (req None None "expected" % string int32)
                  (req None None "found" % string int32))
                (fun function_parameter =>
                  match function_parameter with
                  | Invalid_level {| expected := expected; found := found |} =>
                    Some (tt, expected, found)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, expected, found) := function_parameter in
                  Invalid_level {| expected := expected; found := found |}))
              (cons
                (case "Invalid_proto_level" % string None
                  (Tezos_base__TzPervasives.Data_encoding.Tag 5)
                  (obj3
                    (req None None "error" % string
                      (constant "invalid_proto_level" % string))
                    (req None None "expected" % string uint8)
                    (req None None "found" % string uint8))
                  (fun function_parameter =>
                    match function_parameter with
                    |
                      Invalid_proto_level {|
                        expected := expected; found := found |} =>
                      Some (tt, expected, found)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let '(tt, expected, found) := function_parameter in
                    Invalid_proto_level
                      {| expected := expected; found := found |}))
                (cons
                  (case "Replayed_operation" % string None
                    (Tezos_base__TzPervasives.Data_encoding.Tag 6)
                    (obj2
                      (req None None "error" % string
                        (constant "replayed_operation" % string))
                      (req None None "operation" % string
                        Operation_hash.encoding))
                    (fun function_parameter =>
                      match function_parameter with
                      | Replayed_operation operation => Some (tt, operation)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let '(tt, operation) := function_parameter in
                      Replayed_operation operation))
                  (cons
                    (case "Outdated_operation" % string None
                      (Tezos_base__TzPervasives.Data_encoding.Tag 7)
                      (obj3
                        (req None None "error" % string
                          (constant "outdated_operation" % string))
                        (req None None "operation" % string
                          Operation_hash.encoding)
                        (req None None "originating_block" % string
                          Block_hash.encoding))
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          Outdated_operation {|
                            operation := operation;
                              originating_block := originating_block
                              |} => Some (tt, operation, originating_block)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        let '(tt, operation, originating_block) :=
                          function_parameter in
                        Outdated_operation
                          {| operation := operation;
                            originating_block := originating_block |}))
                    (cons
                      (case "Expired_chain" % string None
                        (Tezos_base__TzPervasives.Data_encoding.Tag 8)
                        (obj4
                          (req None None "error" % string
                            (constant "expired_chain" % string))
                          (req None None "chain_id" % string Chain_id.encoding)
                          (req None None "expiration" % string
                            Time.Protocol.encoding)
                          (req None None "timestamp" % string
                            Time.Protocol.encoding))
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Expired_chain {|
                              chain_id := chain_id;
                                expiration := expiration;
                                timestamp := timestamp
                                |} => Some (tt, chain_id, expiration, timestamp)
                          | _ => None
                          end)
                        (fun function_parameter =>
                          let '(tt, chain_id, expiration, timestamp) :=
                            function_parameter in
                          Expired_chain
                            {| chain_id := chain_id; expiration := expiration;
                              timestamp := timestamp |}))
                      (cons
                        (case "Unexpected_number_of_validation_passes" % string
                          None (Tezos_base__TzPervasives.Data_encoding.Tag 9)
                          (obj2
                            (req None None "error" % string
                              (constant "unexpected_number_of_passes" % string))
                            (req None None "found" % string uint8))
                          (fun function_parameter =>
                            match function_parameter with
                            | Unexpected_number_of_validation_passes n =>
                              Some (tt, n)
                            | _ => None
                            end)
                          (fun function_parameter =>
                            let '(tt, n) := function_parameter in
                            Unexpected_number_of_validation_passes n))
                        (cons
                          (case "Too_many_operations" % string None
                            (Tezos_base__TzPervasives.Data_encoding.Tag 10)
                            (obj4
                              (req None None "error" % string
                                (constant "too_many_operations" % string))
                              (req None None "validation_pass" % string uint8)
                              (req None None "found" % string uint16)
                              (req None None "max" % string uint16))
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Too_many_operations {|
                                  pass := pass;
                                    found := found;
                                    max := max
                                    |} => Some (tt, pass, found, max)
                              | _ => None
                              end)
                            (fun function_parameter =>
                              let '(tt, pass, found, max) := function_parameter
                                in
                              Too_many_operations
                                {| pass := pass; found := found; max := max |}))
                          (cons
                            (case "Oversized_operation" % string None
                              (Tezos_base__TzPervasives.Data_encoding.Tag 11)
                              (obj4
                                (req None None "error" % string
                                  (constant "oversized_operation" % string))
                                (req None None "operation" % string
                                  Operation_hash.encoding)
                                (req None None "found" % string int31)
                                (req None None "max" % string int31))
                              (fun function_parameter =>
                                match function_parameter with
                                |
                                  Oversized_operation {|
                                    operation := operation;
                                      size := size;
                                      max := max
                                      |} => Some (tt, operation, size, max)
                                | _ => None
                                end)
                              (fun function_parameter =>
                                let '(tt, operation, size, max) :=
                                  function_parameter in
                                Oversized_operation
                                  {| operation := operation; size := size;
                                    max := max |}))
                            (cons
                              (case "Unallowed_pass" % string None
                                (Tezos_base__TzPervasives.Data_encoding.Tag 12)
                                (obj4
                                  (req None None "error" % string
                                    (constant "invalid_pass" % string))
                                  (req None None "operation" % string
                                    Operation_hash.encoding)
                                  (req None None "pass" % string uint8)
                                  (req None None "allowed_pass" % string
                                    (list None uint8)))
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    Unallowed_pass {|
                                      operation := operation;
                                        pass := pass;
                                        allowed_pass := allowed_pass
                                        |} =>
                                    Some (tt, operation, pass, allowed_pass)
                                  | _ => None
                                  end)
                                (fun function_parameter =>
                                  let '(tt, operation, pass, allowed_pass) :=
                                    function_parameter in
                                  Unallowed_pass
                                    {| operation := operation; pass := pass;
                                      allowed_pass := allowed_pass |}))
                              (cons
                                (case "Cannot_parse_block_header" % string None
                                  (Tezos_base__TzPervasives.Data_encoding.Tag 13)
                                  (obj1
                                    (req None None "error" % string
                                      (constant
                                        "cannot_parse_bock_header" % string)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Cannot_parse_block_header => Some tt
                                    | _ => None
                                    end)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    Cannot_parse_block_header)) [])))))))))))))).

Definition pp_block_error
  (ppf : Stdlib.Format.formatter) (function_parameter : block_error) : unit :=
  match function_parameter with
  | Cannot_parse_operation oph =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Failed to parse the operation %a." % string) Operation_hash.pp_short
      oph
  | Invalid_fitness {| expected := expected; found := found |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Invalid fitness:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.String_literal " expected " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal " found " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))))
        "@[<v 2>Invalid fitness:@  expected %a@  found %a@]" % string)
      Fitness.pp expected Fitness.pp found
  | Non_increasing_timestamp =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Non increasing timestamp" % string
          CamlinternalFormatBasics.End_of_format)
        "Non increasing timestamp" % string)
  | Non_increasing_fitness =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Non increasing fitness" % string
          CamlinternalFormatBasics.End_of_format)
        "Non increasing fitness" % string)
  | Invalid_level {| expected := expected; found := found |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Invalid level:" % string
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal " expected " % string
              (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal " found " % string
                    (CamlinternalFormatBasics.Int32
                      CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid level:@  expected %ld@  found %ld" % string) expected found
  | Invalid_proto_level {| expected := expected; found := found |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid protocol level:" % string
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal " expected " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal " found " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      CamlinternalFormatBasics.End_of_format)))))))
        "Invalid protocol level:@  expected %d@  found %d" % string) expected
      found
  | Replayed_operation oph =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "The operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " was previously included in the chain." % string
              CamlinternalFormatBasics.End_of_format)))
        "The operation %a was previously included in the chain." % string)
      Operation_hash.pp_short oph
  |
    Outdated_operation {|
      operation := operation; originating_block := originating_block |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "The operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " is outdated (originated in block: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "The operation %a is outdated (originated in block: %a)" % string)
      Operation_hash.pp_short operation Block_hash.pp_short originating_block
  |
    Expired_chain {|
      chain_id := chain_id;
        expiration := expiration;
        timestamp := timestamp
        |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "The block timestamp (" % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              ") is later than its chain expiration date: " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " (chain: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ")." % string
                      CamlinternalFormatBasics.End_of_format)))))))
        "The block timestamp (%a) is later than its chain expiration date: %a (chain: %a)."
          % string) Time.System.pp_hum (Time.System.of_protocol_exn timestamp)
      Time.System.pp_hum (Time.System.of_protocol_exn expiration)
      Chain_id.pp_short chain_id
  | Unexpected_number_of_validation_passes n =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Invalid number of validation passes (found: " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Invalid number of validation passes (found: %d)" % string) n
  | Too_many_operations {| pass := pass; found := found; max := max |} =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Too many operations in validation pass " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.String_literal " (found: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ", max: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "Too many operations in validation pass %d (found: %d, max: %d)" %
          string) pass found max
  | Oversized_operation {| operation := operation; size := size; max := max |}
    =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Oversized operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal " (size: " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ", max: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format)))))))
        "Oversized operation %a (size: %d, max: %d)" % string)
      Operation_hash.pp_short operation size max
  |
    Unallowed_pass {|
      operation := operation; pass := pass; allowed_pass := allowed_pass |}
    =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "Operation " % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.String_literal
              " included in validation pass " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal
                  ",  while only the following passes are allowed: " % string
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal "<h>" % string
                          CamlinternalFormatBasics.End_of_format) "<h>" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))))
        "Operation %a included in validation pass %d,  while only the following passes are allowed: @[<h>%a@]"
          % string) Operation_hash.pp_short operation pass
      (pp_print_list None pp_print_int) allowed_pass
  | Cannot_parse_block_header =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to parse the block header." % string
          CamlinternalFormatBasics.End_of_format)
        "Failed to parse the block header." % string)
  | Economic_protocol_error err =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Failed to validate the economic-protocol content of the block: " %
            string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Failed to validate the economic-protocol content of the block: %a." %
          string) Error_monad.pp_print_error err
  end.

Inductive validation_process_error : Type :=
| Missing_handshake : validation_process_error
| Inconsistent_handshake : string -> validation_process_error
| Protocol_dynlink_failure : string -> validation_process_error.

Definition validation_process_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding validation_process_error :=
  union None
    (cons
      (case "Missing_handshake" % string None
        (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (obj1
          (req None None "constant" % string
            (constant "missing_handshake" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Missing_handshake => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Missing_handshake))
      (cons
        (case "Inconsistent_handshake" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj1 (req None None "inconsistent_handshake" % string string))
          (fun function_parameter =>
            match function_parameter with
            | Inconsistent_handshake msg => Some msg
            | _ => None
            end) (fun msg => Inconsistent_handshake msg))
        (cons
          (case "Protocol_dynlink_failure" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 2)
            (obj1 (req None None "pretocol_dynlink_failure" % string string))
            (fun function_parameter =>
              match function_parameter with
              | Protocol_dynlink_failure msg => Some msg
              | _ => None
              end) (fun msg => Protocol_dynlink_failure msg)) []))).

Definition pp_validation_process_error
  (ppf : Stdlib.Format.formatter)
  (function_parameter : validation_process_error) : unit :=
  match function_parameter with
  | Missing_handshake =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Missing handshake while initializing validation process." % string
          CamlinternalFormatBasics.End_of_format)
        "Missing handshake while initializing validation process." % string)
  | Protocol_dynlink_failure msg =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string) msg
  | Inconsistent_handshake msg =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Inconsistent handshake: " % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "." % char
              CamlinternalFormatBasics.End_of_format)))
        "Inconsistent handshake: %s." % string) msg
  end.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition invalid_block
  (block : Tezos_base__TzPervasives.Block_hash.t) (error : block_error)
  : Tezos_base__TzPervasives.error :=
  Tezos_base__TzPervasives.Invalid_block {| block := block; error := error |}.

src/lib_shell_services/block_validator_worker_state.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type view = {
    chain_id : Chain_id.t;
    block : Block_hash.t;
    peer : P2p_peer.Id.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {chain_id; block; peer} -> (block, chain_id, peer))
      (fun (block, chain_id, peer) -> {chain_id; block; peer})
      (obj3
         (req "block" Block_hash.encoding)
         (req "chain_id" Chain_id.encoding)
         (opt "peer" P2p_peer.Id.encoding))

  let pp ppf {chain_id; block; peer} =
    Format.fprintf
      ppf
      "Validation of %a (chain: %a)"
      Block_hash.pp
      block
      Chain_id.pp_short
      chain_id ;
    match peer with
    | None ->
        ()
    | Some peer ->
        Format.fprintf ppf "from peer %a" P2p_peer.Id.pp_short peer
end

module Event = struct
  type t =
    | Validation_success of Request.view * Worker_types.request_status
    | Validation_failure of
        Request.view * Worker_types.request_status * error list
    | Debug of string

  let level req =
    match req with
    | Debug _ ->
        Internal_event.Debug
    | Validation_success _ | Validation_failure _ ->
        Internal_event.Notice

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Debug"
          (obj1 (req "message" string))
          (function Debug msg -> Some msg | _ -> None)
          (fun msg -> Debug msg);
        case
          (Tag 1)
          ~title:"Validation_success"
          (obj2
             (req "successful_validation" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function Validation_success (r, s) -> Some (r, s) | _ -> None)
          (fun (r, s) -> Validation_success (r, s));
        case
          (Tag 2)
          ~title:"Validation_failure"
          (obj3
             (req "failed_validation" Request.encoding)
             (req "status" Worker_types.request_status_encoding)
             (dft "errors" RPC_error.encoding []))
          (function
            | Validation_failure (r, s, err) -> Some (r, s, err) | _ -> None)
          (fun (r, s, err) -> Validation_failure (r, s, err)) ]

  let pp ppf = function
    | Debug msg ->
        Format.fprintf ppf "%s" msg
    | Validation_success (req, {pushed; treated; completed}) ->
        Format.fprintf
          ppf
          "@[<v 0>Block %a successfully validated@,%a@]"
          Block_hash.pp
          req.block
          Worker_types.pp_status
          {pushed; treated; completed}
    | Validation_failure (req, {pushed; treated; completed}, errs) ->
        Format.fprintf
          ppf
          "@[<v 0>Validation of block %a failed@,%a, %a@]"
          Block_hash.pp
          req.block
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errs
end

module Worker_state = struct
  type view = unit

  let encoding = Data_encoding.empty

  let pp _ppf _view = ()
end
src/lib_shell_services/block_validator_worker_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Record view := {
    chain_id : Tezos_base__TzPervasives.Chain_id.t;
    block : Tezos_base__TzPervasives.Block_hash.t;
    peer : option Tezos_base__TzPervasives.P2p_peer.Id.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    conv
      (fun function_parameter =>
        let '{| chain_id := chain_id; block := block; peer := peer |} :=
          function_parameter in
        (block, chain_id, peer))
      (fun function_parameter =>
        let '(block, chain_id, peer) := function_parameter in
        {| chain_id := chain_id; block := block; peer := peer |}) None
      (obj3 (req None None "block" % string Block_hash.encoding)
        (req None None "chain_id" % string Chain_id.encoding)
        (opt None None "peer" % string P2p_peer.Id.encoding)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    let '{| chain_id := chain_id; block := block; peer := peer |} :=
      function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Validation of " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " (chain: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))))
          "Validation of %a (chain: %a)" % string) Block_hash.pp block
        Chain_id.pp_short chain_id in
    match peer with
    | None => tt
    | Some peer =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "from peer " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "from peer %a" % string)
        P2p_peer.Id.pp_short peer
    end.
End Request.

Module Event.
  Inductive t : Type :=
  | Validation_success : Request.view ->
    Tezos_shell_services.Worker_types.request_status -> t
  | Validation_failure : Request.view ->
    Tezos_shell_services.Worker_types.request_status ->
    (list Tezos_base__TzPervasives.error) -> t
  | Debug : string -> t.
  
  Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
    match req with
    | Debug _ => Tezos_base__TzPervasives.Internal_event.Debug
    | Validation_success _ _ | Validation_failure _ _ _ =>
      Tezos_base__TzPervasives.Internal_event.Notice
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    union None
      (cons
        (case "Debug" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 0)
          (obj1 (req None None "message" % string string))
          (fun function_parameter =>
            match function_parameter with
            | Debug msg => Some msg
            | _ => None
            end) (fun msg => Debug msg))
        (cons
          (case "Validation_success" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1)
            (obj2
              (req None None "successful_validation" % string Request.encoding)
              (req None None "status" % string
                Worker_types.request_status_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Validation_success r s => Some (r, s)
              | _ => None
              end)
            (fun function_parameter =>
              let '(r, s) := function_parameter in
              Validation_success r s))
          (cons
            (case "Validation_failure" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 2)
              (obj3
                (req None None "failed_validation" % string Request.encoding)
                (req None None "status" % string
                  Worker_types.request_status_encoding)
                (dft None None "errors" % string RPC_error.encoding []))
              (fun function_parameter =>
                match function_parameter with
                | Validation_failure r s err => Some (r, s, err)
                | _ => None
                end)
              (fun function_parameter =>
                let '(r, s, err) := function_parameter in
                Validation_failure r s err)) []))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Debug msg =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) msg
    |
      Validation_success req {|
        pushed := pushed; treated := treated; completed := completed |} =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal "Block " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " successfully validated" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))
          "@[<v 0>Block %a successfully validated@,%a@]" % string) Block_hash.pp
        (block req) Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
    |
      Validation_failure req {|
        pushed := pushed; treated := treated; completed := completed |} errs
      =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Validation of block " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal " failed" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal ", " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))))))
          "@[<v 0>Validation of block %a failed@,%a, %a@]" % string)
        Block_hash.pp (block req) Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
        (Format.pp_print_list None Error_monad.pp) errs
    end.
End Event.

Module Worker_state.
  Definition view := unit.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding unit :=
    Data_encoding.empty.
  
  Definition pp {A B : Type} (_ppf : A) (_view : B) : unit := tt.
End Worker_state.

src/lib_shell_services/chain_services.ml 77 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

type chain = [`Main | `Test | `Hash of Chain_id.t]

let chain_arg = Block_services.chain_arg

let to_string = Block_services.chain_to_string

let parse_chain = Block_services.parse_chain

type invalid_block = {
  hash : Block_hash.t;
  level : Int32.t;
  errors : error list;
}

type prefix = Block_services.chain_prefix

let path = Block_services.chain_path

let checkpoint_encoding =
  obj4
    (req "block" Block_header.encoding)
    (req "save_point" int32)
    (req "caboose" int32)
    (req "history_mode" History_mode.encoding)

let invalid_block_encoding =
  conv
    (fun {hash; level; errors} -> (hash, level, errors))
    (fun (hash, level, errors) -> {hash; level; errors})
    (obj3
       (req "block" Block_hash.encoding)
       (req "level" int32)
       (req "errors" RPC_error.encoding))

module S = struct
  let path : prefix RPC_path.context = RPC_path.open_root

  let chain_id =
    RPC_service.get_service
      ~description:"The chain unique identifier."
      ~query:RPC_query.empty
      ~output:Chain_id.encoding
      RPC_path.(path / "chain_id")

  let checkpoint =
    RPC_service.get_service
      ~description:"The current checkpoint for this chain."
      ~query:RPC_query.empty
      ~output:checkpoint_encoding
      RPC_path.(path / "checkpoint")

  module Blocks = struct
    let list_query =
      let open RPC_query in
      query (fun length heads min_date ->
          object
            method length = length

            method heads = heads

            method min_date = min_date
          end)
      |+ opt_field
           "length"
           ~descr:
             "The requested number of predecessors to returns (per requested \
              head)."
           RPC_arg.int
           (fun x -> x#length)
      |+ multi_field
           "head"
           ~descr:
             "An empty argument requests blocks from the current heads. A non \
              empty list allow to request specific fragment of the chain."
           Block_hash.rpc_arg
           (fun x -> x#heads)
      |+ opt_field
           "min_date"
           ~descr:
             "When `min_date` is provided, heads with a timestamp before \
              `min_date` are filtered out"
           Time.Protocol.rpc_arg
           (fun x -> x#min_date)
      |> seal

    let path = RPC_path.(path / "blocks")

    let list =
      let open Data_encoding in
      RPC_service.get_service
        ~description:
          "Lists known heads of the blockchain sorted with decreasing \
           fitness. Optional arguments allows to returns the list of \
           predecessors for known heads or the list of predecessors for a \
           given list of blocks."
        ~query:list_query
        ~output:(list (list Block_hash.encoding))
        path
  end

  module Invalid_blocks = struct
    let path = RPC_path.(path / "invalid_blocks")

    let list =
      RPC_service.get_service
        ~description:
          "Lists blocks that have been declared invalid along with the errors \
           that led to them being declared invalid."
        ~query:RPC_query.empty
        ~output:(list invalid_block_encoding)
        path

    let get =
      RPC_service.get_service
        ~description:"The errors that appears during the block (in)validation."
        ~query:RPC_query.empty
        ~output:invalid_block_encoding
        RPC_path.(path /: Block_hash.rpc_arg)

    let delete =
      RPC_service.delete_service
        ~description:"Remove an invalid block for the tezos storage"
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        RPC_path.(path /: Block_hash.rpc_arg)
  end
end

let make_call0 s ctxt chain q p =
  let s = RPC_service.prefix path s in
  RPC_context.make_call1 s ctxt chain q p

let make_call1 s ctxt chain a q p =
  let s = RPC_service.prefix path s in
  RPC_context.make_call2 s ctxt chain a q p

let chain_id ctxt =
  let f = make_call0 S.chain_id ctxt in
  fun ?(chain = `Main) () ->
    match chain with `Hash h -> return h | _ -> f chain () ()

let checkpoint ctxt ?(chain = `Main) () =
  make_call0 S.checkpoint ctxt chain () ()

module Blocks = struct
  let list ctxt =
    let f = make_call0 S.Blocks.list ctxt in
    fun ?(chain = `Main) ?(heads = []) ?length ?min_date () ->
      f
        chain
        (object
           method heads = heads

           method length = length

           method min_date = min_date
        end)
        ()

  include Block_services.Empty

  type protocols = Block_services.protocols = {
    current_protocol : Protocol_hash.t;
    next_protocol : Protocol_hash.t;
  }

  let protocols = Block_services.protocols
end

module Mempool = Block_services.Empty.Mempool

module Invalid_blocks = struct
  let list ctxt =
    let f = make_call0 S.Invalid_blocks.list ctxt in
    fun ?(chain = `Main) () -> f chain () ()

  let get ctxt =
    let f = make_call1 S.Invalid_blocks.get ctxt in
    fun ?(chain = `Main) block -> f chain block () ()

  let delete ctxt =
    let f = make_call1 S.Invalid_blocks.delete ctxt in
    fun ?(chain = `Main) block -> f chain block () ()
end
src/lib_shell_services/chain_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Definition chain := variant.

Definition chain_arg
  : Tezos_base__TzPervasives.RPC_arg.t Tezos_shell_services.Block_services.chain :=
  Block_services.chain_arg.

Definition to_string : Tezos_shell_services.Block_services.chain -> string :=
  Block_services.chain_to_string.

Definition parse_chain
  : string -> sum Tezos_shell_services.Block_services.chain string :=
  Block_services.parse_chain.

Record invalid_block := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  level : Stdlib.Int32.t;
  errors : list Tezos_base__TzPervasives.error }.

Definition prefix := Tezos_shell_services.Block_services.chain_prefix.

Definition path
  : Tezos_base__TzPervasives.RPC_path.t unit
    Tezos_shell_services.Block_services.chain_prefix :=
  Block_services.chain_path.

Definition checkpoint_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
      Tezos_shell_services.History_mode.t) :=
  obj4 (req None None "block" % string Block_header.encoding)
    (req None None "save_point" % string int32)
    (req None None "caboose" % string int32)
    (req None None "history_mode" % string History_mode.encoding).

Definition invalid_block_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding invalid_block :=
  conv
    (fun function_parameter =>
      let '{| hash := hash; level := level; errors := errors |} :=
        function_parameter in
      (hash, level, errors))
    (fun function_parameter =>
      let '(hash, level, errors) := function_parameter in
      {| hash := hash; level := level; errors := errors |}) None
    (obj3 (req None None "block" % string Block_hash.encoding)
      (req None None "level" % string int32)
      (req None None "errors" % string RPC_error.encoding)).

Module S.
  Definition path : Tezos_base__TzPervasives.RPC_path.context prefix :=
    RPC_path.open_root.
  
  Definition chain_id
    : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
      unit Tezos_base__TzPervasives.Chain_id.t :=
    RPC_service.get_service (Some "The chain unique identifier." % string)
      RPC_query.empty Chain_id.encoding (op_div path "chain_id" % string).
  
  Definition checkpoint
    : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
      unit
      (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
        Tezos_shell_services.History_mode.t) :=
    RPC_service.get_service
      (Some "The current checkpoint for this chain." % string) RPC_query.empty
      checkpoint_encoding (op_div path "checkpoint" % string).
  
  Module Blocks.
    Definition list_query
      : Tezos_base__TzPervasives.RPC_query.t
        (((option Z) *
          ((list Tezos_base__TzPervasives.Block_hash.t) *
            ((option Tezos_base__TzPervasives.Time.Protocol.t) * nil)))) :=
      OCaml.Stdlib.reverse_apply
        (op_pipeplus
          (op_pipeplus
            (op_pipeplus
              (query
                (fun length =>
                  fun heads =>
                    fun min_date =>
                      (* ❌ Creation of objects is not handled *)
                      object))
              (opt_field
                (Some
                  "The requested number of predecessors to returns (per requested head)."
                    % string) "length" % string RPC_arg.int
                (fun x =>
                  (* ❌ Sending method message is not handled *)
                  send)))
            (multi_field
              (Some
                "An empty argument requests blocks from the current heads. A non empty list allow to request specific fragment of the chain."
                  % string) "head" % string Block_hash.rpc_arg
              (fun x =>
                (* ❌ Sending method message is not handled *)
                send)))
          (opt_field
            (Some
              "When `min_date` is provided, heads with a timestamp before `min_date` are filtered out"
                % string) "min_date" % string Time.Protocol.rpc_arg
            (fun x =>
              (* ❌ Sending method message is not handled *)
              send))) seal.
    
    Definition path : Tezos_base__TzPervasives.RPC_path.path prefix prefix :=
      op_div path "blocks" % string.
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix
        (((option Z) *
          ((list Tezos_base__TzPervasives.Block_hash.t) *
            ((option Tezos_base__TzPervasives.Time.Protocol.t) * nil)))) unit
        (list (list Tezos_base__TzPervasives.Block_hash.t)) :=
      RPC_service.get_service
        (Some
          "Lists known heads of the blockchain sorted with decreasing fitness. Optional arguments allows to returns the list of predecessors for known heads or the list of predecessors for a given list of blocks."
            % string) list_query (list None (list None Block_hash.encoding))
        path.
  End Blocks.
  
  Module Invalid_blocks.
    Definition path : Tezos_base__TzPervasives.RPC_path.path prefix prefix :=
      op_div path "invalid_blocks" % string.
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant prefix prefix unit
        unit (list invalid_block) :=
      RPC_service.get_service
        (Some
          "Lists blocks that have been declared invalid along with the errors that led to them being declared invalid."
            % string) RPC_query.empty (list None invalid_block_encoding) path.
    
    Definition get
      : Tezos_base__TzPervasives.RPC_service.service variant prefix
        (prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit invalid_block :=
      RPC_service.get_service
        (Some
          "The errors that appears during the block (in)validation." % string)
        RPC_query.empty invalid_block_encoding
        (op_divcolon path Block_hash.rpc_arg).
    
    Definition delete
      : Tezos_base__TzPervasives.RPC_service.service variant prefix
        (prefix * Tezos_base__TzPervasives.Block_hash.t) unit unit unit :=
      RPC_service.delete_service
        (Some "Remove an invalid block for the tezos storage" % string)
        RPC_query.empty Data_encoding.empty
        (op_divcolon path Block_hash.rpc_arg).
  End Invalid_blocks.
End S.

Definition make_call0 {A B C D I J i o p q : Type}
  (s :
    Tezos_base__TzPervasives.RPC_service.raw variant
      Tezos_shell_services.Block_services.chain_prefix (unit * A) B C D
      Tezos_rpc.RPC_service.error)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (I * p * q * i * o)) * J) * J) (chain : A) (q : B) (p : C)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult D) :=
  let s := RPC_service.prefix path s in
  RPC_context.make_call1 s ctxt chain q p.

Definition make_call1 {A B C D E J K i o p q : Type}
  (s :
    Tezos_base__TzPervasives.RPC_service.raw variant
      Tezos_shell_services.Block_services.chain_prefix ((unit * A) * B) C D E
      Tezos_rpc.RPC_service.error)
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (J * p * q * i * o)) * K) * K) (chain : A) (a : B) (q : C) (p : D)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult E) :=
  let s := RPC_service.prefix path s in
  RPC_context.make_call2 s ctxt chain a q p.

Definition chain_id {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : (option variant) ->
    unit ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Chain_id.t) :=
  let f := make_call0 S.chain_id ctxt in
  fun op_staroptstar =>
    let chain :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None =>
        (* ❌ Variants not supported *)
        variant
      end in
    fun function_parameter =>
      let 'tt := function_parameter in
      match chain with
      | Hash h => _return h
      | _ => f chain tt tt
      end.

Definition checkpoint {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_staroptstar : option variant)
  : unit ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_base__TzPervasives.Block_header.t * int32 * int32 *
          Tezos_shell_services.History_mode.t)) :=
  let chain :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    make_call0 S.checkpoint ctxt chain tt tt.

Module Blocks.
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option variant) ->
      (option (list Tezos_base__TzPervasives.Block_hash.t)) ->
        (option Z) ->
          (option Tezos_base__TzPervasives.Time.Protocol.t) ->
            unit ->
              Lwt.t
                (Tezos_error_monad.Error_monad.tzresult
                  (list (list Tezos_base__TzPervasives.Block_hash.t))) :=
    let f := make_call0 S.Blocks.list ctxt in
    fun op_staroptstar =>
      let chain :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Variants not supported *)
          variant
        end in
      fun op_staroptstar =>
        let heads :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => []
          end in
        fun length =>
          fun min_date =>
            fun function_parameter =>
              let 'tt := function_parameter in
              f chain
                (* ❌ Creation of objects is not handled *)
                object tt.
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Record protocols := {
    current_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
    next_protocol : Tezos_base__TzPervasives.Protocol_hash.t }.
  
  Definition protocols {E F i o p q : Type}
    : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) ->
      (option Tezos_shell_services.Block_services.chain) ->
        (option Tezos_shell_services.Block_services.block) ->
          unit ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_shell_services.Block_services.protocols) :=
    Block_services.protocols.
End Blocks.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Invalid_blocks.
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option variant) ->
      unit ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult (list invalid_block)) :=
    let f := make_call0 S.Invalid_blocks.list ctxt in
    fun op_staroptstar =>
      let chain :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Variants not supported *)
          variant
        end in
      fun function_parameter =>
        let 'tt := function_parameter in
        f chain tt tt.
  
  Definition get {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option Tezos_shell_services.Block_services.chain) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult invalid_block) :=
    let f := make_call1 S.Invalid_blocks.get ctxt in
    fun op_staroptstar =>
      let chain :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Variants not supported *)
          variant
        end in
      fun block => f chain block tt tt.
  
  Definition delete {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : (option Tezos_shell_services.Block_services.chain) ->
      Tezos_base__TzPervasives.Block_hash.t ->
        Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let f := make_call1 S.Invalid_blocks.delete ctxt in
    fun op_staroptstar =>
      let chain :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Variants not supported *)
          variant
        end in
      fun block => f chain block tt tt.
End Invalid_blocks.

src/lib_shell_services/chain_validator_worker_state.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type view = Block_hash.t

  let encoding = Block_hash.encoding

  let pp = Block_hash.pp
end

module Event = struct
  type update = Ignored_head | Branch_switch | Head_increment

  type t =
    | Processed_block of {
        request : Request.view;
        request_status : Worker_types.request_status;
        update : update;
        fitness : Fitness.t;
      }
    | Could_not_switch_testchain of error list

  let level = function
    | Processed_block req -> (
      match req.update with
      | Ignored_head ->
          Internal_event.Info
      | Branch_switch | Head_increment ->
          Internal_event.Notice )
    | Could_not_switch_testchain _ ->
        Internal_event.Error

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Processed_block"
          (obj4
             (req "request" Request.encoding)
             (req "status" Worker_types.request_status_encoding)
             (req
                "outcome"
                (string_enum
                   [ ("ignored", Ignored_head);
                     ("branch", Branch_switch);
                     ("increment", Head_increment) ]))
             (req "fitness" Fitness.encoding))
          (function
            | Processed_block {request; request_status; update; fitness} ->
                Some (request, request_status, update, fitness)
            | _ ->
                None)
          (fun (request, request_status, update, fitness) ->
            Processed_block {request; request_status; update; fitness});
        case
          (Tag 1)
          ~title:"Could_not_switch_testchain"
          RPC_error.encoding
          (function Could_not_switch_testchain err -> Some err | _ -> None)
          (fun err -> Could_not_switch_testchain err) ]

  let pp ppf = function
    | Processed_block req ->
        Format.fprintf ppf "@[<v 0>" ;
        ( match req.update with
        | Ignored_head ->
            Format.fprintf
              ppf
              "Current head is better than %a (fitness %a), we do not switch@,"
        | Branch_switch ->
            Format.fprintf
              ppf
              "Update current head to %a (fitness %a), changing branch@,"
        | Head_increment ->
            Format.fprintf
              ppf
              "Update current head to %a (fitness %a), same branch@," )
          Request.pp
          req.request
          Fitness.pp
          req.fitness ;
        Format.fprintf ppf "%a@]" Worker_types.pp_status req.request_status
    | Could_not_switch_testchain err ->
        Format.fprintf
          ppf
          "@[<v 0>Error while switching test chain:@ %a@]"
          (Format.pp_print_list Error_monad.pp)
          err
end

module Worker_state = struct
  type view = {
    active_peers : P2p_peer.Id.t list;
    bootstrapped_peers : P2p_peer.Id.t list;
    bootstrapped : bool;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {bootstrapped; bootstrapped_peers; active_peers} ->
        (bootstrapped, bootstrapped_peers, active_peers))
      (fun (bootstrapped, bootstrapped_peers, active_peers) ->
        {bootstrapped; bootstrapped_peers; active_peers})
      (obj3
         (req "bootstrapped" bool)
         (req "bootstrapped_peers" (list P2p_peer.Id.encoding))
         (req "active_peers" (list P2p_peer.Id.encoding)))

  let pp ppf {bootstrapped; bootstrapped_peers; active_peers} =
    Format.fprintf
      ppf
      "@[<v 0>Network is%s bootstrapped.@,\
       @[<v 2>Active peers:%a@]@,\
       @[<v 2>Bootstrapped peers:%a@]@]"
      (if bootstrapped then "" else " not yet")
      (fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
      active_peers
      (fun ppf -> List.iter (Format.fprintf ppf "@,- %a" P2p_peer.Id.pp))
      bootstrapped_peers
end

module Distributed_db_state = struct
  type table_scheduler = {table_length : int; scheduler_length : int}

  type view = {
    p2p_readers_length : int;
    active_chains_length : int;
    operation_db : table_scheduler;
    operations_db : table_scheduler;
    block_header_db : table_scheduler;
    operations_hashed_db : table_scheduler;
    active_connections_length : int;
    active_peers_length : int;
  }

  let table_scheduler_encoding =
    let open Data_encoding in
    conv
      (fun {table_length; scheduler_length} ->
        (table_length, scheduler_length))
      (fun (table_length, scheduler_length) ->
        {table_length; scheduler_length})
      (obj2 (req "table_length" int31) (req "scheduler_length" int31))

  let encoding =
    let open Data_encoding in
    conv
      (fun { p2p_readers_length;
             active_chains_length;
             operation_db;
             operations_db;
             block_header_db;
             operations_hashed_db;
             active_connections_length;
             active_peers_length } ->
        ( p2p_readers_length,
          active_chains_length,
          operation_db,
          operations_db,
          block_header_db,
          operations_hashed_db,
          active_connections_length,
          active_peers_length ))
      (fun ( p2p_readers_length,
             active_chains_length,
             operation_db,
             operations_db,
             block_header_db,
             operations_hashed_db,
             active_connections_length,
             active_peers_length ) ->
        {
          p2p_readers_length;
          active_chains_length;
          operation_db;
          operations_db;
          block_header_db;
          operations_hashed_db;
          active_connections_length;
          active_peers_length;
        })
      (obj8
         (req "p2p_readers" int31)
         (req "active_chains" int31)
         (req "operation_db" table_scheduler_encoding)
         (req "operations_db" table_scheduler_encoding)
         (req "block_header_db" table_scheduler_encoding)
         (req "operations_hashed_db" table_scheduler_encoding)
         (req "active_connections" int31)
         (req "active_peers" int31))
end
src/lib_shell_services/chain_validator_worker_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Definition view := Tezos_base__TzPervasives.Block_hash.t.
  
  Definition encoding
    : Tezos_data_encoding.Data_encoding.t Tezos_base__TzPervasives.Block_hash.t :=
    Block_hash.encoding.
  
  Definition pp
    : Stdlib.Format.formatter -> Tezos_base__TzPervasives.Block_hash.t -> unit :=
    Block_hash.pp.
End Request.

Module Event.
  Inductive update : Type :=
  | Ignored_head : update
  | Branch_switch : update
  | Head_increment : update.
  
  Inductive t : Type :=
  | Processed_block : Request.view ->
    Tezos_shell_services.Worker_types.request_status -> update ->
    Tezos_base__TzPervasives.Fitness.t -> t
  | Could_not_switch_testchain : (list Tezos_base__TzPervasives.error) -> t.
  
  Definition level (function_parameter : t)
    : Tezos_base__TzPervasives.Internal_event.level :=
    match function_parameter with
    | Processed_block req =>
      match update req with
      | Ignored_head => Tezos_base__TzPervasives.Internal_event.Info
      | Branch_switch | Head_increment =>
        Tezos_base__TzPervasives.Internal_event.Notice
      end
    | Could_not_switch_testchain _ =>
      Tezos_base__TzPervasives.Internal_event.Error
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    union None
      (cons
        (case "Processed_block" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 0)
          (obj4 (req None None "request" % string Request.encoding)
            (req None None "status" % string
              Worker_types.request_status_encoding)
            (req None None "outcome" % string
              (string_enum
                (cons ("ignored" % string, Ignored_head)
                  (cons ("branch" % string, Branch_switch)
                    (cons ("increment" % string, Head_increment) [])))))
            (req None None "fitness" % string Fitness.encoding))
          (fun function_parameter =>
            match function_parameter with
            |
              Processed_block {|
                request := request;
                  request_status := request_status;
                  update := update;
                  fitness := fitness
                  |} => Some (request, request_status, update, fitness)
            | _ => None
            end)
          (fun function_parameter =>
            let '(request, request_status, update, fitness) :=
              function_parameter in
            Processed_block
              {| request := request; request_status := request_status;
                update := update; fitness := fitness |}))
        (cons
          (case "Could_not_switch_testchain" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1) RPC_error.encoding
            (fun function_parameter =>
              match function_parameter with
              | Could_not_switch_testchain err => Some err
              | _ => None
              end) (fun err => Could_not_switch_testchain err)) [])).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Processed_block req =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        match update req with
        | Ignored_head =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Current head is better than " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (fitness " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        "), we do not switch" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          CamlinternalFormatBasics.End_of_format))))))
              "Current head is better than %a (fitness %a), we do not switch@,"
                % string)
        | Branch_switch =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Update current head to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (fitness " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        "), changing branch" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          CamlinternalFormatBasics.End_of_format))))))
              "Update current head to %a (fitness %a), changing branch@," %
                string)
        | Head_increment =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Update current head to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (fitness " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.String_literal
                        "), same branch" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          CamlinternalFormatBasics.End_of_format))))))
              "Update current head to %a (fitness %a), same branch@," % string)
        end Request.pp (request req) Fitness.pp (fitness req) in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format)) "%a@]" % string)
        Worker_types.pp_status (request_status req)
    | Could_not_switch_testchain err =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "Error while switching test chain:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "@[<v 0>Error while switching test chain:@ %a@]" % string)
        (Format.pp_print_list None Error_monad.pp) err
    end.
End Event.

Module Worker_state.
  Record view := {
    active_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
    bootstrapped_peers : list Tezos_base__TzPervasives.P2p_peer.Id.t;
    bootstrapped : bool }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    conv
      (fun function_parameter =>
        let '{|
          active_peers := active_peers;
            bootstrapped_peers := bootstrapped_peers;
            bootstrapped := bootstrapped
            |} := function_parameter in
        (bootstrapped, bootstrapped_peers, active_peers))
      (fun function_parameter =>
        let '(bootstrapped, bootstrapped_peers, active_peers) :=
          function_parameter in
        {| active_peers := active_peers;
          bootstrapped_peers := bootstrapped_peers; bootstrapped := bootstrapped
          |}) None
      (obj3 (req None None "bootstrapped" % string bool)
        (req None None "bootstrapped_peers" % string
          (list None P2p_peer.Id.encoding))
        (req None None "active_peers" % string (list None P2p_peer.Id.encoding))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    let '{|
      active_peers := active_peers;
        bootstrapped_peers := bootstrapped_peers;
        bootstrapped := bootstrapped
        |} := function_parameter in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal "Network is" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal " bootstrapped." % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 2>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 2>" % string))
                    (CamlinternalFormatBasics.String_literal
                      "Active peers:" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<v 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<v 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Bootstrapped peers:" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[<v 0>Network is%s bootstrapped.@,@[<v 2>Active peers:%a@]@,@[<v 2>Bootstrapped peers:%a@]@]"
          % string)
      (if bootstrapped then
        "" % string
      else
        " not yet" % string)
      (fun ppf =>
        List.iter
          (Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "- " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))) "@,- %a" % string)
            P2p_peer.Id.pp)) active_peers
      (fun ppf =>
        List.iter
          (Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "- " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))) "@,- %a" % string)
            P2p_peer.Id.pp)) bootstrapped_peers.
End Worker_state.

Module Distributed_db_state.
  Record table_scheduler := {
    table_length : Z;
    scheduler_length : Z }.
  
  Record view := {
    p2p_readers_length : Z;
    active_chains_length : Z;
    operation_db : table_scheduler;
    operations_db : table_scheduler;
    block_header_db : table_scheduler;
    operations_hashed_db : table_scheduler;
    active_connections_length : Z;
    active_peers_length : Z }.
  
  Definition table_scheduler_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding table_scheduler :=
    conv
      (fun function_parameter =>
        let '{|
          table_length := table_length;
            scheduler_length := scheduler_length
            |} := function_parameter in
        (table_length, scheduler_length))
      (fun function_parameter =>
        let '(table_length, scheduler_length) := function_parameter in
        {| table_length := table_length; scheduler_length := scheduler_length |})
      None
      (obj2 (req None None "table_length" % string int31)
        (req None None "scheduler_length" % string int31)).
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    conv
      (fun function_parameter =>
        let '{|
          p2p_readers_length := p2p_readers_length;
            active_chains_length := active_chains_length;
            operation_db := operation_db;
            operations_db := operations_db;
            block_header_db := block_header_db;
            operations_hashed_db := operations_hashed_db;
            active_connections_length := active_connections_length;
            active_peers_length := active_peers_length
            |} := function_parameter in
        (p2p_readers_length, active_chains_length, operation_db, operations_db,
          block_header_db, operations_hashed_db, active_connections_length,
          active_peers_length))
      (fun function_parameter =>
        let
          '(p2p_readers_length, active_chains_length, operation_db,
            operations_db, block_header_db, operations_hashed_db,
            active_connections_length, active_peers_length) :=
          function_parameter in
        {| p2p_readers_length := p2p_readers_length;
          active_chains_length := active_chains_length;
          operation_db := operation_db; operations_db := operations_db;
          block_header_db := block_header_db;
          operations_hashed_db := operations_hashed_db;
          active_connections_length := active_connections_length;
          active_peers_length := active_peers_length |}) None
      (obj8 (req None None "p2p_readers" % string int31)
        (req None None "active_chains" % string int31)
        (req None None "operation_db" % string table_scheduler_encoding)
        (req None None "operations_db" % string table_scheduler_encoding)
        (req None None "block_header_db" % string table_scheduler_encoding)
        (req None None "operations_hashed_db" % string table_scheduler_encoding)
        (req None None "active_connections" % string int31)
        (req None None "active_peers" % string int31)).
End Distributed_db_state.

src/lib_shell_services/connection_metadata.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {disable_mempool : bool; private_node : bool}

let encoding =
  let open Data_encoding in
  (conv
     (fun {disable_mempool; private_node} -> (disable_mempool, private_node))
     (fun (disable_mempool, private_node) -> {disable_mempool; private_node}))
    (obj2 (req "disable_mempool" bool) (req "private_node" bool))

let pp _ppf _ = ()
src/lib_shell_services/connection_metadata.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  disable_mempool : bool;
  private_node : bool }.

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  (conv
    (fun function_parameter =>
      let '{|
        disable_mempool := disable_mempool; private_node := private_node |} :=
        function_parameter in
      (disable_mempool, private_node))
    (fun function_parameter =>
      let '(disable_mempool, private_node) := function_parameter in
      {| disable_mempool := disable_mempool; private_node := private_node |}))
    None
    (obj2 (req None None "disable_mempool" % string bool)
      (req None None "private_node" % string bool)).

Definition pp {A B : Type} (_ppf : A) (function_parameter : B) : unit :=
  let '_ := function_parameter in
  tt.

src/lib_shell_services/history_mode.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs. <contact@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Archive | Full | Rolling

let encoding =
  Data_encoding.string_enum
    [("archive", Archive); ("full", Full); ("rolling", Rolling)]

let equal hm1 hm2 =
  match (hm1, hm2) with
  | (Archive, Archive) | (Full, Full) | (Rolling, Rolling) ->
      true
  | (Archive, _) | (Full, _) | (Rolling, _) ->
      false

let pp ppf = function
  | Archive ->
      Format.fprintf ppf "archive"
  | Full ->
      Format.fprintf ppf "full"
  | Rolling ->
      Format.fprintf ppf "rolling"

let tag = Tag.def "history_mode" pp
src/lib_shell_services/history_mode.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Archive : t
| Full : t
| Rolling : t.

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  Data_encoding.string_enum
    (cons ("archive" % string, Archive)
      (cons ("full" % string, Full) (cons ("rolling" % string, Rolling) []))).

Definition equal (hm1 : t) (hm2 : t) : bool :=
  match (hm1, hm2) with
  | (Archive, Archive) | (Full, Full) | (Rolling, Rolling) => true
  | (Archive, _) | (Full, _) | (Rolling, _) => false
  end.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  match function_parameter with
  | Archive =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "archive" % string
          CamlinternalFormatBasics.End_of_format) "archive" % string)
  | Full =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "full" % string
          CamlinternalFormatBasics.End_of_format) "full" % string)
  | Rolling =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "rolling" % string
          CamlinternalFormatBasics.End_of_format) "rolling" % string)
  end.

Definition tag : Tezos_base__TzPervasives.Tag.def t :=
  Tag.def None "history_mode" % string pp.

src/lib_shell_services/injection_services.ml 51 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module S = struct
  open Data_encoding

  let path = RPC_path.(root / "injection")

  let block_query =
    let open RPC_query in
    query (fun async force chain ->
        object
          method async = async

          method force = force

          method chain = chain
        end)
    |+ flag "async" (fun t -> t#async)
    |+ flag "force" (fun t -> t#force)
    |+ opt_field "chain" Chain_services.chain_arg (fun t -> t#chain)
    |> seal

  let block_param =
    obj2
      (req "data" bytes)
      (req
         "operations"
         (list (dynamic_size (list (dynamic_size Operation.encoding)))))

  let block =
    RPC_service.post_service
      ~description:
        "Inject a block in the node and broadcast it. The `operations` \
         embedded in `blockHeader` might be pre-validated using a contextual \
         RPCs from the latest block (e.g. '/blocks/head/context/preapply'). \
         Returns the ID of the block. By default, the RPC will wait for the \
         block to be validated before answering. If ?async is true, the \
         function returns immediately. Otherwise, the block will be validated \
         before the result is returned. If ?force is true, it will be \
         injected even on non strictly increasing fitness. An optional ?chain \
         parameter can be used to specify whether to inject on the test chain \
         or the main chain."
      ~query:block_query
      ~input:block_param
      ~output:Block_hash.encoding
      RPC_path.(path / "block")

  let operation_query =
    let open RPC_query in
    query (fun async chain ->
        object
          method async = async

          method chain = chain
        end)
    |+ flag "async" (fun t -> t#async)
    |+ opt_field "chain" Chain_services.chain_arg (fun t -> t#chain)
    |> seal

  let operation =
    RPC_service.post_service
      ~description:
        "Inject an operation in node and broadcast it. Returns the ID of the \
         operation. The `signedOperationContents` should be constructed using \
         a contextual RPCs from the latest block and signed by the client. By \
         default, the RPC will wait for the operation to be (pre-)validated \
         before answering. See RPCs under /blocks/prevalidation for more \
         details on the prevalidation context. If ?async is true, the \
         function returns immediately. Otherwise, the operation will be \
         validated before the result is returned. An optional ?chain \
         parameter can be used to specify whether to inject on the test chain \
         or the main chain."
      ~query:operation_query
      ~input:bytes
      ~output:Operation_hash.encoding
      RPC_path.(path / "operation")

  let protocol_query =
    let open RPC_query in
    query (fun async ->
        object
          method async = async
        end)
    |+ flag "async" (fun t -> t#async)
    |> seal

  let protocol =
    RPC_service.post_service
      ~description:
        "Inject a protocol in node. Returns the ID of the protocol. If ?async \
         is true, the function returns immediately. Otherwise, the protocol \
         will be validated before the result is returned."
      ~query:protocol_query
      ~input:Protocol.encoding
      ~output:Protocol_hash.encoding
      RPC_path.(path / "protocol")
end

open RPC_context

let block ctxt ?(async = false) ?(force = false) ?chain raw operations =
  make_call
    S.block
    ctxt
    ()
    (object
       method async = async

       method force = force

       method chain = chain
    end)
    (raw, operations)

let operation ctxt ?(async = false) ?chain operation =
  make_call
    S.operation
    ctxt
    ()
    (object
       method async = async

       method chain = chain
    end)
    operation

let protocol ctxt ?(async = false) protocol =
  make_call
    S.protocol
    ctxt
    ()
    (object
       method async = async
    end)
    protocol
src/lib_shell_services/injection_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Import Data_encoding.
  
  Definition path : Tezos_base__TzPervasives.RPC_path.path unit unit :=
    op_div root "injection" % string.
  
  Definition block_query
    : Tezos_base__TzPervasives.RPC_query.t
      ((bool *
        (bool * ((option Tezos_shell_services.Chain_services.chain) * nil)))) :=
    OCaml.Stdlib.reverse_apply
      (op_pipeplus
        (op_pipeplus
          (op_pipeplus
            (query
              (fun async =>
                fun force =>
                  fun chain =>
                    (* ❌ Creation of objects is not handled *)
                    object))
            (flag None "async" % string
              (fun t =>
                (* ❌ Sending method message is not handled *)
                send)))
          (flag None "force" % string
            (fun t =>
              (* ❌ Sending method message is not handled *)
              send)))
        (opt_field None "chain" % string Chain_services.chain_arg
          (fun t =>
            (* ❌ Sending method message is not handled *)
            send))) seal.
  
  Definition block_param
    : Tezos_base__TzPervasives.Data_encoding.encoding
      (Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t))) :=
    obj2 (req None None "data" % string bytes)
      (req None None "operations" % string
        (list None
          (dynamic_size None (list None (dynamic_size None Operation.encoding))))).
  
  Definition block
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      ((bool *
        (bool * ((option Tezos_shell_services.Chain_services.chain) * nil))))
      (Stdlib.Bytes.t * (list (list Tezos_base__TzPervasives.Operation.t)))
      Tezos_base__TzPervasives.Block_hash.t :=
    RPC_service.post_service
      (Some
        "Inject a block in the node and broadcast it. The `operations` embedded in `blockHeader` might be pre-validated using a contextual RPCs from the latest block (e.g. '/blocks/head/context/preapply'). Returns the ID of the block. By default, the RPC will wait for the block to be validated before answering. If ?async is true, the function returns immediately. Otherwise, the block will be validated before the result is returned. If ?force is true, it will be injected even on non strictly increasing fitness. An optional ?chain parameter can be used to specify whether to inject on the test chain or the main chain."
          % string) block_query block_param Block_hash.encoding
      (op_div path "block" % string).
  
  Definition operation_query
    : Tezos_base__TzPervasives.RPC_query.t
      ((bool * ((option Tezos_shell_services.Chain_services.chain) * nil))) :=
    OCaml.Stdlib.reverse_apply
      (op_pipeplus
        (op_pipeplus
          (query
            (fun async =>
              fun chain =>
                (* ❌ Creation of objects is not handled *)
                object))
          (flag None "async" % string
            (fun t =>
              (* ❌ Sending method message is not handled *)
              send)))
        (opt_field None "chain" % string Chain_services.chain_arg
          (fun t =>
            (* ❌ Sending method message is not handled *)
            send))) seal.
  
  Definition operation
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      ((bool * ((option Tezos_shell_services.Chain_services.chain) * nil)))
      Stdlib.Bytes.t Tezos_base__TzPervasives.Operation_hash.t :=
    RPC_service.post_service
      (Some
        "Inject an operation in node and broadcast it. Returns the ID of the operation. The `signedOperationContents` should be constructed using a contextual RPCs from the latest block and signed by the client. By default, the RPC will wait for the operation to be (pre-)validated before answering. See RPCs under /blocks/prevalidation for more details on the prevalidation context. If ?async is true, the function returns immediately. Otherwise, the operation will be validated before the result is returned. An optional ?chain parameter can be used to specify whether to inject on the test chain or the main chain."
          % string) operation_query bytes Operation_hash.encoding
      (op_div path "operation" % string).
  
  Definition protocol_query
    : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
    OCaml.Stdlib.reverse_apply
      (op_pipeplus
        (query
          (fun async =>
            (* ❌ Creation of objects is not handled *)
            object))
        (flag None "async" % string
          (fun t =>
            (* ❌ Sending method message is not handled *)
            send))) seal.
  
  Definition protocol
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      ((bool * nil)) Tezos_base__TzPervasives.Protocol.t
      Tezos_base__TzPervasives.Protocol_hash.t :=
    RPC_service.post_service
      (Some
        "Inject a protocol in node. Returns the ID of the protocol. If ?async is true, the function returns immediately. Otherwise, the protocol will be validated before the result is returned."
          % string) protocol_query Protocol.encoding Protocol_hash.encoding
      (op_div path "protocol" % string).
End S.

Import RPC_context.

Definition block {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
  : (option bool) ->
    (option Tezos_shell_services.Chain_services.chain) ->
      Stdlib.Bytes.t ->
        (list (list Tezos_base__TzPervasives.Operation.t)) ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult
              Tezos_base__TzPervasives.Block_hash.t) :=
  let async :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun op_staroptstar =>
    let force :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun chain =>
      fun raw =>
        fun operations =>
          make_call S.block ctxt tt
            (* ❌ Creation of objects is not handled *)
            object (raw, operations).

Definition operation {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
  : (option Tezos_shell_services.Chain_services.chain) ->
    Stdlib.Bytes.t ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          Tezos_base__TzPervasives.Operation_hash.t) :=
  let async :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun chain =>
    fun operation =>
      make_call S.operation ctxt tt
        (* ❌ Creation of objects is not handled *)
        object operation.

Definition protocol {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
  : Tezos_base__TzPervasives.Protocol.t ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_base__TzPervasives.Protocol_hash.t) :=
  let async :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun protocol =>
    make_call S.protocol ctxt tt
      (* ❌ Creation of objects is not handled *)
      object protocol.

src/lib_shell_services/monitor_services.ml 63 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain_status =
  | Active_main of Chain_id.t
  | Active_test of {
      chain : Chain_id.t;
      protocol : Protocol_hash.t;
      expiration_date : Time.Protocol.t;
    }
  | Stopping of Chain_id.t

let chain_status_encoding =
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        ~title:"Main"
        (obj1 (req "chain_id" Chain_id.encoding))
        (function Active_main chain_id -> Some chain_id | _ -> None)
        (fun chain_id -> Active_main chain_id);
      case
        (Tag 1)
        ~title:"Test"
        (obj3
           (req "chain_id" Chain_id.encoding)
           (req "test_protocol" Protocol_hash.encoding)
           (req "expiration_date" Time.Protocol.encoding))
        (function
          | Active_test {chain; protocol; expiration_date} ->
              Some (chain, protocol, expiration_date)
          | _ ->
              None)
        (fun (chain, protocol, expiration_date) ->
          Active_test {chain; protocol; expiration_date});
      case
        (Tag 2)
        ~title:"Stopping"
        (obj1 (req "stopping" Chain_id.encoding))
        (function Stopping chain_id -> Some chain_id | _ -> None)
        (fun chain_id -> Stopping chain_id) ]

module S = struct
  open Data_encoding

  let path = RPC_path.(root / "monitor")

  let bootstrapped =
    RPC_service.get_service
      ~description:
        "Wait for the node to have synchronized its chain with a few peers \
         (configured by the node's administrator), streaming head updates \
         that happen during the bootstrapping process, and closing the stream \
         at the end. If the node was already bootstrapped, returns the \
         current head immediately."
      ~query:RPC_query.empty
      ~output:
        (obj2
           (req "block" Block_hash.encoding)
           (req "timestamp" Time.Protocol.encoding))
      RPC_path.(path / "bootstrapped")

  let valid_blocks_query =
    let open RPC_query in
    query (fun protocols next_protocols chains ->
        object
          method protocols = protocols

          method next_protocols = next_protocols

          method chains = chains
        end)
    |+ multi_field "protocol" Protocol_hash.rpc_arg (fun t -> t#protocols)
    |+ multi_field "next_protocol" Protocol_hash.rpc_arg (fun t ->
           t#next_protocols)
    |+ multi_field "chain" Chain_services.chain_arg (fun t -> t#chains)
    |> seal

  let valid_blocks =
    RPC_service.get_service
      ~description:
        "Monitor all blocks that are successfully validated by the node, \
         disregarding whether they were selected as the new head or not."
      ~query:valid_blocks_query
      ~output:
        (merge_objs
           (obj2
              (req "chain_id" Chain_id.encoding)
              (req "hash" Block_hash.encoding))
           Block_header.encoding)
      RPC_path.(path / "valid_blocks")

  let heads_query =
    let open RPC_query in
    query (fun next_protocols ->
        object
          method next_protocols = next_protocols
        end)
    |+ multi_field "next_protocol" Protocol_hash.rpc_arg (fun t ->
           t#next_protocols)
    |> seal

  let heads =
    RPC_service.get_service
      ~description:
        "Monitor all blocks that are successfully validated by the node and \
         selected as the new head of the given chain."
      ~query:heads_query
      ~output:
        (merge_objs
           (obj1 (req "hash" Block_hash.encoding))
           Block_header.encoding)
      RPC_path.(path / "heads" /: Chain_services.chain_arg)

  let protocols =
    RPC_service.get_service
      ~description:
        "Monitor all economic protocols that are retrieved and successfully \
         loaded and compiled by the node."
      ~query:RPC_query.empty
      ~output:Protocol_hash.encoding
      RPC_path.(path / "protocols")

  let commit_hash =
    RPC_service.get_service
      ~description:"Get information on the build of the node."
      ~query:RPC_query.empty
      ~output:string
      RPC_path.(path / "commit_hash")

  let active_chains =
    RPC_service.get_service
      ~description:
        "Monitor every chain creation and destruction. Currently active \
         chains will be given as first elements"
      ~query:RPC_query.empty
      ~output:(Data_encoding.list chain_status_encoding)
      RPC_path.(path / "active_chains")
end

open RPC_context

let bootstrapped ctxt = make_streamed_call S.bootstrapped ctxt () () ()

let valid_blocks ctxt ?(chains = [`Main]) ?(protocols = [])
    ?(next_protocols = []) () =
  make_streamed_call
    S.valid_blocks
    ctxt
    ()
    (object
       method chains = chains

       method protocols = protocols

       method next_protocols = next_protocols
    end)
    ()

let heads ctxt ?(next_protocols = []) chain =
  make_streamed_call
    S.heads
    ctxt
    ((), chain)
    (object
       method next_protocols = next_protocols
    end)
    ()

let protocols ctxt = make_streamed_call S.protocols ctxt () () ()

let commit_hash ctxt = make_call S.commit_hash ctxt () () ()

let active_chains ctxt = make_streamed_call S.active_chains ctxt () () ()
src/lib_shell_services/monitor_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive chain_status : Type :=
| Active_main : Tezos_base__TzPervasives.Chain_id.t -> chain_status
| Active_test : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Protocol_hash.t ->
  Tezos_base__TzPervasives.Time.Protocol.t -> chain_status
| Stopping : Tezos_base__TzPervasives.Chain_id.t -> chain_status.

Definition chain_status_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding chain_status :=
  union
    (Some
      (* ❌ Variants not supported *)
      variant)
    (cons
      (case "Main" % string None (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (obj1 (req None None "chain_id" % string Chain_id.encoding))
        (fun function_parameter =>
          match function_parameter with
          | Active_main chain_id => Some chain_id
          | _ => None
          end) (fun chain_id => Active_main chain_id))
      (cons
        (case "Test" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj3 (req None None "chain_id" % string Chain_id.encoding)
            (req None None "test_protocol" % string Protocol_hash.encoding)
            (req None None "expiration_date" % string Time.Protocol.encoding))
          (fun function_parameter =>
            match function_parameter with
            |
              Active_test {|
                chain := chain;
                  protocol := protocol;
                  expiration_date := expiration_date
                  |} => Some (chain, protocol, expiration_date)
            | _ => None
            end)
          (fun function_parameter =>
            let '(chain, protocol, expiration_date) := function_parameter in
            Active_test
              {| chain := chain; protocol := protocol;
                expiration_date := expiration_date |}))
        (cons
          (case "Stopping" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 2)
            (obj1 (req None None "stopping" % string Chain_id.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Stopping chain_id => Some chain_id
              | _ => None
              end) (fun chain_id => Stopping chain_id)) []))).

Module S.
  Import Data_encoding.
  
  Definition path : Tezos_base__TzPervasives.RPC_path.path unit unit :=
    op_div root "monitor" % string.
  
  Definition bootstrapped
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Time.Protocol.t) :=
    RPC_service.get_service
      (Some
        "Wait for the node to have synchronized its chain with a few peers (configured by the node's administrator), streaming head updates that happen during the bootstrapping process, and closing the stream at the end. If the node was already bootstrapped, returns the current head immediately."
          % string) RPC_query.empty
      (obj2 (req None None "block" % string Block_hash.encoding)
        (req None None "timestamp" % string Time.Protocol.encoding))
      (op_div path "bootstrapped" % string).
  
  Definition valid_blocks_query
    : Tezos_base__TzPervasives.RPC_query.t
      (((list Tezos_base__TzPervasives.Protocol_hash.t) *
        ((list Tezos_base__TzPervasives.Protocol_hash.t) *
          ((list Tezos_shell_services.Chain_services.chain) * nil)))) :=
    OCaml.Stdlib.reverse_apply
      (op_pipeplus
        (op_pipeplus
          (op_pipeplus
            (query
              (fun protocols =>
                fun next_protocols =>
                  fun chains =>
                    (* ❌ Creation of objects is not handled *)
                    object))
            (multi_field None "protocol" % string Protocol_hash.rpc_arg
              (fun t =>
                (* ❌ Sending method message is not handled *)
                send)))
          (multi_field None "next_protocol" % string Protocol_hash.rpc_arg
            (fun t =>
              (* ❌ Sending method message is not handled *)
              send)))
        (multi_field None "chain" % string Chain_services.chain_arg
          (fun t =>
            (* ❌ Sending method message is not handled *)
            send))) seal.
  
  Definition valid_blocks
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit
      (((list Tezos_base__TzPervasives.Protocol_hash.t) *
        ((list Tezos_base__TzPervasives.Protocol_hash.t) *
          ((list Tezos_shell_services.Chain_services.chain) * nil)))) unit
      ((Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.Block_hash.t) *
        Tezos_base__TzPervasives.Block_header.t) :=
    RPC_service.get_service
      (Some
        "Monitor all blocks that are successfully validated by the node, disregarding whether they were selected as the new head or not."
          % string) valid_blocks_query
      (merge_objs
        (obj2 (req None None "chain_id" % string Chain_id.encoding)
          (req None None "hash" % string Block_hash.encoding))
        Block_header.encoding) (op_div path "valid_blocks" % string).
  
  Definition heads_query
    : Tezos_base__TzPervasives.RPC_query.t
      (((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) :=
    OCaml.Stdlib.reverse_apply
      (op_pipeplus
        (query
          (fun next_protocols =>
            (* ❌ Creation of objects is not handled *)
            object))
        (multi_field None "next_protocol" % string Protocol_hash.rpc_arg
          (fun t =>
            (* ❌ Sending method message is not handled *)
            send))) seal.
  
  Definition heads
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_shell_services.Chain_services.chain)
      (((list Tezos_base__TzPervasives.Protocol_hash.t) * nil)) unit
      (Tezos_base__TzPervasives.Block_hash.t *
        Tezos_base__TzPervasives.Block_header.t) :=
    RPC_service.get_service
      (Some
        "Monitor all blocks that are successfully validated by the node and selected as the new head of the given chain."
          % string) heads_query
      (merge_objs (obj1 (req None None "hash" % string Block_hash.encoding))
        Block_header.encoding)
      (op_divcolon (op_div path "heads" % string) Chain_services.chain_arg).
  
  Definition protocols
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.Protocol_hash.t :=
    RPC_service.get_service
      (Some
        "Monitor all economic protocols that are retrieved and successfully loaded and compiled by the node."
          % string) RPC_query.empty Protocol_hash.encoding
      (op_div path "protocols" % string).
  
  Definition commit_hash
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      string :=
    RPC_service.get_service
      (Some "Get information on the build of the node." % string)
      RPC_query.empty string (op_div path "commit_hash" % string).
  
  Definition active_chains
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (list chain_status) :=
    RPC_service.get_service
      (Some
        "Monitor every chain creation and destruction. Currently active chains will be given as first elements"
          % string) RPC_query.empty
      (Data_encoding.list None chain_status_encoding)
      (op_div path "active_chains" % string).
End S.

Import RPC_context.

Definition bootstrapped {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t
        (Tezos_base__TzPervasives.Block_hash.t *
          Tezos_base__TzPervasives.Time.Protocol.t)) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  make_streamed_call S.bootstrapped ctxt tt tt tt.

Definition valid_blocks {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F) (op_staroptstar : option (list variant))
  : (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
    (option (list Tezos_base__TzPervasives.Protocol_hash.t)) ->
      unit ->
        Lwt.t
          (Tezos_error_monad.Error_monad.tzresult
            ((Lwt_stream.t
              ((Tezos_base__TzPervasives.Chain_id.t *
                Tezos_base__TzPervasives.Block_hash.t) *
                Tezos_base__TzPervasives.Block_header.t)) *
              Tezos_base__TzPervasives.RPC_context.stopper)) :=
  let chains :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      cons
        (* ❌ Variants not supported *)
        variant []
    end in
  fun op_staroptstar =>
    let protocols :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun op_staroptstar =>
      let next_protocols :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => []
        end in
      fun function_parameter =>
        let 'tt := function_parameter in
        make_streamed_call S.valid_blocks ctxt tt
          (* ❌ Creation of objects is not handled *)
          object tt.

Definition heads {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  (op_staroptstar : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  : Tezos_shell_services.Chain_services.chain ->
    Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Lwt_stream.t
          (Tezos_base__TzPervasives.Block_hash.t *
            Tezos_base__TzPervasives.Block_header.t)) *
          Tezos_base__TzPervasives.RPC_context.stopper)) :=
  let next_protocols :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun chain =>
    make_streamed_call S.heads ctxt (tt, chain)
      (* ❌ Creation of objects is not handled *)
      object tt.

Definition protocols {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t Tezos_base__TzPervasives.Protocol_hash.t) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  make_streamed_call S.protocols ctxt tt tt tt.

Definition commit_hash {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult string) :=
  make_call S.commit_hash ctxt tt tt tt.

Definition active_chains {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t (list chain_status)) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  make_streamed_call S.active_chains ctxt tt tt tt.

src/lib_shell_services/p2p_services.ml 244 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let wait_query =
  let open RPC_query in
  query (fun wait ->
      object
        method wait = wait
      end)
  |+ flag "wait" (fun t -> t#wait)
  |> seal

let monitor_query =
  let open RPC_query in
  query (fun monitor ->
      object
        method monitor = monitor
      end)
  |+ flag "monitor" (fun t -> t#monitor)
  |> seal

let timeout_query =
  let open RPC_query in
  query (fun timeout ->
      object
        method timeout = timeout
      end)
  |+ field
       "timeout"
       Time.System.Span.rpc_arg
       (Time.System.Span.of_seconds_exn 10.)
       (fun t -> t#timeout)
  |> seal

module S = struct
  let self =
    RPC_service.get_service
      ~description:"Return the node's peer id"
      ~query:RPC_query.empty
      ~output:P2p_peer.Id.encoding
      RPC_path.(root / "network" / "self")

  let version =
    RPC_service.get_service
      ~description:"Supported network layer version."
      ~query:RPC_query.empty
      ~output:Network_version.encoding
      RPC_path.(root / "network" / "version")

  (* DEPRECATED: use [version] instead. *)
  let versions =
    RPC_service.get_service
      ~description:"DEPRECATED: use `version` instead."
      ~query:RPC_query.empty
      ~output:(Data_encoding.list Network_version.encoding)
      RPC_path.(root / "network" / "versions")

  let stat =
    RPC_service.get_service
      ~description:"Global network bandwidth statistics in B/s."
      ~query:RPC_query.empty
      ~output:P2p_stat.encoding
      RPC_path.(root / "network" / "stat")

  let events =
    RPC_service.get_service
      ~description:"Stream of all network events"
      ~query:RPC_query.empty
      ~output:P2p_connection.P2p_event.encoding
      RPC_path.(root / "network" / "log")

  let connect =
    RPC_service.put_service
      ~description:"Connect to a peer"
      ~query:timeout_query
      ~input:Data_encoding.empty
      ~output:Data_encoding.empty
      RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg)
end

open RPC_context

let self ctxt = make_call S.self ctxt () () ()

let stat ctxt = make_call S.stat ctxt () () ()

let version ctxt = make_call S.version ctxt () () ()

let versions ctxt = make_call S.versions ctxt () () ()

(* DEPRECATED: use [version] instead. *)

let events ctxt = make_streamed_call S.events ctxt () () ()

let connect ctxt ~timeout peer_id =
  make_call1
    S.connect
    ctxt
    peer_id
    (object
       method timeout = timeout
    end)
    ()

module Connections = struct
  type connection_info = Connection_metadata.t P2p_connection.Info.t

  let connection_info_encoding =
    P2p_connection.Info.encoding Connection_metadata.encoding

  module S = struct
    let list =
      RPC_service.get_service
        ~description:"List the running P2P connection."
        ~query:RPC_query.empty
        ~output:(Data_encoding.list connection_info_encoding)
        RPC_path.(root / "network" / "connections")

    let info =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:connection_info_encoding
        ~description:
          "Details about the current P2P connection to the given peer."
        RPC_path.(root / "network" / "connections" /: P2p_peer.Id.rpc_arg)

    let kick =
      RPC_service.delete_service
        ~query:wait_query
        ~output:Data_encoding.empty
        ~description:
          "Forced close of the current P2P connection to the given peer."
        RPC_path.(root / "network" / "connections" /: P2p_peer.Id.rpc_arg)
  end

  let list ctxt = make_call S.list ctxt () () ()

  let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()

  let kick ctxt ?(wait = false) peer_id =
    make_call1
      S.kick
      ctxt
      peer_id
      (object
         method wait = wait
      end)
      ()
end

module Points = struct
  module S = struct
    let info =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:P2p_point.Info.encoding
        ~description:"Details about a given `IP:addr`."
        RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg)

    let events =
      RPC_service.get_service
        ~query:monitor_query
        ~output:(Data_encoding.list P2p_point.Pool_event.encoding)
        ~description:"Monitor network events related to an `IP:addr`."
        RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg / "log")

    let list =
      let filter_query =
        let open RPC_query in
        query (fun filters ->
            object
              method filters = filters
            end)
        |+ multi_field "filter" P2p_point.Filter.rpc_arg (fun t -> t#filters)
        |> seal
      in
      RPC_service.get_service
        ~query:filter_query
        ~output:
          Data_encoding.(
            list (tup2 P2p_point.Id.encoding P2p_point.Info.encoding))
        ~description:
          "List the pool of known `IP:port` used for establishing P2P \
           connections."
        RPC_path.(root / "network" / "points")

    let ban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Blacklist the given address and remove it from the whitelist if \
           present."
        RPC_path.(root / "network" / "points" /: P2p_point.Id.rpc_arg / "ban")

    let unban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove an address from the blacklist."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "unban")

    let trust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Trust a given address permanently and remove it from the blacklist \
           if present. Connections from this address can still be closed on \
           authentication if the peer is greylisted."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "trust")

    let untrust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove an address from the whitelist."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "untrust")

    let banned =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.bool
        ~description:"Check is a given address is blacklisted or greylisted."
        RPC_path.(
          root / "network" / "points" /: P2p_point.Id.rpc_arg / "banned")
  end

  open RPC_context

  let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()

  let events ctxt point =
    make_streamed_call
      S.events
      ctxt
      ((), point)
      (object
         method monitor = true
      end)
      ()

  let list ?(filter = []) ctxt =
    make_call
      S.list
      ctxt
      ()
      (object
         method filters = filter
      end)
      ()

  let ban ctxt peer_id = make_call1 S.ban ctxt peer_id () ()

  let unban ctxt peer_id = make_call1 S.unban ctxt peer_id () ()

  let trust ctxt peer_id = make_call1 S.trust ctxt peer_id () ()

  let untrust ctxt peer_id = make_call1 S.untrust ctxt peer_id () ()

  let banned ctxt peer_id = make_call1 S.banned ctxt peer_id () ()
end

module Peers = struct
  module S = struct
    let info =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:
          (P2p_peer.Info.encoding
             Peer_metadata.encoding
             Connection_metadata.encoding)
        ~description:"Details about a given peer."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg)

    let events =
      RPC_service.get_service
        ~query:monitor_query
        ~output:(Data_encoding.list P2p_peer.Pool_event.encoding)
        ~description:"Monitor network events related to a given peer."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "log")

    let list =
      let filter =
        let open RPC_query in
        query (fun filters ->
            object
              method filters = filters
            end)
        |+ multi_field "filter" P2p_peer.Filter.rpc_arg (fun t -> t#filters)
        |> seal
      in
      RPC_service.get_service
        ~query:filter
        ~output:
          Data_encoding.(
            list
              (tup2
                 P2p_peer.Id.encoding
                 (P2p_peer.Info.encoding
                    Peer_metadata.encoding
                    Connection_metadata.encoding)))
        ~description:"List the peers the node ever met."
        RPC_path.(root / "network" / "peers")

    let ban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Blacklist the given peer and remove it from the whitelist if \
           present."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "ban")

    let unban =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove the given peer from the blacklist."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "unban")

    let trust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:
          "Whitelist a given peer permanently and remove it from the \
           blacklist if present. The peer cannot be blocked (but its host IP \
           still can)."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "trust")

    let untrust =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Remove a given peer from the whitelist."
        RPC_path.(
          root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "untrust")

    let banned =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.bool
        ~description:"Check if a given peer is blacklisted or greylisted."
        RPC_path.(root / "network" / "peers" /: P2p_peer.Id.rpc_arg / "banned")
  end

  let info ctxt peer_id = make_call1 S.info ctxt peer_id () ()

  let events ctxt point =
    make_streamed_call
      S.events
      ctxt
      ((), point)
      (object
         method monitor = true
      end)
      ()

  let list ?(filter = []) ctxt =
    make_call
      S.list
      ctxt
      ()
      (object
         method filters = filter
      end)
      ()

  let ban ctxt point_id = make_call1 S.ban ctxt point_id () ()

  let unban ctxt point_id = make_call1 S.unban ctxt point_id () ()

  let trust ctxt point_id = make_call1 S.trust ctxt point_id () ()

  let untrust ctxt point_id = make_call1 S.untrust ctxt point_id () ()

  let banned ctxt point_id = make_call1 S.banned ctxt point_id () ()
end

module ACL = struct
  module S = struct
    let clear =
      RPC_service.get_service
        ~query:RPC_query.empty
        ~output:Data_encoding.empty
        ~description:"Clear all greylists tables."
        RPC_path.(root / "network" / "greylist" / "clear")
  end

  let clear ctxt = make_call S.clear ctxt () ()
end
src/lib_shell_services/p2p_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition wait_query : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
  OCaml.Stdlib.reverse_apply
    (op_pipeplus
      (query
        (fun wait =>
          (* ❌ Creation of objects is not handled *)
          object))
      (flag None "wait" % string
        (fun t =>
          (* ❌ Sending method message is not handled *)
          send))) seal.

Definition monitor_query
  : Tezos_base__TzPervasives.RPC_query.t ((bool * nil)) :=
  OCaml.Stdlib.reverse_apply
    (op_pipeplus
      (query
        (fun monitor =>
          (* ❌ Creation of objects is not handled *)
          object))
      (flag None "monitor" % string
        (fun t =>
          (* ❌ Sending method message is not handled *)
          send))) seal.

Definition timeout_query
  : Tezos_base__TzPervasives.RPC_query.t
    ((Tezos_base__TzPervasives.Time.System.Span.t * nil)) :=
  OCaml.Stdlib.reverse_apply
    (op_pipeplus
      (query
        (fun timeout =>
          (* ❌ Creation of objects is not handled *)
          object))
      (field None "timeout" % string Time.System.Span.rpc_arg
        (Time.System.Span.of_seconds_exn
          (* ❌ Float constant 10. is approximated by the integer 10 *)
          10)
        (fun t =>
          (* ❌ Sending method message is not handled *)
          send))) seal.

Module S.
  Definition self
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.P2p_peer.Id.t :=
    RPC_service.get_service (Some "Return the node's peer id" % string)
      RPC_query.empty P2p_peer.Id.encoding
      (op_div (op_div root "network" % string) "self" % string).
  
  Definition version
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.Network_version.t :=
    RPC_service.get_service (Some "Supported network layer version." % string)
      RPC_query.empty Network_version.encoding
      (op_div (op_div root "network" % string) "version" % string).
  
  Definition versions
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (list Tezos_base__TzPervasives.Network_version.t) :=
    RPC_service.get_service (Some "DEPRECATED: use `version` instead." % string)
      RPC_query.empty (Data_encoding.list None Network_version.encoding)
      (op_div (op_div root "network" % string) "versions" % string).
  
  Definition stat
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.P2p_stat.t :=
    RPC_service.get_service
      (Some "Global network bandwidth statistics in B/s." % string)
      RPC_query.empty P2p_stat.encoding
      (op_div (op_div root "network" % string) "stat" % string).
  
  Definition events
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.P2p_connection.P2p_event.t :=
    RPC_service.get_service (Some "Stream of all network events" % string)
      RPC_query.empty P2p_connection.P2p_event.encoding
      (op_div (op_div root "network" % string) "log" % string).
  
  Definition connect
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_base__TzPervasives.P2p_point.Id.t)
      ((Tezos_base__TzPervasives.Time.System.Span.t * nil)) unit unit :=
    RPC_service.put_service (Some "Connect to a peer" % string) timeout_query
      Data_encoding.empty Data_encoding.empty
      (op_divcolon (op_div (op_div root "network" % string) "points" % string)
        P2p_point.Id.rpc_arg).
End S.

Import RPC_context.

Definition self {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.P2p_peer.Id.t) := make_call S.self ctxt tt tt tt.

Definition stat {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult Tezos_base__TzPervasives.P2p_stat.t) :=
  make_call S.stat ctxt tt tt tt.

Definition version {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Network_version.t) :=
  make_call S.version ctxt tt tt tt.

Definition versions {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      (list Tezos_base__TzPervasives.Network_version.t)) :=
  make_call S.versions ctxt tt tt tt.

Definition events {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      ((Lwt_stream.t Tezos_base__TzPervasives.P2p_connection.P2p_event.t) *
        Tezos_base__TzPervasives.RPC_context.stopper)) :=
  make_streamed_call S.events ctxt tt tt tt.

Definition connect {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (timeout : Tezos_base__TzPervasives.Time.System.Span.t)
  (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  make_call1 S.connect ctxt peer_id
    (* ❌ Creation of objects is not handled *)
    object tt.

Module Connections.
  Definition connection_info :=
    Tezos_base__TzPervasives.P2p_connection.Info.t
      Tezos_shell_services.Connection_metadata.t.
  
  Definition connection_info_encoding
    : Tezos_data_encoding.Data_encoding.t
      (Tezos_base__TzPervasives.P2p_connection.Info.t
        Tezos_shell_services.Connection_metadata.t) :=
    P2p_connection.Info.encoding Connection_metadata.encoding.
  
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (list
          (Tezos_base__TzPervasives.P2p_connection.Info.t
            Tezos_shell_services.Connection_metadata.t)) :=
      RPC_service.get_service (Some "List the running P2P connection." % string)
        RPC_query.empty (Data_encoding.list None connection_info_encoding)
        (op_div (op_div root "network" % string) "connections" % string).
    
    Definition info
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
        (Tezos_base__TzPervasives.P2p_connection.Info.t
          Tezos_shell_services.Connection_metadata.t) :=
      RPC_service.get_service
        (Some
          "Details about the current P2P connection to the given peer." % string)
        RPC_query.empty connection_info_encoding
        (op_divcolon
          (op_div (op_div root "network" % string) "connections" % string)
          P2p_peer.Id.rpc_arg).
    
    Definition kick
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) ((bool * nil)) unit unit :=
      RPC_service.delete_service
        (Some
          "Forced close of the current P2P connection to the given peer." %
            string) wait_query Data_encoding.empty
        (op_divcolon
          (op_div (op_div root "network" % string) "connections" % string)
          P2p_peer.Id.rpc_arg).
  End S.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.P2p_connection.Info.t
            Tezos_shell_services.Connection_metadata.t))) :=
    make_call S.list ctxt tt tt tt.
  
  Definition info {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_base__TzPervasives.P2p_connection.Info.t
          Tezos_shell_services.Connection_metadata.t)) :=
    make_call1 S.info ctxt peer_id tt tt.
  
  Definition kick {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F) (op_staroptstar : option bool)
    : Tezos_base__TzPervasives.P2p_peer.Id.t ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let wait :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun peer_id =>
      make_call1 S.kick ctxt peer_id
        (* ❌ Creation of objects is not handled *)
        object tt.
End Connections.

Module Points.
  Module S.
    Definition info
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit
        Tezos_base__TzPervasives.P2p_point.Info.t :=
      RPC_service.get_service (Some "Details about a given `IP:addr`." % string)
        RPC_query.empty P2p_point.Info.encoding
        (op_divcolon (op_div (op_div root "network" % string) "points" % string)
          P2p_point.Id.rpc_arg).
    
    Definition events
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) ((bool * nil)) unit
        (list Tezos_base__TzPervasives.P2p_point.Pool_event.t) :=
      RPC_service.get_service
        (Some "Monitor network events related to an `IP:addr`." % string)
        monitor_query (Data_encoding.list None P2p_point.Pool_event.encoding)
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "points" % string)
            P2p_point.Id.rpc_arg) "log" % string).
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit
        (((list Tezos_base__TzPervasives.P2p_point.Filter.t) * nil)) unit
        (list
          (Tezos_base__TzPervasives.P2p_point.Id.t *
            Tezos_base__TzPervasives.P2p_point.Info.t)) :=
      let filter_query :=
        OCaml.Stdlib.reverse_apply
          (op_pipeplus
            (query
              (fun filters =>
                (* ❌ Creation of objects is not handled *)
                object))
            (multi_field None "filter" % string P2p_point.Filter.rpc_arg
              (fun t =>
                (* ❌ Sending method message is not handled *)
                send))) seal in
      RPC_service.get_service
        (Some
          "List the pool of known `IP:port` used for establishing P2P connections."
            % string) filter_query
        (list None (tup2 P2p_point.Id.encoding P2p_point.Info.encoding))
        (op_div (op_div root "network" % string) "points" % string).
    
    Definition ban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some
          "Blacklist the given address and remove it from the whitelist if present."
            % string) RPC_query.empty Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "points" % string)
            P2p_point.Id.rpc_arg) "ban" % string).
    
    Definition unban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some "Remove an address from the blacklist." % string) RPC_query.empty
        Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "points" % string)
            P2p_point.Id.rpc_arg) "unban" % string).
    
    Definition trust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some
          "Trust a given address permanently and remove it from the blacklist if present. Connections from this address can still be closed on authentication if the peer is greylisted."
            % string) RPC_query.empty Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "points" % string)
            P2p_point.Id.rpc_arg) "trust" % string).
    
    Definition untrust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some "Remove an address from the whitelist." % string) RPC_query.empty
        Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "points" % string)
            P2p_point.Id.rpc_arg) "untrust" % string).
    
    Definition banned
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_point.Id.t) unit unit bool :=
      RPC_service.get_service
        (Some "Check is a given address is blacklisted or greylisted." % string)
        RPC_query.empty Data_encoding.bool
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "points" % string)
            P2p_point.Id.rpc_arg) "banned" % string).
  End S.
  
  Import RPC_context.
  
  Definition info {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_base__TzPervasives.P2p_point.Info.t) :=
    make_call1 S.info ctxt peer_id tt tt.
  
  Definition events {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        (o -> unit) ->
          (unit -> unit) ->
            p ->
              q ->
                i ->
                  Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
        * (E * p * q * i * o)) * F) * F)
    (point : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_point.Pool_event.t)) *
          Tezos_base__TzPervasives.RPC_context.stopper)) :=
    make_streamed_call S.events ctxt (tt, point)
      (* ❌ Creation of objects is not handled *)
      object tt.
  
  Definition list {E F i o p q : Type}
    (op_staroptstar : option (list Tezos_base__TzPervasives.P2p_point.Filter.t))
    : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_point.Id.t *
              Tezos_base__TzPervasives.P2p_point.Info.t))) :=
    let filter :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun ctxt =>
      make_call S.list ctxt tt
        (* ❌ Creation of objects is not handled *)
        object tt.
  
  Definition ban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.ban ctxt peer_id tt tt.
  
  Definition unban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.unban ctxt peer_id tt tt.
  
  Definition trust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.trust ctxt peer_id tt tt.
  
  Definition untrust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.untrust ctxt peer_id tt tt.
  
  Definition banned {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_point.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
    make_call1 S.banned ctxt peer_id tt tt.
End Points.

Module Peers.
  Module S.
    Definition info
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
        (Tezos_base__TzPervasives.P2p_peer.Info.t
          Tezos_shell_services.Peer_metadata.t
          Tezos_shell_services.Connection_metadata.t) :=
      RPC_service.get_service (Some "Details about a given peer." % string)
        RPC_query.empty
        (P2p_peer.Info.encoding Peer_metadata.encoding
          Connection_metadata.encoding)
        (op_divcolon (op_div (op_div root "network" % string) "peers" % string)
          P2p_peer.Id.rpc_arg).
    
    Definition events
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) ((bool * nil)) unit
        (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t) :=
      RPC_service.get_service
        (Some "Monitor network events related to a given peer." % string)
        monitor_query (Data_encoding.list None P2p_peer.Pool_event.encoding)
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "peers" % string)
            P2p_peer.Id.rpc_arg) "log" % string).
    
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit
        (((list Tezos_base__TzPervasives.P2p_peer.Filter.t) * nil)) unit
        (list
          (Tezos_base__TzPervasives.P2p_peer.Id.t *
            (Tezos_base__TzPervasives.P2p_peer.Info.t
              Tezos_shell_services.Peer_metadata.t
              Tezos_shell_services.Connection_metadata.t))) :=
      let filter :=
        OCaml.Stdlib.reverse_apply
          (op_pipeplus
            (query
              (fun filters =>
                (* ❌ Creation of objects is not handled *)
                object))
            (multi_field None "filter" % string P2p_peer.Filter.rpc_arg
              (fun t =>
                (* ❌ Sending method message is not handled *)
                send))) seal in
      RPC_service.get_service
        (Some "List the peers the node ever met." % string) filter
        (list None
          (tup2 P2p_peer.Id.encoding
            (P2p_peer.Info.encoding Peer_metadata.encoding
              Connection_metadata.encoding)))
        (op_div (op_div root "network" % string) "peers" % string).
    
    Definition ban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some
          "Blacklist the given peer and remove it from the whitelist if present."
            % string) RPC_query.empty Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "peers" % string)
            P2p_peer.Id.rpc_arg) "ban" % string).
    
    Definition unban
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some "Remove the given peer from the blacklist." % string)
        RPC_query.empty Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "peers" % string)
            P2p_peer.Id.rpc_arg) "unban" % string).
    
    Definition trust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some
          "Whitelist a given peer permanently and remove it from the blacklist if present. The peer cannot be blocked (but its host IP still can)."
            % string) RPC_query.empty Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "peers" % string)
            P2p_peer.Id.rpc_arg) "trust" % string).
    
    Definition untrust
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit unit :=
      RPC_service.get_service
        (Some "Remove a given peer from the whitelist." % string)
        RPC_query.empty Data_encoding.empty
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "peers" % string)
            P2p_peer.Id.rpc_arg) "untrust" % string).
    
    Definition banned
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit bool :=
      RPC_service.get_service
        (Some "Check if a given peer is blacklisted or greylisted." % string)
        RPC_query.empty Data_encoding.bool
        (op_div
          (op_divcolon
            (op_div (op_div root "network" % string) "peers" % string)
            P2p_peer.Id.rpc_arg) "banned" % string).
  End S.
  
  Definition info {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (peer_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_base__TzPervasives.P2p_peer.Info.t
          Tezos_shell_services.Peer_metadata.t
          Tezos_shell_services.Connection_metadata.t)) :=
    make_call1 S.info ctxt peer_id tt tt.
  
  Definition events {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        (o -> unit) ->
          (unit -> unit) ->
            p ->
              q ->
                i ->
                  Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
        * (E * p * q * i * o)) * F) * F)
    (point : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        ((Lwt_stream.t (list Tezos_base__TzPervasives.P2p_peer.Pool_event.t)) *
          Tezos_base__TzPervasives.RPC_context.stopper)) :=
    make_streamed_call S.events ctxt (tt, point)
      (* ❌ Creation of objects is not handled *)
      object tt.
  
  Definition list {E F i o p q : Type}
    (op_staroptstar : option (list Tezos_base__TzPervasives.P2p_peer.Filter.t))
    : (((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F) ->
      Lwt.t
        (Tezos_error_monad.Error_monad.tzresult
          (list
            (Tezos_base__TzPervasives.P2p_peer.Id.t *
              (Tezos_base__TzPervasives.P2p_peer.Info.t
                Tezos_shell_services.Peer_metadata.t
                Tezos_shell_services.Connection_metadata.t)))) :=
    let filter :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun ctxt =>
      make_call S.list ctxt tt
        (* ❌ Creation of objects is not handled *)
        object tt.
  
  Definition ban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.ban ctxt point_id tt tt.
  
  Definition unban {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.unban ctxt point_id tt tt.
  
  Definition trust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.trust ctxt point_id tt tt.
  
  Definition untrust {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call1 S.untrust ctxt point_id tt tt.
  
  Definition banned {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (point_id : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
    make_call1 S.banned ctxt point_id tt tt.
End Peers.

Module ACL.
  Module S.
    Definition clear
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        unit :=
      RPC_service.get_service (Some "Clear all greylists tables." % string)
        RPC_query.empty Data_encoding.empty
        (op_div (op_div (op_div root "network" % string) "greylist" % string)
          "clear" % string).
  End S.
  
  Definition clear {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : unit -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    make_call S.clear ctxt tt tt.
End ACL.

src/lib_shell_services/peer_metadata.ml 43 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type counter = Z.t

let counter = Data_encoding.z

let (( + ) : counter -> counter -> counter) = Z.add

let zero : counter = Z.zero

let one : counter = Z.one

(* Distributed DB peer metadata *)
type messages = {
  mutable branch : counter;
  mutable head : counter;
  mutable block_header : counter;
  mutable operations : counter;
  mutable protocols : counter;
  mutable operation_hashes_for_block : counter;
  mutable operations_for_block : counter;
  mutable other : counter;
}

let sent_requests_encoding =
  let open Data_encoding in
  (conv
     (fun { branch;
            head;
            block_header;
            operations;
            protocols;
            operation_hashes_for_block;
            operations_for_block;
            other } ->
       ( branch,
         head,
         block_header,
         operations,
         protocols,
         operation_hashes_for_block,
         operations_for_block,
         other ))
     (fun ( branch,
            head,
            block_header,
            operations,
            protocols,
            operation_hashes_for_block,
            operations_for_block,
            other ) ->
       {
         branch;
         head;
         block_header;
         operations;
         protocols;
         operation_hashes_for_block;
         operations_for_block;
         other;
       }))
    (obj8
       (req "branch" counter)
       (req "head" counter)
       (req "block_header" counter)
       (req "operations" counter)
       (req "protocols" counter)
       (req "operation_hashes_for_block" counter)
       (req "operations_for_block" counter)
       (req "other" counter))

type requests_kind =
  | Branch
  | Head
  | Block_header
  | Operations
  | Protocols
  | Operation_hashes_for_block
  | Operations_for_block
  | Other

type requests = {
  sent : messages;  (** p2p sent messages of type requests *)
  received : messages;  (** p2p received messages of type requests *)
  failed : messages;
      (** p2p messages of type requests that we failed to send *)
  scheduled : messages;  (** p2p messages ent via request scheduler *)
}

let requests_encoding =
  let open Data_encoding in
  (conv
     (fun {sent; received; failed; scheduled} ->
       (sent, received, failed, scheduled))
     (fun (sent, received, failed, scheduled) ->
       {sent; received; failed; scheduled}))
    (obj4
       (req "sent" sent_requests_encoding)
       (req "received" sent_requests_encoding)
       (req "failed" sent_requests_encoding)
       (req "scheduled" sent_requests_encoding))

(* Prevalidator peer metadata *)
type prevalidator_results = {
  cannot_download : counter;
  cannot_parse : counter;
  refused_by_prefilter : counter;
  refused_by_postfilter : counter;
  (* prevalidation results *)
  applied : counter;
  branch_delayed : counter;
  branch_refused : counter;
  refused : counter;
  duplicate : counter;
  outdated : counter;
}

let prevalidator_results_encoding =
  let open Data_encoding in
  conv
    (fun { cannot_download;
           cannot_parse;
           refused_by_prefilter;
           refused_by_postfilter;
           applied;
           branch_delayed;
           branch_refused;
           refused;
           duplicate;
           outdated } ->
      ( cannot_download,
        cannot_parse,
        refused_by_prefilter,
        refused_by_postfilter,
        applied,
        branch_delayed,
        branch_refused,
        refused,
        duplicate,
        outdated ))
    (fun ( cannot_download,
           cannot_parse,
           refused_by_prefilter,
           refused_by_postfilter,
           applied,
           branch_delayed,
           branch_refused,
           refused,
           duplicate,
           outdated ) ->
      {
        cannot_download;
        cannot_parse;
        refused_by_prefilter;
        refused_by_postfilter;
        applied;
        branch_delayed;
        branch_refused;
        refused;
        duplicate;
        outdated;
      })
    (obj10
       (req "cannot_download" counter)
       (req "cannot_parse" counter)
       (req "refused_by_prefilter" counter)
       (req "refused_by_postfilter" counter)
       (req "applied" counter)
       (req "branch_delayed" counter)
       (req "branch_refused" counter)
       (req "refused" counter)
       (req "duplicate" counter)
       (req "outdated" counter))

type resource_kind = Block | Operations | Protocol

type advertisement = Head | Branch

type metadata =
  (* Distributed_db *)
  | Received_request of requests_kind
  | Sent_request of requests_kind
  | Failed_request of requests_kind
  | Scheduled_request of requests_kind
  | Received_response of requests_kind
  | Sent_response of requests_kind
  | Unexpected_response
  | Unactivated_chain
  | Inactive_chain
  | Future_block
  | Unadvertised of resource_kind
  | Sent_advertisement of advertisement
  | Received_advertisement of advertisement
  | Outdated_response (* TODO : unused *)
  (* Peer validator *)
  | Valid_blocks
  | Old_heads
  (* Prevalidation *)
  | Cannot_download
  | Cannot_parse
  | Refused_by_prefilter
  | Refused_by_postfilter
  | Applied
  | Branch_delayed
  | Branch_refused
  | Refused
  | Duplicate
  | Outdated

type responses = {
  mutable sent : messages;  (** p2p sent messages of type responses *)
  mutable failed : messages;  (** p2p sent messages of type responses *)
  mutable received : messages;  (** p2p received responses *)
  mutable unexpected : counter;
      (** p2p received responses that were unexpected *)
  mutable outdated : counter;
      (** p2p received responses that are now outdated *)
}

let responses_encoding =
  let open Data_encoding in
  (conv
     (fun {sent; failed; received; unexpected; outdated} ->
       (sent, failed, received, unexpected, outdated))
     (fun (sent, failed, received, unexpected, outdated) ->
       {sent; failed; received; unexpected; outdated}))
    (obj5
       (req "sent" sent_requests_encoding)
       (req "failed" sent_requests_encoding)
       (req "received" sent_requests_encoding)
       (req "unexpected" counter)
       (req "outdated" counter))

type unadvertised = {
  mutable block : counter;  (** requests for unadvertised block *)
  mutable operations : counter;  (** requests for unadvertised operations *)
  mutable protocol : counter;  (** requests for unadvertised protocol *)
}

let unadvertised_encoding =
  let open Data_encoding in
  (conv
     (fun {block; operations; protocol} -> (block, operations, protocol))
     (fun (block, operations, protocol) -> {block; operations; protocol}))
    (obj3
       (req "block" counter)
       (req "operations" counter)
       (req "protocol" counter))

type advertisements_kind = {mutable head : counter; mutable branch : counter}

let advertisements_kind_encoding =
  let open Data_encoding in
  (conv
     (fun {head; branch} -> (head, branch))
     (fun (head, branch) -> {head; branch}))
    (obj2 (req "head" counter) (req "branch" counter))

type advertisements = {
  mutable sent : advertisements_kind;
  mutable received : advertisements_kind;
}

let advertisements_encoding =
  let open Data_encoding in
  (conv
     (fun {sent; received} -> (sent, received))
     (fun (sent, received) -> {sent; received}))
    (obj2
       (req "sent" advertisements_kind_encoding)
       (req "received" advertisements_kind_encoding))

type t = {
  mutable responses : responses;  (** responses sent/received *)
  mutable requests : requests;  (** requests sent/received  *)
  mutable valid_blocks : counter;  (** new valid blocks advertized by a peer *)
  mutable old_heads : counter;  (** previously validated blocks from a peer *)
  mutable prevalidator_results : prevalidator_results;
      (** prevalidator metadata *)
  mutable unactivated_chains : counter;
      (** requests from unactivated chains *)
  mutable inactive_chains : counter;  (** advertise inactive chains *)
  mutable future_blocks_advertised : counter;  (** future blocks *)
  mutable unadvertised : unadvertised;
      (** requests for unadvertised resources *)
  mutable advertisements : advertisements;  (** advertisements sent *)
}

let empty () =
  let empty_request () =
    {
      branch = zero;
      head = zero;
      block_header = zero;
      operations = zero;
      protocols = zero;
      operation_hashes_for_block = zero;
      operations_for_block = zero;
      other = zero;
    }
  in
  {
    responses =
      {
        sent = empty_request ();
        failed = empty_request ();
        received = empty_request ();
        unexpected = zero;
        outdated = zero;
      };
    requests =
      {
        sent = empty_request ();
        failed = empty_request ();
        scheduled = empty_request ();
        received = empty_request ();
      };
    valid_blocks = zero;
    old_heads = zero;
    prevalidator_results =
      {
        cannot_download = zero;
        cannot_parse = zero;
        refused_by_prefilter = zero;
        refused_by_postfilter = zero;
        applied = zero;
        branch_delayed = zero;
        branch_refused = zero;
        refused = zero;
        duplicate = zero;
        outdated = zero;
      };
    unactivated_chains = zero;
    inactive_chains = zero;
    future_blocks_advertised = zero;
    unadvertised = {block = zero; operations = zero; protocol = zero};
    advertisements =
      {
        sent = {head = zero; branch = zero};
        received = {head = zero; branch = zero};
      };
  }

let encoding =
  let open Data_encoding in
  (conv
     (fun { responses;
            requests;
            valid_blocks;
            old_heads;
            prevalidator_results;
            unactivated_chains;
            inactive_chains;
            future_blocks_advertised;
            unadvertised;
            advertisements } ->
       ( ( responses,
           requests,
           valid_blocks,
           old_heads,
           prevalidator_results,
           unactivated_chains,
           inactive_chains,
           future_blocks_advertised ),
         (unadvertised, advertisements) ))
     (fun ( ( responses,
              requests,
              valid_blocks,
              old_heads,
              prevalidator_results,
              unactivated_chains,
              inactive_chains,
              future_blocks_advertised ),
            (unadvertised, advertisements) ) ->
       {
         responses;
         requests;
         valid_blocks;
         old_heads;
         prevalidator_results;
         unactivated_chains;
         inactive_chains;
         future_blocks_advertised;
         unadvertised;
         advertisements;
       }))
    (merge_objs
       (obj8
          (req "responses" responses_encoding)
          (req "requests" requests_encoding)
          (req "valid_blocks" counter)
          (req "old_heads" counter)
          (req "prevalidator_results" prevalidator_results_encoding)
          (req "unactivated_chains" counter)
          (req "inactive_chains" counter)
          (req "future_blocks_advertised" counter))
       (obj2
          (req "unadvertised" unadvertised_encoding)
          (req "advertisements" advertisements_encoding)))

let incr_requests (msgs : messages) (req : requests_kind) =
  match req with
  | Branch ->
      msgs.branch <- msgs.branch + one
  | Head ->
      msgs.head <- msgs.head + one
  | Block_header ->
      msgs.block_header <- msgs.block_header + one
  | Operations ->
      msgs.operations <- msgs.operations + one
  | Protocols ->
      msgs.protocols <- msgs.protocols + one
  | Operation_hashes_for_block ->
      msgs.operation_hashes_for_block <- msgs.operation_hashes_for_block + one
  | Operations_for_block ->
      msgs.operations_for_block <- msgs.operations_for_block + one
  | Other ->
      msgs.other <- msgs.other + one

let incr_unadvertised {unadvertised = u; _} = function
  | Block ->
      u.block <- u.block + one
  | Operations ->
      u.operations <- u.operations + one
  | Protocol ->
      u.protocol <- u.protocol + one

let incr ({responses = rsps; requests = rqst; _} as m) metadata =
  match metadata with
  (* requests *)
  | Received_request req ->
      incr_requests rqst.received req
  | Sent_request req ->
      incr_requests rqst.sent req
  | Scheduled_request req ->
      incr_requests rqst.scheduled req
  | Failed_request req ->
      incr_requests rqst.failed req
  (* responses *)
  | Received_response req ->
      incr_requests rsps.received req
  | Sent_response req ->
      incr_requests rsps.sent req
  | Unexpected_response ->
      rsps.unexpected <- rsps.unexpected + one
  | Outdated_response ->
      rsps.outdated <- rsps.outdated + one
  (* Advertisements *)
  | Sent_advertisement ad -> (
    match ad with
    | Head ->
        m.advertisements.sent.head <- m.advertisements.sent.head + one
    | Branch ->
        m.advertisements.sent.branch <- m.advertisements.sent.branch + one )
  | Received_advertisement ad -> (
    match ad with
    | Head ->
        m.advertisements.received.head <- m.advertisements.received.head + one
    | Branch ->
        m.advertisements.received.branch <-
          m.advertisements.received.branch + one )
  (* Unexpected erroneous msg *)
  | Unactivated_chain ->
      m.unactivated_chains <- m.unactivated_chains + one
  | Inactive_chain ->
      m.inactive_chains <- m.inactive_chains + one
  | Future_block ->
      m.future_blocks_advertised <- m.future_blocks_advertised + one
  | Unadvertised u ->
      incr_unadvertised m u
  (* Peer validator *)
  | Valid_blocks ->
      m.valid_blocks <- m.valid_blocks + one
  | Old_heads ->
      m.old_heads <- m.old_heads + one
  (* prevalidation *)
  | Cannot_download ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          cannot_download = m.prevalidator_results.cannot_download + one;
        }
  | Cannot_parse ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          cannot_parse = m.prevalidator_results.cannot_parse + one;
        }
  | Refused_by_prefilter ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          refused_by_prefilter =
            m.prevalidator_results.refused_by_prefilter + one;
        }
  | Refused_by_postfilter ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          refused_by_postfilter =
            m.prevalidator_results.refused_by_postfilter + one;
        }
  | Applied ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          applied = m.prevalidator_results.applied + one;
        }
  | Branch_delayed ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          branch_delayed = m.prevalidator_results.branch_delayed + one;
        }
  | Branch_refused ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          branch_refused = m.prevalidator_results.branch_refused + one;
        }
  | Refused ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          refused = m.prevalidator_results.refused + one;
        }
  | Duplicate ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          duplicate = m.prevalidator_results.duplicate + one;
        }
  | Outdated ->
      m.prevalidator_results <-
        {
          m.prevalidator_results with
          outdated = m.prevalidator_results.outdated + one;
        }

(* shortcuts to update sent/failed requests/responses *)
let update_requests {requests = {sent; failed; _}; _} kind = function
  | true ->
      incr_requests sent kind
  | false ->
      incr_requests failed kind

let update_responses {responses = {sent; failed; _}; _} kind = function
  | true ->
      incr_requests sent kind
  | false ->
      incr_requests failed kind

(* Scores computation *)
(* TODO:
   - scores cannot be kept as integers (use big numbers?)
   - they scores should probably be reset frequently (at each block/cycle?)
   - we might still need to keep some kind of score history
       - store only best/worst/last_value/mean/variance... ?
   - do we need to keep "good" scores ?
        - maybe "bad" scores are enough to reduce resources
          allocated to misbehaving peers *)
let distributed_db_score _ =
  (* TODO *)
  1.0

let prevalidation_score {prevalidator_results = _; _} =
  (* TODO *)
  1.0

let score _ =
  (* TODO *)
  1.0
src/lib_shell_services/peer_metadata.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition counter := Z.t.

Definition counter : Tezos_base__TzPervasives.Data_encoding.encoding Z.t :=
  Data_encoding.z.



Definition zero : counter := Z.zero.

Definition one : counter := Z.one.

Record messages := {
  branch : counter;
  head : counter;
  block_header : counter;
  operations : counter;
  protocols : counter;
  operation_hashes_for_block : counter;
  operations_for_block : counter;
  other : counter }.

Definition sent_requests_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding messages :=
  (conv
    (fun function_parameter =>
      let '{|
        branch := branch;
          head := head;
          block_header := block_header;
          operations := operations;
          protocols := protocols;
          operation_hashes_for_block := operation_hashes_for_block;
          operations_for_block := operations_for_block;
          other := other
          |} := function_parameter in
      (branch, head, block_header, operations, protocols,
        operation_hashes_for_block, operations_for_block, other))
    (fun function_parameter =>
      let
        '(branch, head, block_header, operations, protocols,
          operation_hashes_for_block, operations_for_block, other) :=
        function_parameter in
      {| branch := branch; head := head; block_header := block_header;
        operations := operations; protocols := protocols;
        operation_hashes_for_block := operation_hashes_for_block;
        operations_for_block := operations_for_block; other := other |})) None
    (obj8 (req None None "branch" % string counter)
      (req None None "head" % string counter)
      (req None None "block_header" % string counter)
      (req None None "operations" % string counter)
      (req None None "protocols" % string counter)
      (req None None "operation_hashes_for_block" % string counter)
      (req None None "operations_for_block" % string counter)
      (req None None "other" % string counter)).

Inductive requests_kind : Type :=
| Branch : requests_kind
| Head : requests_kind
| Block_header : requests_kind
| Operations : requests_kind
| Protocols : requests_kind
| Operation_hashes_for_block : requests_kind
| Operations_for_block : requests_kind
| Other : requests_kind.

Record requests := {
  sent : messages;
  received : messages;
  failed : messages;
  scheduled : messages }.

Definition requests_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding requests :=
  (conv
    (fun function_parameter =>
      let '{|
        sent := sent;
          received := received;
          failed := failed;
          scheduled := scheduled
          |} := function_parameter in
      (sent, received, failed, scheduled))
    (fun function_parameter =>
      let '(sent, received, failed, scheduled) := function_parameter in
      {| sent := sent; received := received; failed := failed;
        scheduled := scheduled |})) None
    (obj4 (req None None "sent" % string sent_requests_encoding)
      (req None None "received" % string sent_requests_encoding)
      (req None None "failed" % string sent_requests_encoding)
      (req None None "scheduled" % string sent_requests_encoding)).

Record prevalidator_results := {
  cannot_download : counter;
  cannot_parse : counter;
  refused_by_prefilter : counter;
  refused_by_postfilter : counter;
  applied : counter;
  branch_delayed : counter;
  branch_refused : counter;
  refused : counter;
  duplicate : counter;
  outdated : counter }.

Definition prevalidator_results_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding prevalidator_results :=
  conv
    (fun function_parameter =>
      let '{|
        cannot_download := cannot_download;
          cannot_parse := cannot_parse;
          refused_by_prefilter := refused_by_prefilter;
          refused_by_postfilter := refused_by_postfilter;
          applied := applied;
          branch_delayed := branch_delayed;
          branch_refused := branch_refused;
          refused := refused;
          duplicate := duplicate;
          outdated := outdated
          |} := function_parameter in
      (cannot_download, cannot_parse, refused_by_prefilter,
        refused_by_postfilter, applied, branch_delayed, branch_refused, refused,
        duplicate, outdated))
    (fun function_parameter =>
      let
        '(cannot_download, cannot_parse, refused_by_prefilter,
          refused_by_postfilter, applied, branch_delayed, branch_refused,
          refused, duplicate, outdated) := function_parameter in
      {| cannot_download := cannot_download; cannot_parse := cannot_parse;
        refused_by_prefilter := refused_by_prefilter;
        refused_by_postfilter := refused_by_postfilter; applied := applied;
        branch_delayed := branch_delayed; branch_refused := branch_refused;
        refused := refused; duplicate := duplicate; outdated := outdated |})
    None
    (obj10 (req None None "cannot_download" % string counter)
      (req None None "cannot_parse" % string counter)
      (req None None "refused_by_prefilter" % string counter)
      (req None None "refused_by_postfilter" % string counter)
      (req None None "applied" % string counter)
      (req None None "branch_delayed" % string counter)
      (req None None "branch_refused" % string counter)
      (req None None "refused" % string counter)
      (req None None "duplicate" % string counter)
      (req None None "outdated" % string counter)).

Inductive resource_kind : Type :=
| Block : resource_kind
| Operations : resource_kind
| Protocol : resource_kind.

Inductive advertisement : Type :=
| Head : advertisement
| Branch : advertisement.

Inductive metadata : Type :=
| Received_request : requests_kind -> metadata
| Sent_request : requests_kind -> metadata
| Failed_request : requests_kind -> metadata
| Scheduled_request : requests_kind -> metadata
| Received_response : requests_kind -> metadata
| Sent_response : requests_kind -> metadata
| Unexpected_response : metadata
| Unactivated_chain : metadata
| Inactive_chain : metadata
| Future_block : metadata
| Unadvertised : resource_kind -> metadata
| Sent_advertisement : advertisement -> metadata
| Received_advertisement : advertisement -> metadata
| Outdated_response : metadata
| Valid_blocks : metadata
| Old_heads : metadata
| Cannot_download : metadata
| Cannot_parse : metadata
| Refused_by_prefilter : metadata
| Refused_by_postfilter : metadata
| Applied : metadata
| Branch_delayed : metadata
| Branch_refused : metadata
| Refused : metadata
| Duplicate : metadata
| Outdated : metadata.

Record responses := {
  sent : messages;
  failed : messages;
  received : messages;
  unexpected : counter;
  outdated : counter }.

Definition responses_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding responses :=
  (conv
    (fun function_parameter =>
      let '{|
        sent := sent;
          failed := failed;
          received := received;
          unexpected := unexpected;
          outdated := outdated
          |} := function_parameter in
      (sent, failed, received, unexpected, outdated))
    (fun function_parameter =>
      let '(sent, failed, received, unexpected, outdated) := function_parameter
        in
      {| sent := sent; failed := failed; received := received;
        unexpected := unexpected; outdated := outdated |})) None
    (obj5 (req None None "sent" % string sent_requests_encoding)
      (req None None "failed" % string sent_requests_encoding)
      (req None None "received" % string sent_requests_encoding)
      (req None None "unexpected" % string counter)
      (req None None "outdated" % string counter)).

Record unadvertised := {
  block : counter;
  operations : counter;
  protocol : counter }.

Definition unadvertised_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding unadvertised :=
  (conv
    (fun function_parameter =>
      let '{|
        block := block; operations := operations; protocol := protocol |} :=
        function_parameter in
      (block, operations, protocol))
    (fun function_parameter =>
      let '(block, operations, protocol) := function_parameter in
      {| block := block; operations := operations; protocol := protocol |}))
    None
    (obj3 (req None None "block" % string counter)
      (req None None "operations" % string counter)
      (req None None "protocol" % string counter)).

Record advertisements_kind := {
  head : counter;
  branch : counter }.

Definition advertisements_kind_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding advertisements_kind :=
  (conv
    (fun function_parameter =>
      let '{| head := head; branch := branch |} := function_parameter in
      (head, branch))
    (fun function_parameter =>
      let '(head, branch) := function_parameter in
      {| head := head; branch := branch |})) None
    (obj2 (req None None "head" % string counter)
      (req None None "branch" % string counter)).

Record advertisements := {
  sent : advertisements_kind;
  received : advertisements_kind }.

Definition advertisements_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding advertisements :=
  (conv
    (fun function_parameter =>
      let '{| sent := sent; received := received |} := function_parameter in
      (sent, received))
    (fun function_parameter =>
      let '(sent, received) := function_parameter in
      {| sent := sent; received := received |})) None
    (obj2 (req None None "sent" % string advertisements_kind_encoding)
      (req None None "received" % string advertisements_kind_encoding)).

Record t := {
  responses : responses;
  requests : requests;
  valid_blocks : counter;
  old_heads : counter;
  prevalidator_results : prevalidator_results;
  unactivated_chains : counter;
  inactive_chains : counter;
  future_blocks_advertised : counter;
  unadvertised : unadvertised;
  advertisements : advertisements }.

Definition empty (function_parameter : unit) : t :=
  let 'tt := function_parameter in
  let empty_request (function_parameter : unit) : messages :=
    let 'tt := function_parameter in
    {| branch := zero; head := zero; block_header := zero; operations := zero;
      protocols := zero; operation_hashes_for_block := zero;
      operations_for_block := zero; other := zero |} in
  {|
    responses :=
      {| sent := empty_request tt; failed := empty_request tt;
        received := empty_request tt; unexpected := zero; outdated := zero |};
    requests :=
      {| sent := empty_request tt; received := empty_request tt;
        failed := empty_request tt; scheduled := empty_request tt |};
    valid_blocks := zero; old_heads := zero;
    prevalidator_results :=
      {| cannot_download := zero; cannot_parse := zero;
        refused_by_prefilter := zero; refused_by_postfilter := zero;
        applied := zero; branch_delayed := zero; branch_refused := zero;
        refused := zero; duplicate := zero; outdated := zero |};
    unactivated_chains := zero; inactive_chains := zero;
    future_blocks_advertised := zero;
    unadvertised := {| block := zero; operations := zero; protocol := zero |};
    advertisements :=
      {| sent := {| head := zero; branch := zero |};
        received := {| head := zero; branch := zero |} |} |}.

Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
  (conv
    (fun function_parameter =>
      let '{|
        responses := responses;
          requests := requests;
          valid_blocks := valid_blocks;
          old_heads := old_heads;
          prevalidator_results := prevalidator_results;
          unactivated_chains := unactivated_chains;
          inactive_chains := inactive_chains;
          future_blocks_advertised := future_blocks_advertised;
          unadvertised := unadvertised;
          advertisements := advertisements
          |} := function_parameter in
      ((responses, requests, valid_blocks, old_heads, prevalidator_results,
        unactivated_chains, inactive_chains, future_blocks_advertised),
        (unadvertised, advertisements)))
    (fun function_parameter =>
      let
        '((responses, requests, valid_blocks, old_heads, prevalidator_results,
          unactivated_chains, inactive_chains, future_blocks_advertised),
          (unadvertised, advertisements)) := function_parameter in
      {| responses := responses; requests := requests;
        valid_blocks := valid_blocks; old_heads := old_heads;
        prevalidator_results := prevalidator_results;
        unactivated_chains := unactivated_chains;
        inactive_chains := inactive_chains;
        future_blocks_advertised := future_blocks_advertised;
        unadvertised := unadvertised; advertisements := advertisements |})) None
    (merge_objs
      (obj8 (req None None "responses" % string responses_encoding)
        (req None None "requests" % string requests_encoding)
        (req None None "valid_blocks" % string counter)
        (req None None "old_heads" % string counter)
        (req None None "prevalidator_results" % string
          prevalidator_results_encoding)
        (req None None "unactivated_chains" % string counter)
        (req None None "inactive_chains" % string counter)
        (req None None "future_blocks_advertised" % string counter))
      (obj2 (req None None "unadvertised" % string unadvertised_encoding)
        (req None None "advertisements" % string advertisements_encoding))).

Definition incr_requests (msgs : messages) (req : requests_kind) : unit :=
  match req with
  | Branch =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "branch" % string (op_plus (branch msgs) one)
  | Head =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "head" % string (op_plus (head msgs) one)
  | Block_header =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "block_header" % string
      (op_plus (block_header msgs) one)
  | Operations =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "operations" % string (op_plus (operations msgs) one)
  | Protocols =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "protocols" % string (op_plus (protocols msgs) one)
  | Operation_hashes_for_block =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "operation_hashes_for_block" % string
      (op_plus (operation_hashes_for_block msgs) one)
  | Operations_for_block =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "operations_for_block" % string
      (op_plus (operations_for_block msgs) one)
  | Other =>
    (* ❌ Set record field not handled. *)
    set_record_field msgs "other" % string (op_plus (other msgs) one)
  end.

Definition incr_unadvertised (function_parameter : t) : resource_kind -> unit :=
  let '{| unadvertised := u |} := function_parameter in
  fun function_parameter =>
    match function_parameter with
    | Block =>
      (* ❌ Set record field not handled. *)
      set_record_field u "block" % string (op_plus (block u) one)
    | Operations =>
      (* ❌ Set record field not handled. *)
      set_record_field u "operations" % string (op_plus (operations u) one)
    | Protocol =>
      (* ❌ Set record field not handled. *)
      set_record_field u "protocol" % string (op_plus (protocol u) one)
    end.

Definition incr (function_parameter : t) : metadata -> unit :=
  let '{| responses := rsps; requests := rqst |} as m := function_parameter in
  fun metadata =>
    match metadata with
    | Received_request req => incr_requests (received rqst) req
    | Sent_request req => incr_requests (sent rqst) req
    | Scheduled_request req => incr_requests (scheduled rqst) req
    | Failed_request req => incr_requests (failed rqst) req
    | Received_response req => incr_requests (received rsps) req
    | Sent_response req => incr_requests (sent rsps) req
    | Unexpected_response =>
      (* ❌ Set record field not handled. *)
      set_record_field rsps "unexpected" % string
        (op_plus (unexpected rsps) one)
    | Outdated_response =>
      (* ❌ Set record field not handled. *)
      set_record_field rsps "outdated" % string (op_plus (outdated rsps) one)
    | Sent_advertisement ad =>
      match ad with
      | Head =>
        (* ❌ Set record field not handled. *)
        set_record_field (sent (advertisements m)) "head" % string
          (op_plus (head (sent (advertisements m))) one)
      | Branch =>
        (* ❌ Set record field not handled. *)
        set_record_field (sent (advertisements m)) "branch" % string
          (op_plus (branch (sent (advertisements m))) one)
      end
    | Received_advertisement ad =>
      match ad with
      | Head =>
        (* ❌ Set record field not handled. *)
        set_record_field (received (advertisements m)) "head" % string
          (op_plus (head (received (advertisements m))) one)
      | Branch =>
        (* ❌ Set record field not handled. *)
        set_record_field (received (advertisements m)) "branch" % string
          (op_plus (branch (received (advertisements m))) one)
      end
    | Unactivated_chain =>
      (* ❌ Set record field not handled. *)
      set_record_field m "unactivated_chains" % string
        (op_plus (unactivated_chains m) one)
    | Inactive_chain =>
      (* ❌ Set record field not handled. *)
      set_record_field m "inactive_chains" % string
        (op_plus (inactive_chains m) one)
    | Future_block =>
      (* ❌ Set record field not handled. *)
      set_record_field m "future_blocks_advertised" % string
        (op_plus (future_blocks_advertised m) one)
    | Unadvertised u => incr_unadvertised m u
    | Valid_blocks =>
      (* ❌ Set record field not handled. *)
      set_record_field m "valid_blocks" % string (op_plus (valid_blocks m) one)
    | Old_heads =>
      (* ❌ Set record field not handled. *)
      set_record_field m "old_heads" % string (op_plus (old_heads m) one)
    | Cannot_download =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Cannot_parse =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Refused_by_prefilter =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Refused_by_postfilter =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Applied =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Branch_delayed =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Branch_refused =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Refused =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Duplicate =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    | Outdated =>
      (* ❌ Set record field not handled. *)
      set_record_field m "prevalidator_results" % string
        (* ❌ Record substitution not handled *)
        record_substitution
    end.

Definition update_requests (function_parameter : t)
  : requests_kind -> bool -> unit :=
  let '{| requests := {| sent := sent; failed := failed |} |} :=
    function_parameter in
  fun kind =>
    fun function_parameter =>
      match function_parameter with
      | true => incr_requests sent kind
      | false => incr_requests failed kind
      end.

Definition update_responses (function_parameter : t)
  : requests_kind -> bool -> unit :=
  let '{| responses := {| sent := sent; failed := failed |} |} :=
    function_parameter in
  fun kind =>
    fun function_parameter =>
      match function_parameter with
      | true => incr_requests sent kind
      | false => incr_requests failed kind
      end.

Definition distributed_db_score {A : Type} (function_parameter : A) : Z :=
  let '_ := function_parameter in
  (* ❌ Float constant 1.0 is approximated by the integer 1 *)
  1.

Definition prevalidation_score (function_parameter : t) : Z :=
  let '{| prevalidator_results := _ |} := function_parameter in
  (* ❌ Float constant 1.0 is approximated by the integer 1 *)
  1.

Definition score {A : Type} (function_parameter : A) : Z :=
  let '_ := function_parameter in
  (* ❌ Float constant 1.0 is approximated by the integer 1 *)
  1.

src/lib_shell_services/peer_validator_worker_state.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type view = New_head of Block_hash.t | New_branch of Block_hash.t * int

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"New_head"
          (obj2
             (req "request" (constant "new_head"))
             (req "block" Block_hash.encoding))
          (function New_head h -> Some ((), h) | _ -> None)
          (fun ((), h) -> New_head h);
        case
          (Tag 1)
          ~title:"New_branch"
          (obj3
             (req "request" (constant "new_branch"))
             (req "block" Block_hash.encoding)
             (req "locators" int31))
          (function New_branch (h, l) -> Some ((), h, l) | _ -> None)
          (fun ((), h, l) -> New_branch (h, l)) ]

  let pp ppf = function
    | New_head hash ->
        Format.fprintf ppf "New head %a" Block_hash.pp hash
    | New_branch (hash, len) ->
        Format.fprintf
          ppf
          "New branch %a, locator length %d"
          Block_hash.pp
          hash
          len
end

module Event = struct
  type t =
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Debug of string

  let level req =
    match req with
    | Debug _ ->
        Internal_event.Debug
    | Request _ ->
        Internal_event.Info

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Debug"
          (obj1 (req "message" string))
          (function Debug msg -> Some msg | _ -> None)
          (fun msg -> Debug msg);
        case
          (Tag 1)
          ~title:"Request"
          (obj2
             (req "request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function Request (req, t, None) -> Some (req, t) | _ -> None)
          (fun (req, t) -> Request (req, t, None));
        case
          (Tag 2)
          ~title:"Failed request"
          (obj3
             (req "error" RPC_error.encoding)
             (req "failed_request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function
            | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
          (fun (errs, req, t) -> Request (req, t, Some errs)) ]

  let pp ppf = function
    | Debug msg ->
        Format.fprintf ppf "%s" msg
    | Request (view, {pushed; treated; completed}, None) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
    | Request (view, {pushed; treated; completed}, Some errors) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errors
end

module Worker_state = struct
  type pipeline_length = {
    fetched_header_length : int;
    fetched_block_length : int;
  }

  let pipeline_length_encoding =
    let open Data_encoding in
    conv
      (function
        | {fetched_header_length; fetched_block_length} ->
            (fetched_header_length, fetched_block_length))
      (function
        | (fetched_header_length, fetched_block_length) ->
            {fetched_header_length; fetched_block_length})
      (obj2 (req "fetched_headers" int31) (req "fetched_blocks" int31))

  type view = {
    bootstrapped : bool;
    pipeline_length : pipeline_length;
    mutable last_validated_head : Block_hash.t;
    mutable last_advertised_head : Block_hash.t;
  }

  let encoding =
    let open Data_encoding in
    conv
      (function
        | { bootstrapped;
            pipeline_length;
            last_validated_head;
            last_advertised_head } ->
            ( bootstrapped,
              pipeline_length,
              last_validated_head,
              last_advertised_head ))
      (function
        | ( bootstrapped,
            pipeline_length,
            last_validated_head,
            last_advertised_head ) ->
            {
              bootstrapped;
              pipeline_length;
              last_validated_head;
              last_advertised_head;
            })
      (obj4
         (req "bootstrapped" bool)
         (req "pipelines" pipeline_length_encoding)
         (req "last_validated_head" Block_hash.encoding)
         (req "last_advertised_head" Block_hash.encoding))

  let pp ppf state =
    Format.fprintf
      ppf
      "@[<v 0>Bootstrapped: %s@,\
       Pipeline_length: %d - %d @,\
       Last validated head: %a@,\
       Last advertised head: %a@]"
      (if state.bootstrapped then "yes" else "no")
      state.pipeline_length.fetched_header_length
      state.pipeline_length.fetched_block_length
      Block_hash.pp
      state.last_validated_head
      Block_hash.pp
      state.last_advertised_head
end
src/lib_shell_services/peer_validator_worker_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Inductive view : Type :=
  | New_head : Tezos_base__TzPervasives.Block_hash.t -> view
  | New_branch : Tezos_base__TzPervasives.Block_hash.t -> Z -> view.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    union None
      (cons
        (case "New_head" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 0)
          (obj2
            (req None None "request" % string (constant "new_head" % string))
            (req None None "block" % string Block_hash.encoding))
          (fun function_parameter =>
            match function_parameter with
            | New_head h => Some (tt, h)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, h) := function_parameter in
            New_head h))
        (cons
          (case "New_branch" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1)
            (obj3
              (req None None "request" % string (constant "new_branch" % string))
              (req None None "block" % string Block_hash.encoding)
              (req None None "locators" % string int31))
            (fun function_parameter =>
              match function_parameter with
              | New_branch h l => Some (tt, h, l)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, h, l) := function_parameter in
              New_branch h l)) [])).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    match function_parameter with
    | New_head hash =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "New head " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "New head %a" % string)
        Block_hash.pp hash
    | New_branch hash len =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "New branch " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                ", locator length " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  CamlinternalFormatBasics.End_of_format))))
          "New branch %a, locator length %d" % string) Block_hash.pp hash len
    end.
End Request.

Module Event.
  Inductive t : Type :=
  | Request :
    (Request.view * Tezos_shell_services.Worker_types.request_status *
      (option (list Tezos_base__TzPervasives.error))) -> t
  | Debug : string -> t.
  
  Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
    match req with
    | Debug _ => Tezos_base__TzPervasives.Internal_event.Debug
    | Request _ => Tezos_base__TzPervasives.Internal_event.Info
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    union None
      (cons
        (case "Debug" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 0)
          (obj1 (req None None "message" % string string))
          (fun function_parameter =>
            match function_parameter with
            | Debug msg => Some msg
            | _ => None
            end) (fun msg => Debug msg))
        (cons
          (case "Request" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1)
            (obj2 (req None None "request" % string Request.encoding)
              (req None None "status" % string
                Worker_types.request_status_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Request (req, t, None) => Some (req, t)
              | _ => None
              end)
            (fun function_parameter =>
              let '(req, t) := function_parameter in
              Request (req, t, None)))
          (cons
            (case "Failed request" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 2)
              (obj3 (req None None "error" % string RPC_error.encoding)
                (req None None "failed_request" % string Request.encoding)
                (req None None "status" % string
                  Worker_types.request_status_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Request (req, t, Some errs) => Some (errs, req, t)
                | _ => None
                end)
              (fun function_parameter =>
                let '(errs, req, t) := function_parameter in
                Request (req, t, (Some errs)))) []))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Debug msg =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) msg
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          None) =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format))))))
          "@[<v 0>%a@, %a@]" % string) Request.pp view Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          Some errors) =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ", " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))))
          "@[<v 0>%a@, %a, %a@]" % string) Request.pp view
        Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
        (Format.pp_print_list None Error_monad.pp) errors
    end.
End Event.

Module Worker_state.
  Record pipeline_length := {
    fetched_header_length : Z;
    fetched_block_length : Z }.
  
  Definition pipeline_length_encoding
    : Tezos_base__TzPervasives.Data_encoding.encoding pipeline_length :=
    conv
      (fun function_parameter =>
        let '{|
          fetched_header_length := fetched_header_length;
            fetched_block_length := fetched_block_length
            |} := function_parameter in
        (fetched_header_length, fetched_block_length))
      (fun function_parameter =>
        let '(fetched_header_length, fetched_block_length) := function_parameter
          in
        {| fetched_header_length := fetched_header_length;
          fetched_block_length := fetched_block_length |}) None
      (obj2 (req None None "fetched_headers" % string int31)
        (req None None "fetched_blocks" % string int31)).
  
  Record view := {
    bootstrapped : bool;
    pipeline_length : pipeline_length;
    last_validated_head : Tezos_base__TzPervasives.Block_hash.t;
    last_advertised_head : Tezos_base__TzPervasives.Block_hash.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    conv
      (fun function_parameter =>
        let '{|
          bootstrapped := bootstrapped;
            pipeline_length := pipeline_length;
            last_validated_head := last_validated_head;
            last_advertised_head := last_advertised_head
            |} := function_parameter in
        (bootstrapped, pipeline_length, last_validated_head,
          last_advertised_head))
      (fun function_parameter =>
        let
          '(bootstrapped, pipeline_length, last_validated_head,
            last_advertised_head) := function_parameter in
        {| bootstrapped := bootstrapped; pipeline_length := pipeline_length;
          last_validated_head := last_validated_head;
          last_advertised_head := last_advertised_head |}) None
      (obj4 (req None None "bootstrapped" % string bool)
        (req None None "pipelines" % string pipeline_length_encoding)
        (req None None "last_validated_head" % string Block_hash.encoding)
        (req None None "last_advertised_head" % string Block_hash.encoding)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (state : view) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal "Bootstrapped: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "Pipeline_length: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal " - " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "Last validated head: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "Last advertised head: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))))
        "@[<v 0>Bootstrapped: %s@,Pipeline_length: %d - %d @,Last validated head: %a@,Last advertised head: %a@]"
          % string)
      (if bootstrapped state then
        "yes" % string
      else
        "no" % string) (fetched_header_length (pipeline_length state))
      (fetched_block_length (pipeline_length state)) Block_hash.pp
      (last_validated_head state) Block_hash.pp (last_advertised_head state).
End Worker_state.

src/lib_shell_services/prevalidator_worker_state.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Request = struct
  type 'a t =
    | Flush : Block_hash.t -> unit t
    | Notify : P2p_peer.Id.t * Mempool.t -> unit t
    | Leftover : unit t
    | Inject : Operation.t -> unit t
    | Arrived : Operation_hash.t * Operation.t -> unit t
    | Advertise : unit t

  type view = View : _ t -> view

  let view req = View req

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Flush"
          (obj2
             (req "request" (constant "flush"))
             (req "block" Block_hash.encoding))
          (function View (Flush hash) -> Some ((), hash) | _ -> None)
          (fun ((), hash) -> View (Flush hash));
        case
          (Tag 1)
          ~title:"Notify"
          (obj3
             (req "request" (constant "notify"))
             (req "peer" P2p_peer.Id.encoding)
             (req "mempool" Mempool.encoding))
          (function
            | View (Notify (peer, mempool)) ->
                Some ((), peer, mempool)
            | _ ->
                None)
          (fun ((), peer, mempool) -> View (Notify (peer, mempool)));
        case
          (Tag 2)
          ~title:"Inject"
          (obj2
             (req "request" (constant "inject"))
             (req "operation" Operation.encoding))
          (function View (Inject op) -> Some ((), op) | _ -> None)
          (fun ((), op) -> View (Inject op));
        case
          (Tag 3)
          ~title:"Arrived"
          (obj3
             (req "request" (constant "arrived"))
             (req "operation_hash" Operation_hash.encoding)
             (req "operation" Operation.encoding))
          (function
            | View (Arrived (oph, op)) -> Some ((), oph, op) | _ -> None)
          (fun ((), oph, op) -> View (Arrived (oph, op)));
        case
          (Tag 4)
          ~title:"Advertise"
          (obj1 (req "request" (constant "advertise")))
          (function View Advertise -> Some () | _ -> None)
          (fun () -> View Advertise) ]

  let pp ppf (View r) =
    match r with
    | Flush hash ->
        Format.fprintf ppf "switching to new head %a" Block_hash.pp hash
    | Notify (id, {Mempool.known_valid; pending}) ->
        Format.fprintf
          ppf
          "@[<v 2>notified by %a of operations"
          P2p_peer.Id.pp
          id ;
        List.iter
          (fun oph ->
            Format.fprintf ppf "@,%a (applied)" Operation_hash.pp oph)
          known_valid ;
        List.iter
          (fun oph ->
            Format.fprintf ppf "@,%a (pending)" Operation_hash.pp oph)
          (Operation_hash.Set.elements pending) ;
        Format.fprintf ppf "@]"
    | Leftover ->
        Format.fprintf ppf "process next batch of operation"
    | Inject op ->
        Format.fprintf
          ppf
          "injecting operation %a"
          Operation_hash.pp
          (Operation.hash op)
    | Arrived (oph, _) ->
        Format.fprintf ppf "operation %a arrived" Operation_hash.pp oph
    | Advertise ->
        Format.fprintf ppf "advertising pending operations"
end

module Event = struct
  type t =
    | Request of
        (Request.view * Worker_types.request_status * error list option)
    | Debug of string

  let level req =
    let open Request in
    match req with
    | Debug _ ->
        Internal_event.Debug
    | Request (View (Flush _), _, _) ->
        Internal_event.Notice
    | Request (View (Notify _), _, _) ->
        Internal_event.Debug
    | Request (View Leftover, _, _) ->
        Internal_event.Debug
    | Request (View (Inject _), _, _) ->
        Internal_event.Notice
    | Request (View (Arrived _), _, _) ->
        Internal_event.Debug
    | Request (View Advertise, _, _) ->
        Internal_event.Debug

  let encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Debug"
          (obj1 (req "message" string))
          (function Debug msg -> Some msg | _ -> None)
          (fun msg -> Debug msg);
        case
          (Tag 1)
          ~title:"Request"
          (obj2
             (req "request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function Request (req, t, None) -> Some (req, t) | _ -> None)
          (fun (req, t) -> Request (req, t, None));
        case
          (Tag 2)
          ~title:"Failed request"
          (obj3
             (req "error" RPC_error.encoding)
             (req "failed_request" Request.encoding)
             (req "status" Worker_types.request_status_encoding))
          (function
            | Request (req, t, Some errs) -> Some (errs, req, t) | _ -> None)
          (fun (errs, req, t) -> Request (req, t, Some errs)) ]

  let pp ppf = function
    | Debug msg ->
        Format.fprintf ppf "%s" msg
    | Request (view, {pushed; treated; completed}, None) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
    | Request (view, {pushed; treated; completed}, Some errors) ->
        Format.fprintf
          ppf
          "@[<v 0>%a@, %a, %a@]"
          Request.pp
          view
          Worker_types.pp_status
          {pushed; treated; completed}
          (Format.pp_print_list Error_monad.pp)
          errors
end

module Worker_state = struct
  type view = {
    head : Block_hash.t;
    timestamp : Time.System.t;
    fetching : Operation_hash.Set.t;
    pending : Operation_hash.Set.t;
    applied : Operation_hash.t list;
    delayed : Operation_hash.Set.t;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {head; timestamp; fetching; pending; applied; delayed} ->
        (head, timestamp, fetching, pending, applied, delayed))
      (fun (head, timestamp, fetching, pending, applied, delayed) ->
        {head; timestamp; fetching; pending; applied; delayed})
      (obj6
         (req "head" Block_hash.encoding)
         (req "timestamp" Time.System.encoding)
         (req "fetching" Operation_hash.Set.encoding)
         (req "pending" Operation_hash.Set.encoding)
         (req "applied" (list Operation_hash.encoding))
         (req "delayed" Operation_hash.Set.encoding))

  let pp ppf view =
    Format.fprintf
      ppf
      "@[<v 0>Head: %a@,\
       Timestamp: %a@,\n\
      \       @[<v 2>Fetching: %a@]@,\n\
      \       @[<v 2>Pending: %a@]@,\n\
      \       @[<v 2>Applied: %a@]@,\n\
      \       @[<v 2>Delayed: %a@]@]"
      Block_hash.pp
      view.head
      Time.System.pp_hum
      view.timestamp
      (Format.pp_print_list Operation_hash.pp)
      (Operation_hash.Set.elements view.fetching)
      (Format.pp_print_list Operation_hash.pp)
      (Operation_hash.Set.elements view.pending)
      (Format.pp_print_list Operation_hash.pp)
      view.applied
      (Format.pp_print_list Operation_hash.pp)
      (Operation_hash.Set.elements view.delayed)
end
src/lib_shell_services/prevalidator_worker_state.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Request.
  Inductive t : forall (a : Type), Type :=
  | Flush : Tezos_base__TzPervasives.Block_hash.t -> t unit
  | Notify : Tezos_base__TzPervasives.P2p_peer.Id.t ->
    Tezos_base__TzPervasives.Mempool.t -> t unit
  | Leftover : t unit
  | Inject : Tezos_base__TzPervasives.Operation.t -> t unit
  | Arrived : Tezos_base__TzPervasives.Operation_hash.t ->
    Tezos_base__TzPervasives.Operation.t -> t unit
  | Advertise : t unit.
  
  Inductive view : Type :=
  | View : forall {A : Type}, (t A) -> view.
  
  Definition view {A : Type} (req : t A) : view := View req.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    union None
      (cons
        (case "Flush" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 0)
          (obj2 (req None None "request" % string (constant "flush" % string))
            (req None None "block" % string Block_hash.encoding))
          (fun function_parameter =>
            match function_parameter with
            | View (Flush hash) => Some (tt, hash)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, hash) := function_parameter in
            View (Flush hash)))
        (cons
          (case "Notify" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1)
            (obj3
              (req None None "request" % string (constant "notify" % string))
              (req None None "peer" % string P2p_peer.Id.encoding)
              (req None None "mempool" % string Mempool.encoding))
            (fun function_parameter =>
              match function_parameter with
              | View (Notify peer mempool) => Some (tt, peer, mempool)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, peer, mempool) := function_parameter in
              View (Notify peer mempool)))
          (cons
            (case "Inject" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 2)
              (obj2
                (req None None "request" % string (constant "inject" % string))
                (req None None "operation" % string Operation.encoding))
              (fun function_parameter =>
                match function_parameter with
                | View (Inject op) => Some (tt, op)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, op) := function_parameter in
                View (Inject op)))
            (cons
              (case "Arrived" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 3)
                (obj3
                  (req None None "request" % string
                    (constant "arrived" % string))
                  (req None None "operation_hash" % string
                    Operation_hash.encoding)
                  (req None None "operation" % string Operation.encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | View (Arrived oph op) => Some (tt, oph, op)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, oph, op) := function_parameter in
                  View (Arrived oph op)))
              (cons
                (case "Advertise" % string None
                  (Tezos_base__TzPervasives.Data_encoding.Tag 4)
                  (obj1
                    (req None None "request" % string
                      (constant "advertise" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | View Advertise => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    View Advertise)) []))))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : view)
    : unit :=
    let 'View r := function_parameter in
    match r with
    | Flush hash =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "switching to new head " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "switching to new head %a" % string) Block_hash.pp hash
    |
      Notify id {|
        Mempool.known_valid := known_valid; Mempool.pending := pending |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal "notified by " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " of operations" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@[<v 2>notified by %a of operations" % string) P2p_peer.Id.pp id in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        List.iter
          (fun oph =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " (applied)" % string
                      CamlinternalFormatBasics.End_of_format)))
                "@,%a (applied)" % string) Operation_hash.pp oph) known_valid in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        List.iter
          (fun oph =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " (pending)" % string
                      CamlinternalFormatBasics.End_of_format)))
                "@,%a (pending)" % string) Operation_hash.pp oph)
          (Operation_hash.Set.elements pending) in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format) "@]" % string)
    | Leftover =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "process next batch of operation" % string
            CamlinternalFormatBasics.End_of_format)
          "process next batch of operation" % string)
    | Inject op =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "injecting operation " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "injecting operation %a" % string) Operation_hash.pp
        (Operation.hash op)
    | Arrived oph _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "operation " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " arrived" % string
                CamlinternalFormatBasics.End_of_format)))
          "operation %a arrived" % string) Operation_hash.pp oph
    | Advertise =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "advertising pending operations" % string
            CamlinternalFormatBasics.End_of_format)
          "advertising pending operations" % string)
    end.
End Request.

Module Event.
  Inductive t : Type :=
  | Request :
    (Request.view * Tezos_shell_services.Worker_types.request_status *
      (option (list Tezos_base__TzPervasives.error))) -> t
  | Debug : string -> t.
  
  Definition level (req : t) : Tezos_base__TzPervasives.Internal_event.level :=
    match req with
    | Debug _ => Tezos_base__TzPervasives.Internal_event.Debug
    | Request (Request.View (Request.Flush _), _, _) =>
      Tezos_base__TzPervasives.Internal_event.Notice
    | Request (Request.View (Request.Notify _ _), _, _) =>
      Tezos_base__TzPervasives.Internal_event.Debug
    | Request (Request.View Request.Leftover, _, _) =>
      Tezos_base__TzPervasives.Internal_event.Debug
    | Request (Request.View (Request.Inject _), _, _) =>
      Tezos_base__TzPervasives.Internal_event.Notice
    | Request (Request.View (Request.Arrived _ _), _, _) =>
      Tezos_base__TzPervasives.Internal_event.Debug
    | Request (Request.View Request.Advertise, _, _) =>
      Tezos_base__TzPervasives.Internal_event.Debug
    end.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    union None
      (cons
        (case "Debug" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 0)
          (obj1 (req None None "message" % string string))
          (fun function_parameter =>
            match function_parameter with
            | Debug msg => Some msg
            | _ => None
            end) (fun msg => Debug msg))
        (cons
          (case "Request" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 1)
            (obj2 (req None None "request" % string Request.encoding)
              (req None None "status" % string
                Worker_types.request_status_encoding))
            (fun function_parameter =>
              match function_parameter with
              | Request (req, t, None) => Some (req, t)
              | _ => None
              end)
            (fun function_parameter =>
              let '(req, t) := function_parameter in
              Request (req, t, None)))
          (cons
            (case "Failed request" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 2)
              (obj3 (req None None "error" % string RPC_error.encoding)
                (req None None "failed_request" % string Request.encoding)
                (req None None "status" % string
                  Worker_types.request_status_encoding))
              (fun function_parameter =>
                match function_parameter with
                | Request (req, t, Some errs) => Some (errs, req, t)
                | _ => None
                end)
              (fun function_parameter =>
                let '(errs, req, t) := function_parameter in
                Request (req, t, (Some errs)))) []))).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Debug msg =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) msg
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          None) =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format))))))
          "@[<v 0>%a@, %a@]" % string) Request.pp view Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
    |
      Request
        (view, {|
          pushed := pushed; treated := treated; completed := completed |},
          Some errors) =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal ", " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))))
          "@[<v 0>%a@, %a, %a@]" % string) Request.pp view
        Worker_types.pp_status
        {| pushed := pushed; treated := treated; completed := completed |}
        (Format.pp_print_list None Error_monad.pp) errors
    end.
End Event.

Module Worker_state.
  Record view := {
    head : Tezos_base__TzPervasives.Block_hash.t;
    timestamp : Tezos_base__TzPervasives.Time.System.t;
    fetching : Tezos_base__TzPervasives.Operation_hash.Set.t;
    pending : Tezos_base__TzPervasives.Operation_hash.Set.t;
    applied : list Tezos_base__TzPervasives.Operation_hash.t;
    delayed : Tezos_base__TzPervasives.Operation_hash.Set.t }.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding view :=
    conv
      (fun function_parameter =>
        let '{|
          head := head;
            timestamp := timestamp;
            fetching := fetching;
            pending := pending;
            applied := applied;
            delayed := delayed
            |} := function_parameter in
        (head, timestamp, fetching, pending, applied, delayed))
      (fun function_parameter =>
        let '(head, timestamp, fetching, pending, applied, delayed) :=
          function_parameter in
        {| head := head; timestamp := timestamp; fetching := fetching;
          pending := pending; applied := applied; delayed := delayed |}) None
      (obj6 (req None None "head" % string Block_hash.encoding)
        (req None None "timestamp" % string Time.System.encoding)
        (req None None "fetching" % string Operation_hash.Set.encoding)
        (req None None "pending" % string Operation_hash.Set.encoding)
        (req None None "applied" % string (list None Operation_hash.encoding))
        (req None None "delayed" % string Operation_hash.Set.encoding)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (view : view) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.String_literal "Head: " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "Timestamp: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal
                        "
       " % string
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Fetching: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "
       " % string
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "Pending: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@," % string 0 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "
       " % string
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<v 2>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<v 2>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Applied: " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          (CamlinternalFormatBasics.Break
                                                            "@," % string 0 0)
                                                          (CamlinternalFormatBasics.String_literal
                                                            "
       " % string
                                                            (CamlinternalFormatBasics.Formatting_gen
                                                              (CamlinternalFormatBasics.Open_box
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "<v 2>" %
                                                                      string
                                                                    CamlinternalFormatBasics.End_of_format)
                                                                  "<v 2>" %
                                                                    string))
                                                              (CamlinternalFormatBasics.String_literal
                                                                "Delayed: " %
                                                                  string
                                                                (CamlinternalFormatBasics.Alpha
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    CamlinternalFormatBasics.Close_box
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Close_box
                                                                      CamlinternalFormatBasics.End_of_format)))))))))))))))))))))))))))))))
        "@[<v 0>Head: %a@,Timestamp: %a@,
       @[<v 2>Fetching: %a@]@,
       @[<v 2>Pending: %a@]@,
       @[<v 2>Applied: %a@]@,
       @[<v 2>Delayed: %a@]@]"
          % string) Block_hash.pp (head view) Time.System.pp_hum
      (timestamp view) (Format.pp_print_list None Operation_hash.pp)
      (Operation_hash.Set.elements (fetching view))
      (Format.pp_print_list None Operation_hash.pp)
      (Operation_hash.Set.elements (pending view))
      (Format.pp_print_list None Operation_hash.pp) (applied view)
      (Format.pp_print_list None Operation_hash.pp)
      (Operation_hash.Set.elements (delayed view)).
End Worker_state.

src/lib_shell_services/protocol_services.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

module S = struct
  let protocols_arg = Protocol_hash.rpc_arg

  let contents =
    RPC_service.get_service
      ~query:RPC_query.empty
      ~output:Protocol.encoding
      RPC_path.(root / "protocols" /: protocols_arg)

  let list =
    RPC_service.get_service
      ~query:RPC_query.empty
      ~output:(list Protocol_hash.encoding)
      RPC_path.(root / "protocols")

  let fetch =
    RPC_service.get_service
      ~description:"Fetch a protocol from the network."
      ~query:RPC_query.empty
      ~output:unit
      RPC_path.(root / "fetch_protocol" /: protocols_arg)
end

open RPC_context

let contents ctxt h = make_call1 S.contents ctxt h () ()

let list ctxt = make_call S.list ctxt () () ()

let fetch ctxt h = make_call1 S.fetch ctxt h () ()
src/lib_shell_services/protocol_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Module S.
  Definition protocols_arg
    : Tezos_rpc.RPC_arg.t Tezos_base__TzPervasives.Protocol_hash.t :=
    Protocol_hash.rpc_arg.
  
  Definition contents
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit
      Tezos_base__TzPervasives.Protocol.t :=
    RPC_service.get_service None RPC_query.empty Protocol.encoding
      (op_divcolon (op_div root "protocols" % string) protocols_arg).
  
  Definition list
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      (list Tezos_base__TzPervasives.Protocol_hash.t) :=
    RPC_service.get_service None RPC_query.empty
      (list None Protocol_hash.encoding) (op_div root "protocols" % string).
  
  Definition fetch
    : Tezos_base__TzPervasives.RPC_service.service variant unit
      (unit * Tezos_base__TzPervasives.Protocol_hash.t) unit unit unit :=
    RPC_service.get_service (Some "Fetch a protocol from the network." % string)
      RPC_query.empty unit
      (op_divcolon (op_div root "fetch_protocol" % string) protocols_arg).
End S.

Import RPC_context.

Definition contents {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (h : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult Tezos_base__TzPervasives.Protocol.t) :=
  make_call1 S.contents ctxt h tt tt.

Definition list {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      (list Tezos_base__TzPervasives.Protocol_hash.t)) :=
  make_call S.list ctxt tt tt tt.

Definition fetch {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (h : Tezos_base__TzPervasives.Protocol_hash.t)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  make_call1 S.fetch ctxt h tt tt.

src/lib_shell_services/shell_services.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type chain = Chain_services.chain

type block = Block_services.block

module Chain = Chain_services
module Blocks = Chain.Blocks
module Invalid_blocks = Chain.Invalid_blocks
module Mempool = Chain.Mempool
module Protocol = Protocol_services
module Monitor = Monitor_services
module Injection = Injection_services
module P2p = P2p_services
module Worker = Worker_services
src/lib_shell_services/shell_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition chain := Tezos_shell_services.Chain_services.chain.

Definition block := Tezos_shell_services.Block_services.block.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

src/lib_shell_services/stat_services.ml 11 errors
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Gc

let gc_stat_encoding =
  let open Data_encoding in
  conv
    (fun { minor_words;
           promoted_words;
           major_words;
           minor_collections;
           major_collections;
           heap_words;
           heap_chunks;
           live_words;
           live_blocks;
           free_words;
           free_blocks;
           largest_free;
           fragments;
           compactions;
           top_heap_words;
           stack_size } ->
      ( ( minor_words,
          promoted_words,
          major_words,
          minor_collections,
          major_collections ),
        ( (heap_words, heap_chunks, live_words, live_blocks, free_words),
          ( free_blocks,
            largest_free,
            fragments,
            compactions,
            top_heap_words,
            stack_size ) ) ))
    (fun ( ( minor_words,
             promoted_words,
             major_words,
             minor_collections,
             major_collections ),
           ( (heap_words, heap_chunks, live_words, live_blocks, free_words),
             ( free_blocks,
               largest_free,
               fragments,
               compactions,
               top_heap_words,
               stack_size ) ) ) ->
      {
        minor_words;
        promoted_words;
        major_words;
        minor_collections;
        major_collections;
        heap_words;
        heap_chunks;
        live_words;
        live_blocks;
        free_words;
        free_blocks;
        largest_free;
        fragments;
        compactions;
        top_heap_words;
        stack_size;
      })
    (merge_objs
       (obj5
          (req "minor_words" float)
          (req "promoted_words" float)
          (req "major_words" float)
          (req "minor_collections" int31)
          (req "major_collections" int31))
       (merge_objs
          (obj5
             (req "heap_words" int31)
             (req "heap_chunks" int31)
             (req "live_words" int31)
             (req "live_blocks" int31)
             (req "free_words" int31))
          (obj6
             (req "free_blocks" int31)
             (req "largest_free" int31)
             (req "fragments" int31)
             (req "compactions" int31)
             (req "top_heap_words" int31)
             (req "stack_size" int31))))

let proc_stat_encoding =
  let open Memory in
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        (conv
           (fun {page_size; size; resident; shared; text; lib; data; dt} ->
             (page_size, size, resident, shared, text, lib, data, dt))
           (fun (page_size, size, resident, shared, text, lib, data, dt) ->
             {page_size; size; resident; shared; text; lib; data; dt})
           (obj8
              (req "page_size" int31)
              (req "size" int64)
              (req "resident" int64)
              (req "shared" int64)
              (req "text" int64)
              (req "lib" int64)
              (req "data" int64)
              (req "dt" int64)))
        ~title:"Linux_proc_statm"
        (function Statm x -> Some x | _ -> None)
        (function res -> Statm res);
      case
        (Tag 1)
        (conv
           (fun {page_size; mem; resident} -> (page_size, mem, resident))
           (fun (page_size, mem, resident) -> {page_size; mem; resident})
           (obj3
              (req "page_size" int31)
              (req "mem" float)
              (req "resident" int64)))
        ~title:"Darwin_ps"
        (function Ps x -> Some x | _ -> None)
        (function res -> Ps res) ]

module S = struct
  let gc =
    RPC_service.get_service
      ~description:"Gets stats from the OCaml Garbage Collector"
      ~query:RPC_query.empty
      ~output:gc_stat_encoding
      RPC_path.(root / "stats" / "gc")

  let memory =
    RPC_service.get_service
      ~description:"Gets memory usage stats"
      ~query:RPC_query.empty
      ~output:proc_stat_encoding
      RPC_path.(root / "stats" / "memory")
end

let gc ctxt = RPC_context.make_call S.gc ctxt () () ()

let memory ctxt = RPC_context.make_call S.memory ctxt () () ()
src/lib_shell_services/stat_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Gc.

Definition gc_stat_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Gc.stat :=
  conv
    (fun function_parameter =>
      let '{|
        minor_words := minor_words;
          promoted_words := promoted_words;
          major_words := major_words;
          minor_collections := minor_collections;
          major_collections := major_collections;
          heap_words := heap_words;
          heap_chunks := heap_chunks;
          live_words := live_words;
          live_blocks := live_blocks;
          free_words := free_words;
          free_blocks := free_blocks;
          largest_free := largest_free;
          fragments := fragments;
          compactions := compactions;
          top_heap_words := top_heap_words;
          stack_size := stack_size
          |} := function_parameter in
      ((minor_words, promoted_words, major_words, minor_collections,
        major_collections),
        ((heap_words, heap_chunks, live_words, live_blocks, free_words),
          (free_blocks, largest_free, fragments, compactions, top_heap_words,
            stack_size))))
    (fun function_parameter =>
      let
        '((minor_words, promoted_words, major_words, minor_collections,
          major_collections),
          ((heap_words, heap_chunks, live_words, live_blocks, free_words),
            (free_blocks, largest_free, fragments, compactions, top_heap_words,
              stack_size))) := function_parameter in
      {| minor_words := minor_words; promoted_words := promoted_words;
        major_words := major_words; minor_collections := minor_collections;
        major_collections := major_collections; heap_words := heap_words;
        heap_chunks := heap_chunks; live_words := live_words;
        live_blocks := live_blocks; free_words := free_words;
        free_blocks := free_blocks; largest_free := largest_free;
        fragments := fragments; compactions := compactions;
        top_heap_words := top_heap_words; stack_size := stack_size |}) None
    (merge_objs
      (obj5 (req None None "minor_words" % string float)
        (req None None "promoted_words" % string float)
        (req None None "major_words" % string float)
        (req None None "minor_collections" % string int31)
        (req None None "major_collections" % string int31))
      (merge_objs
        (obj5 (req None None "heap_words" % string int31)
          (req None None "heap_chunks" % string int31)
          (req None None "live_words" % string int31)
          (req None None "live_blocks" % string int31)
          (req None None "free_words" % string int31))
        (obj6 (req None None "free_blocks" % string int31)
          (req None None "largest_free" % string int31)
          (req None None "fragments" % string int31)
          (req None None "compactions" % string int31)
          (req None None "top_heap_words" % string int31)
          (req None None "stack_size" % string int31)))).

Definition proc_stat_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    Tezos_base__TzPervasives.Memory.mem_stats :=
  union
    (Some
      (* ❌ Variants not supported *)
      variant)
    (cons
      (case "Linux_proc_statm" % string None
        (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (conv
          (fun function_parameter =>
            let '{|
              page_size := page_size;
                size := size;
                resident := resident;
                shared := shared;
                text := text;
                lib := lib;
                data := data;
                dt := dt
                |} := function_parameter in
            (page_size, size, resident, shared, text, lib, data, dt))
          (fun function_parameter =>
            let '(page_size, size, resident, shared, text, lib, data, dt) :=
              function_parameter in
            {| page_size := page_size; size := size; resident := resident;
              shared := shared; text := text; lib := lib; data := data; dt := dt
              |}) None
          (obj8 (req None None "page_size" % string int31)
            (req None None "size" % string int64)
            (req None None "resident" % string int64)
            (req None None "shared" % string int64)
            (req None None "text" % string int64)
            (req None None "lib" % string int64)
            (req None None "data" % string int64)
            (req None None "dt" % string int64)))
        (fun function_parameter =>
          match function_parameter with
          | Tezos_base__TzPervasives.Memory.Statm x => Some x
          | _ => None
          end) (fun res => Tezos_base__TzPervasives.Memory.Statm res))
      (cons
        (case "Darwin_ps" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (conv
            (fun function_parameter =>
              let '{|
                page_size := page_size; mem := mem; resident := resident |} :=
                function_parameter in
              (page_size, mem, resident))
            (fun function_parameter =>
              let '(page_size, mem, resident) := function_parameter in
              {| page_size := page_size; mem := mem; resident := resident |})
            None
            (obj3 (req None None "page_size" % string int31)
              (req None None "mem" % string float)
              (req None None "resident" % string int64)))
          (fun function_parameter =>
            match function_parameter with
            | Tezos_base__TzPervasives.Memory.Ps x => Some x
            | _ => None
            end) (fun res => Tezos_base__TzPervasives.Memory.Ps res)) [])).

Module S.
  Definition gc
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Stdlib.Gc.stat :=
    RPC_service.get_service
      (Some "Gets stats from the OCaml Garbage Collector" % string)
      RPC_query.empty gc_stat_encoding
      (op_div (op_div root "stats" % string) "gc" % string).
  
  Definition memory
    : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
      Tezos_base__TzPervasives.Memory.mem_stats :=
    RPC_service.get_service (Some "Gets memory usage stats" % string)
      RPC_query.empty proc_stat_encoding
      (op_div (op_div root "stats" % string) "memory" % string).
End S.

Definition gc {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Stdlib.Gc.stat) :=
  RPC_context.make_call S.gc ctxt tt tt tt.

Definition memory {E F i o p q : Type}
  (ctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Memory.mem_stats) :=
  RPC_context.make_call S.memory ctxt tt tt tt.

src/lib_shell_services/state_logging.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = "node.state"
end)

let chain_id = Tag.def ~doc:"Chain ID" "chain_id" Chain_id.pp
src/lib_shell_services/state_logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition chain_id : Tag.def Tezos_base__TzPervasives.Chain_id.t :=
  Tag.def (Some "Chain ID" % string) "chain_id" % string Chain_id.pp.

src/lib_shell_services/validation_errors.ml 21 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(***************** Prevalidation errors ***********************************)

type error += Parse_error

type error += Too_many_operations

type error += Oversized_operation of {size : int; max : int}

type error +=
  | Future_block_header of {
      block : Block_hash.t;
      block_time : Time.Protocol.t;
      time : Time.System.t;
    }

let () =
  (* Parse error *)
  register_error_kind
    `Permanent
    ~id:"node.prevalidation.parse_error"
    ~title:"Parsing error in prevalidation"
    ~description:
      "Raised when an operation has not been parsed correctly during \
       prevalidation."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Operation parsing error in prevalidation.")
    Data_encoding.empty
    (function Parse_error -> Some () | _ -> None)
    (fun () -> Parse_error) ;
  (* Too many operations *)
  register_error_kind
    `Temporary
    ~id:"node.prevalidation.too_many_operations"
    ~title:"Too many pending operations in prevalidation"
    ~description:"The prevalidation context is full."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Too many operations in prevalidation context.")
    Data_encoding.empty
    (function Too_many_operations -> Some () | _ -> None)
    (fun () -> Too_many_operations) ;
  (* Oversized operation *)
  register_error_kind
    `Permanent
    ~id:"node.prevalidation.oversized_operation"
    ~title:"Oversized operation"
    ~description:"The operation size is bigger than allowed."
    ~pp:(fun ppf (size, max) ->
      Format.fprintf ppf "Oversized operation (size: %d, max: %d)" size max)
    Data_encoding.(obj2 (req "size" int31) (req "max_size" int31))
    (function
      | Oversized_operation {size; max} -> Some (size, max) | _ -> None)
    (fun (size, max) -> Oversized_operation {size; max}) ;
  (* Block from the future *)
  register_error_kind
    `Temporary
    ~id:"node.prevalidation.future_block_header"
    ~title:"Future block header"
    ~description:"The block was annotated with a time too far in the future."
    ~pp:(fun ppf (block, block_time, time) ->
      Format.fprintf
        ppf
        "Future block header (block: %a, block_time: %a, time: %a)"
        Block_hash.pp
        block
        Time.System.pp_hum
        (Time.System.of_protocol_exn block_time)
        Time.System.pp_hum
        time)
    Data_encoding.(
      obj3
        (req "block" Block_hash.encoding)
        (req "block_time" Time.Protocol.encoding)
        (req "time" Time.System.encoding))
    (function
      | Future_block_header {block; block_time; time} ->
          Some (block, block_time, time)
      | _ ->
          None)
    (fun (block, block_time, time) ->
      Future_block_header {block; block_time; time})

(************************* State errors ***********************************)

type error += Unknown_chain of Chain_id.t

type error += Bad_data_dir

type error += Block_not_invalid of Block_hash.t

let () =
  (* Unknown network *)
  register_error_kind
    `Permanent
    ~id:"node.state.unknown_chain"
    ~title:"Unknown chain"
    ~description:
      "The chain identifier could not be found in the chain identifiers table."
    ~pp:(fun ppf id -> Format.fprintf ppf "Unknown chain %a" Chain_id.pp id)
    Data_encoding.(obj1 (req "chain" Chain_id.encoding))
    (function Unknown_chain x -> Some x | _ -> None)
    (fun x -> Unknown_chain x) ;
  register_error_kind
    `Permanent
    ~id:"node.state.bad_data_dir"
    ~title:"Bad data directory"
    ~description:
      "The data directory could not be read. This could be because it was \
       generated with an old version of the tezos-node program. Deleting and \
       regenerating this directory may fix the problem."
    ~pp:(fun ppf () -> Format.fprintf ppf "Bad data directory.")
    Data_encoding.empty
    (function Bad_data_dir -> Some () | _ -> None)
    (fun () -> Bad_data_dir) ;
  (* Block not invalid *)
  register_error_kind
    `Permanent
    ~id:"node.state.block_not_invalid"
    ~title:"Block not invalid"
    ~description:"The invalid block to be unmarked was not actually invalid."
    ~pp:(fun ppf block ->
      Format.fprintf
        ppf
        "Block %a was expected to be invalid, but was not actually invalid."
        Block_hash.pp
        block)
    Data_encoding.(obj1 (req "block" Block_hash.encoding))
    (function Block_not_invalid block -> Some block | _ -> None)
    (fun block -> Block_not_invalid block)

(* Block database error *)

type error += Inconsistent_hash of Context_hash.t * Context_hash.t

let () =
  (* Inconsistent hash *)
  register_error_kind
    `Permanent
    ~id:"node.state.block.inconsistent_context_hash"
    ~title:"Inconsistent commit hash"
    ~description:
      "When commiting the context of a block, the announced context hash was \
       not the one computed at commit time."
    ~pp:(fun ppf (got, exp) ->
      Format.fprintf
        ppf
        "@[<v 2>Inconsistent hash:@ got: %a@ expected: %a"
        Context_hash.pp
        got
        Context_hash.pp
        exp)
    Data_encoding.(
      obj2
        (req "wrong_context_hash" Context_hash.encoding)
        (req "expected_context_hash" Context_hash.encoding))
    (function Inconsistent_hash (got, exp) -> Some (got, exp) | _ -> None)
    (fun (got, exp) -> Inconsistent_hash (got, exp))

(******************* Bootstrap pipeline errors ****************************)

type error += Invalid_locator of P2p_peer.Id.t * Block_locator.t

type error += Too_short_locator of P2p_peer.Id.t * Block_locator.t

let () =
  (* Invalid locator *)
  register_error_kind
    `Permanent
    ~id:"node.bootstrap_pipeline.invalid_locator"
    ~title:"Invalid block locator"
    ~description:"Block locator is invalid."
    ~pp:(fun ppf (id, locator) ->
      Format.fprintf
        ppf
        "Invalid block locator on peer %a:\n%a"
        P2p_peer.Id.pp
        id
        Block_locator.pp
        locator)
    Data_encoding.(
      obj2
        (req "id" P2p_peer.Id.encoding)
        (req "locator" Block_locator.encoding))
    (function Invalid_locator (id, loc) -> Some (id, loc) | _ -> None)
    (fun (id, loc) -> Invalid_locator (id, loc)) ;
  (* Too short locator *)
  register_error_kind
    `Permanent
    ~id:"node.bootstrap_pipeline.too_short_locator"
    ~title:"Too short locator"
    ~description:"Block locator is too short."
    ~pp:(fun ppf (id, locator) ->
      Format.fprintf
        ppf
        "Too short locator on peer %a:\n%a"
        P2p_peer.Id.pp
        id
        Block_locator.pp
        locator)
    Data_encoding.(
      obj2
        (req "id" P2p_peer.Id.encoding)
        (req "locator" Block_locator.encoding))
    (function Too_short_locator (id, loc) -> Some (id, loc) | _ -> None)
    (fun (id, loc) -> Too_short_locator (id, loc))

(******************* Protocol validator errors ****************************)

type protocol_error = Compilation_failed | Dynlinking_failed

type error +=
  | Invalid_protocol of {hash : Protocol_hash.t; error : protocol_error}

let protocol_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Compilation failed"
        (obj1 (req "error" (constant "compilation_failed")))
        (function Compilation_failed -> Some () | _ -> None)
        (fun () -> Compilation_failed);
      case
        (Tag 1)
        ~title:"Dynlinking failed"
        (obj1 (req "error" (constant "dynlinking_failed")))
        (function Dynlinking_failed -> Some () | _ -> None)
        (fun () -> Dynlinking_failed) ]

let pp_protocol_error ppf = function
  | Compilation_failed ->
      Format.fprintf ppf "compilation error"
  | Dynlinking_failed ->
      Format.fprintf ppf "dynlinking error"

let () =
  (* Invalid protocol *)
  register_error_kind
    `Permanent
    ~id:"node.protocol_validator.invalid_protocol"
    ~title:"Invalid protocol"
    ~description:"Invalid protocol."
    ~pp:(fun ppf (protocol, error) ->
      Format.fprintf
        ppf
        "@[<v 2>Invalid protocol %a@ %a@]"
        Protocol_hash.pp_short
        protocol
        pp_protocol_error
        error)
    Data_encoding.(
      merge_objs
        (obj1 (req "invalid_protocol" Protocol_hash.encoding))
        protocol_error_encoding)
    (function
      | Invalid_protocol {hash; error} -> Some (hash, error) | _ -> None)
    (fun (hash, error) -> Invalid_protocol {hash; error})

(********************* Peer validator errors ******************************)

type error += Unknown_ancestor | Known_invalid

let () =
  (* Unknown ancestor *)
  register_error_kind
    `Permanent
    ~id:"node.peer_validator.unknown_ancestor"
    ~title:"Unknown ancestor"
    ~description:"Unknown ancestor block found in the peer's chain"
    ~pp:(fun ppf () -> Format.fprintf ppf "Unknown ancestor")
    Data_encoding.empty
    (function Unknown_ancestor -> Some () | _ -> None)
    (fun () -> Unknown_ancestor) ;
  (* Known invalid *)
  register_error_kind
    `Permanent
    ~id:"node.peer_validator.known_invalid"
    ~title:"Known invalid"
    ~description:"Known invalid block found in the peer's chain"
    ~pp:(fun ppf () -> Format.fprintf ppf "Known invalid")
    Data_encoding.empty
    (function Known_invalid -> Some () | _ -> None)
    (fun () -> Known_invalid)

(************************ Validator errors ********************************)

type error += Inactive_chain of Chain_id.t

type error += Checkpoint_error of Block_hash.t * P2p_peer.Id.t option

let () =
  (* Inactive network *)
  register_error_kind
    `Branch
    ~id:"node.validator.inactive_chain"
    ~title:"Inactive chain"
    ~description:"Attempted validation of a block from an inactive chain."
    ~pp:(fun ppf chain ->
      Format.fprintf
        ppf
        "Tried to validate a block from chain %a, that is not currently \
         considered active."
        Chain_id.pp
        chain)
    Data_encoding.(obj1 (req "inactive_chain" Chain_id.encoding))
    (function Inactive_chain chain -> Some chain | _ -> None)
    (fun chain -> Inactive_chain chain) ;
  register_error_kind
    `Branch
    ~id:"node.validator.checkpoint_error"
    ~title:"Block incompatible with the current checkpoint."
    ~description:
      "The block belongs to a branch that is not compatible with the current \
       checkpoint."
    ~pp:(fun ppf (block, peer) ->
      match peer with
      | None ->
          Format.fprintf
            ppf
            "The block %a is incompatible with the current checkpoint."
            Block_hash.pp_short
            block
      | Some peer ->
          Format.fprintf
            ppf
            "The peer %a send us a block which is a sibling of the configured \
             checkpoint (%a)."
            P2p_peer.Id.pp
            peer
            Block_hash.pp_short
            block)
    Data_encoding.(
      obj2 (req "block" Block_hash.encoding) (opt "peer" P2p_peer.Id.encoding))
    (function
      | Checkpoint_error (block, peer) -> Some (block, peer) | _ -> None)
    (fun (block, peer) -> Checkpoint_error (block, peer))
src/lib_shell_services/validation_errors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Inductive protocol_error : Type :=
| Compilation_failed : protocol_error
| Dynlinking_failed : protocol_error.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition protocol_error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding protocol_error :=
  union None
    (cons
      (case "Compilation failed" % string None
        (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (obj1
          (req None None "error" % string
            (constant "compilation_failed" % string)))
        (fun function_parameter =>
          match function_parameter with
          | Compilation_failed => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Compilation_failed))
      (cons
        (case "Dynlinking failed" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj1
            (req None None "error" % string
              (constant "dynlinking_failed" % string)))
          (fun function_parameter =>
            match function_parameter with
            | Dynlinking_failed => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Dynlinking_failed)) [])).

Definition pp_protocol_error
  (ppf : Stdlib.Format.formatter) (function_parameter : protocol_error)
  : unit :=
  match function_parameter with
  | Compilation_failed =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "compilation error" % string
          CamlinternalFormatBasics.End_of_format) "compilation error" % string)
  | Dynlinking_failed =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "dynlinking error" % string
          CamlinternalFormatBasics.End_of_format) "dynlinking error" % string)
  end.



(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



src/lib_shell_services/worker_services.ml 70 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Data_encoding

module Prevalidators = struct
  module S = struct
    let list =
      RPC_service.get_service
        ~description:"Lists the Prevalidator workers and their status."
        ~query:RPC_query.empty
        ~output:
          (list
             (obj4
                (req "chain_id" Chain_id.encoding)
                (req
                   "status"
                   (Worker_types.worker_status_encoding RPC_error.encoding))
                (req
                   "information"
                   (Worker_types.worker_information_encoding RPC_error.encoding))
                (req "pipelines" int8)))
        RPC_path.(root / "workers" / "prevalidators")

    let state =
      RPC_service.get_service
        ~description:"Introspect the state of prevalidator workers."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Prevalidator_worker_state.Request.encoding
             Prevalidator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(
          root / "workers" / "prevalidators" /: Chain_services.chain_arg)
  end

  open RPC_context

  let list ctxt = make_call S.list ctxt () () ()

  let state ctxt h = make_call1 S.state ctxt h () ()
end

module Block_validator = struct
  module S = struct
    let state =
      RPC_service.get_service
        ~description:"Introspect the state of the block_validator worker."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Block_validator_worker_state.Request.encoding
             Block_validator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(root / "workers" / "block_validator")
  end

  open RPC_context

  let state ctxt = make_call S.state ctxt () () ()
end

module Peer_validators = struct
  module S = struct
    let list =
      RPC_service.get_service
        ~description:"Lists the peer validator workers and their status."
        ~query:RPC_query.empty
        ~output:
          (list
             (obj4
                (req "peer_id" P2p_peer.Id.encoding)
                (req
                   "status"
                   (Worker_types.worker_status_encoding RPC_error.encoding))
                (req
                   "information"
                   (Worker_types.worker_information_encoding RPC_error.encoding))
                (req
                   "pipelines"
                   Peer_validator_worker_state.Worker_state
                   .pipeline_length_encoding)))
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg
          / "peers_validators")

    let state =
      RPC_service.get_service
        ~description:"Introspect the state of a peer validator worker."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Peer_validator_worker_state.Request.encoding
             Peer_validator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg
          / "peers_validators" /: P2p_peer.Id.rpc_arg)
  end

  open RPC_context

  let list ctxt n = make_call1 S.list ctxt n () ()

  let state ctxt n h = make_call2 S.state ctxt n h () ()
end

module Chain_validators = struct
  module S = struct
    let list =
      RPC_service.get_service
        ~description:"Lists the chain validator workers and their status."
        ~query:RPC_query.empty
        ~output:
          (list
             (obj4
                (req "chain_id" Chain_id.encoding)
                (req
                   "status"
                   (Worker_types.worker_status_encoding RPC_error.encoding))
                (req
                   "information"
                   (Worker_types.worker_information_encoding RPC_error.encoding))
                (req "pipelines" int8)))
        RPC_path.(root / "workers" / "chain_validators")

    let state =
      RPC_service.get_service
        ~description:"Introspect the state of a chain validator worker."
        ~query:RPC_query.empty
        ~output:
          (Worker_types.full_status_encoding
             Chain_validator_worker_state.Request.encoding
             Chain_validator_worker_state.Event.encoding
             RPC_error.encoding)
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg)

    let ddb_state =
      RPC_service.get_service
        ~description:
          "Introspect the state of the DDB attached to a chain validator \
           worker."
        ~query:RPC_query.empty
        ~output:Chain_validator_worker_state.Distributed_db_state.encoding
        RPC_path.(
          root / "workers" / "chain_validators" /: Chain_services.chain_arg
          / "ddb")
  end

  open RPC_context

  let list ctxt = make_call S.list ctxt () () ()

  let state ctxt h = make_call1 S.state ctxt h () ()

  let ddb_state ctxt h = make_call1 S.ddb_state ctxt h () ()
end
src/lib_shell_services/worker_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Data_encoding.

Module Prevalidators.
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z)) :=
      RPC_service.get_service
        (Some "Lists the Prevalidator workers and their status." % string)
        RPC_query.empty
        (list None
          (obj4 (req None None "chain_id" % string Chain_id.encoding)
            (req None None "status" % string
              (Worker_types.worker_status_encoding RPC_error.encoding))
            (req None None "information" % string
              (Worker_types.worker_information_encoding RPC_error.encoding))
            (req None None "pipelines" % string int8)))
        (op_div (op_div root "workers" % string) "prevalidators" % string).
    
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Prevalidator_worker_state.Request.view
          Tezos_shell_services.Prevalidator_worker_state.Event.t) :=
      RPC_service.get_service
        (Some "Introspect the state of prevalidator workers." % string)
        RPC_query.empty
        (Worker_types.full_status_encoding
          Prevalidator_worker_state.Request.encoding
          Prevalidator_worker_state.Event.encoding RPC_error.encoding)
        (op_divcolon
          (op_div (op_div root "workers" % string) "prevalidators" % string)
          Chain_services.chain_arg).
  End S.
  
  Import RPC_context.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z))) :=
    make_call S.list ctxt tt tt tt.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (h : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Prevalidator_worker_state.Request.view
          Tezos_shell_services.Prevalidator_worker_state.Event.t)) :=
    make_call1 S.state ctxt h tt tt.
End Prevalidators.

Module Block_validator.
  Module S.
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Block_validator_worker_state.Request.view
          Tezos_shell_services.Block_validator_worker_state.Event.t) :=
      RPC_service.get_service
        (Some "Introspect the state of the block_validator worker." % string)
        RPC_query.empty
        (Worker_types.full_status_encoding
          Block_validator_worker_state.Request.encoding
          Block_validator_worker_state.Event.encoding RPC_error.encoding)
        (op_div (op_div root "workers" % string) "block_validator" % string).
  End S.
  
  Import RPC_context.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Block_validator_worker_state.Request.view
          Tezos_shell_services.Block_validator_worker_state.Event.t)) :=
    make_call S.state ctxt tt tt tt.
End Block_validator.

Module Peer_validators.
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        (list
          (Tezos_base__TzPervasives.P2p_peer.Id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information *
            Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length)) :=
      RPC_service.get_service
        (Some "Lists the peer validator workers and their status." % string)
        RPC_query.empty
        (list None
          (obj4 (req None None "peer_id" % string P2p_peer.Id.encoding)
            (req None None "status" % string
              (Worker_types.worker_status_encoding RPC_error.encoding))
            (req None None "information" % string
              (Worker_types.worker_information_encoding RPC_error.encoding))
            (req None None "pipelines" % string
              Peer_validator_worker_state.Worker_state.pipeline_length_encoding)))
        (op_div
          (op_divcolon
            (op_div (op_div root "workers" % string) "chain_validators" % string)
            Chain_services.chain_arg) "peers_validators" % string).
    
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        ((unit * Tezos_shell_services.Chain_services.chain) *
          Tezos_base__TzPervasives.P2p_peer.Id.t) unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Peer_validator_worker_state.Request.view
          Tezos_shell_services.Peer_validator_worker_state.Event.t) :=
      RPC_service.get_service
        (Some "Introspect the state of a peer validator worker." % string)
        RPC_query.empty
        (Worker_types.full_status_encoding
          Peer_validator_worker_state.Request.encoding
          Peer_validator_worker_state.Event.encoding RPC_error.encoding)
        (op_divcolon
          (op_div
            (op_divcolon
              (op_div (op_div root "workers" % string)
                "chain_validators" % string) Chain_services.chain_arg)
            "peers_validators" % string) P2p_peer.Id.rpc_arg).
  End S.
  
  Import RPC_context.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (n : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.P2p_peer.Id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information *
            Tezos_shell_services.Peer_validator_worker_state.Worker_state.pipeline_length))) :=
    make_call1 S.list ctxt n tt tt.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (n : Tezos_shell_services.Chain_services.chain)
    (h : Tezos_base__TzPervasives.P2p_peer.Id.t)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Peer_validator_worker_state.Request.view
          Tezos_shell_services.Peer_validator_worker_state.Event.t)) :=
    make_call2 S.state ctxt n h tt tt.
End Peer_validators.

Module Chain_validators.
  Module S.
    Definition list
      : Tezos_base__TzPervasives.RPC_service.service variant unit unit unit unit
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z)) :=
      RPC_service.get_service
        (Some "Lists the chain validator workers and their status." % string)
        RPC_query.empty
        (list None
          (obj4 (req None None "chain_id" % string Chain_id.encoding)
            (req None None "status" % string
              (Worker_types.worker_status_encoding RPC_error.encoding))
            (req None None "information" % string
              (Worker_types.worker_information_encoding RPC_error.encoding))
            (req None None "pipelines" % string int8)))
        (op_div (op_div root "workers" % string) "chain_validators" % string).
    
    Definition state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Chain_validator_worker_state.Request.view
          Tezos_shell_services.Chain_validator_worker_state.Event.t) :=
      RPC_service.get_service
        (Some "Introspect the state of a chain validator worker." % string)
        RPC_query.empty
        (Worker_types.full_status_encoding
          Chain_validator_worker_state.Request.encoding
          Chain_validator_worker_state.Event.encoding RPC_error.encoding)
        (op_divcolon
          (op_div (op_div root "workers" % string) "chain_validators" % string)
          Chain_services.chain_arg).
    
    Definition ddb_state
      : Tezos_base__TzPervasives.RPC_service.service variant unit
        (unit * Tezos_shell_services.Chain_services.chain) unit unit
        Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view :=
      RPC_service.get_service
        (Some
          "Introspect the state of the DDB attached to a chain validator worker."
            % string) RPC_query.empty
        Chain_validator_worker_state.Distributed_db_state.encoding
        (op_div
          (op_divcolon
            (op_div (op_div root "workers" % string) "chain_validators" % string)
            Chain_services.chain_arg) "ddb" % string).
  End S.
  
  Import RPC_context.
  
  Definition list {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (list
          (Tezos_base__TzPervasives.Chain_id.t *
            Tezos_shell_services.Worker_types.worker_status *
            Tezos_shell_services.Worker_types.worker_information * Z))) :=
    make_call S.list ctxt tt tt tt.
  
  Definition state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (h : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        (Tezos_shell_services.Worker_types.full_status
          Tezos_shell_services.Chain_validator_worker_state.Request.view
          Tezos_shell_services.Chain_validator_worker_state.Event.t)) :=
    make_call1 S.state ctxt h tt tt.
  
  Definition ddb_state {E F i o p q : Type}
    (ctxt :
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * F) * F)
    (h : Tezos_shell_services.Chain_services.chain)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_shell_services.Chain_validator_worker_state.Distributed_db_state.view) :=
    make_call1 S.ddb_state ctxt h tt tt.
End Chain_validators.

src/lib_shell_services/worker_types.ml 28 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type limits = {backlog_size : int; backlog_level : Internal_event.level}

type worker_status =
  | Launching of Time.System.t
  | Running of Time.System.t
  | Closing of Time.System.t * Time.System.t
  | Closed of Time.System.t * Time.System.t * error list option

let worker_status_encoding error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Launching"
        (obj2
           (req "phase" (constant "launching"))
           (req "since" Time.System.encoding))
        (function Launching t -> Some ((), t) | _ -> None)
        (fun ((), t) -> Launching t);
      case
        (Tag 1)
        ~title:"Running"
        (obj2
           (req "phase" (constant "running"))
           (req "since" Time.System.encoding))
        (function Running t -> Some ((), t) | _ -> None)
        (fun ((), t) -> Running t);
      case
        (Tag 2)
        ~title:"Closing"
        (obj3
           (req "phase" (constant "closing"))
           (req "birth" Time.System.encoding)
           (req "since" Time.System.encoding))
        (function Closing (t0, t) -> Some ((), t0, t) | _ -> None)
        (fun ((), t0, t) -> Closing (t0, t));
      case
        (Tag 3)
        ~title:"Closed"
        (obj3
           (req "phase" (constant "closed"))
           (req "birth" Time.System.encoding)
           (req "since" Time.System.encoding))
        (function Closed (t0, t, None) -> Some ((), t0, t) | _ -> None)
        (fun ((), t0, t) -> Closed (t0, t, None));
      case
        (Tag 4)
        ~title:"Crashed"
        (obj4
           (req "phase" (constant "crashed"))
           (req "birth" Time.System.encoding)
           (req "since" Time.System.encoding)
           (req "errors" error_encoding))
        (function
          | Closed (t0, t, Some errs) -> Some ((), t0, t, errs) | _ -> None)
        (fun ((), t0, t, errs) -> Closed (t0, t, Some errs)) ]

type worker_information = {
  instances_number : int;
  wstatus : worker_status;
  queue_length : int;
}

let worker_information_encoding error_encoding =
  Data_encoding.(
    conv
      (fun {instances_number; wstatus; queue_length} ->
        (instances_number, wstatus, queue_length))
      (fun (instances_number, wstatus, queue_length) ->
        {instances_number; wstatus; queue_length})
      (obj3
         (req "instances" int31)
         (req "status" (worker_status_encoding error_encoding))
         (req "queue_length" int31)))

type request_status = {
  pushed : Time.System.t;
  treated : Time.System.t;
  completed : Time.System.t;
}

let request_status_encoding =
  let open Data_encoding in
  conv
    (fun {pushed; treated; completed} -> (pushed, treated, completed))
    (fun (pushed, treated, completed) -> {pushed; treated; completed})
    (obj3
       (req "pushed" Time.System.encoding)
       (req "treated" Time.System.encoding)
       (req "completed" Time.System.encoding))

type ('req, 'evt) full_status = {
  status : worker_status;
  pending_requests : (Time.System.t * 'req) list;
  backlog : (Internal_event.level * 'evt list) list;
  current_request : (Time.System.t * Time.System.t * 'req) option;
}

let full_status_encoding req_encoding evt_encoding error_encoding =
  let open Data_encoding in
  let requests_encoding =
    list
      (obj2
         (req "pushed" Time.System.encoding)
         (req "request" (dynamic_size req_encoding)))
  in
  let events_encoding =
    list
      (obj2
         (req "level" Internal_event.Level.encoding)
         (req "events" (dynamic_size (list (dynamic_size evt_encoding)))))
  in
  let current_request_encoding =
    obj3
      (req "pushed" Time.System.encoding)
      (req "treated" Time.System.encoding)
      (req "request" req_encoding)
  in
  conv
    (fun {status; pending_requests; backlog; current_request} ->
      (status, pending_requests, backlog, current_request))
    (fun (status, pending_requests, backlog, current_request) ->
      {status; pending_requests; backlog; current_request})
    (obj4
       (req "status" (worker_status_encoding error_encoding))
       (req "pending_requests" requests_encoding)
       (req "backlog" events_encoding)
       (opt "current_request" current_request_encoding))

let pp_status ppf {pushed; treated; completed} =
  let completed = Ptime.diff completed treated
  and treated = Ptime.diff treated pushed in
  Format.fprintf
    ppf
    "Request pushed on %a, treated in %a, completed in %a "
    Time.System.pp_hum
    pushed
    Ptime.Span.pp
    treated
    Ptime.Span.pp
    completed
src/lib_shell_services/worker_types.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record limits := {
  backlog_size : Z;
  backlog_level : Tezos_base__TzPervasives.Internal_event.level }.

Inductive worker_status : Type :=
| Launching : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Running : Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closing : Tezos_base__TzPervasives.Time.System.t ->
  Tezos_base__TzPervasives.Time.System.t -> worker_status
| Closed : Tezos_base__TzPervasives.Time.System.t ->
  Tezos_base__TzPervasives.Time.System.t ->
  (option (list Tezos_base__TzPervasives.error)) -> worker_status.

Definition worker_status_encoding
  (error_encoding :
    Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.error))
  : Tezos_base__TzPervasives.Data_encoding.encoding worker_status :=
  union None
    (cons
      (case "Launching" % string None
        (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        (obj2 (req None None "phase" % string (constant "launching" % string))
          (req None None "since" % string Time.System.encoding))
        (fun function_parameter =>
          match function_parameter with
          | Launching t => Some (tt, t)
          | _ => None
          end)
        (fun function_parameter =>
          let '(tt, t) := function_parameter in
          Launching t))
      (cons
        (case "Running" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj2 (req None None "phase" % string (constant "running" % string))
            (req None None "since" % string Time.System.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Running t => Some (tt, t)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, t) := function_parameter in
            Running t))
        (cons
          (case "Closing" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 2)
            (obj3 (req None None "phase" % string (constant "closing" % string))
              (req None None "birth" % string Time.System.encoding)
              (req None None "since" % string Time.System.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Closing t0 t => Some (tt, t0, t)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, t0, t) := function_parameter in
              Closing t0 t))
          (cons
            (case "Closed" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 3)
              (obj3
                (req None None "phase" % string (constant "closed" % string))
                (req None None "birth" % string Time.System.encoding)
                (req None None "since" % string Time.System.encoding))
              (fun function_parameter =>
                match function_parameter with
                | Closed t0 t None => Some (tt, t0, t)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, t0, t) := function_parameter in
                Closed t0 t None))
            (cons
              (case "Crashed" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 4)
                (obj4
                  (req None None "phase" % string (constant "crashed" % string))
                  (req None None "birth" % string Time.System.encoding)
                  (req None None "since" % string Time.System.encoding)
                  (req None None "errors" % string error_encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | Closed t0 t (Some errs) => Some (tt, t0, t, errs)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, t0, t, errs) := function_parameter in
                  Closed t0 t (Some errs))) []))))).

Record worker_information := {
  instances_number : Z;
  wstatus : worker_status;
  queue_length : Z }.

Definition worker_information_encoding
  (error_encoding :
    Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.error))
  : Tezos_base__TzPervasives.Data_encoding.encoding worker_information :=
  conv
    (fun function_parameter =>
      let '{|
        instances_number := instances_number;
          wstatus := wstatus;
          queue_length := queue_length
          |} := function_parameter in
      (instances_number, wstatus, queue_length))
    (fun function_parameter =>
      let '(instances_number, wstatus, queue_length) := function_parameter in
      {| instances_number := instances_number; wstatus := wstatus;
        queue_length := queue_length |}) None
    (obj3 (req None None "instances" % string int31)
      (req None None "status" % string (worker_status_encoding error_encoding))
      (req None None "queue_length" % string int31)).

Record request_status := {
  pushed : Tezos_base__TzPervasives.Time.System.t;
  treated : Tezos_base__TzPervasives.Time.System.t;
  completed : Tezos_base__TzPervasives.Time.System.t }.

Definition request_status_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding request_status :=
  conv
    (fun function_parameter =>
      let '{| pushed := pushed; treated := treated; completed := completed |} :=
        function_parameter in
      (pushed, treated, completed))
    (fun function_parameter =>
      let '(pushed, treated, completed) := function_parameter in
      {| pushed := pushed; treated := treated; completed := completed |}) None
    (obj3 (req None None "pushed" % string Time.System.encoding)
      (req None None "treated" % string Time.System.encoding)
      (req None None "completed" % string Time.System.encoding)).

Record full_status {req evt : Type} := {
  status : worker_status;
  pending_requests : list (Tezos_base__TzPervasives.Time.System.t * req);
  backlog : list (Tezos_base__TzPervasives.Internal_event.level * (list evt));
  current_request :
    option
      (Tezos_base__TzPervasives.Time.System.t *
        Tezos_base__TzPervasives.Time.System.t * req) }.
Arguments full_status : clear implicits.

Definition full_status_encoding {A B : Type}
  (req_encoding : Tezos_base__TzPervasives.Data_encoding.encoding A)
  (evt_encoding : Tezos_base__TzPervasives.Data_encoding.encoding B)
  (error_encoding :
    Tezos_base__TzPervasives.Data_encoding.encoding
      (list Tezos_base__TzPervasives.error))
  : Tezos_base__TzPervasives.Data_encoding.encoding (full_status A B) :=
  let requests_encoding :=
    list None
      (obj2 (req None None "pushed" % string Time.System.encoding)
        (req None None "request" % string (dynamic_size None req_encoding))) in
  let events_encoding :=
    list None
      (obj2 (req None None "level" % string Internal_event.Level.encoding)
        (req None None "events" % string
          (dynamic_size None (list None (dynamic_size None evt_encoding))))) in
  let current_request_encoding :=
    obj3 (req None None "pushed" % string Time.System.encoding)
      (req None None "treated" % string Time.System.encoding)
      (req None None "request" % string req_encoding) in
  conv
    (fun function_parameter =>
      let '{|
        status := status;
          pending_requests := pending_requests;
          backlog := backlog;
          current_request := current_request
          |} := function_parameter in
      (status, pending_requests, backlog, current_request))
    (fun function_parameter =>
      let '(status, pending_requests, backlog, current_request) :=
        function_parameter in
      {| status := status; pending_requests := pending_requests;
        backlog := backlog; current_request := current_request |}) None
    (obj4
      (req None None "status" % string (worker_status_encoding error_encoding))
      (req None None "pending_requests" % string requests_encoding)
      (req None None "backlog" % string events_encoding)
      (opt None None "current_request" % string current_request_encoding)).

Definition pp_status
  (ppf : Stdlib.Format.formatter) (function_parameter : request_status)
  : unit :=
  let '{| pushed := pushed; treated := treated; completed := completed |} :=
    function_parameter in
  let completed : Ptime.span :=
    Ptime.diff completed treated
  with treated : Ptime.span :=
    Ptime.diff treated pushed in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "Request pushed on " % string
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.String_literal ", treated in " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                ", completed in " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal " " % char
                    CamlinternalFormatBasics.End_of_format)))))))
      "Request pushed on %a, treated in %a, completed in %a " % string)
    Time.System.pp_hum pushed Ptime.Span.pp treated Ptime.Span.pp completed.

src/lib_signer_backends/encrypted.ml 135 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type Base58.data += Encrypted_ed25519 of Bytes.t

type Base58.data += Encrypted_secp256k1 of Bytes.t

type Base58.data += Encrypted_p256 of Bytes.t

open Client_keys

let scheme = "encrypted"

module Raw = struct
  (* https://tools.ietf.org/html/rfc2898#section-4.1 *)
  let salt_len = 8

  (* Fixed zero nonce *)
  let nonce = Crypto_box.zero_nonce

  (* Secret keys for Ed25519, secp256k1, P256 are 32 bytes long. *)
  let encrypted_size = Crypto_box.boxzerobytes + 32

  let pbkdf ~salt ~password =
    Pbkdf.SHA512.pbkdf2 ~count:32768 ~dk_len:32l ~salt ~password

  let encrypt ~password sk =
    let salt = Hacl.Rand.gen salt_len in
    let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in
    let msg =
      match (sk : Signature.secret_key) with
      | Ed25519 sk ->
          Data_encoding.Binary.to_bytes_exn Ed25519.Secret_key.encoding sk
      | Secp256k1 sk ->
          Data_encoding.Binary.to_bytes_exn Secp256k1.Secret_key.encoding sk
      | P256 sk ->
          Data_encoding.Binary.to_bytes_exn P256.Secret_key.encoding sk
    in
    Bigstring.concat "" [salt; Crypto_box.Secretbox.box key msg nonce]

  let decrypt algo ~password ~encrypted_sk =
    let salt = Bigstring.sub encrypted_sk 0 salt_len in
    let encrypted_sk = Bigstring.sub encrypted_sk salt_len encrypted_size in
    let key = Crypto_box.Secretbox.unsafe_of_bytes (pbkdf ~salt ~password) in
    match (Crypto_box.Secretbox.box_open key encrypted_sk nonce, algo) with
    | (None, _) ->
        return_none
    | (Some bytes, Signature.Ed25519) -> (
      match
        Data_encoding.Binary.of_bytes Ed25519.Secret_key.encoding bytes
      with
      | Some sk ->
          return_some (Ed25519 sk : Signature.Secret_key.t)
      | None ->
          failwith
            "Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
      )
    | (Some bytes, Signature.Secp256k1) -> (
      match
        Data_encoding.Binary.of_bytes Secp256k1.Secret_key.encoding bytes
      with
      | Some sk ->
          return_some (Secp256k1 sk : Signature.Secret_key.t)
      | None ->
          failwith
            "Corrupted wallet, deciphered key is not a valid Secp256k1 secret \
             key" )
    | (Some bytes, Signature.P256) -> (
      match Data_encoding.Binary.of_bytes P256.Secret_key.encoding bytes with
      | Some sk ->
          return_some (P256 sk : Signature.Secret_key.t)
      | None ->
          failwith
            "Corrupted wallet, deciphered key is not a valid P256 secret key" )
end

module Encodings = struct
  let ed25519 =
    let length = Hacl.Sign.skbytes + Crypto_box.boxzerobytes + Raw.salt_len in
    Base58.register_encoding
      ~prefix:Base58.Prefix.ed25519_encrypted_seed
      ~length
      ~to_raw:(fun sk -> Bytes.to_string sk)
      ~of_raw:(fun buf ->
        if String.length buf <> length then None
        else Some (Bytes.of_string buf))
      ~wrap:(fun sk -> Encrypted_ed25519 sk)

  let secp256k1 =
    let open Libsecp256k1.External in
    let length = Key.secret_bytes + Crypto_box.boxzerobytes + Raw.salt_len in
    Base58.register_encoding
      ~prefix:Base58.Prefix.secp256k1_encrypted_secret_key
      ~length
      ~to_raw:(fun sk -> Bytes.to_string sk)
      ~of_raw:(fun buf ->
        if String.length buf <> length then None
        else Some (Bytes.of_string buf))
      ~wrap:(fun sk -> Encrypted_secp256k1 sk)

  let p256 =
    let length =
      Uecc.(sk_size secp256r1) + Crypto_box.boxzerobytes + Raw.salt_len
    in
    Base58.register_encoding
      ~prefix:Base58.Prefix.p256_encrypted_secret_key
      ~length
      ~to_raw:(fun sk -> Bytes.to_string sk)
      ~of_raw:(fun buf ->
        if String.length buf <> length then None
        else Some (Bytes.of_string buf))
      ~wrap:(fun sk -> Encrypted_p256 sk)

  let () =
    Base58.check_encoded_prefix ed25519 "edesk" 88 ;
    Base58.check_encoded_prefix secp256k1 "spesk" 88 ;
    Base58.check_encoded_prefix p256 "p2esk" 88
end

let decrypted = Hashtbl.create 13

(* we cache the password in this list to avoid
   asking the user all the time *)
let passwords = ref []

let rec interactive_decrypt_loop (cctxt : #Client_context.prompter) ?name
    ~encrypted_sk algo =
  ( match name with
  | None ->
      cctxt#prompt_password "Enter password for encrypted key: "
  | Some name ->
      cctxt#prompt_password "Enter password for encrypted key \"%s\": " name )
  >>=? fun password ->
  Raw.decrypt algo ~password ~encrypted_sk
  >>=? function
  | Some sk ->
      passwords := password :: !passwords ;
      return sk
  | None ->
      interactive_decrypt_loop cctxt ?name ~encrypted_sk algo

(* add all passwords obtained by [ctxt#load_passwords] to the list of known passwords *)
let password_file_load ctxt =
  match ctxt#load_passwords with
  | Some stream ->
      Lwt_stream.iter
        (fun p -> passwords := Bigstring.of_string p :: !passwords)
        stream
      >>= fun () -> return_unit
  | None ->
      return_unit

let rec noninteractive_decrypt_loop algo ~encrypted_sk = function
  | [] ->
      return_none
  | password :: passwords -> (
      Raw.decrypt algo ~password ~encrypted_sk
      >>=? function
      | None ->
          noninteractive_decrypt_loop algo ~encrypted_sk passwords
      | Some sk ->
          return_some sk )

let decrypt_payload cctxt ?name encrypted_sk =
  ( match Base58.decode encrypted_sk with
  | Some (Encrypted_ed25519 encrypted_sk) ->
      return (Signature.Ed25519, encrypted_sk)
  | Some (Encrypted_secp256k1 encrypted_sk) ->
      return (Signature.Secp256k1, encrypted_sk)
  | Some (Encrypted_p256 encrypted_sk) ->
      return (Signature.P256, encrypted_sk)
  | _ ->
      failwith "Not a Base58Check-encoded encrypted key" )
  >>=? fun (algo, encrypted_sk) ->
  let encrypted_sk = Bigstring.of_bytes encrypted_sk in
  noninteractive_decrypt_loop algo ~encrypted_sk !passwords
  >>=? function
  | Some sk ->
      return sk
  | None ->
      interactive_decrypt_loop cctxt ?name ~encrypted_sk algo

let decrypt (cctxt : #Client_context.prompter) ?name sk_uri =
  let payload = Uri.path (sk_uri : sk_uri :> Uri.t) in
  decrypt_payload cctxt ?name payload
  >>=? fun sk ->
  Hashtbl.replace decrypted sk_uri sk ;
  return sk

let decrypt_all (cctxt : #Client_context.io_wallet) =
  Secret_key.load cctxt
  >>=? fun sks ->
  password_file_load cctxt
  >>=? fun () ->
  iter_s
    (fun (name, sk_uri) ->
      if Uri.scheme (sk_uri : sk_uri :> Uri.t) <> Some scheme then return_unit
      else decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit)
    sks

let decrypt_list (cctxt : #Client_context.io_wallet) keys =
  Secret_key.load cctxt
  >>=? fun sks ->
  password_file_load cctxt
  >>=? fun () ->
  iter_s
    (fun (name, sk_uri) ->
      if
        Uri.scheme (sk_uri : sk_uri :> Uri.t) = Some scheme
        && (keys = [] || List.mem name keys)
      then decrypt cctxt ~name sk_uri >>=? fun _ -> return_unit
      else return_unit)
    sks

let rec read_password (cctxt : #Client_context.io) =
  cctxt#prompt_password "Enter password to encrypt your key: "
  >>=? fun password ->
  cctxt#prompt_password "Confirm password: "
  >>=? fun confirm ->
  if not (Bigstring.equal password confirm) then
    cctxt#message "Passwords do not match." >>= fun () -> read_password cctxt
  else return password

let encrypt cctxt sk =
  read_password cctxt
  >>=? fun password ->
  let payload = Raw.encrypt ~password sk in
  let encoding =
    match sk with
    | Ed25519 _ ->
        Encodings.ed25519
    | Secp256k1 _ ->
        Encodings.secp256k1
    | P256 _ ->
        Encodings.p256
  in
  let payload = Bigstring.to_bytes payload in
  let path = Base58.simple_encode encoding payload in
  let sk_uri = Client_keys.make_sk_uri (Uri.make ~scheme ~path ()) in
  Hashtbl.replace decrypted sk_uri sk ;
  return sk_uri

module Make (C : sig
  val cctxt : Client_context.prompter
end) =
struct
  let scheme = "encrypted"

  let title = "Built-in signer using encrypted keys."

  let description =
    "Valid secret key URIs are of the form\n\
    \ - encrypted:<encrypted_key>\n\
     where <encrypted_key> is the encrypted (password protected using Nacl's \
     cryptobox and pbkdf) secret key, formatted in unprefixed Base58.\n\
     Valid public key URIs are of the form\n\
    \ - encrypted:<public_key>\n\
     where <public_key> is the public key in Base58."

  let public_key = Unencrypted.public_key

  let public_key_hash = Unencrypted.public_key_hash

  let import_secret_key = Unencrypted.import_secret_key

  let neuterize sk_uri =
    decrypt C.cctxt sk_uri
    >>=? fun sk ->
    return (Unencrypted.make_pk (Signature.Secret_key.to_public_key sk))

  let sign ?watermark sk_uri buf =
    decrypt C.cctxt sk_uri
    >>=? fun sk -> return (Signature.sign ?watermark sk buf)

  let deterministic_nonce sk_uri buf =
    decrypt C.cctxt sk_uri
    >>=? fun sk -> return (Signature.deterministic_nonce sk buf)

  let deterministic_nonce_hash sk_uri buf =
    decrypt C.cctxt sk_uri
    >>=? fun sk -> return (Signature.deterministic_nonce_hash sk buf)

  let supports_deterministic_nonces _ = return_true
end
src/lib_signer_backends/encrypted.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Import Client_keys.

Definition scheme : string := "encrypted" % string.

Module Raw.
  Definition salt_len : Z := 8.
  
  Definition nonce : Tezos_base__TzPervasives.Crypto_box.nonce :=
    Crypto_box.zero_nonce.
  
  Definition encrypted_size : Z := Z.add Crypto_box.boxzerobytes 32.
  
  Definition pbkdf (salt : Bigstring.t) (password : Bigstring.t)
    : Bigstring.t :=
    Pbkdf.SHA512.(Pbkdf.S.pbkdf2) password salt 32768
      (* ❌ Constant of type int32 is converted to int *)
      32.
  
  Definition encrypt
    (password : Bigstring.t)
    (sk : Tezos_base__TzPervasives.Signature.secret_key) : Bigstring.t :=
    let salt := Hacl.Rand.gen salt_len in
    let key := Crypto_box.Secretbox.unsafe_of_bytes (pbkdf salt password) in
    let msg :=
      match sk with
      | Tezos_base__TzPervasives.Signature.Ed25519 sk =>
        Data_encoding.Binary.to_bytes_exn Ed25519.Secret_key.encoding sk
      | Tezos_base__TzPervasives.Signature.Secp256k1 sk =>
        Data_encoding.Binary.to_bytes_exn Secp256k1.Secret_key.encoding sk
      | Tezos_base__TzPervasives.Signature.P256 sk =>
        Data_encoding.Binary.to_bytes_exn P256.Secret_key.encoding sk
      end in
    Bigstring.concat "" % string
      (cons salt (cons (Crypto_box.Secretbox.box key msg nonce) [])).
  
  Definition decrypt
    (algo : Tezos_base__TzPervasives.Signature.algo) (password : Bigstring.t)
    (encrypted_sk : Bigstring.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
    let salt := Bigstring.sub encrypted_sk 0 salt_len in
    let encrypted_sk := Bigstring.sub encrypted_sk salt_len encrypted_size in
    let key := Crypto_box.Secretbox.unsafe_of_bytes (pbkdf salt password) in
    match ((Crypto_box.Secretbox.box_open key encrypted_sk nonce), algo) with
    | (None, _) => return_none
    | (Some bytes, Tezos_base__TzPervasives.Signature.Ed25519) =>
      match Data_encoding.Binary.of_bytes Ed25519.Secret_key.encoding string
        with
      | Some sk => return_some (Tezos_crypto__Signature.Ed25519 sk)
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
                % string CamlinternalFormatBasics.End_of_format)
            "Corrupted wallet, deciphered key is not a valid Ed25519 secret key"
              % string)
      end
    | (Some bytes, Tezos_base__TzPervasives.Signature.Secp256k1) =>
      match Data_encoding.Binary.of_bytes Secp256k1.Secret_key.encoding string
        with
      | Some sk => return_some (Tezos_crypto__Signature.Secp256k1 sk)
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Corrupted wallet, deciphered key is not a valid Secp256k1 secret key"
                % string CamlinternalFormatBasics.End_of_format)
            "Corrupted wallet, deciphered key is not a valid Secp256k1 secret key"
              % string)
      end
    | (Some bytes, Tezos_base__TzPervasives.Signature.P256) =>
      match Data_encoding.Binary.of_bytes P256.Secret_key.encoding string with
      | Some sk => return_some (Tezos_crypto__Signature.P256 sk)
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Corrupted wallet, deciphered key is not a valid P256 secret key"
                % string CamlinternalFormatBasics.End_of_format)
            "Corrupted wallet, deciphered key is not a valid P256 secret key" %
              string)
      end
    end.
End Raw.

Module Encodings.
  Definition ed25519
    : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
    let length :=
      Z.add (Z.add Hacl.Sign.skbytes Crypto_box.boxzerobytes) Raw.salt_len in
    Base58.register_encoding Base58.Prefix.ed25519_encrypted_seed length
      (fun sk => Stdlib.Bytes.to_string sk)
      (fun buf =>
        if nequiv_decb (String.length buf) length then
          None
        else
          Some (Stdlib.Bytes.of_string buf))
      (fun sk => Tezos_base__TzPervasives.Base58.Encrypted_ed25519 sk).
  
  Definition secp256k1
    : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
    let length :=
      Z.add (Z.add Key.secret_bytes Crypto_box.boxzerobytes) Raw.salt_len in
    Base58.register_encoding Base58.Prefix.secp256k1_encrypted_secret_key length
      (fun sk => Stdlib.Bytes.to_string sk)
      (fun buf =>
        if nequiv_decb (String.length buf) length then
          None
        else
          Some (Stdlib.Bytes.of_string buf))
      (fun sk => Tezos_base__TzPervasives.Base58.Encrypted_secp256k1 sk).
  
  Definition p256 : Tezos_base__TzPervasives.Base58.encoding Stdlib.Bytes.t :=
    let length :=
      Z.add (Z.add (sk_size secp256r1) Crypto_box.boxzerobytes) Raw.salt_len in
    Base58.register_encoding Base58.Prefix.p256_encrypted_secret_key length
      (fun sk => Stdlib.Bytes.to_string sk)
      (fun buf =>
        if nequiv_decb (String.length buf) length then
          None
        else
          Some (Stdlib.Bytes.of_string buf))
      (fun sk => Tezos_base__TzPervasives.Base58.Encrypted_p256 sk).
  

End Encodings.

Definition decrypted
  : Stdlib.Hashtbl.t Tezos_client_base.Client_keys.sk_uri
    Tezos_base__TzPervasives.Signature.Secret_key.t := Hashtbl.create None 13.

Definition passwords : Stdlib.ref (list Bigstring.t) := Stdlib.ref [].

Fixpoint interactive_decrypt_loop {B a : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
  (name : option string) (encrypted_sk : Bigstring.t)
  (algo : Tezos_base__TzPervasives.Signature.algo)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  op_gtgteqquestion
    match name with
    | None =>
      (* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Enter password for encrypted key: " % string
            CamlinternalFormatBasics.End_of_format)
          "Enter password for encrypted key: " % string)
    | Some name =>
      (* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Enter password for encrypted key """ % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal """: " % string
                CamlinternalFormatBasics.End_of_format)))
          "Enter password for encrypted key ""%s"": " % string) name
    end
    (fun password =>
      op_gtgteqquestion (Raw.decrypt algo password encrypted_sk)
        (fun function_parameter =>
          match function_parameter with
          | Some sk =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Stdlib.op_coloneq passwords
                (cons password (Stdlib.op_exclamation passwords)) in
            _return sk
          | None => interactive_decrypt_loop cctxt name encrypted_sk algo
          end)).

Definition password_file_load {A : Type}
  (ctxt : ((option (Lwt_stream.t string)) * A))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match
    (* ❌ Sending method message is not handled *)
    send with
  | Some stream =>
    op_gtgteq
      (Lwt_stream.iter
        (fun p =>
          Stdlib.op_coloneq passwords
            (cons (Bigstring.of_string p) (Stdlib.op_exclamation passwords)))
        stream)
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  | None => return_unit
  end.

Fixpoint noninteractive_decrypt_loop
  (algo : Tezos_base__TzPervasives.Signature.algo) (encrypted_sk : Bigstring.t)
  (function_parameter : list Bigstring.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
  match function_parameter with
  | [] => return_none
  | cons password passwords =>
    op_gtgteqquestion (Raw.decrypt algo password encrypted_sk)
      (fun function_parameter =>
        match function_parameter with
        | None => noninteractive_decrypt_loop algo encrypted_sk passwords
        | Some sk => return_some sk
        end)
  end.

Definition decrypt_payload {B a : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
  (name : option string) (encrypted_sk : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  op_gtgteqquestion
    match Base58.decode None encrypted_sk with
    | Some (Tezos_base__TzPervasives.Base58.Encrypted_ed25519 encrypted_sk) =>
      _return (Tezos_base__TzPervasives.Signature.Ed25519, encrypted_sk)
    | Some (Tezos_base__TzPervasives.Base58.Encrypted_secp256k1 encrypted_sk) =>
      _return (Tezos_base__TzPervasives.Signature.Secp256k1, encrypted_sk)
    | Some (Tezos_base__TzPervasives.Base58.Encrypted_p256 encrypted_sk) =>
      _return (Tezos_base__TzPervasives.Signature.P256, encrypted_sk)
    | _ =>
      failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Not a Base58Check-encoded encrypted key" % string
            CamlinternalFormatBasics.End_of_format)
          "Not a Base58Check-encoded encrypted key" % string)
    end
    (fun function_parameter =>
      let '(algo, encrypted_sk) := function_parameter in
      let encrypted_sk := Bigstring.of_bytes encrypted_sk in
      op_gtgteqquestion
        (noninteractive_decrypt_loop algo encrypted_sk
          (Stdlib.op_exclamation passwords))
        (fun function_parameter =>
          match function_parameter with
          | Some sk => _return sk
          | None => interactive_decrypt_loop cctxt name encrypted_sk algo
          end)).

Definition decrypt {B a : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) * B)) * B)
  (name : option string) (sk_uri : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  let payload := Uri.path sk_uri in
  op_gtgteqquestion (decrypt_payload cctxt name payload)
    (fun sk =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Hashtbl.replace decrypted sk_uri sk in
      _return sk).

Definition decrypt_all {C a b : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * C)))))))))))) * C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (Secret_key.load cctxt)
    (fun sks =>
      op_gtgteqquestion (password_file_load cctxt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          iter_s
            (fun function_parameter =>
              let '(name, sk_uri) := function_parameter in
              if nequiv_decb (Uri.scheme sk_uri) (Some scheme) then
                return_unit
              else
                op_gtgteqquestion (decrypt cctxt (Some name) sk_uri)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    return_unit)) sks)).

Definition decrypt_list {C a b : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                  (a * b)) *
                  (((string ->
                    (Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                    (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      ((((Tezos_client_base.Client_context.lwt_format a
                        (Tezos_base__TzPervasives.tzresult string)) -> a) * (a))
                        *
                        ((((Tezos_client_base.Client_context.lwt_format a
                          (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a)
                          * (a)) *
                          ((((Tezos_client_base.Client_context.lwt_format a unit)
                            -> a) * (a)) * C)))))))))))) * C)
  (keys : list string) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (Secret_key.load cctxt)
    (fun sks =>
      op_gtgteqquestion (password_file_load cctxt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          iter_s
            (fun function_parameter =>
              let '(name, sk_uri) := function_parameter in
              if
                andb (equiv_decb (Uri.scheme sk_uri) (Some scheme))
                  (orb (equiv_decb keys []) (List.mem name keys)) then
                op_gtgteqquestion (decrypt cctxt (Some name) sk_uri)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    return_unit)
              else
                return_unit) sks)).

Fixpoint read_password {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
            *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) * C))))))) * C)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  op_gtgteqquestion
    ((* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Enter password to encrypt your key: " % string
          CamlinternalFormatBasics.End_of_format)
        "Enter password to encrypt your key: " % string))
    (fun password =>
      op_gtgteqquestion
        ((* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Confirm password: " % string
              CamlinternalFormatBasics.End_of_format)
            "Confirm password: " % string))
        (fun confirm =>
          if negb (Bigstring.equal password confirm) then
            op_gtgteq
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Passwords do not match." % string
                    CamlinternalFormatBasics.End_of_format)
                  "Passwords do not match." % string))
              (fun function_parameter =>
                let 'tt := function_parameter in
                read_password cctxt)
          else
            _return password)).

Definition encrypt {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a
      (Tezos_base__TzPervasives.tzresult string)) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a
        (Tezos_base__TzPervasives.tzresult Bigstring.t)) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b))
            *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) * C))))))) * C)
  (sk : Tezos_base__TzPervasives.Signature.secret_key)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.sk_uri) :=
  op_gtgteqquestion (read_password cctxt)
    (fun password =>
      let payload := Raw.encrypt password sk in
      let encoding :=
        match sk with
        | Tezos_base__TzPervasives.Signature.Ed25519 _ => Encodings.ed25519
        | Tezos_base__TzPervasives.Signature.Secp256k1 _ => Encodings.secp256k1
        | Tezos_base__TzPervasives.Signature.P256 _ => Encodings.p256
        end in
      let payload := Bigstring.to_bytes payload in
      let path := Base58.simple_encode None encoding payload in
      let sk_uri :=
        Client_keys.make_sk_uri
          (Uri.make (Some scheme) None None None (Some path) None None tt) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Hashtbl.replace decrypted sk_uri sk in
      _return sk_uri).

(* ❌ Functors are not handled. *)
functor

src/lib_signer_backends/http.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Http_gen.Make (struct
  let scheme = "http"
end)
src/lib_signer_backends/http.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_signer_backends/http_gen.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Make (N : sig
  val scheme : string
end) =
struct
  open Client_keys

  let scheme = N.scheme

  module Make
      (RPC_client : RPC_client.S) (P : sig
        val authenticate :
          Signature.Public_key_hash.t list ->
          Bytes.t ->
          Signature.t tzresult Lwt.t

        val logger : RPC_client.logger
      end) =
  struct
    let scheme = scheme

    let title =
      "Built-in tezos-signer using remote signer through hardcoded " ^ scheme
      ^ " requests."

    let description =
      "Valid locators are of this form:\n" ^ " - " ^ scheme
      ^ "://host/tz1...\n" ^ " - " ^ scheme
      ^ "://host:port/path/to/service/tz1...\n"
      ^ "Environment variable TEZOS_SIGNER_HTTP_HEADERS can be specified to \
         add headers to the requests (only 'host' and custom 'x-...' headers \
         are supported)."

    let headers =
      match Sys.getenv_opt "TEZOS_SIGNER_HTTP_HEADERS" with
      | None ->
          None
      | Some contents ->
          let lines = String.split_on_char '\n' contents in
          Some
            (List.fold_left
               (fun acc line ->
                 match String.index_opt line ':' with
                 | None ->
                     Pervasives.failwith
                       "Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS \
                        environment variable, missing colon"
                 | Some pos ->
                     let header = String.trim (String.sub line 0 pos) in
                     let header = String.lowercase_ascii header in
                     if
                       header <> "host"
                       && ( String.length header < 2
                          || String.sub header 0 2 <> "x-" )
                     then
                       Pervasives.failwith
                         "Http signer: invalid TEZOS_SIGNER_HTTP_HEADERS \
                          environment variable, only 'host' or 'x-' headers \
                          are supported" ;
                     let value =
                       String.trim
                         (String.sub
                            line
                            (pos + 1)
                            (String.length line - pos - 1))
                     in
                     (header, value) :: acc)
               []
               lines)

    let parse uri =
      (* extract `tz1..` from the last component of the path *)
      assert (Uri.scheme uri = Some scheme) ;
      let path = Uri.path uri in
      ( match String.rindex_opt path '/' with
      | None ->
          failwith "Invalid locator %a" Uri.pp_hum uri
      | Some i ->
          let pkh =
            try String.sub path (i + 1) (String.length path - i - 1)
            with _ -> ""
          in
          let path = String.sub path 0 i in
          return (Uri.with_path uri path, pkh) )
      >>=? fun (base, pkh) ->
      Lwt.return (Signature.Public_key_hash.of_b58check pkh)
      >>=? fun pkh -> return (base, pkh)

    let public_key uri =
      parse (uri : pk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.public_key
        ((), pkh)
        ()
        ()

    let neuterize uri =
      return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))

    let public_key_hash uri =
      public_key uri
      >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

    let import_secret_key ~io:_ = public_key_hash

    let get_signature base pkh msg =
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.authorized_keys
        ()
        ()
        ()
      >>=? function
      | Some authorized_keys ->
          P.authenticate
            authorized_keys
            (Signer_messages.Sign.Request.to_sign ~pkh ~data:msg)
          >>=? fun signature -> return_some signature
      | None ->
          return_none

    let sign ?watermark uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      let msg =
        match watermark with
        | None ->
            msg
        | Some watermark ->
            Bytes.cat (Signature.bytes_of_watermark watermark) msg
      in
      get_signature base pkh msg
      >>=? fun signature ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.sign
        ((), pkh)
        signature
        msg

    let deterministic_nonce uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      get_signature base pkh msg
      >>=? fun signature ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.deterministic_nonce
        ((), pkh)
        signature
        msg

    let deterministic_nonce_hash uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      get_signature base pkh msg
      >>=? fun signature ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.deterministic_nonce_hash
        ((), pkh)
        signature
        msg

    let supports_deterministic_nonces uri =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (base, pkh) ->
      RPC_client.call_service
        ~logger:P.logger
        ?headers
        Media_type.all_media_types
        ~base
        Signer_services.supports_deterministic_nonces
        ((), pkh)
        ()
        ()
      >>= function
      | Ok ans ->
          return ans
      | Error (RPC_context.Not_found _ :: _) ->
          return_false
      | Error _ as res ->
          Lwt.return res
  end

  let make_base host port = Uri.make ~scheme ~host ~port ()
end
src/lib_signer_backends/http_gen.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Functors are not handled. *)
functor

src/lib_signer_backends/https.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Http_gen.Make (struct
  let scheme = "https"
end)
src/lib_signer_backends/https.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_signer_backends/test/test_encrypted.ml 31 errors
(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2018.                                          *)
(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
(*                                                                        *)
(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
(*                                                                        *)
(**************************************************************************)

open Error_monad

let loops = 10

let passwords =
  List.map
    Bigstring.of_string
    [ "ahThie5H";
      "aVah7eid";
      "Hihohh1n";
      "mui0Hoox";
      "Piu7pual";
      "paik6aiW";
      "caeS5me5";
      "boh5dauL";
      "zaiK1Oht";
      "Oogh4hah";
      "kiY5ohlo";
      "booth0Ei";
      "xa2Aidao";
      "aju6oXu4";
      "gooruGh9";
      "ahy4Daih";
      "chosh0Wu";
      "Cheij6za";
      "quee9ooL";
      "Sohs9are";
      "Pae3gay7";
      "Naif5iel";
      " eir6Aed1";
      "aa6Aesai";
      "" ]

let nb_passwds = List.length passwords

let fake_ctx () =
  object
    val mutable i = 0

    val mutable distributed = false

    inherit Client_context.simple_printer (fun _ _ -> Lwt.return_unit)

    method prompt : type a. (a, string tzresult) Client_context.lwt_format -> a
        =
      Format.kasprintf (fun _ -> return "")

    method prompt_password : type a.
        (a, Bigstring.t tzresult) Client_context.lwt_format -> a =
      Format.kasprintf (fun _ ->
          (* return Bigstring.empty *)
          match distributed with
          | false ->
              distributed <- true ;
              return (List.nth passwords 0)
          | true ->
              i <- (if i = nb_passwds - 1 then 0 else succ i) ;
              distributed <- false ;
              return (List.nth passwords i))
  end

let make_sk_uris =
  List.map (fun path ->
      Client_keys.make_sk_uri (Uri.make ~scheme:"encrypted" ~path ()))

let ed25519_sks =
  [ "edsk3kMNLNdzLPbbABASDLARft8JRZ3Wpwibn8SMAb4KmuWSMJmAFd";
    "edsk3Kqr8VHRx9kmR8Pj5qRGcmvQH34cForiMaMz1Ahhq5DkZp7FxJ";
    "edsk2mBu4w9sMGhryvvXK53dXgpcNdZWi8pJQ1QL2rAgRPrE5y12az" ]

let ed25519_sks_encrypted =
  make_sk_uris
    [ "edesk1oGXxunJ5FTGpQ6o1xdop8VGKdT36Fj7LwWF9HLjzEqaCC4V6tdRVN1jaeJTfCHS8bYf7U2YhMK2yW6jSUy";
      "edesk1s4xEifbUdUkghHHimbNUuyQ4eidDVJdc8JtPRUon758hBqZNZsQxadUDFRSRiUdLoFqBG35HAiLKafyczw";
      "edesk1zY5jEs4QXrF9tXxFq1mfW9PkatdRxCKQ2Q598y5LLz65nQj4eWxefYFp8YLerya1haRdGe5NWckHDb5ApM"
    ]

let secp256k1_sks =
  [ "spsk24attf9uuQ7PUKFHxTm6E3TMqB6SPkFiMbXPBur7JNrvupW2xg";
    "spsk2H32XfWL7MkW58r76q6Yu5tJg77YGgVyjwq7EvLUHhn4JmAtEG";
    "spsk3KQ56REAUGc6Gn87xCRnWyPwR2Un667vegQVuU16ZcgNyLCooh" ]

let secp256k1_sks_encrypted =
  make_sk_uris
    [ "spesk2CXQHDbzrcNatRzmg83Dto6kX6BWwpP2zGs4Zks9LDsXzaX6mAYRj5ZrrdgyZQap4DS9YRRLNSpaVC2TSsk";
      "spesk1upiFp23osWSUTgHcx8DCVpTrMr9xtdqVQkQDWj5sFG7vqcWLDaNv9AKKcF27Nb266YfuAGF2hEbcyAxHmK";
      "spesk1w7d68hzTWJusk5Xn5oz8EgDXbotDW9BXb5ksFjr8Jd94Kxnu5yKAhgRszojhMUoJ1EEt5BtPpGpkgCjELq"
    ]

let p256_sks =
  [ "p2sk2YQcwF5h7qgRztocEMrfizUwZaM41f4v7zWneiig2Y5AxajqYC";
    "p2sk2XiSoQC9tvejVBDJyvkbHUq2kvcQHdJJ2wM8rii228DkjKV2b5";
    "p2sk3ZsfsEaxDNn74orv91Ruu35fomzF373aT9ForA4fDo54c47o6H" ]

let p256_sks_encrypted =
  make_sk_uris
    [ "p2esk2JMFpR9yaSpgsaKQYLqFnv16t4gowJ4cgjj7D7iMfoaJz2vZuH7Tdi11MrX6FC2yhfs2nvy5VRxAvzH1STE";
      "p2esk1nfobVL73mY5Y18W8Ltb3Vm6Nf5Th7trN3yA3ucyyP4AH93XfyRatkh9AxxaDtnju1EtArykjroEQHDT97k";
      "p2esk2Ge1jrVak7NhxksimzaQjRCTLx5vxUZ4Akgq3spGQLx6N41h6aKXeEYDgxN5eztnPwD6QiCHCfVAKXLPNm8"
    ]

let sk_testable =
  Alcotest.testable Signature.Secret_key.pp Signature.Secret_key.equal

let test_vectors () =
  let open Encrypted in
  iter_s
    (fun (sks, encrypted_sks) ->
      let ctx = fake_ctx () in
      let sks = List.map Signature.Secret_key.of_b58check_exn sks in
      map_s (decrypt ctx) encrypted_sks
      >>=? fun decs ->
      assert (decs = sks) ;
      return_unit)
    [ (ed25519_sks, ed25519_sks_encrypted);
      (secp256k1_sks, secp256k1_sks_encrypted);
      (p256_sks, p256_sks_encrypted) ]

let test_random algo =
  let open Encrypted in
  let ctx = fake_ctx () in
  let decrypt_ctx = (ctx :> Client_context.prompter) in
  let rec inner i =
    if i >= loops then return_unit
    else
      let (_, _, sk) = Signature.generate_key ~algo () in
      encrypt ctx sk
      >>=? fun sk_uri ->
      decrypt decrypt_ctx sk_uri
      >>=? fun decrypted_sk ->
      Alcotest.check sk_testable "test_encrypt: decrypt" sk decrypted_sk ;
      inner (succ i)
  in
  inner 0

let test_random _switch () =
  iter_s test_random Signature.[Ed25519; Secp256k1; P256]
  >>= function
  | Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_random"

let test_vectors _switch () =
  test_vectors ()
  >>= function
  | Ok _ -> Lwt.return_unit | Error _ -> Lwt.fail_with "test_vectors"

let tests =
  [ Alcotest_lwt.test_case "random_roundtrip" `Quick test_random;
    Alcotest_lwt.test_case "vectors_decrypt" `Quick test_vectors ]

let () = Alcotest.run "tezos-signer-backends" [("encrypted", tests)]
src/lib_signer_backends/test/test_encrypted.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Definition loops : Z := 10.

Definition passwords : list Bigstring.t :=
  List.map Bigstring.of_string
    (cons "ahThie5H" % string
      (cons "aVah7eid" % string
        (cons "Hihohh1n" % string
          (cons "mui0Hoox" % string
            (cons "Piu7pual" % string
              (cons "paik6aiW" % string
                (cons "caeS5me5" % string
                  (cons "boh5dauL" % string
                    (cons "zaiK1Oht" % string
                      (cons "Oogh4hah" % string
                        (cons "kiY5ohlo" % string
                          (cons "booth0Ei" % string
                            (cons "xa2Aidao" % string
                              (cons "aju6oXu4" % string
                                (cons "gooruGh9" % string
                                  (cons "ahy4Daih" % string
                                    (cons "chosh0Wu" % string
                                      (cons "Cheij6za" % string
                                        (cons "quee9ooL" % string
                                          (cons "Sohs9are" % string
                                            (cons "Pae3gay7" % string
                                              (cons "Naif5iel" % string
                                                (cons " eir6Aed1" % string
                                                  (cons "aa6Aesai" % string
                                                    (cons "" % string []))))))))))))))))))))))))).

Definition nb_passwds : Z := List.length passwords.

Definition fake_ctx {a b : Type} (function_parameter : unit)
  : ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (((string -> (Tezos_client_base.Client_context.lwt_format a unit) -> a)
            * (a)) *
            ((((Tezos_client_base.Client_context.lwt_format a
              (Tezos_base__TzPervasives.Error_monad.tzresult string)) -> a) *
              (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a
                (Tezos_base__TzPervasives.Error_monad.tzresult Bigstring.t)) ->
                a) * (a)) * nil))))))) :=
  let 'tt := function_parameter in
  (* ❌ Creation of objects is not handled *)
  object.

Definition make_sk_uris
  : (list string) -> list Tezos_client_base.Client_keys.sk_uri :=
  List.map
    (fun path =>
      Client_keys.make_sk_uri
        (Uri.make (Some "encrypted" % string) None None None (Some path) None
          None tt)).

Definition ed25519_sks : list string :=
  cons "edsk3kMNLNdzLPbbABASDLARft8JRZ3Wpwibn8SMAb4KmuWSMJmAFd" % string
    (cons "edsk3Kqr8VHRx9kmR8Pj5qRGcmvQH34cForiMaMz1Ahhq5DkZp7FxJ" % string
      (cons "edsk2mBu4w9sMGhryvvXK53dXgpcNdZWi8pJQ1QL2rAgRPrE5y12az" % string [])).

Definition ed25519_sks_encrypted : list Tezos_client_base.Client_keys.sk_uri :=
  make_sk_uris
    (cons
      "edesk1oGXxunJ5FTGpQ6o1xdop8VGKdT36Fj7LwWF9HLjzEqaCC4V6tdRVN1jaeJTfCHS8bYf7U2YhMK2yW6jSUy"
        % string
      (cons
        "edesk1s4xEifbUdUkghHHimbNUuyQ4eidDVJdc8JtPRUon758hBqZNZsQxadUDFRSRiUdLoFqBG35HAiLKafyczw"
          % string
        (cons
          "edesk1zY5jEs4QXrF9tXxFq1mfW9PkatdRxCKQ2Q598y5LLz65nQj4eWxefYFp8YLerya1haRdGe5NWckHDb5ApM"
            % string []))).

Definition secp256k1_sks : list string :=
  cons "spsk24attf9uuQ7PUKFHxTm6E3TMqB6SPkFiMbXPBur7JNrvupW2xg" % string
    (cons "spsk2H32XfWL7MkW58r76q6Yu5tJg77YGgVyjwq7EvLUHhn4JmAtEG" % string
      (cons "spsk3KQ56REAUGc6Gn87xCRnWyPwR2Un667vegQVuU16ZcgNyLCooh" % string [])).

Definition secp256k1_sks_encrypted
  : list Tezos_client_base.Client_keys.sk_uri :=
  make_sk_uris
    (cons
      "spesk2CXQHDbzrcNatRzmg83Dto6kX6BWwpP2zGs4Zks9LDsXzaX6mAYRj5ZrrdgyZQap4DS9YRRLNSpaVC2TSsk"
        % string
      (cons
        "spesk1upiFp23osWSUTgHcx8DCVpTrMr9xtdqVQkQDWj5sFG7vqcWLDaNv9AKKcF27Nb266YfuAGF2hEbcyAxHmK"
          % string
        (cons
          "spesk1w7d68hzTWJusk5Xn5oz8EgDXbotDW9BXb5ksFjr8Jd94Kxnu5yKAhgRszojhMUoJ1EEt5BtPpGpkgCjELq"
            % string []))).

Definition p256_sks : list string :=
  cons "p2sk2YQcwF5h7qgRztocEMrfizUwZaM41f4v7zWneiig2Y5AxajqYC" % string
    (cons "p2sk2XiSoQC9tvejVBDJyvkbHUq2kvcQHdJJ2wM8rii228DkjKV2b5" % string
      (cons "p2sk3ZsfsEaxDNn74orv91Ruu35fomzF373aT9ForA4fDo54c47o6H" % string [])).

Definition p256_sks_encrypted : list Tezos_client_base.Client_keys.sk_uri :=
  make_sk_uris
    (cons
      "p2esk2JMFpR9yaSpgsaKQYLqFnv16t4gowJ4cgjj7D7iMfoaJz2vZuH7Tdi11MrX6FC2yhfs2nvy5VRxAvzH1STE"
        % string
      (cons
        "p2esk1nfobVL73mY5Y18W8Ltb3Vm6Nf5Th7trN3yA3ucyyP4AH93XfyRatkh9AxxaDtnju1EtArykjroEQHDT97k"
          % string
        (cons
          "p2esk2Ge1jrVak7NhxksimzaQjRCTLx5vxUZ4Akgq3spGQLx6N41h6aKXeEYDgxN5eztnPwD6QiCHCfVAKXLPNm8"
            % string []))).

Definition sk_testable {A : Type} : A :=
  op_startypeminuserrorstar Signature.Secret_key.pp Signature.Secret_key.equal.

Definition test_vectors (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  iter_s
    (fun function_parameter =>
      let '(sks, encrypted_sks) := function_parameter in
      let ctx := fake_ctx tt in
      let sks := List.map Signature.Secret_key.of_b58check_exn sks in
      op_gtgteqquestion
        (map_s
          (let arg := decrypt ctx in
          fun eta => arg None eta) encrypted_sks)
        (fun decs =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb decs sks) in
          return_unit))
    (cons (ed25519_sks, ed25519_sks_encrypted)
      (cons (secp256k1_sks, secp256k1_sks_encrypted)
        (cons (p256_sks, p256_sks_encrypted) []))).

Definition test_random (algo : Tezos_base__TzPervasives.Signature.algo)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
  let ctx := fake_ctx tt in
  let decrypt_ctx := ctx in
  let fix inner (i : Z)
    : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult unit) :=
    if OCaml.Stdlib.ge i loops then
      return_unit
    else
      let '(_, _, sk) := Signature.generate_key (Some algo) None tt in
      op_gtgteqquestion (encrypt ctx sk)
        (fun sk_uri =>
          op_gtgteqquestion (decrypt decrypt_ctx None sk_uri)
            (fun decrypted_sk =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                op_startypeminuserrorstar sk_testable
                  "test_encrypt: decrypt" % string sk decrypted_sk in
              inner (Z.succ i))) in
  inner 0.

Definition test_random {A : Type} (_switch : A) (function_parameter : unit)
  : Lwt.t unit :=
  let 'tt := function_parameter in
  op_gtgteq
    (iter_s test_random
      (cons Tezos_base__TzPervasives.Signature.Ed25519
        (cons Tezos_base__TzPervasives.Signature.Secp256k1
          (cons Tezos_base__TzPervasives.Signature.P256 []))))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok _ => Lwt.return_unit
      | Stdlib.Error _ => Lwt.fail_with "test_random" % string
      end).

Definition test_vectors {A : Type} (_switch : A) (function_parameter : unit)
  : Lwt.t unit :=
  let 'tt := function_parameter in
  op_gtgteq (test_vectors tt)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok _ => Lwt.return_unit
      | Stdlib.Error _ => Lwt.fail_with "test_vectors" % string
      end).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "random_roundtrip" % string
      (* ❌ Variants not supported *)
      variant test_random)
    (cons
      (op_startypeminuserrorstar "vectors_decrypt" % string
        (* ❌ Variants not supported *)
        variant test_vectors) []).



src/lib_signer_backends/unencrypted.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

let scheme = "unencrypted"

let title = "Built-in signer using raw unencrypted keys."

let description =
  "Please DO NOT USE this signer outside of test environments.\n\
   Valid secret key URIs are of the form\n\
  \ - unencrypted:<key>\n\
   where <key> is the secret key in Base58.\n\
   Valid public key URIs are of the form\n\
  \ - unencrypted:<public_key>\n\
   where <public_key> is the public key in Base58."

let secret_key sk_uri =
  Lwt.return
    (Signature.Secret_key.of_b58check (Uri.path (sk_uri : sk_uri :> Uri.t)))

let make_sk sk =
  Client_keys.make_sk_uri
    (Uri.make ~scheme ~path:(Signature.Secret_key.to_b58check sk) ())

let public_key pk_uri =
  Lwt.return
    (Signature.Public_key.of_b58check (Uri.path (pk_uri : pk_uri :> Uri.t)))

let make_pk pk =
  Client_keys.make_pk_uri
    (Uri.make ~scheme ~path:(Signature.Public_key.to_b58check pk) ())

let neuterize sk_uri =
  secret_key sk_uri
  >>=? fun sk -> return (make_pk (Signature.Secret_key.to_public_key sk))

let public_key_hash pk_uri =
  public_key pk_uri
  >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

let import_secret_key ~io:_ = public_key_hash

let sign ?watermark sk_uri buf =
  secret_key sk_uri >>=? fun sk -> return (Signature.sign ?watermark sk buf)

let deterministic_nonce sk_uri buf =
  secret_key sk_uri
  >>=? fun sk -> return (Signature.deterministic_nonce sk buf)

let deterministic_nonce_hash sk_uri buf =
  secret_key sk_uri
  >>=? fun sk -> return (Signature.deterministic_nonce_hash sk buf)

let supports_deterministic_nonces _ = return_true
src/lib_signer_backends/unencrypted.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_keys.

Definition scheme : string := "unencrypted" % string.

Definition title : string :=
  "Built-in signer using raw unencrypted keys." % string.

Definition description : string :=
  "Please DO NOT USE this signer outside of test environments.
Valid secret key URIs are of the form
 - unencrypted:<key>
where <key> is the secret key in Base58.
Valid public key URIs are of the form
 - unencrypted:<public_key>
where <public_key> is the public key in Base58."
    % string.

Definition secret_key (sk_uri : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Signature.Secret_key.t) :=
  Lwt._return (Signature.Secret_key.of_b58check (Uri.path sk_uri)).

Definition make_sk (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
  : Tezos_client_base.Client_keys.sk_uri :=
  Client_keys.make_sk_uri
    (Uri.make (Some scheme) None None None
      (Some (Signature.Secret_key.to_b58check sk)) None None tt).

Definition public_key (pk_uri : Tezos_client_base.Client_keys.pk_uri)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_base__TzPervasives.Signature.Public_key.t) :=
  Lwt._return (Signature.Public_key.of_b58check (Uri.path pk_uri)).

Definition make_pk (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Tezos_client_base.Client_keys.pk_uri :=
  Client_keys.make_pk_uri
    (Uri.make (Some scheme) None None None
      (Some (Signature.Public_key.to_b58check pk)) None None tt).

Definition neuterize (sk_uri : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.pk_uri) :=
  op_gtgteqquestion (secret_key sk_uri)
    (fun sk => _return (make_pk (Signature.Secret_key.to_public_key sk))).

Definition public_key_hash (pk_uri : Tezos_client_base.Client_keys.pk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_crypto__Signature.Public_key_hash.t *
        (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  op_gtgteqquestion (public_key pk_uri)
    (fun pk => _return ((Signature.Public_key.hash pk), (Some pk))).

Definition import_secret_key {A : Type} (function_parameter : A)
  : Tezos_client_base.Client_keys.pk_uri ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_crypto__Signature.Public_key_hash.t *
          (option Tezos_base__TzPervasives.Signature.Public_key.t))) :=
  let '_ := function_parameter in
  public_key_hash.

Definition sign
  (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
  op_gtgteqquestion (secret_key sk_uri)
    (fun sk => _return (Signature.sign watermark sk buf)).

Definition deterministic_nonce
  (sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
  op_gtgteqquestion (secret_key sk_uri)
    (fun sk => _return (Signature.deterministic_nonce sk buf)).

Definition deterministic_nonce_hash
  (sk_uri : Tezos_client_base.Client_keys.sk_uri) (buf : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  op_gtgteqquestion (secret_key sk_uri)
    (fun sk => _return (Signature.deterministic_nonce_hash sk buf)).

Definition supports_deterministic_nonces {A : Type} (function_parameter : A)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  let '_ := function_parameter in
  return_true.

src/lib_signer_backends/unix/ledger.ml 186 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

include Internal_event.Legacy_logging.Make (struct
  let name = "client.signer.ledger"
end)

module Bip32_path = struct
  let hard = Int32.logor 0x8000_0000l

  let unhard = Int32.logand 0x7fff_ffffl

  let is_hard n = Int32.logand 0x8000_0000l n <> 0l

  let tezos_root = [hard 44l; hard 1729l]

  let node_of_string str =
    match Int32.of_string_opt str with
    | Some node ->
        Some node
    | None -> (
      match Int32.of_string_opt String.(sub str 0 (length str - 1)) with
      | None ->
          None
      | Some node ->
          Some (hard node) )

  let node_of_string_exn str =
    match node_of_string str with
    | None ->
        invalid_arg (Printf.sprintf "node_of_string_exn: got %S" str)
    | Some str ->
        str

  let pp_node ppf node =
    match is_hard node with
    | true ->
        Fmt.pf ppf "%ldh" (unhard node)
    | false ->
        Fmt.pf ppf "%ld" node

  let string_of_node = Fmt.to_to_string pp_node

  let path_of_string_exn s =
    match String.split_on_char '/' s with
    | [""] ->
        []
    | nodes ->
        List.map node_of_string_exn nodes

  let path_of_string s = try Some (path_of_string_exn s) with _ -> None

  let pp_path = Fmt.(list ~sep:(const char '/') pp_node)

  let string_of_path = Fmt.to_to_string pp_path
end

type error +=
  | LedgerError of Ledgerwallet.Transport.error
  | Ledger_signing_hash_mismatch of string * string

let error_encoding =
  let open Data_encoding in
  conv
    (fun e -> Format.asprintf "%a" Ledgerwallet.Transport.pp_error e)
    (fun _ -> invalid_arg "Ledger error is not deserializable")
    (obj1 (req "ledger-error" string))

let () =
  register_error_kind
    `Permanent
    ~id:"signer.ledger"
    ~title:"Ledger error"
    ~description:"Error communicating with a Ledger Nano device"
    ~pp:(fun ppf e ->
      Format.fprintf ppf "@[Ledger %a@]" Ledgerwallet.Transport.pp_error e)
    error_encoding
    (function LedgerError e -> Some e | _ -> None)
    (fun e -> LedgerError e)

let () =
  let description ledger_hash computed_hash =
    let paren fmt hash_opt =
      match Base.Option.bind ~f:Blake2B.of_string_opt hash_opt with
      | None ->
          ()
      | Some hash ->
          Format.fprintf fmt " (%a)" Blake2B.pp_short hash
    in
    Format.asprintf
      "The ledger returned a hash%a which doesn't match the independently \
       computed hash%a."
      paren
      ledger_hash
      paren
      computed_hash
  in
  register_error_kind
    `Permanent
    ~id:"signer.ledger.signing-hash-mismatch"
    ~title:"Ledger signing-hash mismatch"
    ~description:(description None None)
    ~pp:(fun ppf (lh, ch) ->
      Format.pp_print_string ppf (description (Some lh) (Some ch)))
    Data_encoding.(
      obj2 (req "ledger-hash" string) (req "computed-hash" string))
    (function
      | Ledger_signing_hash_mismatch (lh, ch) -> Some (lh, ch) | _ -> None)
    (fun (lh, ch) -> Ledger_signing_hash_mismatch (lh, ch))

(** Wrappers around Ledger APDUs. *)
module Ledger_commands = struct
  let wrap_ledger_cmd f =
    let buf = Buffer.create 100 in
    let pp =
      Format.make_formatter
        (fun s ofs lgth -> Buffer.add_substring buf s ofs lgth)
        (fun () ->
          debug "%s%!" (Buffer.contents buf) ;
          Buffer.clear buf)
    in
    let res = f pp in
    lwt_debug "%!"
    >>= fun () ->
    match res with Error err -> fail (LedgerError err) | Ok v -> return v

  let get_version ~device_info h =
    let buf = Buffer.create 100 in
    let pp = Format.formatter_of_buffer buf in
    let version = Ledgerwallet_tezos.get_version ~pp h in
    debug "%s" (Buffer.contents buf) ;
    match version with
    | Error e ->
        warn
          "WARNING:@ The device at [%s] is not a Tezos application@ %a"
          device_info.Hidapi.path
          Ledgerwallet.Transport.pp_error
          e ;
        return_none
    | Ok version ->
        ( if (version.major, version.minor) < (1, 4) then
          failwith
            "Version %a of the ledger apps is not supported by this client"
            Ledgerwallet_tezos.Version.pp
            version
        else return_unit )
        >>=? fun () ->
        wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_git_commit ~pp h)
        >>=? fun git_commit ->
        log_info
          "Found a %a application at [%s] (git-description: %S)"
          Ledgerwallet_tezos.Version.pp
          version
          device_info.path
          git_commit ;
        let cleaned_up =
          (* The ledger sends a NUL-terminated C-String: *)
          if git_commit.[String.length git_commit - 1] = '\x00' then
            String.sub git_commit 0 (String.length git_commit - 1)
          else git_commit
        in
        return_some (version, cleaned_up)

  let secp256k1_ctx =
    Libsecp256k1.External.Context.create ~sign:false ~verify:false ()

  let public_key_returning_instruction which ?(prompt = false) hidapi curve
      path =
    let path = Bip32_path.tezos_root @ path in
    ( match which with
    | `Get_public_key ->
        wrap_ledger_cmd (fun pp ->
            Ledgerwallet_tezos.get_public_key ~prompt ~pp hidapi curve path)
    | `Authorize_baking ->
        wrap_ledger_cmd (fun pp ->
            Ledgerwallet_tezos.authorize_baking ~pp hidapi curve path)
    | `Setup (main_chain_id, main_hwm, test_hwm) ->
        wrap_ledger_cmd (fun pp ->
            Ledgerwallet_tezos.setup_baking
              ~pp
              hidapi
              curve
              path
              ~main_chain_id
              ~main_hwm
              ~test_hwm) )
    >>|? fun pk ->
    match curve with
    | Ed25519 | Bip32_ed25519 ->
        let pk = Cstruct.to_bytes pk in
        TzEndian.set_int8 pk 0 0 ;
        (* hackish, but works. *)
        Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding pk
    | Secp256k1 ->
        let open Libsecp256k1.External in
        let buf = Bigstring.create (Key.compressed_pk_bytes + 1) in
        let pk = Key.read_pk_exn secp256k1_ctx (Cstruct.to_bigarray pk) in
        EndianBigstring.BigEndian.set_int8 buf 0 1 ;
        let _nb_written = Key.write secp256k1_ctx ~pos:1 buf pk in
        Data_encoding.Binary.of_bytes_exn
          Signature.Public_key.encoding
          (Bigstring.to_bytes buf)
    | Secp256r1 -> (
        let open Uecc in
        let pklen = compressed_size secp256r1 in
        let buf = Bigstring.create (pklen + 1) in
        match pk_of_bytes secp256r1 (Cstruct.to_bigarray pk) with
        | None ->
            Pervasives.failwith
              "Impossible to read P256 public key from Ledger"
        | Some pk ->
            EndianBigstring.BigEndian.set_int8 buf 0 2 ;
            let _nb_written =
              write_key ~compress:true (Bigstring.sub buf 1 pklen) pk
            in
            Data_encoding.Binary.of_bytes_exn
              Signature.Public_key.encoding
              (Bigstring.to_bytes buf) )

  let get_public_key = public_key_returning_instruction `Get_public_key

  let pkh_of_pk = Signature.Public_key.hash

  let public_key ?(first_import : Client_context.io_wallet option) hid curve
      path =
    match first_import with
    | Some cctxt ->
        get_public_key ~prompt:false hid curve path
        >>=? fun pk ->
        let pkh = pkh_of_pk pk in
        cctxt#message
          "Please validate@ (and write down)@ the public key hash@ displayed@ \
           on the Ledger,@ it should be equal@ to `%a`:"
          Signature.Public_key_hash.pp
          pkh
        >>= fun () -> get_public_key ~prompt:true hid curve path
    | None ->
        get_public_key ~prompt:false hid curve path

  let public_key_hash ?first_import hid curve path =
    public_key ?first_import hid curve path
    >>=? fun pk -> return (pkh_of_pk pk, pk)

  let get_authorized_path hid version =
    let open Ledgerwallet_tezos.Version in
    if version.major < 2 then
      wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_key ~pp hid)
      >>|? fun path -> `Legacy_path path
    else
      wrap_ledger_cmd (fun pp ->
          Ledgerwallet_tezos.get_authorized_path_and_curve ~pp hid)
      >>= function
      | Error
          (LedgerError
             (AppError
               { status =
                   Ledgerwallet.Transport.Status.Referenced_data_not_found;
                 _ })
          :: _) ->
          return `No_baking_authorized
      | Error _ as e ->
          Lwt.return e
      | Ok (path, curve) ->
          return (`Path_curve (path, curve))

  let sign ?watermark ~version hid curve path (base_msg : Bytes.t) =
    let msg =
      Option.unopt_map watermark ~default:base_msg ~f:(fun watermark ->
          Bytes.cat (Signature.bytes_of_watermark watermark) base_msg)
    in
    let path = Bip32_path.tezos_root @ path in
    wrap_ledger_cmd (fun pp ->
        let {Ledgerwallet_tezos.Version.major; minor; patch; _} = version in
        let open Rresult.R.Infix in
        if (major, minor, patch) <= (2, 0, 0) then
          Ledgerwallet_tezos.sign ~pp hid curve path (Cstruct.of_bytes msg)
          >>= fun s -> Ok (None, s)
        else
          Ledgerwallet_tezos.sign_and_hash
            ~pp
            hid
            curve
            path
            (Cstruct.of_bytes msg)
          >>= fun (h, s) -> Ok (Some h, s))
    >>=? fun (hash_opt, signature) ->
    ( match hash_opt with
    | None ->
        return_unit
    | Some hsh ->
        let hash_msg = Blake2B.hash_bytes [msg] in
        let ledger_one = Blake2B.of_bytes_exn (Cstruct.to_bytes hsh) in
        if Blake2B.equal hash_msg ledger_one then return_unit
        else
          fail
            (Ledger_signing_hash_mismatch
               (Blake2B.to_string ledger_one, Blake2B.to_string hash_msg)) )
    >>=? fun () ->
    match curve with
    | Ed25519 | Bip32_ed25519 ->
        let signature = Ed25519.of_bytes_exn (Cstruct.to_bytes signature) in
        return (Signature.of_ed25519 signature)
    | Secp256k1 ->
        (* Remove parity info *)
        Cstruct.(set_uint8 signature 0 (get_uint8 signature 0 land 0xfe)) ;
        let signature = Cstruct.to_bigarray signature in
        let open Libsecp256k1.External in
        let signature = Sign.read_der_exn secp256k1_ctx signature in
        let bytes = Sign.to_bytes secp256k1_ctx signature in
        let signature = Secp256k1.of_bytes_exn (Bigstring.to_bytes bytes) in
        return (Signature.of_secp256k1 signature)
    | Secp256r1 ->
        (* Remove parity info *)
        Cstruct.(set_uint8 signature 0 (get_uint8 signature 0 land 0xfe)) ;
        let signature = Cstruct.to_bigarray signature in
        let open Libsecp256k1.External in
        (* We use secp256r1 library to extract P256 DER signature. *)
        let signature = Sign.read_der_exn secp256k1_ctx signature in
        let buf = Sign.to_bytes secp256k1_ctx signature in
        let signature = P256.of_bytes_exn (Bigstring.to_bytes buf) in
        return (Signature.of_p256 signature)

  let get_deterministic_nonce hid curve path msg =
    let path = Bip32_path.tezos_root @ path in
    wrap_ledger_cmd (fun pp ->
        Ledgerwallet_tezos.get_deterministic_nonce
          ~pp
          hid
          curve
          path
          (Cstruct.of_bytes msg))
    >>=? fun nonce -> return (Bigstring.of_bytes (Cstruct.to_bytes nonce))
end

(** Identification of a ledger's root key through crouching-tigers
    (not the keys used for an account). *)
module Ledger_id = struct
  (**
     The “ID” of the ledger is the animals (or pkh) corresponding to
     ["/ed25519/"] (first curve, no path).
  *)
  type t = Animals of Ledger_names.t | Pkh of Signature.public_key_hash

  let animals_of_pkh pkh =
    pkh |> Signature.Public_key_hash.to_string |> Ledger_names.crouching_tiger

  let curve = Ledgerwallet_tezos.Ed25519

  let get hidapi =
    Ledger_commands.get_public_key hidapi curve []
    >>=? fun pk ->
    let pkh = Signature.Public_key.hash pk in
    let animals = animals_of_pkh pkh in
    return (Animals animals)

  let pp ppf = function
    | Animals a ->
        Ledger_names.pp ppf a
    | Pkh pkh ->
        Signature.Public_key_hash.pp ppf pkh

  let to_animals = function Animals a -> a | Pkh pkh -> animals_of_pkh pkh

  let equal a b = to_animals a = to_animals b
end

(** An account is a given key-pair corresponding to a
    [ledger + curve + derivation-path]. *)
module Ledger_account = struct
  type t = {
    ledger : Ledger_id.t;
    curve : Ledgerwallet_tezos.curve;
    path : int32 list;
  }
end

(** {!Ledger_uri.t} represents a parsed ["ledger://..."] URI which may
    refer to a {!Ledger_id.t} or a full blown {!Ledger_account.t}. *)
module Ledger_uri = struct
  type t = [`Ledger of Ledger_id.t | `Ledger_account of Ledger_account.t]

  let int32_of_path_element_exn ~allow_weak x =
    let failf ppf = Printf.ksprintf Pervasives.failwith ppf in
    let len = String.length x in
    match x.[len - 1] with
    | exception _ ->
        failf "Empty path element"
    | '\'' | 'h' -> (
        let intpart = String.sub x 0 (len - 1) in
        match Int32.of_string_opt intpart with
        | Some i ->
            Bip32_path.hard i
        | None ->
            failf "Path is not an integer: %S" intpart )
    | _ when allow_weak -> (
      match Int32.of_string_opt x with
      | Some i ->
          i
      | None ->
          failf "Path is not a non-hardened integer: %S" x )
    | _ ->
        failf
          "Non-hardened paths are not allowed for this derivation scheme (%S)"
          x

  let parse_animals animals =
    match String.split '-' animals with
    | [c; t; h; d] ->
        Some {Ledger_names.c; t; h; d}
    | _ ->
        None

  let derivation_supports_weak_paths = function
    | Ledgerwallet_tezos.Ed25519 ->
        false
    | Ledgerwallet_tezos.Secp256k1 ->
        true
    | Ledgerwallet_tezos.Secp256r1 ->
        true
    | Ledgerwallet_tezos.Bip32_ed25519 ->
        true

  let parse ?allow_weak uri : t tzresult Lwt.t =
    let host = Uri.host uri in
    ( match Option.apply host ~f:Signature.Public_key_hash.of_b58check_opt with
    | Some pkh ->
        return (Ledger_id.Pkh pkh)
    | None -> (
      match Option.apply host ~f:parse_animals with
      | Some animals ->
          return (Ledger_id.Animals animals)
      | None ->
          failwith "Cannot parse host of URI: %s" (Uri.to_string uri) ) )
    >>=? fun ledger ->
    let components = String.split '/' (Uri.path uri) in
    match components with
    | s :: tl ->
        let (curve, more_path) =
          match Ledgerwallet_tezos.curve_of_string s with
          | Some curve ->
              (curve, tl)
          | None ->
              (Ledger_id.curve, s :: tl)
        in
        let actually_allow_weak =
          match allow_weak with
          | None ->
              derivation_supports_weak_paths curve
          | Some x ->
              x
        in
        ( try
            return
              (List.map
                 (int32_of_path_element_exn ~allow_weak:actually_allow_weak)
                 more_path)
          with Failure s ->
            failwith
              "Failed to parse Curve/BIP32 path from %s (%s): %s"
              (Uri.path uri)
              (Uri.to_string uri)
              s )
        >>=? fun bip32 ->
        return (`Ledger_account Ledger_account.{ledger; curve; path = bip32})
    | [] ->
        return (`Ledger ledger)

  let ledger_uri_or_alias_param next =
    let name = "account-alias-or-ledger-uri" in
    let desc =
      "An imported ledger alias or a ledger URI (e.g. \
       \"ledger://animal/curve/path\")."
    in
    let open Clic in
    param
      ~name
      ~desc
      (parameter (fun cctxt str ->
           Public_key.find_opt cctxt str
           >>=? (function
                  | Some ((x : pk_uri), _) ->
                      return (x :> Uri.t)
                  | None -> (
                    try return (Uri.of_string str)
                    with e ->
                      failwith
                        "Error while parsing URI: %s"
                        (Printexc.to_string e) ))
           >>=? fun uri -> parse uri))
      next

  let pp : _ -> t -> unit =
   fun ppf ->
    Format.(
      function
      | `Ledger lid ->
          fprintf ppf "ledger://%a" Ledger_id.pp lid
      | `Ledger_account {Ledger_account.ledger; curve; path} ->
          fprintf
            ppf
            "ledger://%a/%a/%a"
            Ledger_id.pp
            ledger
            Ledgerwallet_tezos.pp_curve
            curve
            Bip32_path.pp_path
            path)

  let if_matches (meta_uri : t) ledger_id cont =
    match meta_uri with
    | `Ledger l ->
        if Ledger_id.equal l ledger_id then cont () else return_none
    | `Ledger_account {Ledger_account.ledger; _} ->
        if Ledger_id.equal ledger ledger_id then cont () else return_none

  let full_account (ledger_uri : t) =
    match ledger_uri with
    | `Ledger_account acc ->
        return acc
    | `Ledger ledger_id ->
        failwith
          "Insufficient information: you need to provide a curve & BIP32 path \
           (%a)."
          Ledger_id.pp
          ledger_id
end

(** Filters allow early dismissal of HID devices/ledgers which
    searching for a ledger. *)
module Filter = struct
  type version_filter = Ledgerwallet_tezos.Version.t * string -> bool

  type t = [`None | `Hid_path of string | `Version of string * version_filter]

  let version_matches (t : t) version_commit =
    match t with `Version (_, f) -> f version_commit | _ -> true

  let is_app : _ -> _ -> t =
   fun msg app ->
    `Version
      ( msg,
        fun ({Ledgerwallet_tezos.Version.app_class; _}, _) -> app = app_class
      )

  let is_baking = is_app "App = Baking" Ledgerwallet_tezos.Version.TezBake

  let pp ppf (f : t) =
    let open Format in
    match f with
    | `None ->
        fprintf ppf "None"
    | `Hid_path s ->
        fprintf ppf "HID-path: %s" s
    | `Version (s, _) ->
        fprintf ppf "%s" s
end

(* Those constants are provided by the vendor (e.g. check the udev
   rules they provide): *)
let vendor_id = 0x2c97

let product_id_nano_s = 0x0001

let product_id_nano_x = 0x0004

let use_ledger ?(filter : Filter.t = `None) f =
  let ledgers =
    Hidapi.enumerate ~vendor_id ~product_id:product_id_nano_s ()
    @ Hidapi.enumerate ~vendor_id ~product_id:product_id_nano_x ()
  in
  debug
    "Found %d Ledger(s) %s"
    (List.length ledgers)
    (String.concat
       " -- "
       (List.map
          Hidapi.(
            fun l -> Printf.sprintf "(%04x, %04x)" l.vendor_id l.product_id)
          ledgers)) ;
  let process_device device_info f =
    log_info "Processing Ledger at path [%s]" device_info.Hidapi.path ;
    (* HID interfaces get the number 0
       (cf. https://github.com/LedgerHQ/ledger-nano-s/issues/48)
       *BUT* on MacOSX the Hidapi library does not report the interface-number
       so we look at the usage-page (which is even more unspecified but used by
       prominent Ledger users:
       https://github.com/LedgerHQ/ledgerjs/commit/333ade0d55dc9c59bcc4b451cf7c976e78629681).
    *)
    if
      device_info.Hidapi.interface_number = 0
      || device_info.Hidapi.interface_number = -1
         && device_info.Hidapi.usage_page = 0xffa0
    then
      match filter with
      | `Hid_path hp when device_info.path <> hp ->
          return_none
      | _ -> (
        match Hidapi.(open_path device_info.path) with
        | None ->
            return_none
        | Some h ->
            Lwt.finalize
              (fun () ->
                Ledger_commands.get_version ~device_info h
                >>=? function
                | Some version_git
                  when Filter.version_matches filter version_git ->
                    Ledger_id.get h
                    >>=? fun ledger_id -> f h version_git device_info ledger_id
                | None | Some _ ->
                    return_none)
              (fun () -> Hidapi.close h ; Lwt.return_unit) )
    else return_none
  in
  let rec go = function
    | [] ->
        return_none
    | h :: t -> (
        process_device h f
        >>=? function Some x -> return_some x | None -> go t )
  in
  go ledgers

let min_version_of_derivation_scheme = function
  | Ledgerwallet_tezos.Ed25519 ->
      (1, 3, 0)
  | Ledgerwallet_tezos.Secp256k1 ->
      (1, 3, 0)
  | Ledgerwallet_tezos.Secp256r1 ->
      (1, 3, 0)
  | Ledgerwallet_tezos.Bip32_ed25519 ->
      (2, 1, 0)

let is_derivation_scheme_supported version curve =
  Ledgerwallet_tezos.Version.(
    let {major; minor; patch; _} = version in
    (major, minor, patch) >= min_version_of_derivation_scheme curve)

let use_ledger_or_fail ~ledger_uri ?filter ?msg f =
  use_ledger ?filter (fun hidapi (version, git_commit) device_info ledger_id ->
      Ledger_uri.if_matches ledger_uri ledger_id (fun () ->
          let go () = f hidapi (version, git_commit) device_info ledger_id in
          match ledger_uri with
          | `Ledger_account {curve; _} ->
              if is_derivation_scheme_supported version curve then go ()
              else
                Ledgerwallet_tezos.(
                  failwith
                    "To use derivation scheme %a you need %a or later but \
                     you're using %a."
                    pp_curve
                    curve
                    Version.pp
                    (let (a, b, c) = min_version_of_derivation_scheme curve in
                     {version with major = a; minor = b; patch = c})
                    Version.pp
                    version)
          | _ ->
              go ()))
  >>=? function
  | Some o ->
      return o
  | None ->
      failwith
        "%sFound no ledger corresponding to %a%t."
        (Option.unopt_map ~default:"" ~f:(Printf.sprintf "%s: ") msg)
        Ledger_uri.pp
        ledger_uri
        (fun ppf ->
          match filter with
          | Some f ->
              Format.fprintf ppf " with filter \"%a\"" Filter.pp f
          | None ->
              ())

(** A global {!Hashtbl.t} which allows us to avoid calling
    {!Signer_implementation.get_public_key} too often. *)
module Global_cache : sig
  val record :
    pk_uri -> pk:Signature.public_key -> pkh:Signature.public_key_hash -> unit

  val get : pk_uri -> (Signature.public_key_hash * Signature.public_key) option
end = struct
  let _cache :
      (pk_uri, Signature.Public_key_hash.t * Signature.Public_key.t) Hashtbl.t
      =
    Hashtbl.create 13

  let record pk_uri ~pk ~pkh = Hashtbl.replace _cache pk_uri (pkh, pk)

  let get pk_uri = Hashtbl.find_opt _cache pk_uri
end

(** The implementation of the “signer-plugin.” *)
module Signer_implementation : Client_keys.SIGNER = struct
  let scheme = "ledger"

  let title = "Built-in signer using a Ledger Nano device."

  let description =
    Printf.sprintf
      "Valid URIs are of the form\n\
      \ - ledger://<animals>/<curve>[/<path>]\n\
       where:\n\
      \ - <animals> is the identifier of the ledger of the form \
       'crouching-tiger-hidden-dragon' and can be obtained with the command \
       `tezos-client list connected ledgers` (which also provides full \
       examples).\n\
       - <curve> is the signing curve, e.g. `ed1551`\n\
       - <path> is a BIP32 path anchored at m/%s. The ledger does not yet \
       support non-hardened paths, so each node of the path must be hardened."
      Bip32_path.(string_of_path tezos_root)

  let neuterize (sk : sk_uri) = return (make_pk_uri (sk :> Uri.t))

  let pkh_of_pk = Signature.Public_key.hash

  let public_key_maybe_prompt ?(first_import : Client_context.io_wallet option)
      (pk_uri : pk_uri) =
    match Global_cache.get pk_uri with
    | Some (_, pk) ->
        return pk
    | None -> (
        Ledger_uri.parse (pk_uri :> Uri.t)
        >>=? (fun ledger_uri ->
               Ledger_uri.full_account ledger_uri
               >>=? fun {curve; path; _} ->
               use_ledger_or_fail
                 ~ledger_uri
                 (fun hidapi (_version, _git_commit) _device_info _ledger_id ->
                   Ledger_commands.public_key ?first_import hidapi curve path
                   >>=? fun pk ->
                   let pkh = pkh_of_pk pk in
                   Global_cache.record pk_uri ~pkh ~pk ;
                   return_some pk))
        >>= function
        | Error err -> failwith "%a" pp_print_error err | Ok v -> return v )

  let public_key_hash_maybe_prompt ?first_import pk_uri =
    match Global_cache.get pk_uri with
    | Some (pkh, pk) ->
        return (pkh, Some pk)
    | None ->
        public_key_maybe_prompt ?first_import pk_uri
        >>=? fun pk -> return (pkh_of_pk pk, Some pk)

  let public_key = public_key_maybe_prompt ?first_import:None

  let public_key_hash = public_key_hash_maybe_prompt ?first_import:None

  let import_secret_key ~io pk_uri =
    public_key_hash_maybe_prompt ~first_import:io pk_uri

  let sign ?watermark (sk_uri : sk_uri) msg =
    Ledger_uri.parse (sk_uri :> Uri.t)
    >>=? fun ledger_uri ->
    Ledger_uri.full_account ledger_uri
    >>=? fun {curve; path; _} ->
    use_ledger_or_fail
      ~ledger_uri
      (fun hidapi (version, _git_commit) _device_info _ledger_id ->
        Ledger_commands.sign ?watermark ~version hidapi curve path msg
        >>=? fun bytes -> return_some bytes)

  let deterministic_nonce (sk_uri : sk_uri) msg =
    Ledger_uri.parse (sk_uri :> Uri.t)
    >>=? fun ledger_uri ->
    Ledger_uri.full_account ledger_uri
    >>=? fun {curve; path; _} ->
    use_ledger_or_fail
      ~ledger_uri
      (fun hidapi (_version, _git_commit) _device_info _ledger_id ->
        Ledger_commands.get_deterministic_nonce hidapi curve path msg
        >>=? fun bytes -> return_some bytes)

  let deterministic_nonce_hash (sk : sk_uri) msg =
    deterministic_nonce sk msg
    >>=? fun nonce ->
    return (Blake2B.to_bytes (Blake2B.hash_bytes [Bigstring.to_bytes nonce]))

  let supports_deterministic_nonces _ = return_true
end

(* The Ledger uses a special value 0x00000000 for the “any” chain-id: *)
let pp_ledger_chain_id fmt s =
  match s with
  | "\x00\x00\x00\x00" ->
      Format.fprintf fmt "'Unspecified'"
  | other ->
      Format.fprintf fmt "%a" Chain_id.pp (Chain_id.of_string_exn other)

(** Commands for both ledger applications. *)
let generic_commands group =
  Clic.
    [ command
        ~group
        ~desc:"List supported Ledger Nano devices connected."
        no_options
        (fixed ["list"; "connected"; "ledgers"])
        (fun () (cctxt : Client_context.full) ->
          use_ledger
            (fun _hidapi (version, git_commit) device_info ledger_id ->
              let open Hidapi in
              cctxt#message
                "%t"
                Format.(
                  fun ppf ->
                    let intro =
                      asprintf
                        "Found a %a (git-description: %S) application running \
                         on %s %s at [%s]."
                        Ledgerwallet_tezos.Version.pp
                        version
                        git_commit
                        ( device_info.manufacturer_string
                        |> Option.unopt ~default:"NO-MANUFACTURER" )
                        ( device_info.product_string
                        |> Option.unopt ~default:"NO-PRODUCT" )
                        device_info.path
                    in
                    pp_open_vbox ppf 0 ;
                    fprintf ppf "## Ledger `%a`@," Ledger_id.pp ledger_id ;
                    pp_open_hovbox ppf 0 ;
                    pp_print_text ppf intro ;
                    pp_close_box ppf () ;
                    pp_print_cut ppf () ;
                    pp_print_cut ppf () ;
                    pp_open_hovbox ppf 0 ;
                    pp_print_text
                      ppf
                      "To use keys at BIP32 path m/44'/1729'/0'/0' (default \
                       Tezos key path), use one of:" ;
                    pp_close_box ppf () ;
                    pp_print_cut ppf () ;
                    List.iter
                      (fun curve ->
                        fprintf
                          ppf
                          "  tezos-client import secret key ledger_%s \
                           \"ledger://%a/%a/0h/0h\""
                          ( Sys.getenv_opt "USER"
                          |> Option.unopt ~default:"user" )
                          Ledger_id.pp
                          ledger_id
                          Ledgerwallet_tezos.pp_curve
                          curve ;
                        pp_print_cut ppf ())
                      (List.filter
                         (is_derivation_scheme_supported version)
                         [Bip32_ed25519; Ed25519; Secp256k1; Secp256r1]) ;
                    pp_close_box ppf () ;
                    pp_print_newline ppf ())
              >>= fun () -> return_none)
          >>=? fun _ -> return_unit);
      Clic.command
        ~group
        ~desc:"Display version/public-key/address information for a Ledger URI"
        (args1 (switch ~doc:"Test signing operation" ~long:"test-sign" ()))
        ( prefixes ["show"; "ledger"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun test_sign ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            (fun hidapi (version, git_commit) device_info _ledger_id ->
              cctxt#message
                "Found ledger corresponding to %a:"
                Ledger_uri.pp
                ledger_uri
              >>= fun () ->
              cctxt#message
                "* Manufacturer: %s"
                (Option.unopt device_info.manufacturer_string ~default:"NONE")
              >>= fun () ->
              cctxt#message
                "* Product: %s"
                (Option.unopt device_info.product_string ~default:"NONE")
              >>= fun () ->
              cctxt#message
                "* Application: %a (git-description: %S)"
                Ledgerwallet_tezos.Version.pp
                version
                git_commit
              >>= fun () ->
              ( match ledger_uri with
              | `Ledger_account {curve; path; _} -> (
                  cctxt#message
                    "* Curve: `%a`"
                    Ledgerwallet_tezos.pp_curve
                    curve
                  >>= fun () ->
                  let full_path = Bip32_path.tezos_root @ path in
                  cctxt#message
                    "* Path: `%s` [%s]"
                    (Bip32_path.string_of_path full_path)
                    (String.concat
                       "; "
                       (List.map (Printf.sprintf "0x%lX") full_path))
                  >>= fun () ->
                  Ledger_commands.public_key_hash hidapi curve path
                  >>=? fun (pkh, pk) ->
                  cctxt#message "* Public Key: %a" Signature.Public_key.pp pk
                  >>= fun () ->
                  cctxt#message
                    "* Public Key Hash: %a@\n"
                    Signature.Public_key_hash.pp
                    pkh
                  >>= fun () ->
                  match (test_sign, version.app_class) with
                  | (true, Tezos) -> (
                      let pkh_bytes = Signature.Public_key_hash.to_bytes pkh in
                      (* Signing requires validation on the device.  *)
                      cctxt#message
                        "@[Attempting a signature@ (of `%a`),@ please@ \
                         validate on@ the ledger.@]"
                        Hex.pp
                        (Hex.of_bytes pkh_bytes)
                      >>= fun () ->
                      Ledger_commands.sign
                        ~version
                        ~watermark:Generic_operation
                        hidapi
                        curve
                        path
                        pkh_bytes
                      >>=? fun signature ->
                      match
                        Signature.check
                          ~watermark:Generic_operation
                          pk
                          signature
                          pkh_bytes
                      with
                      | false ->
                          failwith
                            "Fatal: Ledger cannot sign with %a"
                            Signature.Public_key_hash.pp
                            pkh
                      | true ->
                          cctxt#message
                            "Tezos Wallet successfully signed:@ %a."
                            Signature.pp
                            signature
                          >>= fun () -> return_unit )
                  | (true, TezBake) ->
                      failwith
                        "Option --test-sign only works for the Tezos Wallet \
                         app."
                  | (false, _) ->
                      return_unit )
              | `Ledger _ when test_sign ->
                  failwith
                    "Option --test-sign only works with a full ledger \
                     URI/account (with curve/path)."
              | `Ledger _ ->
                  cctxt#message "* This is just a ledger URI."
                  >>= fun () -> return_unit )
              >>=? fun () -> return_some ())) ]

(** Commands specific to the Baking app minus the high-water-mark ones
    which get a specific treatment in {!high_water_mark_commands}. *)
let baking_commands group =
  Clic.
    [ Clic.command
        ~group
        ~desc:"Query the path of the authorized key"
        no_options
        ( prefixes ["get"; "ledger"; "authorized"; "path"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun () ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              Ledger_commands.get_authorized_path hidapi version
              >>=? fun authorized ->
              match authorized with
              | `Legacy_path p ->
                  cctxt#message
                    "@[<v 0>Authorized baking path (Legacy < 2.x.y): %a@]"
                    Bip32_path.pp_path
                    p
                  >>= fun () -> return_some ()
              | `No_baking_authorized ->
                  cctxt#message "No baking key authorized at all."
                  >>= fun () -> return_some ()
              | `Path_curve (ledger_path, ledger_curve) -> (
                  cctxt#message
                    "@[<v 0>Authorized baking path: %a@]"
                    Bip32_path.pp_path
                    ledger_path
                  >>= fun () ->
                  cctxt#message
                    "@[<v 0>Authorized baking curve: %a@]"
                    Ledgerwallet_tezos.pp_curve
                    ledger_curve
                  >>= fun () ->
                  match ledger_uri with
                  | `Ledger _ ->
                      return_some ()
                  | `Ledger_account {curve; path; _}
                    when curve = ledger_curve
                         && Bip32_path.tezos_root @ path = ledger_path ->
                      cctxt#message
                        "@[<v 0>Authorized baking URI: %a@]"
                        Ledger_uri.pp
                        ledger_uri
                      >>= fun () -> return_some ()
                  | `Ledger_account {curve; path; _} ->
                      failwith
                        "Path and curve do not match the ones specified in \
                         the command line: %a & %a"
                        Ledgerwallet_tezos.pp_curve
                        curve
                        Bip32_path.pp_path
                        (Bip32_path.tezos_root @ path) )));
      Clic.command
        ~group
        ~desc:
          "Authorize a Ledger to bake for a key (deprecated, use `setup \
           ledger ...` with recent versions of the Baking app)"
        no_options
        ( prefixes ["authorize"; "ledger"; "to"; "bake"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun () ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              ( match version with
              | {Ledgerwallet_tezos.Version.app_class = Tezos; _} ->
                  failwith
                    "This command (`authorize ledger ...`) only works with \
                     the Tezos Baking app"
              | {Ledgerwallet_tezos.Version.app_class = TezBake; major; _}
                when major >= 2 ->
                  failwith
                    "This command (`authorize ledger ...`) is@ not compatible \
                     with@ this version of the Ledger@ Baking app (%a >= \
                     2.0.0),@ please use the command@ `setup ledger to bake \
                     for ...`@ from now on."
                    Ledgerwallet_tezos.Version.pp
                    version
              | _ ->
                  cctxt#message
                    "This Ledger Baking app is outdated (%a)@ running@ in \
                     backwards@ compatibility mode."
                    Ledgerwallet_tezos.Version.pp
                    version
                  >>= fun () -> return_unit )
              >>=? fun () ->
              Ledger_uri.full_account ledger_uri
              >>=? fun {Ledger_account.curve; path; _} ->
              Ledger_commands.public_key_returning_instruction
                `Authorize_baking
                hidapi
                curve
                path
              >>=? fun pk ->
              let pkh = Signature.Public_key.hash pk in
              cctxt#message
                "@[<v 0>Authorized baking for address: %a@,\
                 Corresponding full public key: %a@]"
                Signature.Public_key_hash.pp
                pkh
                Signature.Public_key.pp
                pk
              >>= fun () -> return_some ()));
      Clic.command
        ~group
        ~desc:"Setup a Ledger to bake for a key"
        (let hwm_arg kind =
           let doc =
             Printf.sprintf
               "Use <HWM> as %s chain high watermark instead of asking the \
                ledger."
               kind
           in
           let long = kind ^ "-hwm" in
           default_arg
             ~doc
             ~long
             ~placeholder:"HWM"
             ~default:"ASK-LEDGER"
             (parameter (fun _ ->
                function
                | "ASK-LEDGER" ->
                    return_none
                | s -> (
                  try return_some (Int32.of_string s)
                  with _ ->
                    failwith "Parameter %S should be a 32-bits integer" s )))
         in
         args3
           (default_arg
              ~doc:"Use <ID> as main chain-id instead of asking the node."
              ~long:"main-chain-id"
              ~placeholder:"ID"
              ~default:"ASK-NODE"
              (parameter (fun _ ->
                 function
                 | "ASK-NODE" ->
                     return `Ask_node
                 | s -> (
                   try return (`Int32 (Int32.of_string s))
                   with _ -> (
                     try return (`Chain_id (Chain_id.of_b58check_exn s))
                     with _ ->
                       failwith
                         "Parameter %S should be a 32-bits integer or a \
                          Base58 chain-id"
                         s ) ))))
           (hwm_arg "main")
           (hwm_arg "test"))
        ( prefixes ["setup"; "ledger"; "to"; "bake"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun (chain_id_opt, main_hwm_opt, test_hwm_opt)
             ledger_uri
             (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              (let open Ledgerwallet_tezos.Version in
              match version with
              | {app_class = Tezos; _} ->
                  failwith
                    "This command (`setup ledger ...`) only works with the \
                     Tezos Baking app"
              | {app_class = TezBake; major; _} when major < 2 ->
                  failwith
                    "This command (`setup ledger ...`)@ is not@ compatible@ \
                     with this version@ of the Ledger Baking app@ (%a < \
                     2.0.0),@ please upgrade@ your ledger@ or use the \
                     command@ `authorize ledger to bake for ...`"
                    pp
                    version
              | _ ->
                  return_unit)
              >>=? fun () ->
              Ledger_uri.full_account ledger_uri
              >>=? fun {Ledger_account.curve; path; _} ->
              let chain_id_of_int32 i32 =
                let open Int32 in
                let byte n =
                  logand 0xFFl (shift_right i32 (n * 8))
                  |> Int32.to_int |> char_of_int
                in
                Chain_id.of_string_exn
                  (Stringext.of_array (Array.init 4 (fun i -> byte (3 - i))))
              in
              ( match chain_id_opt with
              | `Ask_node ->
                  Chain_services.chain_id cctxt ()
              | `Int32 s ->
                  return (chain_id_of_int32 s)
              | `Chain_id chid ->
                  return chid )
              >>=? fun main_chain_id ->
              Ledger_commands.wrap_ledger_cmd (fun pp ->
                  Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi)
              >>=? fun ( `Main_hwm current_mh,
                         `Test_hwm current_th,
                         `Chain_id current_ci ) ->
              let main_hwm = Option.unopt main_hwm_opt ~default:current_mh in
              let test_hwm = Option.unopt test_hwm_opt ~default:current_th in
              cctxt#message
                "Setting up the ledger:@.* Main chain ID: %a -> %a@.* Main \
                 chain High Watermark: %ld -> %ld@.* Test chain High \
                 Watermark: %ld -> %ld"
                pp_ledger_chain_id
                current_ci
                Chain_id.pp
                main_chain_id
                current_mh
                main_hwm
                current_th
                test_hwm
              >>= fun () ->
              Ledger_commands.public_key_returning_instruction
                (`Setup (Chain_id.to_string main_chain_id, main_hwm, test_hwm))
                hidapi
                curve
                path
              >>=? fun pk ->
              let pkh = Signature.Public_key.hash pk in
              cctxt#message
                "@[<v 0>Authorized baking for address: %a@,\
                 Corresponding full public key: %a@]"
                Signature.Public_key_hash.pp
                pkh
                Signature.Public_key.pp
                pk
              >>= fun () -> return_some ()));
      Clic.command
        ~group
        ~desc:"Deauthorize Ledger from baking"
        no_options
        ( prefixes ["deauthorize"; "ledger"; "baking"; "for"]
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun () ledger_uri (_cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (_version, _git_commit) _device_info _ledger_id ->
              Ledger_commands.wrap_ledger_cmd (fun pp ->
                  Ledgerwallet_tezos.deauthorize_baking ~pp hidapi)
              >>=? fun () -> return_some ())) ]

(** Commands for high water mark of the Baking app. The
    [watermark_spelling] argument is used to make 2 sets of commands: with
    the old/wrong spelling “watermark” for backwards compatibility and
    with the correct one “high water mark” (it's a mark of the highest
    water level). *)
let high_water_mark_commands group watermark_spelling =
  let make_desc desc =
    if List.length watermark_spelling = 1 then
      desc ^ " (legacy/deprecated spelling)"
    else desc
  in
  Clic.
    [ Clic.command
        ~group
        ~desc:(make_desc "Get high water mark of a Ledger")
        (args1
           (switch
              ~doc:
                "Prevent the fallback to the (deprecated) Ledger instructions \
                 (for 1.x.y versions of the Baking app)"
              ~long:"no-legacy-instructions"
              ()))
        ( prefixes (["get"; "ledger"; "high"] @ watermark_spelling @ ["for"])
        @@ Ledger_uri.ledger_uri_or_alias_param @@ stop )
        (fun no_legacy_apdu ledger_uri (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              match version.app_class with
              | Tezos ->
                  failwith
                    "Fatal: this operation is only valid with the Tezos \
                     Baking application"
              | TezBake when (not no_legacy_apdu) && version.major < 2 ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.get_high_watermark ~pp hidapi)
                  >>=? fun hwm ->
                  cctxt#message
                    "The high water mark for@ %a@ is %ld."
                    Ledger_uri.pp
                    ledger_uri
                    hwm
                  >>= fun () -> return_some ()
              | TezBake when no_legacy_apdu && version.major < 2 ->
                  failwith
                    "Cannot get the high water mark with@ \
                     `--no-legacy-instructions` and version %a"
                    Ledgerwallet_tezos.Version.pp
                    version
              | TezBake ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.get_all_high_watermarks ~pp hidapi)
                  >>=? fun (`Main_hwm mh, `Test_hwm th, `Chain_id ci) ->
                  cctxt#message
                    "The high water mark values for@ %a@ are@ %ld for the \
                     main-chain@ (%a)@ and@ %ld for the test-chain."
                    Ledger_uri.pp
                    ledger_uri
                    mh
                    pp_ledger_chain_id
                    ci
                    th
                  >>= fun () -> return_some ()));
      Clic.command
        ~group
        ~desc:(make_desc "Set high water mark of a Ledger")
        no_options
        ( prefixes (["set"; "ledger"; "high"] @ watermark_spelling @ ["for"])
        @@ Ledger_uri.ledger_uri_or_alias_param @@ prefix "to"
        @@ param
             ~name:"high watermark"
             ~desc:"High watermark"
             (parameter (fun _ctx s ->
                  try return (Int32.of_string s)
                  with _ -> failwith "%s is not an int32 value" s))
        @@ stop )
        (fun () ledger_uri hwm (cctxt : Client_context.full) ->
          use_ledger_or_fail
            ~ledger_uri
            ~filter:Filter.is_baking
            (fun hidapi (version, _git_commit) _device_info _ledger_id ->
              match version.app_class with
              | Tezos ->
                  failwith "Fatal: this operation is only valid with TezBake"
              | TezBake ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.set_high_watermark ~pp hidapi hwm)
                  >>=? fun () ->
                  Ledger_commands.wrap_ledger_cmd (fun pp ->
                      Ledgerwallet_tezos.get_high_watermark ~pp hidapi)
                  >>=? fun new_hwm ->
                  cctxt#message
                    "@[<v 0>%a has now high water mark: %ld@]"
                    Ledger_uri.pp
                    ledger_uri
                    new_hwm
                  >>= fun () -> return_some ())) ]

let commands =
  let group =
    {
      Clic.name = "ledger";
      title = "Commands for managing the connected Ledger Nano devices";
    }
  in
  fun () ->
    generic_commands group @ baking_commands group
    @ high_water_mark_commands group ["water"; "mark"]
    @ high_water_mark_commands group ["watermark"]
src/lib_signer_backends/unix/ledger.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_keys.

(* ❌ Structure item `include` not handled. *)
include

Module Bip32_path.
  Definition hard : int32 -> int32 :=
    Int32.logor
      (* ❌ Constant of type int32 is converted to int *)
      (-2147483648).
  
  Definition unhard : int32 -> int32 :=
    Int32.logand
      (* ❌ Constant of type int32 is converted to int *)
      2147483647.
  
  Definition is_hard (n : int32) : bool :=
    nequiv_decb
      (Int32.logand
        (* ❌ Constant of type int32 is converted to int *)
        (-2147483648) n)
      (* ❌ Constant of type int32 is converted to int *)
      0.
  
  Definition tezos_root : list int32 :=
    cons
      (hard
        (* ❌ Constant of type int32 is converted to int *)
        44)
      (cons
        (hard
          (* ❌ Constant of type int32 is converted to int *)
          1729) []).
  
  Definition node_of_string (str : string) : option int32 :=
    match Int32.of_string_opt str with
    | Some node => Some node
    | None =>
      match Int32.of_string_opt (sub str 0 (Z.sub (length str) 1)) with
      | None => None
      | Some node => Some (hard node)
      end
    end.
  
  Definition node_of_string_exn (str : string) : int32 :=
    match node_of_string str with
    | None =>
      OCaml.Stdlib.invalid_arg
        (Printf.sprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "node_of_string_exn: got " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "node_of_string_exn: got %S" % string) str)
    | Some str => str
    end.
  
  Definition pp_node (ppf : Stdlib.Format.formatter) (node : int32) : unit :=
    match is_hard node with
    | true =>
      Fmt.pf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Char_literal "h" % char
              CamlinternalFormatBasics.End_of_format)) "%ldh" % string)
        (unhard node)
    | false =>
      Fmt.pf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int32 CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format) "%ld" % string) node
    end.
  
  Definition string_of_node : int32 -> string := Fmt.to_to_string pp_node.
  
  Definition path_of_string_exn (s : string) : list int32 :=
    match String.split_on_char "/" % char s with
    | cons "" % string [] => []
    | nodes => List.map node_of_string_exn nodes
    end.
  
  Definition path_of_string (s : string) : option (list int32) :=
    (* ❌ Try-with are not handled *)
    try (Some (path_of_string_exn s)).
  
  Definition pp_path : Fmt.t (list int32) :=
    list (Some (const char "/" % char)) pp_node.
  
  Definition string_of_path : (list int32) -> string := Fmt.to_to_string pp_path.
End Bip32_path.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition error_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding Ledgerwallet.Transport.error :=
  conv
    (fun e =>
      Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) Ledgerwallet.Transport.pp_error e)
    (fun function_parameter =>
      let '_ := function_parameter in
      OCaml.Stdlib.invalid_arg "Ledger error is not deserializable" % string)
    None (obj1 (req None None "ledger-error" % string string)).





Module Ledger_commands.
  Definition wrap_ledger_cmd {A : Type}
    (f : Stdlib.Format.formatter -> sum A Ledgerwallet.Transport.error)
    : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
    let buf := Buffer.create 100 in
    let pp :=
      Format.make_formatter
        (fun s => fun ofs => fun lgth => Buffer.add_substring buf s ofs lgth)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            debug
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Flush
                    CamlinternalFormatBasics.End_of_format)) "%s%!" % string)
              (Buffer.contents buf) in
          Buffer.clear buf) in
    let res := f pp in
    op_gtgteq
      (lwt_debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format)
          "%!" % string))
      (fun function_parameter =>
        let 'tt := function_parameter in
        match res with
        | Stdlib.Error err => fail (Tezos_base__TzPervasives.LedgerError err)
        | Stdlib.Ok v => _return v
        end).
  
  Definition get_version (device_info : Hidapi.device_info) (h : Hidapi.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (option (Ledgerwallet_tezos.Version.t * string))) :=
    let buf := Buffer.create 100 in
    let pp := Format.formatter_of_buffer buf in
    let version := Ledgerwallet_tezos.get_version (Some pp) None h in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string)
        (Buffer.contents buf) in
    match version with
    | Stdlib.Error e =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        warn
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "WARNING:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.String_literal
                  "The device at [" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      "] is not a Tezos application" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format)))))))
            "WARNING:@ The device at [%s] is not a Tezos application@ %a" %
              string) (Hidapi.path device_info) Ledgerwallet.Transport.pp_error
          e in
      return_none
    | Stdlib.Ok version =>
      op_gtgteqquestion
        (if OCaml.Stdlib.lt ((major version), (minor version)) (1, 4) then
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Version " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    " of the ledger apps is not supported by this client" %
                      string CamlinternalFormatBasics.End_of_format)))
              "Version %a of the ledger apps is not supported by this client" %
                string) Ledgerwallet_tezos.Version.pp version
        else
          return_unit)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (wrap_ledger_cmd
              (fun pp => Ledgerwallet_tezos.get_git_commit (Some pp) None h))
            (fun git_commit =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                log_info
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "Found a " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal
                          " application at [" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              "] (git-description: " % string
                              (CamlinternalFormatBasics.Caml_string
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Char_literal
                                  ")" % char
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "Found a %a application at [%s] (git-description: %S)" %
                      string) Ledgerwallet_tezos.Version.pp version
                  (path device_info) git_commit in
              let cleaned_up :=
                if
                  equiv_decb
                    (String.get git_commit (Z.sub (String.length git_commit) 1))
                    "000" % char then
                  String.sub git_commit 0 (Z.sub (String.length git_commit) 1)
                else
                  git_commit in
              return_some (version, cleaned_up)))
    end.
  
  Definition secp256k1_ctx : Libsecp256k1.External.Context.t :=
    Libsecp256k1.External.Context.create (Some false) (Some false) tt.
  
  Definition public_key_returning_instruction
    (which : variant) (op_staroptstar : option bool)
    : Hidapi.t ->
      Ledgerwallet_tezos.curve ->
        (list int32) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              Tezos_base__TzPervasives.Signature.Public_key.t) :=
    let prompt :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun hidapi =>
      fun curve =>
        fun path =>
          let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
          op_gtgtpipequestion
            match which with
            | Get_public_key =>
              wrap_ledger_cmd
                (fun pp =>
                  Ledgerwallet_tezos.get_public_key (Some prompt) (Some pp) None
                    hidapi curve path)
            | Authorize_baking =>
              wrap_ledger_cmd
                (fun pp =>
                  Ledgerwallet_tezos.authorize_baking (Some pp) None hidapi
                    curve path)
            | Setup (main_chain_id, main_hwm, test_hwm) =>
              wrap_ledger_cmd
                (fun pp =>
                  Ledgerwallet_tezos.setup_baking (Some pp) None hidapi
                    main_chain_id main_hwm test_hwm curve path)
            end
            (fun pk =>
              match curve with
              | Ledgerwallet_tezos.Ed25519 | Ledgerwallet_tezos.Bip32_ed25519 =>
                let pk := Cstruct.to_bytes pk in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := TzEndian.set_int8 pk 0 0 in
                Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding
                  pk
              | Ledgerwallet_tezos.Secp256k1 =>
                let buf := Bigstring.create (Z.add Key.compressed_pk_bytes 1) in
                let pk := Key.read_pk_exn secp256k1_ctx (Cstruct.to_bigarray pk)
                  in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  EndianBigstring.BigEndian.(EndianBigstring.EndianBigstringSig.set_int8)
                    buf 0 1 in
                let _nb_written := Key.write None secp256k1_ctx (Some 1) buf pk
                  in
                Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding
                  (Bigstring.to_bytes buf)
              | Ledgerwallet_tezos.Secp256r1 =>
                let pklen := compressed_size secp256r1 in
                let buf := Bigstring.create (Z.add pklen 1) in
                match pk_of_bytes secp256r1 (Cstruct.to_bigarray pk) with
                | None =>
                  Pervasives.failwith
                    "Impossible to read P256 public key from Ledger" % string
                | Some pk =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    EndianBigstring.BigEndian.(EndianBigstring.EndianBigstringSig.set_int8)
                      buf 0 2 in
                  let _nb_written :=
                    write_key (Some true) (Bigstring.sub buf 1 pklen) pk in
                  Data_encoding.Binary.of_bytes_exn
                    Signature.Public_key.encoding (Bigstring.to_bytes buf)
                end
              end).
  
  Definition get_public_key
    : (option bool) ->
      Hidapi.t ->
        Ledgerwallet_tezos.curve ->
          (list int32) ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_base__TzPervasives.Signature.Public_key.t) :=
    public_key_returning_instruction
      (* ❌ Variants not supported *)
      variant.
  
  Definition pkh_of_pk
    : Tezos_base__TzPervasives.Signature.Public_key.t ->
      Tezos_crypto__Signature.Public_key_hash.t := Signature.Public_key.hash.
  
  Definition public_key
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Signature.Public_key.t) :=
    match first_import with
    | Some cctxt =>
      op_gtgteqquestion (get_public_key (Some false) hid curve path)
        (fun pk =>
          let pkh := pkh_of_pk pk in
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Please validate" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal
                      "(and write down)" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.String_literal
                          "the public key hash" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "displayed" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "on the Ledger," % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "it should be equal" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "to `" % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              "`:" % string
                                              CamlinternalFormatBasics.End_of_format)))))))))))))))
                "Please validate@ (and write down)@ the public key hash@ displayed@ on the Ledger,@ it should be equal@ to `%a`:"
                  % string) Signature.Public_key_hash.pp pkh)
            (fun function_parameter =>
              let 'tt := function_parameter in
              get_public_key (Some true) hid curve path))
    | None => get_public_key (Some false) hid curve path
    end.
  
  Definition public_key_hash
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_crypto__Signature.Public_key_hash.t *
          Tezos_base__TzPervasives.Signature.Public_key.t)) :=
    op_gtgteqquestion (public_key first_import hid curve path)
      (fun pk => _return ((pkh_of_pk pk), pk)).
  
  Definition get_authorized_path
    (hid : Hidapi.t) (version : Ledgerwallet_tezos.Version.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult variant) :=
    if OCaml.Stdlib.lt (major version) 2 then
      op_gtgtpipequestion
        (wrap_ledger_cmd
          (fun pp => Ledgerwallet_tezos.get_authorized_key (Some pp) None hid))
        (fun path =>
          (* ❌ Variants not supported *)
          variant)
    else
      op_gtgteq
        (wrap_ledger_cmd
          (fun pp =>
            Ledgerwallet_tezos.get_authorized_path_and_curve (Some pp) None hid))
        (fun function_parameter =>
          match function_parameter with
          |
            Stdlib.Error
              (cons
                (Tezos_base__TzPervasives.LedgerError
                  (Ledgerwallet.Transport.AppError {|
                    status := Ledgerwallet.Transport.Status.Referenced_data_not_found
                      |})) _) =>
            _return
              (* ❌ Variants not supported *)
              variant
          | (Stdlib.Error _) as e => Lwt._return e
          | Stdlib.Ok (path, curve) =>
            _return
              (* ❌ Variants not supported *)
              variant
          end).
  
  Definition sign
    (watermark : option Tezos_base__TzPervasives.Signature.watermark)
    (version : Ledgerwallet_tezos.Version.t) (hid : Hidapi.t)
    (curve : Ledgerwallet_tezos.curve) (path : list int32)
    (base_msg : Stdlib.Bytes.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
    let msg :=
      Option.unopt_map
        (fun watermark =>
          String.append (Signature.bytes_of_watermark watermark) base_msg)
        base_msg watermark in
    let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
    op_gtgteqquestion
      (wrap_ledger_cmd
        (fun pp =>
          let '{|
            Ledgerwallet_tezos.Version.major := major;
              Ledgerwallet_tezos.Version.minor := minor;
              Ledgerwallet_tezos.Version.patch := patch
              |} := version in
          if OCaml.Stdlib.le (major, minor, patch) (2, 0, 0) then
            op_gtgteq
              (Ledgerwallet_tezos.sign (Some pp) None None hid curve path
                (Cstruct.of_bytes None None None msg))
              (fun s => Stdlib.Ok (None, s))
          else
            op_gtgteq
              (Ledgerwallet_tezos.sign_and_hash (Some pp) None hid curve path
                (Cstruct.of_bytes None None None msg))
              (fun function_parameter =>
                let '(h, s) := function_parameter in
                Stdlib.Ok ((Some h), s))))
      (fun function_parameter =>
        let '(hash_opt, signature) := function_parameter in
        op_gtgteqquestion
          match hash_opt with
          | None => return_unit
          | Some hsh =>
            let hash_msg := Blake2B.hash_bytes None (cons msg []) in
            let ledger_one := Blake2B.of_bytes_exn (Cstruct.to_bytes hsh) in
            if Blake2B.equal hash_msg ledger_one then
              return_unit
            else
              fail
                (Tezos_base__TzPervasives.Ledger_signing_hash_mismatch
                  (Blake2B.to_string ledger_one) (Blake2B.to_string hash_msg))
          end
          (fun function_parameter =>
            let 'tt := function_parameter in
            match curve with
            | Ledgerwallet_tezos.Ed25519 | Ledgerwallet_tezos.Bip32_ed25519 =>
              let signature := Ed25519.of_bytes_exn (Cstruct.to_bytes signature)
                in
              _return (Signature.of_ed25519 signature)
            | Ledgerwallet_tezos.Secp256k1 =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                set_uint8 signature 0 (Z.land (get_uint8 signature 0) 254) in
              let signature := Cstruct.to_bigarray signature in
              let signature := Sign.read_der_exn secp256k1_ctx signature in
              let bytes := Sign.to_bytes None secp256k1_ctx signature in
              let signature :=
                Secp256k1.of_bytes_exn (Bigstring.to_bytes string) in
              _return (Signature.of_secp256k1 signature)
            | Ledgerwallet_tezos.Secp256r1 =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                set_uint8 signature 0 (Z.land (get_uint8 signature 0) 254) in
              let signature := Cstruct.to_bigarray signature in
              let signature := Sign.read_der_exn secp256k1_ctx signature in
              let buf := Sign.to_bytes None secp256k1_ctx signature in
              let signature := P256.of_bytes_exn (Bigstring.to_bytes buf) in
              _return (Signature.of_p256 signature)
            end)).
  
  Definition get_deterministic_nonce
    (hid : Hidapi.t) (curve : Ledgerwallet_tezos.curve) (path : list int32)
    (msg : string) : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
    let path := OCaml.Stdlib.app Bip32_path.tezos_root path in
    op_gtgteqquestion
      (wrap_ledger_cmd
        (fun pp =>
          Ledgerwallet_tezos.get_deterministic_nonce (Some pp) None hid curve
            path (Cstruct.of_bytes None None None msg)))
      (fun nonce => _return (Bigstring.of_bytes (Cstruct.to_bytes nonce))).
End Ledger_commands.

Module Ledger_id.
  Inductive t : Type :=
  | Animals : Tezos_signer_backends_unix.Ledger_names.t -> t
  | Pkh : Tezos_base__TzPervasives.Signature.public_key_hash -> t.
  
  Definition animals_of_pkh
    (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    : Tezos_signer_backends_unix.Ledger_names.t :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply pkh Signature.Public_key_hash.to_string)
      Ledger_names.crouching_tiger.
  
  Definition curve : Ledgerwallet_tezos.curve := Ledgerwallet_tezos.Ed25519.
  
  Definition get (hidapi : Hidapi.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    op_gtgteqquestion (Ledger_commands.get_public_key None hidapi curve [])
      (fun pk =>
        let pkh := Signature.Public_key.hash pk in
        let animals := animals_of_pkh pkh in
        _return (Animals animals)).
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Animals a => Ledger_names.pp ppf a
    | Pkh pkh => Signature.Public_key_hash.pp ppf pkh
    end.
  
  Definition to_animals (function_parameter : t)
    : Tezos_signer_backends_unix.Ledger_names.t :=
    match function_parameter with
    | Animals a => a
    | Pkh pkh => animals_of_pkh pkh
    end.
  
  Definition equal (a : t) (b : t) : bool :=
    equiv_decb (to_animals a) (to_animals b).
End Ledger_id.

Module Ledger_account.
  Record t := {
    ledger : Ledger_id.t;
    curve : Ledgerwallet_tezos.curve;
    path : list int32 }.
End Ledger_account.

Module Ledger_uri.
  Definition t := variant.
  
  Definition int32_of_path_element_exn (allow_weak : bool) (x : string)
    : int32 :=
    let failf {A B : Type} (ppf : Stdlib.format4 A unit string B) : A :=
      Printf.ksprintf Pervasives.failwith ppf in
    let len := String.length x in
    match String.get x (Z.sub len 1) with
    | "'" % char | "h" % char =>
      let intpart := String.sub x 0 (Z.sub len 1) in
      match Int32.of_string_opt intpart with
      | Some i => Bip32_path.hard i
      | None =>
        failf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Path is not an integer: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Path is not an integer: %S" % string) intpart
      end
    | _ =>
      match Int32.of_string_opt x with
      | Some i => i
      | None =>
        failf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Path is not a non-hardened integer: " % string
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Path is not a non-hardened integer: %S" % string) x
      end
    | _ =>
      failf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Non-hardened paths are not allowed for this derivation scheme (" %
              string
            (CamlinternalFormatBasics.Caml_string
              CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))
          "Non-hardened paths are not allowed for this derivation scheme (%S)" %
            string) x
    end.
  
  Definition parse_animals (animals : string)
    : option Tezos_signer_backends_unix.Ledger_names.t :=
    match String.split "-" % char None None animals with
    | cons c (cons t (cons h (cons d []))) =>
      Some
        {| Ledger_names.c := c; Ledger_names.t := t; Ledger_names.h := h;
          Ledger_names.d := d |}
    | _ => None
    end.
  
  Definition derivation_supports_weak_paths
    (function_parameter : Ledgerwallet_tezos.curve) : bool :=
    match function_parameter with
    | Ledgerwallet_tezos.Ed25519 => false
    | Ledgerwallet_tezos.Secp256k1 => true
    | Ledgerwallet_tezos.Secp256r1 => true
    | Ledgerwallet_tezos.Bip32_ed25519 => true
    end.
  
  Definition parse (allow_weak : option bool) (uri : Uri.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
    let host := Uri.host uri in
    op_gtgteqquestion
      match Option.apply Signature.Public_key_hash.of_b58check_opt host with
      | Some pkh => _return (Ledger_id.Pkh pkh)
      | None =>
        match Option.apply parse_animals host with
        | Some animals => _return (Ledger_id.Animals animals)
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot parse host of URI: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))
              "Cannot parse host of URI: %s" % string) (Uri.to_string uri)
        end
      end
      (fun ledger =>
        let components := String.split "/" % char None None (Uri.path uri) in
        match components with
        | cons s tl =>
          let '(curve, more_path) :=
            match Ledgerwallet_tezos.curve_of_string s with
            | Some curve => (curve, tl)
            | None => (Ledger_id.curve, (cons s tl))
            end in
          let actually_allow_weak :=
            match allow_weak with
            | None => derivation_supports_weak_paths curve
            | Some x => x
            end in
          op_gtgteqquestion
            (* ❌ Try-with are not handled *)
            (try
              (_return
                (List.map (int32_of_path_element_exn actually_allow_weak)
                  more_path)))
            (fun bip32 =>
              _return
                (* ❌ Variants not supported *)
                variant)
        | [] =>
          _return
            (* ❌ Variants not supported *)
            variant
        end).
  
  Definition ledger_uri_or_alias_param {A C a : Type}
    (next :
      Tezos_base__TzPervasives.Clic.params A
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
          * C))
    : Tezos_base__TzPervasives.Clic.params (t -> A)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
        * C) :=
    let name := "account-alias-or-ledger-uri" % string in
    let desc :=
      "An imported ledger alias or a ledger URI (e.g. ""ledger://animal/curve/path"")."
        % string in
    param name desc
      (parameter None
        (fun cctxt =>
          fun str =>
            op_gtgteqquestion
              (op_gtgteqquestion (Public_key.find_opt cctxt str)
                (fun function_parameter =>
                  match function_parameter with
                  | Some (_ as x, _) => _return x
                  | None =>
                    (* ❌ Try-with are not handled *)
                    try (_return (Uri.of_string str))
                  end)) (fun uri => parse None uri))) next.
  
  Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
    : unit :=
    match function_parameter with
    | Ledger lid =>
      fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "ledger://" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "ledger://%a" % string)
        Ledger_id.pp lid
    |
      Ledger_account {|
        Ledger_account.ledger := ledger;
          Ledger_account.curve := curve;
          Ledger_account.path := path
          |} =>
      fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "ledger://" % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal "/" % char
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal "/" % char
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))))))
          "ledger://%a/%a/%a" % string) Ledger_id.pp ledger
        Ledgerwallet_tezos.pp_curve curve Bip32_path.pp_path path
    end.
  
  Definition if_matches {A : Type}
    (meta_uri : t) (ledger_id : Ledger_id.t)
    (cont : unit -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A)))
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
    match meta_uri with
    | Ledger l =>
      if Ledger_id.equal l ledger_id then
        cont tt
      else
        return_none
    | Ledger_account {| Ledger_account.ledger := ledger |} =>
      if Ledger_id.equal ledger ledger_id then
        cont tt
      else
        return_none
    end.
  
  Definition full_account (ledger_uri : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Ledger_account.(Base.T.t)) :=
    match ledger_uri with
    | Ledger_account acc => _return acc
    | Ledger ledger_id =>
      failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Insufficient information: you need to provide a curve & BIP32 path ("
              % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal ")." % string
                CamlinternalFormatBasics.End_of_format)))
          "Insufficient information: you need to provide a curve & BIP32 path (%a)."
            % string) Ledger_id.pp ledger_id
    end.
End Ledger_uri.

Module Filter.
  Definition version_filter := (Ledgerwallet_tezos.Version.t * string) -> bool.
  
  Definition t := variant.
  
  Definition version_matches
    (t : t) (version_commit : Ledgerwallet_tezos.Version.t * string) : bool :=
    match t with
    | Version (_, f) => f version_commit
    | _ => true
    end.
  
  Definition is_app (msg : string) (app : Ledgerwallet_tezos.Version.app_class)
    : t :=
    (* ❌ Variants not supported *)
    variant.
  
  Definition is_baking : t :=
    is_app "App = Baking" % string Ledgerwallet_tezos.Version.TezBake.
  
  Definition pp (ppf : Stdlib.Format.formatter) (f : t) : unit :=
    match f with
    | None =>
      fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "None" % string
            CamlinternalFormatBasics.End_of_format) "None" % string)
    | Hid_path s =>
      fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "HID-path: " % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) "HID-path: %s" % string)
        s
    | Version (s, _) =>
      fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) s
    end.
End Filter.

Definition vendor_id : Z := 11415.

Definition product_id_nano_s : Z := 1.

Definition product_id_nano_x : Z := 4.

Definition use_ledger {A : Type} (op_staroptstar : option Filter.t)
  : (Hidapi.t ->
    (Ledgerwallet_tezos.Version.t * string) ->
      Hidapi.device_info ->
        Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A))) ->
    Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
  let '_ as filter :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun f =>
    let ledgers :=
      OCaml.Stdlib.app
        (Hidapi.enumerate (Some vendor_id) (Some product_id_nano_s) tt)
        (Hidapi.enumerate (Some vendor_id) (Some product_id_nano_x) tt) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      debug
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Found " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal " Ledger(s) " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format))))
          "Found %d Ledger(s) %s" % string) (List.length ledgers)
        (String.concat " -- " % string
          (List.map
            (fun l =>
              Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Char_literal "(" % char
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_x
                      (CamlinternalFormatBasics.Lit_padding
                        CamlinternalFormatBasics.Zeros 4)
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal ", " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_x
                          (CamlinternalFormatBasics.Lit_padding
                            CamlinternalFormatBasics.Zeros 4)
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))
                  "(%04x, %04x)" % string) (vendor_id l) (product_id l)) ledgers))
      in
    let process_device {B : Type}
      (device_info : Hidapi.device_info) (f :
      Hidapi.t ->
        (Ledgerwallet_tezos.Version.t * string) ->
          Hidapi.device_info ->
            Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option B)))
      : Lwt.t (Tezos_base__TzPervasives.tzresult (option B)) :=
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        log_info
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Processing Ledger at path [" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "]" % char
                  CamlinternalFormatBasics.End_of_format)))
            "Processing Ledger at path [%s]" % string) (Hidapi.path device_info)
        in
      if
        orb (equiv_decb (Hidapi.interface_number device_info) 0)
          (andb (equiv_decb (Hidapi.interface_number device_info) (-1))
            (equiv_decb (Hidapi.usage_page device_info) 65440)) then
        match filter with
        | Hid_path hp => return_none
        | _ =>
          match open_path (path device_info) with
          | None => return_none
          | Some h =>
            Lwt.finalize
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (Ledger_commands.get_version device_info h)
                  (fun function_parameter =>
                    match function_parameter with
                    | Some version_git =>
                      op_gtgteqquestion (Ledger_id.get h)
                        (fun ledger_id => f h version_git device_info ledger_id)
                    | None | Some _ => return_none
                    end))
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := Hidapi.close h in
                Lwt.return_unit)
          end
        end
      else
        return_none in
    let fix go (function_parameter : list Hidapi.device_info)
      : Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
      match function_parameter with
      | [] => return_none
      | cons h t =>
        op_gtgteqquestion (process_device h f)
          (fun function_parameter =>
            match function_parameter with
            | Some x => return_some x
            | None => go t
            end)
      end in
    go ledgers.

Definition min_version_of_derivation_scheme
  (function_parameter : Ledgerwallet_tezos.curve) : Z * Z * Z :=
  match function_parameter with
  | Ledgerwallet_tezos.Ed25519 => (1, 3, 0)
  | Ledgerwallet_tezos.Secp256k1 => (1, 3, 0)
  | Ledgerwallet_tezos.Secp256r1 => (1, 3, 0)
  | Ledgerwallet_tezos.Bip32_ed25519 => (2, 1, 0)
  end.

Definition is_derivation_scheme_supported
  (version : Ledgerwallet_tezos.Version.t) (curve : Ledgerwallet_tezos.curve)
  : bool :=
  let '{| major := major; minor := minor; patch := patch |} := version in
  OCaml.Stdlib.ge (major, minor, patch) (min_version_of_derivation_scheme curve).

Definition use_ledger_or_fail {A : Type}
  (ledger_uri : Ledger_uri.t) (filter : option Filter.t) (msg : option string)
  (f :
    Hidapi.t ->
      (Ledgerwallet_tezos.Version.t * string) ->
        Hidapi.device_info ->
          Ledger_id.t -> Lwt.t (Tezos_base__TzPervasives.tzresult (option A)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult A) :=
  op_gtgteqquestion
    (use_ledger filter
      (fun hidapi =>
        fun function_parameter =>
          let '(version, git_commit) := function_parameter in
          fun device_info =>
            fun ledger_id =>
              Ledger_uri.if_matches ledger_uri ledger_id
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let go (function_parameter : unit)
                    : Lwt.t (Tezos_base__TzPervasives.tzresult (option A)) :=
                    let 'tt := function_parameter in
                    f hidapi (version, git_commit) device_info ledger_id in
                  match ledger_uri with
                  | Ledger_account {| curve := curve |} =>
                    if is_derivation_scheme_supported version curve then
                      go tt
                    else
                      failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "To use derivation scheme " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " you need " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " or later but you're using " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        "." % char
                                        CamlinternalFormatBasics.End_of_format)))))))
                          "To use derivation scheme %a you need %a or later but you're using %a."
                            % string) pp_curve curve Version.pp
                        (let '(a, b, c) :=
                          min_version_of_derivation_scheme curve in
                        (* ❌ Record substitution not handled *)
                        record_substitution) Version.pp version
                  | _ => go tt
                  end)))
    (fun function_parameter =>
      match function_parameter with
      | Some o => _return o
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                "Found no ledger corresponding to " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Theta
                    (CamlinternalFormatBasics.Char_literal "." % char
                      CamlinternalFormatBasics.End_of_format)))))
            "%sFound no ledger corresponding to %a%t." % string)
          (Option.unopt_map
            (Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal ": " % string
                    CamlinternalFormatBasics.End_of_format)) "%s: " % string))
            "" % string msg) Ledger_uri.pp ledger_uri
          (fun ppf =>
            match filter with
            | Some f =>
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    " with filter """ % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal """" % char
                        CamlinternalFormatBasics.End_of_format)))
                  " with filter ""%a""" % string) Filter.pp f
            | None => tt
            end)
      end).

Module Global_cache.
  Definition _cache
    : Stdlib.Hashtbl.t Tezos_client_base.Client_keys.pk_uri
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        Tezos_base__TzPervasives.Signature.Public_key.t) :=
    Hashtbl.create None 13.
  
  Definition record
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
    (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t) : unit :=
    Hashtbl.replace _cache pk_uri (pkh, pk).
  
  Definition get (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : option
      (Tezos_base__TzPervasives.Signature.Public_key_hash.t *
        Tezos_base__TzPervasives.Signature.Public_key.t) :=
    Hashtbl.find_opt _cache pk_uri.
End Global_cache.

Module Signer_implementation.
  Definition scheme : string := "ledger" % string.
  
  Definition title : string :=
    "Built-in signer using a Ledger Nano device." % string.
  
  Definition description : string :=
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Valid URIs are of the form
 - ledger://<animals>/<curve>[/<path>]
where:
 - <animals> is the identifier of the ledger of the form 'crouching-tiger-hidden-dragon' and can be obtained with the command `tezos-client list connected ledgers` (which also provides full examples).
- <curve> is the signing curve, e.g. `ed1551`
- <path> is a BIP32 path anchored at m/"
            % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal
              ". The ledger does not yet support non-hardened paths, so each node of the path must be hardened."
                % string CamlinternalFormatBasics.End_of_format)))
        "Valid URIs are of the form
 - ledger://<animals>/<curve>[/<path>]
where:
 - <animals> is the identifier of the ledger of the form 'crouching-tiger-hidden-dragon' and can be obtained with the command `tezos-client list connected ledgers` (which also provides full examples).
- <curve> is the signing curve, e.g. `ed1551`
- <path> is a BIP32 path anchored at m/%s. The ledger does not yet support non-hardened paths, so each node of the path must be hardened."
          % string) (string_of_path tezos_root).
  
  Definition neuterize (sk : Tezos_client_base.Client_keys.sk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_client_base.Client_keys.pk_uri) :=
    _return (make_pk_uri sk).
  
  Definition pkh_of_pk
    : Tezos_base__TzPervasives.Signature.Public_key.t ->
      Tezos_crypto__Signature.Public_key_hash.t := Signature.Public_key.hash.
  
  Definition public_key_maybe_prompt
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_base__TzPervasives.Signature.public_key) :=
    match Global_cache.get pk_uri with
    | Some (_, pk) => _return pk
    | None =>
      op_gtgteq
        (op_gtgteqquestion (Ledger_uri.parse None pk_uri)
          (fun ledger_uri =>
            op_gtgteqquestion (Ledger_uri.full_account ledger_uri)
              (fun function_parameter =>
                let '{| curve := curve; path := path |} := function_parameter in
                use_ledger_or_fail ledger_uri None None
                  (fun hidapi =>
                    fun function_parameter =>
                      let '(_version, _git_commit) := function_parameter in
                      fun _device_info =>
                        fun _ledger_id =>
                          op_gtgteqquestion
                            (Ledger_commands.public_key first_import hidapi
                              curve path)
                            (fun pk =>
                              let pkh := pkh_of_pk pk in
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ := Global_cache.record pk_uri pk pkh in
                              return_some pk)))))
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Error err =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              pp_print_error err
          | Stdlib.Ok v => _return v
          end)
    end.
  
  Definition public_key_hash_maybe_prompt
    (first_import : option Tezos_client_base.Client_context.io_wallet)
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Signature.public_key_hash *
          (option Tezos_base__TzPervasives.Signature.public_key))) :=
    match Global_cache.get pk_uri with
    | Some (pkh, pk) => _return (pkh, (Some pk))
    | None =>
      op_gtgteqquestion (public_key_maybe_prompt first_import pk_uri)
        (fun pk => _return ((pkh_of_pk pk), (Some pk)))
    end.
  
  Definition public_key
    : Tezos_client_base.Client_keys.pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Signature.public_key) :=
    public_key_maybe_prompt None.
  
  Definition public_key_hash
    : Tezos_client_base.Client_keys.pk_uri ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          (Tezos_base__TzPervasives.Signature.public_key_hash *
            (option Tezos_base__TzPervasives.Signature.public_key))) :=
    public_key_hash_maybe_prompt None.
  
  Definition import_secret_key
    (io : Tezos_client_base.Client_context.io_wallet)
    (pk_uri : Tezos_client_base.Client_keys.pk_uri)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_base__TzPervasives.Signature.public_key_hash *
          (option Tezos_base__TzPervasives.Signature.public_key))) :=
    public_key_hash_maybe_prompt (Some io) pk_uri.
  
  Definition sign
    (watermark : option Tezos_base__TzPervasives.Signature.watermark)
    (sk_uri : Tezos_client_base.Client_keys.sk_uri) (msg : Stdlib.Bytes.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Signature.t) :=
    op_gtgteqquestion (Ledger_uri.parse None sk_uri)
      (fun ledger_uri =>
        op_gtgteqquestion (Ledger_uri.full_account ledger_uri)
          (fun function_parameter =>
            let '{| curve := curve; path := path |} := function_parameter in
            use_ledger_or_fail ledger_uri None None
              (fun hidapi =>
                fun function_parameter =>
                  let '(version, _git_commit) := function_parameter in
                  fun _device_info =>
                    fun _ledger_id =>
                      op_gtgteqquestion
                        (Ledger_commands.sign watermark version hidapi curve
                          path msg) (fun bytes => return_some string)))).
  
  Definition deterministic_nonce
    (sk_uri : Tezos_client_base.Client_keys.sk_uri) (msg : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Bigstring.t) :=
    op_gtgteqquestion (Ledger_uri.parse None sk_uri)
      (fun ledger_uri =>
        op_gtgteqquestion (Ledger_uri.full_account ledger_uri)
          (fun function_parameter =>
            let '{| curve := curve; path := path |} := function_parameter in
            use_ledger_or_fail ledger_uri None None
              (fun hidapi =>
                fun function_parameter =>
                  let '(_version, _git_commit) := function_parameter in
                  fun _device_info =>
                    fun _ledger_id =>
                      op_gtgteqquestion
                        (Ledger_commands.get_deterministic_nonce hidapi curve
                          path msg) (fun bytes => return_some string)))).
  
  Definition deterministic_nonce_hash
    (sk : Tezos_client_base.Client_keys.sk_uri) (msg : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
    op_gtgteqquestion (deterministic_nonce sk msg)
      (fun nonce =>
        _return
          (Blake2B.to_bytes
            (Blake2B.hash_bytes None (cons (Bigstring.to_bytes nonce) [])))).
  
  Definition supports_deterministic_nonces {A : Type} (function_parameter : A)
    : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    let '_ := function_parameter in
    return_true.
End Signer_implementation.

Definition pp_ledger_chain_id (fmt : Stdlib.Format.formatter) (s : string)
  : unit :=
  match s with
  | "" % string =>
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "'Unspecified'" % string
          CamlinternalFormatBasics.End_of_format) "'Unspecified'" % string)
  | other =>
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Chain_id.pp (Chain_id.of_string_exn other)
  end.

Definition generic_commands (group : Tezos_base__TzPervasives.Clic.group)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  cons
    (command (Some group)
      "List supported Ledger Nano devices connected." % string no_options
      (fixed
        (cons "list" % string
          (cons "connected" % string (cons "ledgers" % string []))))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          op_gtgteqquestion
            (use_ledger None
              (fun _hidapi =>
                fun function_parameter =>
                  let '(version, git_commit) := function_parameter in
                  fun device_info =>
                    fun ledger_id =>
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Theta
                              CamlinternalFormatBasics.End_of_format)
                            "%t" % string)
                          (fun ppf =>
                            let intro :=
                              asprintf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Found a " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " (git-description: " % string
                                        (CamlinternalFormatBasics.Caml_string
                                          CamlinternalFormatBasics.No_padding
                                          (CamlinternalFormatBasics.String_literal
                                            ") application running on " % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.Char_literal
                                                " " % char
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.String_literal
                                                    " at [" % string
                                                    (CamlinternalFormatBasics.String
                                                      CamlinternalFormatBasics.No_padding
                                                      (CamlinternalFormatBasics.String_literal
                                                        "]." % string
                                                        CamlinternalFormatBasics.End_of_format)))))))))))
                                  "Found a %a (git-description: %S) application running on %s %s at [%s]."
                                    % string) Ledgerwallet_tezos.Version.pp
                                version git_commit
                                (OCaml.Stdlib.reverse_apply
                                  (manufacturer_string device_info)
                                  (Option.unopt "NO-MANUFACTURER" % string))
                                (OCaml.Stdlib.reverse_apply
                                  (product_string device_info)
                                  (Option.unopt "NO-PRODUCT" % string))
                                (path device_info) in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_open_vbox ppf 0 in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              fprintf ppf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "## Ledger `" % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        "`" % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          CamlinternalFormatBasics.End_of_format))))
                                  "## Ledger `%a`@," % string) Ledger_id.pp
                                ledger_id in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_open_hovbox ppf 0 in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_print_text ppf intro in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_close_box ppf tt in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_print_cut ppf tt in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_print_cut ppf tt in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_open_hovbox ppf 0 in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              pp_print_text ppf
                                "To use keys at BIP32 path m/44'/1729'/0'/0' (default Tezos key path), use one of:"
                                  % string in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_close_box ppf tt in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_print_cut ppf tt in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ :=
                              List.iter
                                (fun curve =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    fprintf ppf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "  tezos-client import secret key ledger_"
                                            % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " ""ledger://" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "/" % char
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      "/0h/0h""" % string
                                                      CamlinternalFormatBasics.End_of_format)))))))
                                        "  tezos-client import secret key ledger_%s ""ledger://%a/%a/0h/0h"""
                                          % string)
                                      (OCaml.Stdlib.reverse_apply
                                        (Sys.getenv_opt "USER" % string)
                                        (Option.unopt "user" % string))
                                      Ledger_id.pp ledger_id
                                      Ledgerwallet_tezos.pp_curve curve in
                                  pp_print_cut ppf tt)
                                (List.filter
                                  (is_derivation_scheme_supported version)
                                  (cons Ledgerwallet_tezos.Bip32_ed25519
                                    (cons Ledgerwallet_tezos.Ed25519
                                      (cons Ledgerwallet_tezos.Secp256k1
                                        (cons Ledgerwallet_tezos.Secp256r1 [])))))
                              in
                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                            let _ := pp_close_box ppf tt in
                            pp_print_newline ppf tt))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_none)))
            (fun function_parameter =>
              let '_ := function_parameter in
              return_unit)))
    (cons
      (Clic.command (Some group)
        "Display version/public-key/address information for a Ledger URI" %
          string
        (args1
          (switch "Test signing operation" % string None "test-sign" % string tt))
        (apply (prefixes (cons "show" % string (cons "ledger" % string [])))
          (apply Ledger_uri.ledger_uri_or_alias_param stop))
        (fun test_sign =>
          fun ledger_uri =>
            fun cctxt =>
              use_ledger_or_fail ledger_uri None None
                (fun hidapi =>
                  fun function_parameter =>
                    let '(version, git_commit) := function_parameter in
                    fun device_info =>
                      fun _ledger_id =>
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Found ledger corresponding to " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    ":" % char
                                    CamlinternalFormatBasics.End_of_format)))
                              "Found ledger corresponding to %a:" % string)
                            Ledger_uri.pp ledger_uri)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "* Manufacturer: " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.End_of_format))
                                  "* Manufacturer: %s" % string)
                                (Option.unopt "NONE" % string
                                  (manufacturer_string device_info)))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "* Product: " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))
                                      "* Product: %s" % string)
                                    (Option.unopt "NONE" % string
                                      (product_string device_info)))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "* Application: " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " (git-description: " % string
                                                (CamlinternalFormatBasics.Caml_string
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.Char_literal
                                                    ")" % char
                                                    CamlinternalFormatBasics.End_of_format)))))
                                          "* Application: %a (git-description: %S)"
                                            % string)
                                        Ledgerwallet_tezos.Version.pp version
                                        git_commit)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteqquestion
                                          match ledger_uri with
                                          |
                                            Ledger_account {|
                                              curve := curve;
                                                path := path
                                                |} =>
                                            op_gtgteq
                                              ((* ❌ Sending method message is not handled *)
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "* Curve: `" % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Char_literal
                                                        "`" % char
                                                        CamlinternalFormatBasics.End_of_format)))
                                                  "* Curve: `%a`" % string)
                                                Ledgerwallet_tezos.pp_curve
                                                curve)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                let full_path :=
                                                  OCaml.Stdlib.app
                                                    Bip32_path.tezos_root path
                                                  in
                                                op_gtgteq
                                                  ((* ❌ Sending method message is not handled *)
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "* Path: `" % string
                                                        (CamlinternalFormatBasics.String
                                                          CamlinternalFormatBasics.No_padding
                                                          (CamlinternalFormatBasics.String_literal
                                                            "` [" % string
                                                            (CamlinternalFormatBasics.String
                                                              CamlinternalFormatBasics.No_padding
                                                              (CamlinternalFormatBasics.Char_literal
                                                                "]" % char
                                                                CamlinternalFormatBasics.End_of_format)))))
                                                      "* Path: `%s` [%s]" %
                                                        string)
                                                    (Bip32_path.string_of_path
                                                      full_path)
                                                    (String.concat "; " % string
                                                      (List.map
                                                        (Printf.sprintf
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "0x" % string
                                                              (CamlinternalFormatBasics.Int32
                                                                CamlinternalFormatBasics.Int_X
                                                                CamlinternalFormatBasics.No_padding
                                                                CamlinternalFormatBasics.No_precision
                                                                CamlinternalFormatBasics.End_of_format))
                                                            "0x%lX" % string))
                                                        full_path)))
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (Ledger_commands.public_key_hash
                                                        None hidapi curve path)
                                                      (fun function_parameter =>
                                                        let '(pkh, pk) :=
                                                          function_parameter in
                                                        op_gtgteq
                                                          ((* ❌ Sending method message is not handled *)
                                                          send
                                                            (CamlinternalFormatBasics.Format
                                                              (CamlinternalFormatBasics.String_literal
                                                                "* Public Key: "
                                                                  % string
                                                                (CamlinternalFormatBasics.Alpha
                                                                  CamlinternalFormatBasics.End_of_format))
                                                              "* Public Key: %a"
                                                                % string)
                                                            Signature.Public_key.pp
                                                            pk)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let 'tt :=
                                                              function_parameter
                                                              in
                                                            op_gtgteq
                                                              ((* ❌ Sending method message is not handled *)
                                                              send
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "* Public Key Hash: "
                                                                      % string
                                                                    (CamlinternalFormatBasics.Alpha
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Force_newline
                                                                        CamlinternalFormatBasics.End_of_format)))
                                                                  "* Public Key Hash: %a@
"
                                                                    % string)
                                                                Signature.Public_key_hash.pp
                                                                pkh)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                match
                                                                  (test_sign,
                                                                    (app_class
                                                                      version))
                                                                  with
                                                                |
                                                                  (true,
                                                                    Ledgerwallet_tezos.Version.Tezos)
                                                                  =>
                                                                  let
                                                                    pkh_bytes :=
                                                                    Signature.Public_key_hash.to_bytes
                                                                      pkh in
                                                                  op_gtgteq
                                                                    ((* ❌ Sending method message is not handled *)
                                                                    send
                                                                      (CamlinternalFormatBasics.Format
                                                                        (CamlinternalFormatBasics.Formatting_gen
                                                                          (CamlinternalFormatBasics.Open_box
                                                                            (CamlinternalFormatBasics.Format
                                                                              CamlinternalFormatBasics.End_of_format
                                                                              ""
                                                                                %
                                                                                string))
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "Attempting a signature"
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                              (CamlinternalFormatBasics.Break
                                                                                "@ "
                                                                                  %
                                                                                  string
                                                                                1
                                                                                0)
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "(of `"
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    "`),"
                                                                                      %
                                                                                      string
                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                      (CamlinternalFormatBasics.Break
                                                                                        "@ "
                                                                                          %
                                                                                          string
                                                                                        1
                                                                                        0)
                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                        "please"
                                                                                          %
                                                                                          string
                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                          (CamlinternalFormatBasics.Break
                                                                                            "@ "
                                                                                              %
                                                                                              string
                                                                                            1
                                                                                            0)
                                                                                          (CamlinternalFormatBasics.String_literal
                                                                                            "validate on"
                                                                                              %
                                                                                              string
                                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                                              (CamlinternalFormatBasics.Break
                                                                                                "@ "
                                                                                                  %
                                                                                                  string
                                                                                                1
                                                                                                0)
                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                "the ledger."
                                                                                                  %
                                                                                                  string
                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                  CamlinternalFormatBasics.Close_box
                                                                                                  CamlinternalFormatBasics.End_of_format)))))))))))))
                                                                        "@[Attempting a signature@ (of `%a`),@ please@ validate on@ the ledger.@]"
                                                                          %
                                                                          string)
                                                                      Hex.pp
                                                                      (Hex.of_bytes
                                                                        None
                                                                        pkh_bytes))
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let 'tt :=
                                                                        function_parameter
                                                                        in
                                                                      op_gtgteqquestion
                                                                        (Ledger_commands.sign
                                                                          (Some
                                                                            Tezos_base__TzPervasives.Signature.Generic_operation)
                                                                          version
                                                                          hidapi
                                                                          curve
                                                                          path
                                                                          pkh_bytes)
                                                                        (fun
                                                                          signature
                                                                          =>
                                                                          match
                                                                            Signature.check
                                                                              (Some
                                                                                Tezos_base__TzPervasives.Signature.Generic_operation)
                                                                              pk
                                                                              signature
                                                                              pkh_bytes
                                                                            with
                                                                          |
                                                                            false
                                                                            =>
                                                                            failwith
                                                                              (CamlinternalFormatBasics.Format
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Fatal: Ledger cannot sign with "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    CamlinternalFormatBasics.End_of_format))
                                                                                "Fatal: Ledger cannot sign with %a"
                                                                                  %
                                                                                  string)
                                                                              Signature.Public_key_hash.pp
                                                                              pkh
                                                                          | true
                                                                            =>
                                                                            op_gtgteq
                                                                              ((* ❌ Sending method message is not handled *)
                                                                              send
                                                                                (CamlinternalFormatBasics.Format
                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                    "Tezos Wallet successfully signed:"
                                                                                      %
                                                                                      string
                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                      (CamlinternalFormatBasics.Break
                                                                                        "@ "
                                                                                          %
                                                                                          string
                                                                                        1
                                                                                        0)
                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                        (CamlinternalFormatBasics.Char_literal
                                                                                          "."
                                                                                            %
                                                                                            char
                                                                                          CamlinternalFormatBasics.End_of_format))))
                                                                                  "Tezos Wallet successfully signed:@ %a."
                                                                                    %
                                                                                    string)
                                                                                Signature.pp
                                                                                signature)
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                let
                                                                                  'tt :=
                                                                                  function_parameter
                                                                                  in
                                                                                return_unit)
                                                                          end))
                                                                |
                                                                  (true,
                                                                    Ledgerwallet_tezos.Version.TezBake)
                                                                  =>
                                                                  failwith
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Option --test-sign only works for the Tezos Wallet app."
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)
                                                                      "Option --test-sign only works for the Tezos Wallet app."
                                                                        % string)
                                                                | (false, _) =>
                                                                  return_unit
                                                                end)))))
                                          | Ledger _ =>
                                            failwith
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Option --test-sign only works with a full ledger URI/account (with curve/path)."
                                                    % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "Option --test-sign only works with a full ledger URI/account (with curve/path)."
                                                  % string)
                                          | Ledger _ =>
                                            op_gtgteq
                                              ((* ❌ Sending method message is not handled *)
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "* This is just a ledger URI."
                                                      % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "* This is just a ledger URI."
                                                    % string))
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                return_unit)
                                          end
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            return_some tt)))))))) []).

Definition baking_commands (group : Tezos_base__TzPervasives.Clic.group)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  cons
    (Clic.command (Some group) "Query the path of the authorized key" % string
      no_options
      (apply
        (prefixes
          (cons "get" % string
            (cons "ledger" % string
              (cons "authorized" % string
                (cons "path" % string (cons "for" % string []))))))
        (apply Ledger_uri.ledger_uri_or_alias_param stop))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun ledger_uri =>
          fun cctxt =>
            use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
              (fun hidapi =>
                fun function_parameter =>
                  let '(version, _git_commit) := function_parameter in
                  fun _device_info =>
                    fun _ledger_id =>
                      op_gtgteqquestion
                        (Ledger_commands.get_authorized_path hidapi version)
                        (fun authorized =>
                          match authorized with
                          | Legacy_path p =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<v 0>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<v 0>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Authorized baking path (Legacy < 2.x.y): "
                                        % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))
                                  "@[<v 0>Authorized baking path (Legacy < 2.x.y): %a@]"
                                    % string) Bip32_path.pp_path p)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_some tt)
                          | No_baking_authorized =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "No baking key authorized at all." % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "No baking key authorized at all." % string))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_some tt)
                          | Path_curve (ledger_path, ledger_curve) =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<v 0>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<v 0>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Authorized baking path: " % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))
                                  "@[<v 0>Authorized baking path: %a@]" % string)
                                Bip32_path.pp_path ledger_path)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 0>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Authorized baking curve: " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format))))
                                      "@[<v 0>Authorized baking curve: %a@]" %
                                        string) Ledgerwallet_tezos.pp_curve
                                    ledger_curve)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    match ledger_uri with
                                    | Ledger _ => return_some tt
                                    |
                                      Ledger_account {|
                                        curve := curve; path := path |} =>
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_box
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<v 0>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<v 0>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "Authorized baking URI: " %
                                                  string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format))))
                                            "@[<v 0>Authorized baking URI: %a@]"
                                              % string) Ledger_uri.pp ledger_uri)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          return_some tt)
                                    |
                                      Ledger_account {|
                                        curve := curve; path := path |} =>
                                      failwith
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Path and curve do not match the ones specified in the command line: "
                                              % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " & " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  CamlinternalFormatBasics.End_of_format))))
                                          "Path and curve do not match the ones specified in the command line: %a & %a"
                                            % string)
                                        Ledgerwallet_tezos.pp_curve curve
                                        Bip32_path.pp_path
                                        (OCaml.Stdlib.app Bip32_path.tezos_root
                                          path)
                                    end))
                          end))))
    (cons
      (Clic.command (Some group)
        "Authorize a Ledger to bake for a key (deprecated, use `setup ledger ...` with recent versions of the Baking app)"
          % string no_options
        (apply
          (prefixes
            (cons "authorize" % string
              (cons "ledger" % string
                (cons "to" % string
                  (cons "bake" % string (cons "for" % string []))))))
          (apply Ledger_uri.ledger_uri_or_alias_param stop))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun ledger_uri =>
            fun cctxt =>
              use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                (fun hidapi =>
                  fun function_parameter =>
                    let '(version, _git_commit) := function_parameter in
                    fun _device_info =>
                      fun _ledger_id =>
                        op_gtgteqquestion
                          match version with
                          | {|
                            Ledgerwallet_tezos.Version.app_class := Ledgerwallet_tezos.Version.Tezos
                              |} =>
                            failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "This command (`authorize ledger ...`) only works with the Tezos Baking app"
                                    % string
                                  CamlinternalFormatBasics.End_of_format)
                                "This command (`authorize ledger ...`) only works with the Tezos Baking app"
                                  % string)
                          | {|
                            Ledgerwallet_tezos.Version.app_class := Ledgerwallet_tezos.Version.TezBake;
                              Ledgerwallet_tezos.Version.major := major
                              |} =>
                            failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "This command (`authorize ledger ...`) is" %
                                    string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "not compatible with" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.String_literal
                                          "this version of the Ledger" % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.String_literal
                                              "Baking app (" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " >= 2.0.0)," % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "please use the command" %
                                                        string
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@ " % string 1 0)
                                                        (CamlinternalFormatBasics.String_literal
                                                          "`setup ledger to bake for ...`"
                                                            % string
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            (CamlinternalFormatBasics.Break
                                                              "@ " % string 1 0)
                                                            (CamlinternalFormatBasics.String_literal
                                                              "from now on." %
                                                                string
                                                              CamlinternalFormatBasics.End_of_format)))))))))))))))
                                "This command (`authorize ledger ...`) is@ not compatible with@ this version of the Ledger@ Baking app (%a >= 2.0.0),@ please use the command@ `setup ledger to bake for ...`@ from now on."
                                  % string) Ledgerwallet_tezos.Version.pp
                              version
                          | _ =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "This Ledger Baking app is outdated (" %
                                      string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        ")" % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "running" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "in backwards" % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@ " % string 1 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "compatibility mode." %
                                                      string
                                                    CamlinternalFormatBasics.End_of_format)))))))))
                                  "This Ledger Baking app is outdated (%a)@ running@ in backwards@ compatibility mode."
                                    % string) Ledgerwallet_tezos.Version.pp
                                version)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit)
                          end
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Ledger_uri.full_account ledger_uri)
                              (fun function_parameter =>
                                let '{|
                                  Ledger_account.curve := curve;
                                    Ledger_account.path := path
                                    |} := function_parameter in
                                op_gtgteqquestion
                                  (Ledger_commands.public_key_returning_instruction
                                    (* ❌ Variants not supported *)
                                    variant None hidapi curve path)
                                  (fun pk =>
                                    let pkh := Signature.Public_key.hash pk in
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Formatting_gen
                                            (CamlinternalFormatBasics.Open_box
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "<v 0>" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "<v 0>" % string))
                                            (CamlinternalFormatBasics.String_literal
                                              "Authorized baking for address: "
                                                % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@," % string 0 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Corresponding full public key: "
                                                      % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        CamlinternalFormatBasics.End_of_format)))))))
                                          "@[<v 0>Authorized baking for address: %a@,Corresponding full public key: %a@]"
                                            % string)
                                        Signature.Public_key_hash.pp pkh
                                        Signature.Public_key.pp pk)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        return_some tt)))))))
      (cons
        (Clic.command (Some group) "Setup a Ledger to bake for a key" % string
          (let hwm_arg {A : Type} (kind : string)
            : Tezos_base__TzPervasives.Clic.arg (option int32) A :=
            let doc :=
              Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Use <HWM> as " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " chain high watermark instead of asking the ledger." %
                          string CamlinternalFormatBasics.End_of_format)))
                  "Use <HWM> as %s chain high watermark instead of asking the ledger."
                    % string) kind in
            let long := String.append kind "-hwm" % string in
            default_arg doc None long "HWM" % string "ASK-LEDGER" % string
              (parameter None
                (fun function_parameter =>
                  let '_ := function_parameter in
                  fun function_parameter =>
                    match function_parameter with
                    | "ASK-LEDGER" % string => return_none
                    | s =>
                      (* ❌ Try-with are not handled *)
                      try (return_some (Int32.of_string s))
                    end)) in
          args3
            (default_arg
              "Use <ID> as main chain-id instead of asking the node." % string
              None "main-chain-id" % string "ID" % string "ASK-NODE" % string
              (parameter None
                (fun function_parameter =>
                  let '_ := function_parameter in
                  fun function_parameter =>
                    match function_parameter with
                    | "ASK-NODE" % string =>
                      _return
                        (* ❌ Variants not supported *)
                        variant
                    | s =>
                      (* ❌ Try-with are not handled *)
                      try
                        (_return
                          (* ❌ Variants not supported *)
                          variant)
                    end))) (hwm_arg "main" % string) (hwm_arg "test" % string))
          (apply
            (prefixes
              (cons "setup" % string
                (cons "ledger" % string
                  (cons "to" % string
                    (cons "bake" % string (cons "for" % string []))))))
            (apply Ledger_uri.ledger_uri_or_alias_param stop))
          (fun function_parameter =>
            let '(chain_id_opt, main_hwm_opt, test_hwm_opt) :=
              function_parameter in
            fun ledger_uri =>
              fun cctxt =>
                use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                  (fun hidapi =>
                    fun function_parameter =>
                      let '(version, _git_commit) := function_parameter in
                      fun _device_info =>
                        fun _ledger_id =>
                          op_gtgteqquestion
                            match version with
                            | {|
                              app_class := Ledgerwallet_tezos.Version.Tezos
                                |} =>
                              failwith
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "This command (`setup ledger ...`) only works with the Tezos Baking app"
                                      % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "This command (`setup ledger ...`) only works with the Tezos Baking app"
                                    % string)
                            | {|
                              app_class := Ledgerwallet_tezos.Version.TezBake;
                                major := major
                                |} =>
                              failwith
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "This command (`setup ledger ...`)" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "is not" % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "compatible" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "with this version" % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@ " % string 1 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "of the Ledger Baking app" %
                                                      string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@ " % string 1 0)
                                                      (CamlinternalFormatBasics.Char_literal
                                                        "(" % char
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.String_literal
                                                            " < 2.0.0)," %
                                                              string
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              (CamlinternalFormatBasics.Break
                                                                "@ " % string 1
                                                                0)
                                                              (CamlinternalFormatBasics.String_literal
                                                                "please upgrade"
                                                                  % string
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  (CamlinternalFormatBasics.Break
                                                                    "@ " %
                                                                      string 1 0)
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "your ledger"
                                                                      % string
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      (CamlinternalFormatBasics.Break
                                                                        "@ " %
                                                                          string
                                                                        1 0)
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "or use the command"
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          (CamlinternalFormatBasics.Break
                                                                            "@ "
                                                                              %
                                                                              string
                                                                            1 0)
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "`authorize ledger to bake for ...`"
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)))))))))))))))))))))
                                  "This command (`setup ledger ...`)@ is not@ compatible@ with this version@ of the Ledger Baking app@ (%a < 2.0.0),@ please upgrade@ your ledger@ or use the command@ `authorize ledger to bake for ...`"
                                    % string) pp version
                            | _ => return_unit
                            end
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (Ledger_uri.full_account ledger_uri)
                                (fun function_parameter =>
                                  let '{|
                                    Ledger_account.curve := curve;
                                      Ledger_account.path := path
                                      |} := function_parameter in
                                  let chain_id_of_int32 (i32 : int32)
                                    : Tezos_base__TzPervasives.Chain_id.t :=
                                    let byte (n : Z) : ascii :=
                                      OCaml.Stdlib.reverse_apply
                                        (OCaml.Stdlib.reverse_apply
                                          (logand
                                            (* ❌ Constant of type int32 is converted to int *)
                                            255 (shift_right i32 (Z.mul n 8)))
                                          Int32.to_int) OCaml.Stdlib.char_of_int
                                      in
                                    Chain_id.of_string_exn
                                      (Stringext.of_array
                                        (Array.init 4
                                          (fun i => byte (Z.sub 3 i)))) in
                                  op_gtgteqquestion
                                    match chain_id_opt with
                                    | Ask_node =>
                                      Chain_services.chain_id cctxt None tt
                                    | Int32 s => _return (chain_id_of_int32 s)
                                    | Chain_id chid => _return chid
                                    end
                                    (fun main_chain_id =>
                                      op_gtgteqquestion
                                        (Ledger_commands.wrap_ledger_cmd
                                          (fun pp =>
                                            Ledgerwallet_tezos.get_all_high_watermarks
                                              (Some pp) None hidapi))
                                        (fun function_parameter =>
                                          let
                                            '(Main_hwm current_mh,
                                              Test_hwm current_th,
                                              Chain_id current_ci) :=
                                            function_parameter in
                                          let main_hwm :=
                                            Option.unopt current_mh main_hwm_opt
                                            in
                                          let test_hwm :=
                                            Option.unopt current_th test_hwm_opt
                                            in
                                          op_gtgteq
                                            ((* ❌ Sending method message is not handled *)
                                            send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Setting up the ledger:" %
                                                    string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    (CamlinternalFormatBasics.String_literal
                                                      "* Main chain ID: " %
                                                        string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          " -> " % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Flush_newline
                                                              (CamlinternalFormatBasics.String_literal
                                                                "* Main chain High Watermark: "
                                                                  % string
                                                                (CamlinternalFormatBasics.Int32
                                                                  CamlinternalFormatBasics.Int_d
                                                                  CamlinternalFormatBasics.No_padding
                                                                  CamlinternalFormatBasics.No_precision
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    " -> " %
                                                                      string
                                                                    (CamlinternalFormatBasics.Int32
                                                                      CamlinternalFormatBasics.Int_d
                                                                      CamlinternalFormatBasics.No_padding
                                                                      CamlinternalFormatBasics.No_precision
                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                        CamlinternalFormatBasics.Flush_newline
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "* Test chain High Watermark: "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Int32
                                                                            CamlinternalFormatBasics.Int_d
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              " -> "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Int32
                                                                                CamlinternalFormatBasics.Int_d
                                                                                CamlinternalFormatBasics.No_padding
                                                                                CamlinternalFormatBasics.No_precision
                                                                                CamlinternalFormatBasics.End_of_format))))))))))))))))
                                                "Setting up the ledger:@.* Main chain ID: %a -> %a@.* Main chain High Watermark: %ld -> %ld@.* Test chain High Watermark: %ld -> %ld"
                                                  % string) pp_ledger_chain_id
                                              current_ci Chain_id.pp
                                              main_chain_id current_mh main_hwm
                                              current_th test_hwm)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteqquestion
                                                (Ledger_commands.public_key_returning_instruction
                                                  (* ❌ Variants not supported *)
                                                  variant None hidapi curve path)
                                                (fun pk =>
                                                  let pkh :=
                                                    Signature.Public_key.hash pk
                                                    in
                                                  op_gtgteq
                                                    ((* ❌ Sending method message is not handled *)
                                                    send
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.Formatting_gen
                                                          (CamlinternalFormatBasics.Open_box
                                                            (CamlinternalFormatBasics.Format
                                                              (CamlinternalFormatBasics.String_literal
                                                                "<v 0>" % string
                                                                CamlinternalFormatBasics.End_of_format)
                                                              "<v 0>" % string))
                                                          (CamlinternalFormatBasics.String_literal
                                                            "Authorized baking for address: "
                                                              % string
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@," % string
                                                                  0 0)
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Corresponding full public key: "
                                                                    % string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                      CamlinternalFormatBasics.Close_box
                                                                      CamlinternalFormatBasics.End_of_format)))))))
                                                        "@[<v 0>Authorized baking for address: %a@,Corresponding full public key: %a@]"
                                                          % string)
                                                      Signature.Public_key_hash.pp
                                                      pkh
                                                      Signature.Public_key.pp pk)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      return_some tt))))))))))
        (cons
          (Clic.command (Some group) "Deauthorize Ledger from baking" % string
            no_options
            (apply
              (prefixes
                (cons "deauthorize" % string
                  (cons "ledger" % string
                    (cons "baking" % string (cons "for" % string [])))))
              (apply Ledger_uri.ledger_uri_or_alias_param stop))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun ledger_uri =>
                fun _cctxt =>
                  use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                    (fun hidapi =>
                      fun function_parameter =>
                        let '(_version, _git_commit) := function_parameter in
                        fun _device_info =>
                          fun _ledger_id =>
                            op_gtgteqquestion
                              (Ledger_commands.wrap_ledger_cmd
                                (fun pp =>
                                  Ledgerwallet_tezos.deauthorize_baking
                                    (Some pp) None hidapi))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_some tt)))) []))).

Definition high_water_mark_commands
  (group : Tezos_base__TzPervasives.Clic.group)
  (watermark_spelling : list string)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  let make_desc (desc : string) : string :=
    if equiv_decb (List.length watermark_spelling) 1 then
      String.append desc " (legacy/deprecated spelling)" % string
    else
      desc in
  cons
    (Clic.command (Some group)
      (make_desc "Get high water mark of a Ledger" % string)
      (args1
        (switch
          "Prevent the fallback to the (deprecated) Ledger instructions (for 1.x.y versions of the Baking app)"
            % string None "no-legacy-instructions" % string tt))
      (apply
        (prefixes
          (OCaml.Stdlib.app
            (cons "get" % string
              (cons "ledger" % string (cons "high" % string [])))
            (OCaml.Stdlib.app watermark_spelling (cons "for" % string []))))
        (apply Ledger_uri.ledger_uri_or_alias_param stop))
      (fun no_legacy_apdu =>
        fun ledger_uri =>
          fun cctxt =>
            use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
              (fun hidapi =>
                fun function_parameter =>
                  let '(version, _git_commit) := function_parameter in
                  fun _device_info =>
                    fun _ledger_id =>
                      match app_class version with
                      | Ledgerwallet_tezos.Version.Tezos =>
                        failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Fatal: this operation is only valid with the Tezos Baking application"
                                % string CamlinternalFormatBasics.End_of_format)
                            "Fatal: this operation is only valid with the Tezos Baking application"
                              % string)
                      | Ledgerwallet_tezos.Version.TezBake =>
                        op_gtgteqquestion
                          (Ledger_commands.wrap_ledger_cmd
                            (fun pp =>
                              Ledgerwallet_tezos.get_high_watermark (Some pp)
                                None hidapi))
                          (fun hwm =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "The high water mark for" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "is " % string
                                            (CamlinternalFormatBasics.Int32
                                              CamlinternalFormatBasics.Int_d
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.No_precision
                                              (CamlinternalFormatBasics.Char_literal
                                                "." % char
                                                CamlinternalFormatBasics.End_of_format)))))))
                                  "The high water mark for@ %a@ is %ld." %
                                    string) Ledger_uri.pp ledger_uri hwm)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_some tt))
                      | Ledgerwallet_tezos.Version.TezBake =>
                        failwith
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Cannot get the high water mark with" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "`--no-legacy-instructions` and version " %
                                    string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))))
                            "Cannot get the high water mark with@ `--no-legacy-instructions` and version %a"
                              % string) Ledgerwallet_tezos.Version.pp version
                      | Ledgerwallet_tezos.Version.TezBake =>
                        op_gtgteqquestion
                          (Ledger_commands.wrap_ledger_cmd
                            (fun pp =>
                              Ledgerwallet_tezos.get_all_high_watermarks
                                (Some pp) None hidapi))
                          (fun function_parameter =>
                            let '(Main_hwm mh, Test_hwm th, Chain_id ci) :=
                              function_parameter in
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "The high water mark values for" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@ " % string 1 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "are" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.Int32
                                                CamlinternalFormatBasics.Int_d
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.String_literal
                                                  " for the main-chain" % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "(" % char
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          ")" % char
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            (CamlinternalFormatBasics.Break
                                                              "@ " % string 1 0)
                                                            (CamlinternalFormatBasics.String_literal
                                                              "and" % string
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@ " % string
                                                                  1 0)
                                                                (CamlinternalFormatBasics.Int32
                                                                  CamlinternalFormatBasics.Int_d
                                                                  CamlinternalFormatBasics.No_padding
                                                                  CamlinternalFormatBasics.No_precision
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    " for the test-chain."
                                                                      % string
                                                                    CamlinternalFormatBasics.End_of_format)))))))))))))))))
                                  "The high water mark values for@ %a@ are@ %ld for the main-chain@ (%a)@ and@ %ld for the test-chain."
                                    % string) Ledger_uri.pp ledger_uri mh
                                pp_ledger_chain_id ci th)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_some tt))
                      end)))
    (cons
      (Clic.command (Some group)
        (make_desc "Set high water mark of a Ledger" % string) no_options
        (apply
          (prefixes
            (OCaml.Stdlib.app
              (cons "set" % string
                (cons "ledger" % string (cons "high" % string [])))
              (OCaml.Stdlib.app watermark_spelling (cons "for" % string []))))
          (apply Ledger_uri.ledger_uri_or_alias_param
            (apply (prefix "to" % string)
              (apply
                (param "high watermark" % string "High watermark" % string
                  (parameter None
                    (fun _ctx =>
                      fun s =>
                        (* ❌ Try-with are not handled *)
                        try (_return (Int32.of_string s))))) stop))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun ledger_uri =>
            fun hwm =>
              fun cctxt =>
                use_ledger_or_fail ledger_uri (Some Filter.is_baking) None
                  (fun hidapi =>
                    fun function_parameter =>
                      let '(version, _git_commit) := function_parameter in
                      fun _device_info =>
                        fun _ledger_id =>
                          match app_class version with
                          | Ledgerwallet_tezos.Version.Tezos =>
                            failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Fatal: this operation is only valid with TezBake"
                                    % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Fatal: this operation is only valid with TezBake"
                                  % string)
                          | Ledgerwallet_tezos.Version.TezBake =>
                            op_gtgteqquestion
                              (Ledger_commands.wrap_ledger_cmd
                                (fun pp =>
                                  Ledgerwallet_tezos.set_high_watermark
                                    (Some pp) None hidapi hwm))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion
                                  (Ledger_commands.wrap_ledger_cmd
                                    (fun pp =>
                                      Ledgerwallet_tezos.get_high_watermark
                                        (Some pp) None hidapi))
                                  (fun new_hwm =>
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Formatting_gen
                                            (CamlinternalFormatBasics.Open_box
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "<v 0>" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "<v 0>" % string))
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " has now high water mark: " %
                                                  string
                                                (CamlinternalFormatBasics.Int32
                                                  CamlinternalFormatBasics.Int_d
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.No_precision
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format)))))
                                          "@[<v 0>%a has now high water mark: %ld@]"
                                            % string) Ledger_uri.pp ledger_uri
                                        new_hwm)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        return_some tt)))
                          end))) []).

Definition commands
  : unit ->
    list
      (Tezos_base__TzPervasives.Clic.command
        Tezos_client_base.Client_context.full) :=
  let group :=
    {| Clic.name := "ledger" % string;
      Clic.title :=
        "Commands for managing the connected Ledger Nano devices" % string |} in
  fun function_parameter =>
    let 'tt := function_parameter in
    OCaml.Stdlib.app (generic_commands group)
      (OCaml.Stdlib.app (baking_commands group)
        (OCaml.Stdlib.app
          (high_water_mark_commands group
            (cons "water" % string (cons "mark" % string [])))
          (high_water_mark_commands group (cons "watermark" % string [])))).

src/lib_signer_backends/unix/ledger_names.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let adjectives =
  [| "abandoned";
     "able";
     "absolute";
     "adorable";
     "adventurous";
     "academic";
     "acceptable";
     "acclaimed";
     "accomplished";
     "accurate";
     "aching";
     "acidic";
     "acrobatic";
     "active";
     "actual";
     "adept";
     "admirable";
     "admired";
     "adolescent";
     "adorable";
     "adored";
     "advanced";
     "afraid";
     "affectionate";
     "aged";
     "aggravating";
     "aggressive";
     "agile";
     "agitated";
     "agonizing";
     "agreeable";
     "ajar";
     "alarmed";
     "alarming";
     "alert";
     "alienated";
     "alive";
     "all";
     "altruistic";
     "amazing";
     "ambitious";
     "ample";
     "amused";
     "amusing";
     "anchored";
     "ancient";
     "angelic";
     "angry";
     "anguished";
     "animated";
     "annual";
     "another";
     "antique";
     "anxious";
     "any";
     "apprehensive";
     "appropriate";
     "apt";
     "arctic";
     "arid";
     "aromatic";
     "artistic";
     "ashamed";
     "assured";
     "astonishing";
     "athletic";
     "attached";
     "attentive";
     "attractive";
     "austere";
     "authentic";
     "authorized";
     "automatic";
     "avaricious";
     "average";
     "aware";
     "awesome";
     "awful";
     "awkward";
     "babyish";
     "bad";
     "back";
     "baggy";
     "bare";
     "barren";
     "basic";
     "beautiful";
     "belated";
     "beloved";
     "beneficial";
     "better";
     "best";
     "bewitched";
     "big";
     "biodegradable";
     "bitter";
     "black";
     "bland";
     "blank";
     "blaring";
     "bleak";
     "blind";
     "blissful";
     "blond";
     "blue";
     "blushing";
     "bogus";
     "boiling";
     "bold";
     "bony";
     "boring";
     "bossy";
     "both";
     "bouncy";
     "bountiful";
     "bowed";
     "brave";
     "breakable";
     "brief";
     "bright";
     "brilliant";
     "brisk";
     "broken";
     "bronze";
     "brown";
     "bruised";
     "bubbly";
     "bulky";
     "bumpy";
     "buoyant";
     "burdensome";
     "burly";
     "bustling";
     "busy";
     "buttery";
     "buzzing";
     "calculating";
     "calm";
     "candid";
     "canine";
     "capital";
     "carefree";
     "careful";
     "careless";
     "caring";
     "cautious";
     "cavernous";
     "celebrated";
     "charming";
     "cheap";
     "cheerful";
     "cheery";
     "chief";
     "chilly";
     "chubby";
     "circular";
     "classic";
     "clean";
     "clear";
     "clever";
     "close";
     "closed";
     "cloudy";
     "clueless";
     "clumsy";
     "cluttered";
     "coarse";
     "cold";
     "colorful";
     "colorless";
     "colossal";
     "comfortable";
     "common";
     "compassionate";
     "competent";
     "complete";
     "complex";
     "complicated";
     "composed";
     "concerned";
     "concrete";
     "confused";
     "conscious";
     "considerate";
     "constant";
     "content";
     "conventional";
     "cooked";
     "cool";
     "cooperative";
     "coordinated";
     "corny";
     "corrupt";
     "costly";
     "courageous";
     "courteous";
     "crafty";
     "crazy";
     "creamy";
     "creative";
     "creepy";
     "criminal";
     "crisp";
     "critical";
     "crooked";
     "crowded";
     "cruel";
     "crushing";
     "cuddly";
     "cultivated";
     "cultured";
     "cumbersome";
     "curly";
     "curvy";
     "cute";
     "cylindrical";
     "damaged";
     "damp";
     "dangerous";
     "dapper";
     "daring";
     "darling";
     "dark";
     "dazzling";
     "dead";
     "deadly";
     "deafening";
     "dear";
     "dearest";
     "decent";
     "decimal";
     "decisive";
     "deep";
     "defenseless";
     "defensive";
     "defiant";
     "deficient";
     "definite";
     "definitive";
     "delayed";
     "delectable";
     "delicious";
     "delightful";
     "delirious";
     "demanding";
     "dense";
     "dental";
     "dependable";
     "dependent";
     "descriptive";
     "deserted";
     "detailed";
     "determined";
     "devoted";
     "different";
     "difficult";
     "digital";
     "diligent";
     "dim";
     "dimpled";
     "dimwitted";
     "direct";
     "disastrous";
     "discrete";
     "disfigured";
     "disgusting";
     "disloyal";
     "dismal";
     "distant";
     "downright";
     "dreary";
     "dirty";
     "disguised";
     "dishonest";
     "dismal";
     "distant";
     "distinct";
     "distorted";
     "dizzy";
     "dopey";
     "doting";
     "double";
     "downright";
     "drab";
     "drafty";
     "dramatic";
     "dreary";
     "droopy";
     "dry";
     "dual";
     "dull";
     "dutiful";
     "eager";
     "earnest";
     "early";
     "easy";
     "ecstatic";
     "edible";
     "educated";
     "elaborate";
     "elastic";
     "elated";
     "elderly";
     "electric";
     "elegant";
     "elementary";
     "elliptical";
     "embarrassed";
     "embellished";
     "eminent";
     "emotional";
     "empty";
     "enchanted";
     "enchanting";
     "energetic";
     "enlightened";
     "enormous";
     "enraged";
     "entire";
     "envious";
     "equal";
     "equatorial";
     "essential";
     "esteemed";
     "ethical";
     "euphoric";
     "even";
     "evergreen";
     "everlasting";
     "every";
     "evil";
     "exalted";
     "excellent";
     "exemplary";
     "exhausted";
     "excitable";
     "excited";
     "exciting";
     "exotic";
     "expensive";
     "experienced";
     "expert";
     "extraneous";
     "extroverted";
     "fabulous";
     "failing";
     "faint";
     "fair";
     "faithful";
     "fake";
     "false";
     "familiar";
     "famous";
     "fancy";
     "fantastic";
     "far";
     "faraway";
     "fast";
     "fat";
     "fatal";
     "fatherly";
     "favorable";
     "favorite";
     "fearful";
     "fearless";
     "feisty";
     "feline";
     "female";
     "feminine";
     "few";
     "fickle";
     "filthy";
     "fine";
     "finished";
     "firm";
     "first";
     "firsthand";
     "fitting";
     "fixed";
     "flaky";
     "flamboyant";
     "flashy";
     "flat";
     "flawed";
     "flawless";
     "flickering";
     "flimsy";
     "flippant";
     "flowery";
     "fluffy";
     "fluid";
     "flustered";
     "focused";
     "fond";
     "foolhardy";
     "foolish";
     "forceful";
     "forked";
     "formal";
     "forsaken";
     "forthright";
     "fortunate";
     "fragrant";
     "frail";
     "frank";
     "frayed";
     "free";
     "french";
     "fresh";
     "frequent";
     "friendly";
     "frightened";
     "frightening";
     "frigid";
     "frilly";
     "frizzy";
     "frivolous";
     "front";
     "frosty";
     "frozen";
     "frugal";
     "fruitful";
     "full";
     "fumbling";
     "functional";
     "funny";
     "fussy";
     "fuzzy";
     "gargantuan";
     "gaseous";
     "general";
     "generous";
     "gentle";
     "genuine";
     "giant";
     "giddy";
     "gigantic";
     "gifted";
     "giving";
     "glamorous";
     "glaring";
     "glass";
     "gleaming";
     "gleeful";
     "glistening";
     "glittering";
     "gloomy";
     "glorious";
     "glossy";
     "glum";
     "golden";
     "good";
     "gorgeous";
     "graceful";
     "gracious";
     "grand";
     "grandiose";
     "granular";
     "grateful";
     "grave";
     "gray";
     "great";
     "greedy";
     "green";
     "gregarious";
     "grim";
     "grimy";
     "gripping";
     "grizzled";
     "gross";
     "grotesque";
     "grouchy";
     "grounded";
     "growing";
     "growling";
     "grown";
     "grubby";
     "gruesome";
     "grumpy";
     "guilty";
     "gullible";
     "gummy";
     "hairy";
     "half";
     "handmade";
     "handsome";
     "handy";
     "happy";
     "hard";
     "harmful";
     "harmless";
     "harmonious";
     "harsh";
     "hasty";
     "hateful";
     "haunting";
     "healthy";
     "heartfelt";
     "hearty";
     "heavenly";
     "heavy";
     "hefty";
     "helpful";
     "helpless";
     "hidden";
     "hideous";
     "high";
     "hilarious";
     "hoarse";
     "hollow";
     "homely";
     "honest";
     "honorable";
     "honored";
     "hopeful";
     "horrible";
     "hospitable";
     "hot";
     "huge";
     "humble";
     "humiliating";
     "humming";
     "humongous";
     "hungry";
     "hurtful";
     "husky";
     "icky";
     "icy";
     "ideal";
     "idealistic";
     "identical";
     "idle";
     "idiotic";
     "idolized";
     "ignorant";
     "ill";
     "illegal";
     "illiterate";
     "illustrious";
     "imaginary";
     "imaginative";
     "immaculate";
     "immaterial";
     "immediate";
     "immense";
     "impassioned";
     "impeccable";
     "impartial";
     "imperfect";
     "imperturbable";
     "impish";
     "impolite";
     "important";
     "impossible";
     "impractical";
     "impressionable";
     "impressive";
     "improbable";
     "impure";
     "inborn";
     "incomparable";
     "incompatible";
     "incomplete";
     "inconsequential";
     "incredible";
     "indelible";
     "inexperienced";
     "indolent";
     "infamous";
     "infantile";
     "infatuated";
     "inferior";
     "infinite";
     "informal";
     "innocent";
     "insecure";
     "insidious";
     "insignificant";
     "insistent";
     "instructive";
     "insubstantial";
     "intelligent";
     "intent";
     "intentional";
     "interesting";
     "internal";
     "international";
     "intrepid";
     "ironclad";
     "irresponsible";
     "irritating";
     "itchy";
     "jaded";
     "jagged";
     "jaunty";
     "jealous";
     "jittery";
     "joint";
     "jolly";
     "jovial";
     "joyful";
     "joyous";
     "jubilant";
     "judicious";
     "juicy";
     "jumbo";
     "junior";
     "jumpy";
     "juvenile";
     "kaleidoscopic";
     "keen";
     "key";
     "kind";
     "kindhearted";
     "kindly";
     "klutzy";
     "knobby";
     "knotty";
     "knowledgeable";
     "knowing";
     "known";
     "kooky";
     "lame";
     "lanky";
     "large";
     "last";
     "lasting";
     "late";
     "lavish";
     "lawful";
     "lazy";
     "leading";
     "lean";
     "leafy";
     "left";
     "legal";
     "legitimate";
     "light";
     "lighthearted";
     "likable";
     "likely";
     "limited";
     "limp";
     "limping";
     "linear";
     "lined";
     "liquid";
     "little";
     "live";
     "lively";
     "livid";
     "loathsome";
     "lone";
     "lonely";
     "long";
     "loose";
     "lopsided";
     "lost";
     "loud";
     "lovable";
     "lovely";
     "loving";
     "low";
     "loyal";
     "lucky";
     "lumbering";
     "luminous";
     "lumpy";
     "lustrous";
     "luxurious";
     "mad";
     "magnificent";
     "majestic";
     "major";
     "male";
     "mammoth";
     "married";
     "marvelous";
     "masculine";
     "massive";
     "mature";
     "meager";
     "mealy";
     "mean";
     "measly";
     "meaty";
     "medical";
     "mediocre";
     "medium";
     "meek";
     "mellow";
     "melodic";
     "memorable";
     "menacing";
     "merry";
     "messy";
     "metallic";
     "mild";
     "milky";
     "mindless";
     "miniature";
     "minor";
     "minty";
     "miserable";
     "miserly";
     "misguided";
     "misty";
     "mixed";
     "modern";
     "modest";
     "moist";
     "monstrous";
     "monthly";
     "monumental";
     "moral";
     "mortified";
     "motherly";
     "motionless";
     "mountainous";
     "muddy";
     "muffled";
     "multicolored";
     "mundane";
     "murky";
     "mushy";
     "musty";
     "muted";
     "mysterious";
     "naive";
     "narrow";
     "nasty";
     "natural";
     "naughty";
     "nautical";
     "near";
     "neat";
     "necessary";
     "needy";
     "negative";
     "neglected";
     "negligible";
     "neighboring";
     "nervous";
     "new";
     "nice";
     "nifty";
     "nimble";
     "nippy";
     "nocturnal";
     "noisy";
     "nonstop";
     "normal";
     "notable";
     "noted";
     "noteworthy";
     "novel";
     "noxious";
     "numb";
     "nutritious";
     "nutty";
     "obedient";
     "obese";
     "oblong";
     "oily";
     "oblong";
     "obvious";
     "occasional";
     "odd";
     "oddball";
     "offbeat";
     "offensive";
     "official";
     "old";
     "only";
     "open";
     "optimal";
     "optimistic";
     "opulent";
     "orange";
     "orderly";
     "organic";
     "ornate";
     "ornery";
     "ordinary";
     "original";
     "other";
     "our";
     "outlying";
     "outgoing";
     "outlandish";
     "outrageous";
     "outstanding";
     "oval";
     "overcooked";
     "overdue";
     "overjoyed";
     "overlooked";
     "palatable";
     "pale";
     "paltry";
     "parallel";
     "parched";
     "partial";
     "passionate";
     "past";
     "pastel";
     "peaceful";
     "peppery";
     "perfect";
     "perfumed";
     "periodic";
     "perky";
     "personal";
     "pertinent";
     "pesky";
     "pessimistic";
     "petty";
     "phony";
     "physical";
     "piercing";
     "pink";
     "pitiful";
     "plain";
     "plaintive";
     "plastic";
     "playful";
     "pleasant";
     "pleased";
     "pleasing";
     "plump";
     "plush";
     "polished";
     "polite";
     "political";
     "pointed";
     "pointless";
     "poised";
     "poor";
     "popular";
     "portly";
     "posh";
     "positive";
     "possible";
     "potable";
     "powerful";
     "powerless";
     "practical";
     "precious";
     "present";
     "prestigious";
     "pretty";
     "precious";
     "previous";
     "pricey";
     "prickly";
     "primary";
     "prime";
     "pristine";
     "private";
     "prize";
     "probable";
     "productive";
     "profitable";
     "profuse";
     "proper";
     "proud";
     "prudent";
     "punctual";
     "pungent";
     "puny";
     "pure";
     "purple";
     "pushy";
     "putrid";
     "puzzled";
     "puzzling";
     "quaint";
     "qualified";
     "quarrelsome";
     "quarterly";
     "queasy";
     "querulous";
     "questionable";
     "quick";
     "quiet";
     "quintessential";
     "quirky";
     "quixotic";
     "quizzical";
     "radiant";
     "ragged";
     "rapid";
     "rare";
     "rash";
     "raw";
     "recent";
     "reckless";
     "rectangular";
     "ready";
     "real";
     "realistic";
     "reasonable";
     "red";
     "reflecting";
     "regal";
     "regular";
     "reliable";
     "relieved";
     "remarkable";
     "remorseful";
     "remote";
     "repentant";
     "required";
     "respectful";
     "responsible";
     "repulsive";
     "revolving";
     "rewarding";
     "rich";
     "rigid";
     "right";
     "ringed";
     "ripe";
     "roasted";
     "robust";
     "rosy";
     "rotating";
     "rotten";
     "rough";
     "round";
     "rowdy";
     "royal";
     "rubbery";
     "rundown";
     "ruddy";
     "rude";
     "runny";
     "rural";
     "rusty";
     "sad";
     "safe";
     "salty";
     "same";
     "sandy";
     "sane";
     "sarcastic";
     "sardonic";
     "satisfied";
     "scaly";
     "scarce";
     "scared";
     "scary";
     "scented";
     "scholarly";
     "scientific";
     "scornful";
     "scratchy";
     "scrawny";
     "second";
     "secondary";
     "secret";
     "selfish";
     "sentimental";
     "separate";
     "serene";
     "serious";
     "serpentine";
     "several";
     "severe";
     "shabby";
     "shadowy";
     "shady";
     "shallow";
     "shameful";
     "shameless";
     "sharp";
     "shimmering";
     "shiny";
     "shocked";
     "shocking";
     "shoddy";
     "short";
     "showy";
     "shrill";
     "shy";
     "sick";
     "silent";
     "silky";
     "silly";
     "silver";
     "similar";
     "simple";
     "simplistic";
     "sinful";
     "single";
     "sizzling";
     "skeletal";
     "skinny";
     "sleepy";
     "slight";
     "slim";
     "slimy";
     "slippery";
     "slow";
     "slushy";
     "small";
     "smart";
     "smoggy";
     "smooth";
     "smug";
     "snappy";
     "snarling";
     "sneaky";
     "sniveling";
     "snoopy";
     "sociable";
     "soft";
     "soggy";
     "solid";
     "somber";
     "some";
     "spherical";
     "sophisticated";
     "sore";
     "sorrowful";
     "soulful";
     "soupy";
     "sour";
     "spanish";
     "sparkling";
     "sparse";
     "specific";
     "spectacular";
     "speedy";
     "spicy";
     "spiffy";
     "spirited";
     "spiteful";
     "splendid";
     "spotless";
     "spotted";
     "spry";
     "square";
     "squeaky";
     "squiggly";
     "stable";
     "staid";
     "stained";
     "stale";
     "standard";
     "starchy";
     "stark";
     "starry";
     "steep";
     "sticky";
     "stiff";
     "stimulating";
     "stingy";
     "stormy";
     "straight";
     "strange";
     "steel";
     "strict";
     "strident";
     "striking";
     "striped";
     "strong";
     "studious";
     "stunning";
     "stupendous";
     "stupid";
     "sturdy";
     "stylish";
     "subdued";
     "submissive";
     "substantial";
     "subtle";
     "suburban";
     "sudden";
     "sugary";
     "sunny";
     "super";
     "superb";
     "superficial";
     "superior";
     "supportive";
     "surprised";
     "suspicious";
     "svelte";
     "sweaty";
     "sweet";
     "sweltering";
     "swift";
     "sympathetic";
     "tall";
     "talkative";
     "tame";
     "tan";
     "tangible";
     "tart";
     "tasty";
     "tattered";
     "taut";
     "tedious";
     "teeming";
     "tempting";
     "tender";
     "tense";
     "tepid";
     "terrible";
     "terrific";
     "testy";
     "thankful";
     "that";
     "these";
     "thick";
     "thin";
     "third";
     "thirsty";
     "this";
     "thorough";
     "thorny";
     "those";
     "thoughtful";
     "threadbare";
     "thrifty";
     "thunderous";
     "tidy";
     "tight";
     "timely";
     "tinted";
     "tiny";
     "tired";
     "torn";
     "total";
     "tough";
     "traumatic";
     "treasured";
     "tremendous";
     "tragic";
     "trained";
     "tremendous";
     "triangular";
     "tricky";
     "trifling";
     "trim";
     "trivial";
     "troubled";
     "true";
     "trusting";
     "trustworthy";
     "trusty";
     "truthful";
     "tubby";
     "turbulent";
     "twin";
     "ugly";
     "ultimate";
     "unacceptable";
     "unaware";
     "uncomfortable";
     "uncommon";
     "unconscious";
     "understated";
     "unequaled";
     "uneven";
     "unfinished";
     "unfit";
     "unfolded";
     "unfortunate";
     "unhappy";
     "unhealthy";
     "uniform";
     "unimportant";
     "unique";
     "united";
     "unkempt";
     "unknown";
     "unlawful";
     "unlined";
     "unlucky";
     "unnatural";
     "unpleasant";
     "unrealistic";
     "unripe";
     "unruly";
     "unselfish";
     "unsightly";
     "unsteady";
     "unsung";
     "untidy";
     "untimely";
     "untried";
     "untrue";
     "unused";
     "unusual";
     "unwelcome";
     "unwieldy";
     "unwilling";
     "unwitting";
     "unwritten";
     "upbeat";
     "upright";
     "upset";
     "urban";
     "usable";
     "used";
     "useful";
     "useless";
     "utilized";
     "utter";
     "vacant";
     "vague";
     "vain";
     "valid";
     "valuable";
     "vapid";
     "variable";
     "vast";
     "velvety";
     "venerated";
     "vengeful";
     "verifiable";
     "vibrant";
     "vicious";
     "victorious";
     "vigilant";
     "vigorous";
     "villainous";
     "violet";
     "violent";
     "virtual";
     "virtuous";
     "visible";
     "vital";
     "vivacious";
     "vivid";
     "voluminous";
     "warlike";
     "warm";
     "warmhearted";
     "warped";
     "wary";
     "wasteful";
     "watchful";
     "waterlogged";
     "watery";
     "wavy";
     "wealthy";
     "weak";
     "weary";
     "webbed";
     "wee";
     "weekly";
     "weepy";
     "weighty";
     "weird";
     "welcome";
     "wet";
     "which";
     "whimsical";
     "whirlwind";
     "whispered";
     "white";
     "whole";
     "whopping";
     "wicked";
     "wide";
     "wiggly";
     "wild";
     "willing";
     "wilted";
     "winding";
     "windy";
     "winged";
     "wiry";
     "wise";
     "witty";
     "wobbly";
     "woeful";
     "wonderful";
     "wooden";
     "woozy";
     "wordy";
     "worldly";
     "worn";
     "worried";
     "worrisome";
     "worse";
     "worst";
     "worthless";
     "worthwhile";
     "worthy";
     "wrathful";
     "wretched";
     "writhing";
     "wrong";
     "wry";
     "yawning";
     "yearly";
     "yellow";
     "yellowish";
     "young";
     "youthful";
     "yummy";
     "zany";
     "zealous";
     "zesty" |]

let animals =
  [| "aardvark";
     "abyssinian";
     "affenpinscher";
     "akbash";
     "akita";
     "albatross";
     "alligator";
     "angelfish";
     "ant";
     "anteater";
     "antelope";
     "armadillo";
     "avocet";
     "axolotl";
     "baboon";
     "badger";
     "balinese";
     "bandicoot";
     "barb";
     "barnacle";
     "barracuda";
     "bat";
     "beagle";
     "bear";
     "beaver";
     "beetle";
     "binturong";
     "birman";
     "bison";
     "bloodhound";
     "bobcat";
     "bombay";
     "bongo";
     "bonobo";
     "booby";
     "budgerigar";
     "buffalo";
     "bulldog";
     "bullfrog";
     "burmese";
     "butterfly";
     "caiman";
     "camel";
     "capybara";
     "caracal";
     "cassowary";
     "cat";
     "caterpillar";
     "catfish";
     "centipede";
     "chameleon";
     "chamois";
     "cheetah";
     "chicken";
     "chihuahua";
     "chimpanzee";
     "chinchilla";
     "chinook";
     "chipmunk";
     "cichlid";
     "coati";
     "cockroach";
     "collie";
     "coral";
     "cougar";
     "cow";
     "coyote";
     "crab";
     "crane";
     "crocodile";
     "cuscus";
     "cuttlefish";
     "dachshund";
     "dalmatian";
     "deer";
     "dhole";
     "dingo";
     "discus";
     "dodo";
     "dog";
     "dolphin";
     "donkey";
     "dormouse";
     "dragonfly";
     "drever";
     "duck";
     "dugong";
     "dunker";
     "eagle";
     "earwig";
     "echidna";
     "elephant";
     "emu";
     "falcon";
     "fennec";
     "ferret";
     "fish";
     "flamingo";
     "flounder";
     "fly";
     "fossa";
     "fox";
     "frigatebird";
     "frog";
     "gar";
     "gecko";
     "gerbil";
     "gharial";
     "gibbon";
     "giraffe";
     "goat";
     "goose";
     "gopher";
     "gorilla";
     "grasshopper";
     "greyhound";
     "grouse";
     "guppy";
     "hamster";
     "hare";
     "harrier";
     "havanese";
     "hedgehog";
     "heron";
     "himalayan";
     "hippopotamus";
     "horse";
     "human";
     "hummingbird";
     "hyena";
     "ibis";
     "iguana";
     "impala";
     "indri";
     "insect";
     "jackal";
     "jaguar";
     "javanese";
     "jellyfish";
     "kakapo";
     "kangaroo";
     "kingfisher";
     "kiwi";
     "koala";
     "kudu";
     "labradoodle";
     "ladybird";
     "lemming";
     "lemur";
     "leopard";
     "liger";
     "lion";
     "lionfish";
     "lizard";
     "llama";
     "lobster";
     "lynx";
     "macaw";
     "magpie";
     "maltese";
     "manatee";
     "mandrill";
     "markhor";
     "mastiff";
     "mayfly";
     "meerkat";
     "millipede";
     "mole";
     "molly";
     "mongoose";
     "mongrel";
     "monkey";
     "moorhen";
     "moose";
     "moth";
     "mouse";
     "mule";
     "neanderthal";
     "newfoundland";
     "newt";
     "nightingale";
     "numbat";
     "ocelot";
     "octopus";
     "okapi";
     "olm";
     "opossum";
     "ostrich";
     "otter";
     "oyster";
     "pademelon";
     "panther";
     "parrot";
     "peacock";
     "pekingese";
     "pelican";
     "penguin";
     "persian";
     "pheasant";
     "pig";
     "pika";
     "pike";
     "piranha";
     "platypus";
     "pointer";
     "poodle";
     "porcupine";
     "possum";
     "prawn";
     "puffin";
     "pug";
     "puma";
     "quail";
     "quetzal";
     "quokka";
     "quoll";
     "rabbit";
     "raccoon";
     "ragdoll";
     "rat";
     "rattlesnake";
     "reindeer";
     "rhinoceros";
     "robin";
     "rottweiler";
     "salamander";
     "saola";
     "scorpion";
     "seahorse";
     "seal";
     "serval";
     "sheep";
     "shrimp";
     "siamese";
     "siberian";
     "skunk";
     "sloth";
     "snail";
     "snake";
     "snowshoe";
     "somali";
     "sparrow";
     "sponge";
     "squid";
     "squirrel";
     "starfish";
     "stingray";
     "stoat";
     "swan";
     "tang";
     "tapir";
     "tarsier";
     "termite";
     "tetra";
     "tiffany";
     "tiger";
     "tortoise";
     "toucan";
     "tropicbird";
     "tuatara";
     "turkey";
     "uakari";
     "uguisu";
     "umbrellabird";
     "vulture";
     "wallaby";
     "walrus";
     "warthog";
     "wasp";
     "weasel";
     "whippet";
     "wildebeest";
     "wolf";
     "wolverine";
     "wombat";
     "woodlouse";
     "woodpecker";
     "wrasse";
     "yak";
     "zebra";
     "zebu";
     "zonkey";
     "zorse" |]

let pick a z = a.(Z.rem z (Array.length a |> Z.of_int) |> Z.to_int)

let hash a = Blake2B.hash_string [a] |> Blake2B.to_string

type t = {c : string; t : string; h : string; d : string}

let pp ppf {c; t; h; d} = Format.fprintf ppf "%s-%s-%s-%s" c t h d

let crouching_tiger string =
  let c = pick adjectives (string |> hash |> Z.of_bits) in
  let t = pick animals (string |> hash |> hash |> Z.of_bits) in
  let h = pick adjectives (string |> hash |> hash |> hash |> Z.of_bits) in
  let d = pick animals (string |> hash |> hash |> hash |> hash |> Z.of_bits) in
  {c; t; h; d}
src/lib_signer_backends/unix/ledger_names.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition adjectives : array string :=
  (* ❌ Arrays not handled. *)
  [
    "abandoned" % string;
    "able" % string;
    "absolute" % string;
    "adorable" % string;
    "adventurous" % string;
    "academic" % string;
    "acceptable" % string;
    "acclaimed" % string;
    "accomplished" % string;
    "accurate" % string;
    "aching" % string;
    "acidic" % string;
    "acrobatic" % string;
    "active" % string;
    "actual" % string;
    "adept" % string;
    "admirable" % string;
    "admired" % string;
    "adolescent" % string;
    "adorable" % string;
    "adored" % string;
    "advanced" % string;
    "afraid" % string;
    "affectionate" % string;
    "aged" % string;
    "aggravating" % string;
    "aggressive" % string;
    "agile" % string;
    "agitated" % string;
    "agonizing" % string;
    "agreeable" % string;
    "ajar" % string;
    "alarmed" % string;
    "alarming" % string;
    "alert" % string;
    "alienated" % string;
    "alive" % string;
    "all" % string;
    "altruistic" % string;
    "amazing" % string;
    "ambitious" % string;
    "ample" % string;
    "amused" % string;
    "amusing" % string;
    "anchored" % string;
    "ancient" % string;
    "angelic" % string;
    "angry" % string;
    "anguished" % string;
    "animated" % string;
    "annual" % string;
    "another" % string;
    "antique" % string;
    "anxious" % string;
    "any" % string;
    "apprehensive" % string;
    "appropriate" % string;
    "apt" % string;
    "arctic" % string;
    "arid" % string;
    "aromatic" % string;
    "artistic" % string;
    "ashamed" % string;
    "assured" % string;
    "astonishing" % string;
    "athletic" % string;
    "attached" % string;
    "attentive" % string;
    "attractive" % string;
    "austere" % string;
    "authentic" % string;
    "authorized" % string;
    "automatic" % string;
    "avaricious" % string;
    "average" % string;
    "aware" % string;
    "awesome" % string;
    "awful" % string;
    "awkward" % string;
    "babyish" % string;
    "bad" % string;
    "back" % string;
    "baggy" % string;
    "bare" % string;
    "barren" % string;
    "basic" % string;
    "beautiful" % string;
    "belated" % string;
    "beloved" % string;
    "beneficial" % string;
    "better" % string;
    "best" % string;
    "bewitched" % string;
    "big" % string;
    "biodegradable" % string;
    "bitter" % string;
    "black" % string;
    "bland" % string;
    "blank" % string;
    "blaring" % string;
    "bleak" % string;
    "blind" % string;
    "blissful" % string;
    "blond" % string;
    "blue" % string;
    "blushing" % string;
    "bogus" % string;
    "boiling" % string;
    "bold" % string;
    "bony" % string;
    "boring" % string;
    "bossy" % string;
    "both" % string;
    "bouncy" % string;
    "bountiful" % string;
    "bowed" % string;
    "brave" % string;
    "breakable" % string;
    "brief" % string;
    "bright" % string;
    "brilliant" % string;
    "brisk" % string;
    "broken" % string;
    "bronze" % string;
    "brown" % string;
    "bruised" % string;
    "bubbly" % string;
    "bulky" % string;
    "bumpy" % string;
    "buoyant" % string;
    "burdensome" % string;
    "burly" % string;
    "bustling" % string;
    "busy" % string;
    "buttery" % string;
    "buzzing" % string;
    "calculating" % string;
    "calm" % string;
    "candid" % string;
    "canine" % string;
    "capital" % string;
    "carefree" % string;
    "careful" % string;
    "careless" % string;
    "caring" % string;
    "cautious" % string;
    "cavernous" % string;
    "celebrated" % string;
    "charming" % string;
    "cheap" % string;
    "cheerful" % string;
    "cheery" % string;
    "chief" % string;
    "chilly" % string;
    "chubby" % string;
    "circular" % string;
    "classic" % string;
    "clean" % string;
    "clear" % string;
    "clever" % string;
    "close" % string;
    "closed" % string;
    "cloudy" % string;
    "clueless" % string;
    "clumsy" % string;
    "cluttered" % string;
    "coarse" % string;
    "cold" % string;
    "colorful" % string;
    "colorless" % string;
    "colossal" % string;
    "comfortable" % string;
    "common" % string;
    "compassionate" % string;
    "competent" % string;
    "complete" % string;
    "complex" % string;
    "complicated" % string;
    "composed" % string;
    "concerned" % string;
    "concrete" % string;
    "confused" % string;
    "conscious" % string;
    "considerate" % string;
    "constant" % string;
    "content" % string;
    "conventional" % string;
    "cooked" % string;
    "cool" % string;
    "cooperative" % string;
    "coordinated" % string;
    "corny" % string;
    "corrupt" % string;
    "costly" % string;
    "courageous" % string;
    "courteous" % string;
    "crafty" % string;
    "crazy" % string;
    "creamy" % string;
    "creative" % string;
    "creepy" % string;
    "criminal" % string;
    "crisp" % string;
    "critical" % string;
    "crooked" % string;
    "crowded" % string;
    "cruel" % string;
    "crushing" % string;
    "cuddly" % string;
    "cultivated" % string;
    "cultured" % string;
    "cumbersome" % string;
    "curly" % string;
    "curvy" % string;
    "cute" % string;
    "cylindrical" % string;
    "damaged" % string;
    "damp" % string;
    "dangerous" % string;
    "dapper" % string;
    "daring" % string;
    "darling" % string;
    "dark" % string;
    "dazzling" % string;
    "dead" % string;
    "deadly" % string;
    "deafening" % string;
    "dear" % string;
    "dearest" % string;
    "decent" % string;
    "decimal" % string;
    "decisive" % string;
    "deep" % string;
    "defenseless" % string;
    "defensive" % string;
    "defiant" % string;
    "deficient" % string;
    "definite" % string;
    "definitive" % string;
    "delayed" % string;
    "delectable" % string;
    "delicious" % string;
    "delightful" % string;
    "delirious" % string;
    "demanding" % string;
    "dense" % string;
    "dental" % string;
    "dependable" % string;
    "dependent" % string;
    "descriptive" % string;
    "deserted" % string;
    "detailed" % string;
    "determined" % string;
    "devoted" % string;
    "different" % string;
    "difficult" % string;
    "digital" % string;
    "diligent" % string;
    "dim" % string;
    "dimpled" % string;
    "dimwitted" % string;
    "direct" % string;
    "disastrous" % string;
    "discrete" % string;
    "disfigured" % string;
    "disgusting" % string;
    "disloyal" % string;
    "dismal" % string;
    "distant" % string;
    "downright" % string;
    "dreary" % string;
    "dirty" % string;
    "disguised" % string;
    "dishonest" % string;
    "dismal" % string;
    "distant" % string;
    "distinct" % string;
    "distorted" % string;
    "dizzy" % string;
    "dopey" % string;
    "doting" % string;
    "double" % string;
    "downright" % string;
    "drab" % string;
    "drafty" % string;
    "dramatic" % string;
    "dreary" % string;
    "droopy" % string;
    "dry" % string;
    "dual" % string;
    "dull" % string;
    "dutiful" % string;
    "eager" % string;
    "earnest" % string;
    "early" % string;
    "easy" % string;
    "ecstatic" % string;
    "edible" % string;
    "educated" % string;
    "elaborate" % string;
    "elastic" % string;
    "elated" % string;
    "elderly" % string;
    "electric" % string;
    "elegant" % string;
    "elementary" % string;
    "elliptical" % string;
    "embarrassed" % string;
    "embellished" % string;
    "eminent" % string;
    "emotional" % string;
    "empty" % string;
    "enchanted" % string;
    "enchanting" % string;
    "energetic" % string;
    "enlightened" % string;
    "enormous" % string;
    "enraged" % string;
    "entire" % string;
    "envious" % string;
    "equal" % string;
    "equatorial" % string;
    "essential" % string;
    "esteemed" % string;
    "ethical" % string;
    "euphoric" % string;
    "even" % string;
    "evergreen" % string;
    "everlasting" % string;
    "every" % string;
    "evil" % string;
    "exalted" % string;
    "excellent" % string;
    "exemplary" % string;
    "exhausted" % string;
    "excitable" % string;
    "excited" % string;
    "exciting" % string;
    "exotic" % string;
    "expensive" % string;
    "experienced" % string;
    "expert" % string;
    "extraneous" % string;
    "extroverted" % string;
    "fabulous" % string;
    "failing" % string;
    "faint" % string;
    "fair" % string;
    "faithful" % string;
    "fake" % string;
    "false" % string;
    "familiar" % string;
    "famous" % string;
    "fancy" % string;
    "fantastic" % string;
    "far" % string;
    "faraway" % string;
    "fast" % string;
    "fat" % string;
    "fatal" % string;
    "fatherly" % string;
    "favorable" % string;
    "favorite" % string;
    "fearful" % string;
    "fearless" % string;
    "feisty" % string;
    "feline" % string;
    "female" % string;
    "feminine" % string;
    "few" % string;
    "fickle" % string;
    "filthy" % string;
    "fine" % string;
    "finished" % string;
    "firm" % string;
    "first" % string;
    "firsthand" % string;
    "fitting" % string;
    "fixed" % string;
    "flaky" % string;
    "flamboyant" % string;
    "flashy" % string;
    "flat" % string;
    "flawed" % string;
    "flawless" % string;
    "flickering" % string;
    "flimsy" % string;
    "flippant" % string;
    "flowery" % string;
    "fluffy" % string;
    "fluid" % string;
    "flustered" % string;
    "focused" % string;
    "fond" % string;
    "foolhardy" % string;
    "foolish" % string;
    "forceful" % string;
    "forked" % string;
    "formal" % string;
    "forsaken" % string;
    "forthright" % string;
    "fortunate" % string;
    "fragrant" % string;
    "frail" % string;
    "frank" % string;
    "frayed" % string;
    "free" % string;
    "french" % string;
    "fresh" % string;
    "frequent" % string;
    "friendly" % string;
    "frightened" % string;
    "frightening" % string;
    "frigid" % string;
    "frilly" % string;
    "frizzy" % string;
    "frivolous" % string;
    "front" % string;
    "frosty" % string;
    "frozen" % string;
    "frugal" % string;
    "fruitful" % string;
    "full" % string;
    "fumbling" % string;
    "functional" % string;
    "funny" % string;
    "fussy" % string;
    "fuzzy" % string;
    "gargantuan" % string;
    "gaseous" % string;
    "general" % string;
    "generous" % string;
    "gentle" % string;
    "genuine" % string;
    "giant" % string;
    "giddy" % string;
    "gigantic" % string;
    "gifted" % string;
    "giving" % string;
    "glamorous" % string;
    "glaring" % string;
    "glass" % string;
    "gleaming" % string;
    "gleeful" % string;
    "glistening" % string;
    "glittering" % string;
    "gloomy" % string;
    "glorious" % string;
    "glossy" % string;
    "glum" % string;
    "golden" % string;
    "good" % string;
    "gorgeous" % string;
    "graceful" % string;
    "gracious" % string;
    "grand" % string;
    "grandiose" % string;
    "granular" % string;
    "grateful" % string;
    "grave" % string;
    "gray" % string;
    "great" % string;
    "greedy" % string;
    "green" % string;
    "gregarious" % string;
    "grim" % string;
    "grimy" % string;
    "gripping" % string;
    "grizzled" % string;
    "gross" % string;
    "grotesque" % string;
    "grouchy" % string;
    "grounded" % string;
    "growing" % string;
    "growling" % string;
    "grown" % string;
    "grubby" % string;
    "gruesome" % string;
    "grumpy" % string;
    "guilty" % string;
    "gullible" % string;
    "gummy" % string;
    "hairy" % string;
    "half" % string;
    "handmade" % string;
    "handsome" % string;
    "handy" % string;
    "happy" % string;
    "hard" % string;
    "harmful" % string;
    "harmless" % string;
    "harmonious" % string;
    "harsh" % string;
    "hasty" % string;
    "hateful" % string;
    "haunting" % string;
    "healthy" % string;
    "heartfelt" % string;
    "hearty" % string;
    "heavenly" % string;
    "heavy" % string;
    "hefty" % string;
    "helpful" % string;
    "helpless" % string;
    "hidden" % string;
    "hideous" % string;
    "high" % string;
    "hilarious" % string;
    "hoarse" % string;
    "hollow" % string;
    "homely" % string;
    "honest" % string;
    "honorable" % string;
    "honored" % string;
    "hopeful" % string;
    "horrible" % string;
    "hospitable" % string;
    "hot" % string;
    "huge" % string;
    "humble" % string;
    "humiliating" % string;
    "humming" % string;
    "humongous" % string;
    "hungry" % string;
    "hurtful" % string;
    "husky" % string;
    "icky" % string;
    "icy" % string;
    "ideal" % string;
    "idealistic" % string;
    "identical" % string;
    "idle" % string;
    "idiotic" % string;
    "idolized" % string;
    "ignorant" % string;
    "ill" % string;
    "illegal" % string;
    "illiterate" % string;
    "illustrious" % string;
    "imaginary" % string;
    "imaginative" % string;
    "immaculate" % string;
    "immaterial" % string;
    "immediate" % string;
    "immense" % string;
    "impassioned" % string;
    "impeccable" % string;
    "impartial" % string;
    "imperfect" % string;
    "imperturbable" % string;
    "impish" % string;
    "impolite" % string;
    "important" % string;
    "impossible" % string;
    "impractical" % string;
    "impressionable" % string;
    "impressive" % string;
    "improbable" % string;
    "impure" % string;
    "inborn" % string;
    "incomparable" % string;
    "incompatible" % string;
    "incomplete" % string;
    "inconsequential" % string;
    "incredible" % string;
    "indelible" % string;
    "inexperienced" % string;
    "indolent" % string;
    "infamous" % string;
    "infantile" % string;
    "infatuated" % string;
    "inferior" % string;
    "infinite" % string;
    "informal" % string;
    "innocent" % string;
    "insecure" % string;
    "insidious" % string;
    "insignificant" % string;
    "insistent" % string;
    "instructive" % string;
    "insubstantial" % string;
    "intelligent" % string;
    "intent" % string;
    "intentional" % string;
    "interesting" % string;
    "internal" % string;
    "international" % string;
    "intrepid" % string;
    "ironclad" % string;
    "irresponsible" % string;
    "irritating" % string;
    "itchy" % string;
    "jaded" % string;
    "jagged" % string;
    "jaunty" % string;
    "jealous" % string;
    "jittery" % string;
    "joint" % string;
    "jolly" % string;
    "jovial" % string;
    "joyful" % string;
    "joyous" % string;
    "jubilant" % string;
    "judicious" % string;
    "juicy" % string;
    "jumbo" % string;
    "junior" % string;
    "jumpy" % string;
    "juvenile" % string;
    "kaleidoscopic" % string;
    "keen" % string;
    "key" % string;
    "kind" % string;
    "kindhearted" % string;
    "kindly" % string;
    "klutzy" % string;
    "knobby" % string;
    "knotty" % string;
    "knowledgeable" % string;
    "knowing" % string;
    "known" % string;
    "kooky" % string;
    "lame" % string;
    "lanky" % string;
    "large" % string;
    "last" % string;
    "lasting" % string;
    "late" % string;
    "lavish" % string;
    "lawful" % string;
    "lazy" % string;
    "leading" % string;
    "lean" % string;
    "leafy" % string;
    "left" % string;
    "legal" % string;
    "legitimate" % string;
    "light" % string;
    "lighthearted" % string;
    "likable" % string;
    "likely" % string;
    "limited" % string;
    "limp" % string;
    "limping" % string;
    "linear" % string;
    "lined" % string;
    "liquid" % string;
    "little" % string;
    "live" % string;
    "lively" % string;
    "livid" % string;
    "loathsome" % string;
    "lone" % string;
    "lonely" % string;
    "long" % string;
    "loose" % string;
    "lopsided" % string;
    "lost" % string;
    "loud" % string;
    "lovable" % string;
    "lovely" % string;
    "loving" % string;
    "low" % string;
    "loyal" % string;
    "lucky" % string;
    "lumbering" % string;
    "luminous" % string;
    "lumpy" % string;
    "lustrous" % string;
    "luxurious" % string;
    "mad" % string;
    "magnificent" % string;
    "majestic" % string;
    "major" % string;
    "male" % string;
    "mammoth" % string;
    "married" % string;
    "marvelous" % string;
    "masculine" % string;
    "massive" % string;
    "mature" % string;
    "meager" % string;
    "mealy" % string;
    "mean" % string;
    "measly" % string;
    "meaty" % string;
    "medical" % string;
    "mediocre" % string;
    "medium" % string;
    "meek" % string;
    "mellow" % string;
    "melodic" % string;
    "memorable" % string;
    "menacing" % string;
    "merry" % string;
    "messy" % string;
    "metallic" % string;
    "mild" % string;
    "milky" % string;
    "mindless" % string;
    "miniature" % string;
    "minor" % string;
    "minty" % string;
    "miserable" % string;
    "miserly" % string;
    "misguided" % string;
    "misty" % string;
    "mixed" % string;
    "modern" % string;
    "modest" % string;
    "moist" % string;
    "monstrous" % string;
    "monthly" % string;
    "monumental" % string;
    "moral" % string;
    "mortified" % string;
    "motherly" % string;
    "motionless" % string;
    "mountainous" % string;
    "muddy" % string;
    "muffled" % string;
    "multicolored" % string;
    "mundane" % string;
    "murky" % string;
    "mushy" % string;
    "musty" % string;
    "muted" % string;
    "mysterious" % string;
    "naive" % string;
    "narrow" % string;
    "nasty" % string;
    "natural" % string;
    "naughty" % string;
    "nautical" % string;
    "near" % string;
    "neat" % string;
    "necessary" % string;
    "needy" % string;
    "negative" % string;
    "neglected" % string;
    "negligible" % string;
    "neighboring" % string;
    "nervous" % string;
    "new" % string;
    "nice" % string;
    "nifty" % string;
    "nimble" % string;
    "nippy" % string;
    "nocturnal" % string;
    "noisy" % string;
    "nonstop" % string;
    "normal" % string;
    "notable" % string;
    "noted" % string;
    "noteworthy" % string;
    "novel" % string;
    "noxious" % string;
    "numb" % string;
    "nutritious" % string;
    "nutty" % string;
    "obedient" % string;
    "obese" % string;
    "oblong" % string;
    "oily" % string;
    "oblong" % string;
    "obvious" % string;
    "occasional" % string;
    "odd" % string;
    "oddball" % string;
    "offbeat" % string;
    "offensive" % string;
    "official" % string;
    "old" % string;
    "only" % string;
    "open" % string;
    "optimal" % string;
    "optimistic" % string;
    "opulent" % string;
    "orange" % string;
    "orderly" % string;
    "organic" % string;
    "ornate" % string;
    "ornery" % string;
    "ordinary" % string;
    "original" % string;
    "other" % string;
    "our" % string;
    "outlying" % string;
    "outgoing" % string;
    "outlandish" % string;
    "outrageous" % string;
    "outstanding" % string;
    "oval" % string;
    "overcooked" % string;
    "overdue" % string;
    "overjoyed" % string;
    "overlooked" % string;
    "palatable" % string;
    "pale" % string;
    "paltry" % string;
    "parallel" % string;
    "parched" % string;
    "partial" % string;
    "passionate" % string;
    "past" % string;
    "pastel" % string;
    "peaceful" % string;
    "peppery" % string;
    "perfect" % string;
    "perfumed" % string;
    "periodic" % string;
    "perky" % string;
    "personal" % string;
    "pertinent" % string;
    "pesky" % string;
    "pessimistic" % string;
    "petty" % string;
    "phony" % string;
    "physical" % string;
    "piercing" % string;
    "pink" % string;
    "pitiful" % string;
    "plain" % string;
    "plaintive" % string;
    "plastic" % string;
    "playful" % string;
    "pleasant" % string;
    "pleased" % string;
    "pleasing" % string;
    "plump" % string;
    "plush" % string;
    "polished" % string;
    "polite" % string;
    "political" % string;
    "pointed" % string;
    "pointless" % string;
    "poised" % string;
    "poor" % string;
    "popular" % string;
    "portly" % string;
    "posh" % string;
    "positive" % string;
    "possible" % string;
    "potable" % string;
    "powerful" % string;
    "powerless" % string;
    "practical" % string;
    "precious" % string;
    "present" % string;
    "prestigious" % string;
    "pretty" % string;
    "precious" % string;
    "previous" % string;
    "pricey" % string;
    "prickly" % string;
    "primary" % string;
    "prime" % string;
    "pristine" % string;
    "private" % string;
    "prize" % string;
    "probable" % string;
    "productive" % string;
    "profitable" % string;
    "profuse" % string;
    "proper" % string;
    "proud" % string;
    "prudent" % string;
    "punctual" % string;
    "pungent" % string;
    "puny" % string;
    "pure" % string;
    "purple" % string;
    "pushy" % string;
    "putrid" % string;
    "puzzled" % string;
    "puzzling" % string;
    "quaint" % string;
    "qualified" % string;
    "quarrelsome" % string;
    "quarterly" % string;
    "queasy" % string;
    "querulous" % string;
    "questionable" % string;
    "quick" % string;
    "quiet" % string;
    "quintessential" % string;
    "quirky" % string;
    "quixotic" % string;
    "quizzical" % string;
    "radiant" % string;
    "ragged" % string;
    "rapid" % string;
    "rare" % string;
    "rash" % string;
    "raw" % string;
    "recent" % string;
    "reckless" % string;
    "rectangular" % string;
    "ready" % string;
    "real" % string;
    "realistic" % string;
    "reasonable" % string;
    "red" % string;
    "reflecting" % string;
    "regal" % string;
    "regular" % string;
    "reliable" % string;
    "relieved" % string;
    "remarkable" % string;
    "remorseful" % string;
    "remote" % string;
    "repentant" % string;
    "required" % string;
    "respectful" % string;
    "responsible" % string;
    "repulsive" % string;
    "revolving" % string;
    "rewarding" % string;
    "rich" % string;
    "rigid" % string;
    "right" % string;
    "ringed" % string;
    "ripe" % string;
    "roasted" % string;
    "robust" % string;
    "rosy" % string;
    "rotating" % string;
    "rotten" % string;
    "rough" % string;
    "round" % string;
    "rowdy" % string;
    "royal" % string;
    "rubbery" % string;
    "rundown" % string;
    "ruddy" % string;
    "rude" % string;
    "runny" % string;
    "rural" % string;
    "rusty" % string;
    "sad" % string;
    "safe" % string;
    "salty" % string;
    "same" % string;
    "sandy" % string;
    "sane" % string;
    "sarcastic" % string;
    "sardonic" % string;
    "satisfied" % string;
    "scaly" % string;
    "scarce" % string;
    "scared" % string;
    "scary" % string;
    "scented" % string;
    "scholarly" % string;
    "scientific" % string;
    "scornful" % string;
    "scratchy" % string;
    "scrawny" % string;
    "second" % string;
    "secondary" % string;
    "secret" % string;
    "selfish" % string;
    "sentimental" % string;
    "separate" % string;
    "serene" % string;
    "serious" % string;
    "serpentine" % string;
    "several" % string;
    "severe" % string;
    "shabby" % string;
    "shadowy" % string;
    "shady" % string;
    "shallow" % string;
    "shameful" % string;
    "shameless" % string;
    "sharp" % string;
    "shimmering" % string;
    "shiny" % string;
    "shocked" % string;
    "shocking" % string;
    "shoddy" % string;
    "short" % string;
    "showy" % string;
    "shrill" % string;
    "shy" % string;
    "sick" % string;
    "silent" % string;
    "silky" % string;
    "silly" % string;
    "silver" % string;
    "similar" % string;
    "simple" % string;
    "simplistic" % string;
    "sinful" % string;
    "single" % string;
    "sizzling" % string;
    "skeletal" % string;
    "skinny" % string;
    "sleepy" % string;
    "slight" % string;
    "slim" % string;
    "slimy" % string;
    "slippery" % string;
    "slow" % string;
    "slushy" % string;
    "small" % string;
    "smart" % string;
    "smoggy" % string;
    "smooth" % string;
    "smug" % string;
    "snappy" % string;
    "snarling" % string;
    "sneaky" % string;
    "sniveling" % string;
    "snoopy" % string;
    "sociable" % string;
    "soft" % string;
    "soggy" % string;
    "solid" % string;
    "somber" % string;
    "some" % string;
    "spherical" % string;
    "sophisticated" % string;
    "sore" % string;
    "sorrowful" % string;
    "soulful" % string;
    "soupy" % string;
    "sour" % string;
    "spanish" % string;
    "sparkling" % string;
    "sparse" % string;
    "specific" % string;
    "spectacular" % string;
    "speedy" % string;
    "spicy" % string;
    "spiffy" % string;
    "spirited" % string;
    "spiteful" % string;
    "splendid" % string;
    "spotless" % string;
    "spotted" % string;
    "spry" % string;
    "square" % string;
    "squeaky" % string;
    "squiggly" % string;
    "stable" % string;
    "staid" % string;
    "stained" % string;
    "stale" % string;
    "standard" % string;
    "starchy" % string;
    "stark" % string;
    "starry" % string;
    "steep" % string;
    "sticky" % string;
    "stiff" % string;
    "stimulating" % string;
    "stingy" % string;
    "stormy" % string;
    "straight" % string;
    "strange" % string;
    "steel" % string;
    "strict" % string;
    "strident" % string;
    "striking" % string;
    "striped" % string;
    "strong" % string;
    "studious" % string;
    "stunning" % string;
    "stupendous" % string;
    "stupid" % string;
    "sturdy" % string;
    "stylish" % string;
    "subdued" % string;
    "submissive" % string;
    "substantial" % string;
    "subtle" % string;
    "suburban" % string;
    "sudden" % string;
    "sugary" % string;
    "sunny" % string;
    "super" % string;
    "superb" % string;
    "superficial" % string;
    "superior" % string;
    "supportive" % string;
    "surprised" % string;
    "suspicious" % string;
    "svelte" % string;
    "sweaty" % string;
    "sweet" % string;
    "sweltering" % string;
    "swift" % string;
    "sympathetic" % string;
    "tall" % string;
    "talkative" % string;
    "tame" % string;
    "tan" % string;
    "tangible" % string;
    "tart" % string;
    "tasty" % string;
    "tattered" % string;
    "taut" % string;
    "tedious" % string;
    "teeming" % string;
    "tempting" % string;
    "tender" % string;
    "tense" % string;
    "tepid" % string;
    "terrible" % string;
    "terrific" % string;
    "testy" % string;
    "thankful" % string;
    "that" % string;
    "these" % string;
    "thick" % string;
    "thin" % string;
    "third" % string;
    "thirsty" % string;
    "this" % string;
    "thorough" % string;
    "thorny" % string;
    "those" % string;
    "thoughtful" % string;
    "threadbare" % string;
    "thrifty" % string;
    "thunderous" % string;
    "tidy" % string;
    "tight" % string;
    "timely" % string;
    "tinted" % string;
    "tiny" % string;
    "tired" % string;
    "torn" % string;
    "total" % string;
    "tough" % string;
    "traumatic" % string;
    "treasured" % string;
    "tremendous" % string;
    "tragic" % string;
    "trained" % string;
    "tremendous" % string;
    "triangular" % string;
    "tricky" % string;
    "trifling" % string;
    "trim" % string;
    "trivial" % string;
    "troubled" % string;
    "true" % string;
    "trusting" % string;
    "trustworthy" % string;
    "trusty" % string;
    "truthful" % string;
    "tubby" % string;
    "turbulent" % string;
    "twin" % string;
    "ugly" % string;
    "ultimate" % string;
    "unacceptable" % string;
    "unaware" % string;
    "uncomfortable" % string;
    "uncommon" % string;
    "unconscious" % string;
    "understated" % string;
    "unequaled" % string;
    "uneven" % string;
    "unfinished" % string;
    "unfit" % string;
    "unfolded" % string;
    "unfortunate" % string;
    "unhappy" % string;
    "unhealthy" % string;
    "uniform" % string;
    "unimportant" % string;
    "unique" % string;
    "united" % string;
    "unkempt" % string;
    "unknown" % string;
    "unlawful" % string;
    "unlined" % string;
    "unlucky" % string;
    "unnatural" % string;
    "unpleasant" % string;
    "unrealistic" % string;
    "unripe" % string;
    "unruly" % string;
    "unselfish" % string;
    "unsightly" % string;
    "unsteady" % string;
    "unsung" % string;
    "untidy" % string;
    "untimely" % string;
    "untried" % string;
    "untrue" % string;
    "unused" % string;
    "unusual" % string;
    "unwelcome" % string;
    "unwieldy" % string;
    "unwilling" % string;
    "unwitting" % string;
    "unwritten" % string;
    "upbeat" % string;
    "upright" % string;
    "upset" % string;
    "urban" % string;
    "usable" % string;
    "used" % string;
    "useful" % string;
    "useless" % string;
    "utilized" % string;
    "utter" % string;
    "vacant" % string;
    "vague" % string;
    "vain" % string;
    "valid" % string;
    "valuable" % string;
    "vapid" % string;
    "variable" % string;
    "vast" % string;
    "velvety" % string;
    "venerated" % string;
    "vengeful" % string;
    "verifiable" % string;
    "vibrant" % string;
    "vicious" % string;
    "victorious" % string;
    "vigilant" % string;
    "vigorous" % string;
    "villainous" % string;
    "violet" % string;
    "violent" % string;
    "virtual" % string;
    "virtuous" % string;
    "visible" % string;
    "vital" % string;
    "vivacious" % string;
    "vivid" % string;
    "voluminous" % string;
    "warlike" % string;
    "warm" % string;
    "warmhearted" % string;
    "warped" % string;
    "wary" % string;
    "wasteful" % string;
    "watchful" % string;
    "waterlogged" % string;
    "watery" % string;
    "wavy" % string;
    "wealthy" % string;
    "weak" % string;
    "weary" % string;
    "webbed" % string;
    "wee" % string;
    "weekly" % string;
    "weepy" % string;
    "weighty" % string;
    "weird" % string;
    "welcome" % string;
    "wet" % string;
    "which" % string;
    "whimsical" % string;
    "whirlwind" % string;
    "whispered" % string;
    "white" % string;
    "whole" % string;
    "whopping" % string;
    "wicked" % string;
    "wide" % string;
    "wiggly" % string;
    "wild" % string;
    "willing" % string;
    "wilted" % string;
    "winding" % string;
    "windy" % string;
    "winged" % string;
    "wiry" % string;
    "wise" % string;
    "witty" % string;
    "wobbly" % string;
    "woeful" % string;
    "wonderful" % string;
    "wooden" % string;
    "woozy" % string;
    "wordy" % string;
    "worldly" % string;
    "worn" % string;
    "worried" % string;
    "worrisome" % string;
    "worse" % string;
    "worst" % string;
    "worthless" % string;
    "worthwhile" % string;
    "worthy" % string;
    "wrathful" % string;
    "wretched" % string;
    "writhing" % string;
    "wrong" % string;
    "wry" % string;
    "yawning" % string;
    "yearly" % string;
    "yellow" % string;
    "yellowish" % string;
    "young" % string;
    "youthful" % string;
    "yummy" % string;
    "zany" % string;
    "zealous" % string;
    "zesty" % string
  ].

Definition animals : array string :=
  (* ❌ Arrays not handled. *)
  [
    "aardvark" % string;
    "abyssinian" % string;
    "affenpinscher" % string;
    "akbash" % string;
    "akita" % string;
    "albatross" % string;
    "alligator" % string;
    "angelfish" % string;
    "ant" % string;
    "anteater" % string;
    "antelope" % string;
    "armadillo" % string;
    "avocet" % string;
    "axolotl" % string;
    "baboon" % string;
    "badger" % string;
    "balinese" % string;
    "bandicoot" % string;
    "barb" % string;
    "barnacle" % string;
    "barracuda" % string;
    "bat" % string;
    "beagle" % string;
    "bear" % string;
    "beaver" % string;
    "beetle" % string;
    "binturong" % string;
    "birman" % string;
    "bison" % string;
    "bloodhound" % string;
    "bobcat" % string;
    "bombay" % string;
    "bongo" % string;
    "bonobo" % string;
    "booby" % string;
    "budgerigar" % string;
    "buffalo" % string;
    "bulldog" % string;
    "bullfrog" % string;
    "burmese" % string;
    "butterfly" % string;
    "caiman" % string;
    "camel" % string;
    "capybara" % string;
    "caracal" % string;
    "cassowary" % string;
    "cat" % string;
    "caterpillar" % string;
    "catfish" % string;
    "centipede" % string;
    "chameleon" % string;
    "chamois" % string;
    "cheetah" % string;
    "chicken" % string;
    "chihuahua" % string;
    "chimpanzee" % string;
    "chinchilla" % string;
    "chinook" % string;
    "chipmunk" % string;
    "cichlid" % string;
    "coati" % string;
    "cockroach" % string;
    "collie" % string;
    "coral" % string;
    "cougar" % string;
    "cow" % string;
    "coyote" % string;
    "crab" % string;
    "crane" % string;
    "crocodile" % string;
    "cuscus" % string;
    "cuttlefish" % string;
    "dachshund" % string;
    "dalmatian" % string;
    "deer" % string;
    "dhole" % string;
    "dingo" % string;
    "discus" % string;
    "dodo" % string;
    "dog" % string;
    "dolphin" % string;
    "donkey" % string;
    "dormouse" % string;
    "dragonfly" % string;
    "drever" % string;
    "duck" % string;
    "dugong" % string;
    "dunker" % string;
    "eagle" % string;
    "earwig" % string;
    "echidna" % string;
    "elephant" % string;
    "emu" % string;
    "falcon" % string;
    "fennec" % string;
    "ferret" % string;
    "fish" % string;
    "flamingo" % string;
    "flounder" % string;
    "fly" % string;
    "fossa" % string;
    "fox" % string;
    "frigatebird" % string;
    "frog" % string;
    "gar" % string;
    "gecko" % string;
    "gerbil" % string;
    "gharial" % string;
    "gibbon" % string;
    "giraffe" % string;
    "goat" % string;
    "goose" % string;
    "gopher" % string;
    "gorilla" % string;
    "grasshopper" % string;
    "greyhound" % string;
    "grouse" % string;
    "guppy" % string;
    "hamster" % string;
    "hare" % string;
    "harrier" % string;
    "havanese" % string;
    "hedgehog" % string;
    "heron" % string;
    "himalayan" % string;
    "hippopotamus" % string;
    "horse" % string;
    "human" % string;
    "hummingbird" % string;
    "hyena" % string;
    "ibis" % string;
    "iguana" % string;
    "impala" % string;
    "indri" % string;
    "insect" % string;
    "jackal" % string;
    "jaguar" % string;
    "javanese" % string;
    "jellyfish" % string;
    "kakapo" % string;
    "kangaroo" % string;
    "kingfisher" % string;
    "kiwi" % string;
    "koala" % string;
    "kudu" % string;
    "labradoodle" % string;
    "ladybird" % string;
    "lemming" % string;
    "lemur" % string;
    "leopard" % string;
    "liger" % string;
    "lion" % string;
    "lionfish" % string;
    "lizard" % string;
    "llama" % string;
    "lobster" % string;
    "lynx" % string;
    "macaw" % string;
    "magpie" % string;
    "maltese" % string;
    "manatee" % string;
    "mandrill" % string;
    "markhor" % string;
    "mastiff" % string;
    "mayfly" % string;
    "meerkat" % string;
    "millipede" % string;
    "mole" % string;
    "molly" % string;
    "mongoose" % string;
    "mongrel" % string;
    "monkey" % string;
    "moorhen" % string;
    "moose" % string;
    "moth" % string;
    "mouse" % string;
    "mule" % string;
    "neanderthal" % string;
    "newfoundland" % string;
    "newt" % string;
    "nightingale" % string;
    "numbat" % string;
    "ocelot" % string;
    "octopus" % string;
    "okapi" % string;
    "olm" % string;
    "opossum" % string;
    "ostrich" % string;
    "otter" % string;
    "oyster" % string;
    "pademelon" % string;
    "panther" % string;
    "parrot" % string;
    "peacock" % string;
    "pekingese" % string;
    "pelican" % string;
    "penguin" % string;
    "persian" % string;
    "pheasant" % string;
    "pig" % string;
    "pika" % string;
    "pike" % string;
    "piranha" % string;
    "platypus" % string;
    "pointer" % string;
    "poodle" % string;
    "porcupine" % string;
    "possum" % string;
    "prawn" % string;
    "puffin" % string;
    "pug" % string;
    "puma" % string;
    "quail" % string;
    "quetzal" % string;
    "quokka" % string;
    "quoll" % string;
    "rabbit" % string;
    "raccoon" % string;
    "ragdoll" % string;
    "rat" % string;
    "rattlesnake" % string;
    "reindeer" % string;
    "rhinoceros" % string;
    "robin" % string;
    "rottweiler" % string;
    "salamander" % string;
    "saola" % string;
    "scorpion" % string;
    "seahorse" % string;
    "seal" % string;
    "serval" % string;
    "sheep" % string;
    "shrimp" % string;
    "siamese" % string;
    "siberian" % string;
    "skunk" % string;
    "sloth" % string;
    "snail" % string;
    "snake" % string;
    "snowshoe" % string;
    "somali" % string;
    "sparrow" % string;
    "sponge" % string;
    "squid" % string;
    "squirrel" % string;
    "starfish" % string;
    "stingray" % string;
    "stoat" % string;
    "swan" % string;
    "tang" % string;
    "tapir" % string;
    "tarsier" % string;
    "termite" % string;
    "tetra" % string;
    "tiffany" % string;
    "tiger" % string;
    "tortoise" % string;
    "toucan" % string;
    "tropicbird" % string;
    "tuatara" % string;
    "turkey" % string;
    "uakari" % string;
    "uguisu" % string;
    "umbrellabird" % string;
    "vulture" % string;
    "wallaby" % string;
    "walrus" % string;
    "warthog" % string;
    "wasp" % string;
    "weasel" % string;
    "whippet" % string;
    "wildebeest" % string;
    "wolf" % string;
    "wolverine" % string;
    "wombat" % string;
    "woodlouse" % string;
    "woodpecker" % string;
    "wrasse" % string;
    "yak" % string;
    "zebra" % string;
    "zebu" % string;
    "zonkey" % string;
    "zorse" % string
  ].

Definition pick {A : Type} (a : array A) (z : Z.t) : A :=
  Array.get a
    (OCaml.Stdlib.reverse_apply
      (Z.rem z (OCaml.Stdlib.reverse_apply (Array.length a) Z.of_int)) Z.to_int).

Definition hash (a : string) : string :=
  OCaml.Stdlib.reverse_apply (Blake2B.hash_string None (cons a []))
    Blake2B.to_string.

Record t := {
  c : string;
  t : string;
  h : string;
  d : string }.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  let '{| c := c; t := t; h := h; d := d |} := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
        (CamlinternalFormatBasics.Char_literal "-" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "-" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "-" % char
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format)))))))
      "%s-%s-%s-%s" % string) c t h d.

Definition crouching_tiger (string : string) : t :=
  let c :=
    pick adjectives
      (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
        Z.of_bits) in
  let t :=
    pick animals
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
          hash) Z.of_bits) in
  let h :=
    pick adjectives
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
            hash) hash) Z.of_bits) in
  let d :=
    pick animals
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply string hash)
              hash) hash) hash) Z.of_bits) in
  {| c := c; t := t; h := h; d := d |}.

src/lib_signer_backends/unix/remote.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys

let scheme = "remote"

module Make
    (RPC_client : RPC_client.S) (S : sig
      val default : Uri.t

      val authenticate :
        Signature.Public_key_hash.t list ->
        Bytes.t ->
        Signature.t tzresult Lwt.t

      val logger : RPC_client.logger
    end) =
struct
  let scheme = scheme

  let title = "Built-in tezos-signer using remote wallet."

  let description =
    "Valid locators are of the form\n\
    \ - remote://tz1...\n\
     The key will be queried to current remote signer, which can be \
     configured with the `--remote-signer` or `-R` options, or by defining \
     the following environment variables:\n\
    \ - $TEZOS_SIGNER_UNIX_PATH,\n\
    \ - $TEZOS_SIGNER_TCP_HOST and $TEZOS_SIGNER_TCP_PORT (default: 7732),\n\
    \ - $TEZOS_SIGNER_HTTP_HOST and $TEZOS_SIGNER_HTTP_PORT (default: 6732),\n\
    \ - $TEZOS_SIGNER_HTTPS_HOST and $TEZOS_SIGNER_HTTPS_PORT (default: 443)."

  module Socket = Socket.Make (S)
  module Http = Http.Make (RPC_client) (S)
  module Https = Https.Make (RPC_client) (S)

  let get_remote () =
    match Uri.scheme S.default with
    | Some "unix" ->
        (module Socket.Unix : SIGNER)
    | Some "tcp" ->
        (module Socket.Tcp : SIGNER)
    | Some "http" ->
        (module Http : SIGNER)
    | Some "https" ->
        (module Https : SIGNER)
    | _ ->
        assert false

  module Remote = (val get_remote () : SIGNER)

  let key =
    match Uri.scheme S.default with
    | Some "unix" ->
        fun uri ->
          let key = Uri.path uri in
          Uri.add_query_param' S.default ("pkh", key)
    | Some "tcp" ->
        fun uri ->
          let key = Uri.path uri in
          Uri.with_path S.default key
    | Some ("https" | "http") -> (
        fun uri ->
          let key = Uri.path uri in
          match Uri.path S.default with
          | "" ->
              Uri.with_path S.default key
          | path ->
              Uri.with_path S.default (path ^ "/" ^ key) )
    | _ ->
        assert false

  let public_key pk_uri =
    Remote.public_key
      (Client_keys.make_pk_uri (key (pk_uri : pk_uri :> Uri.t)))

  let public_key_hash pk_uri =
    Remote.public_key_hash
      (Client_keys.make_pk_uri (key (pk_uri : pk_uri :> Uri.t)))

  let import_secret_key ~io:_ = public_key_hash

  let neuterize sk_uri =
    return (Client_keys.make_pk_uri (sk_uri : sk_uri :> Uri.t))

  let sign ?watermark sk_uri msg =
    Remote.sign
      ?watermark
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
      msg

  let deterministic_nonce sk_uri msg =
    Remote.deterministic_nonce
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
      msg

  let deterministic_nonce_hash sk_uri msg =
    Remote.deterministic_nonce_hash
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
      msg

  let supports_deterministic_nonces sk_uri =
    Remote.supports_deterministic_nonces
      (Client_keys.make_sk_uri (key (sk_uri : sk_uri :> Uri.t)))
end

let make_sk sk =
  Client_keys.make_sk_uri
    (Uri.make ~scheme ~path:(Signature.Secret_key.to_b58check sk) ())

let make_pk pk =
  Client_keys.make_pk_uri
    (Uri.make ~scheme ~path:(Signature.Public_key.to_b58check pk) ())

let read_base_uri_from_env () =
  match
    ( Sys.getenv_opt "TEZOS_SIGNER_UNIX_PATH",
      Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST",
      Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST",
      Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" )
  with
  | (None, None, None, None) ->
      return_none
  | (Some path, None, None, None) ->
      return_some (Socket.make_unix_base path)
  | (None, Some host, None, None) -> (
    try
      let port =
        match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" with
        | None ->
            7732
        | Some port ->
            int_of_string port
      in
      return_some (Socket.make_tcp_base host port)
    with Invalid_argument _ ->
      failwith "Failed to parse TEZOS_SIGNER_TCP_PORT.@." )
  | (None, None, Some host, None) -> (
    try
      let port =
        match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" with
        | None ->
            6732
        | Some port ->
            int_of_string port
      in
      return_some (Http.make_base host port)
    with Invalid_argument _ ->
      failwith "Failed to parse TEZOS_SIGNER_HTTP_PORT.@." )
  | (None, None, None, Some host) -> (
    try
      let port =
        match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" with
        | None ->
            443
        | Some port ->
            int_of_string port
      in
      return_some (Https.make_base host port)
    with Invalid_argument _ ->
      failwith "Failed to parse TEZOS_SIGNER_HTTPS_PORT.@." )
  | (_, _, _, _) ->
      failwith
        "Only one the following environment variable must be defined: \
         TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, \
         TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST@."

type error += Invalid_remote_signer of string

let () =
  register_error_kind
    `Branch
    ~id:"invalid_remote_signer"
    ~title:"Unexpected URI fot remote signer"
    ~description:"The provided remote signer is invalid."
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "@[<v 0>Value '%s' is not a valid URI for a remote signer.@,\
         Supported URIs for remote signers are of the form:@,\
        \ - unix:///path/to/socket/file@,\
        \ - tcp://host:port@,\
        \ - http://host[:port][/prefix]@,\
        \ - https://host[:port][/prefix]@]"
        s)
    Data_encoding.(obj1 (req "uri" string))
    (function Invalid_remote_signer s -> Some s | _ -> None)
    (fun s -> Invalid_remote_signer s)

let parse_base_uri s =
  trace (Invalid_remote_signer s)
  @@
  try
    let uri = Uri.of_string s in
    match Uri.scheme uri with
    | Some "http" ->
        return uri
    | Some "https" ->
        return uri
    | Some "tcp" ->
        return uri
    | Some "unix" ->
        return uri
    | Some scheme ->
        failwith "Unknown scheme: %s" scheme
    | None ->
        failwith "Unknown scheme: <empty>"
  with Invalid_argument msg -> failwith "Malformed URI: %s" msg
src/lib_signer_backends/unix/remote.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_keys.

Definition scheme : string := "remote" % string.

(* ❌ Functors are not handled. *)
functor

Definition make_sk (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
  : Tezos_client_base.Client_keys.sk_uri :=
  Client_keys.make_sk_uri
    (Uri.make (Some scheme) None None None
      (Some (Signature.Secret_key.to_b58check sk)) None None tt).

Definition make_pk (pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Tezos_client_base.Client_keys.pk_uri :=
  Client_keys.make_pk_uri
    (Uri.make (Some scheme) None None None
      (Some (Signature.Public_key.to_b58check pk)) None None tt).

Definition read_base_uri_from_env (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (option Uri.t)) :=
  let 'tt := function_parameter in
  match
    ((Sys.getenv_opt "TEZOS_SIGNER_UNIX_PATH" % string),
      (Sys.getenv_opt "TEZOS_SIGNER_TCP_HOST" % string),
      (Sys.getenv_opt "TEZOS_SIGNER_HTTP_HOST" % string),
      (Sys.getenv_opt "TEZOS_SIGNER_HTTPS_HOST" % string)) with
  | (None, None, None, None) => return_none
  | (Some path, None, None, None) => return_some (Socket.make_unix_base path)
  | (None, Some host, None, None) =>
    (* ❌ Try-with are not handled *)
    try
      (let port :=
        match Sys.getenv_opt "TEZOS_SIGNER_TCP_PORT" % string with
        | None => 7732
        | Some port => OCaml.Stdlib.int_of_string port
        end in
      return_some (Socket.make_tcp_base host port))
  | (None, None, Some host, None) =>
    (* ❌ Try-with are not handled *)
    try
      (let port :=
        match Sys.getenv_opt "TEZOS_SIGNER_HTTP_PORT" % string with
        | None => 6732
        | Some port => OCaml.Stdlib.int_of_string port
        end in
      return_some (Http.make_base host port))
  | (None, None, None, Some host) =>
    (* ❌ Try-with are not handled *)
    try
      (let port :=
        match Sys.getenv_opt "TEZOS_SIGNER_HTTPS_PORT" % string with
        | None => 443
        | Some port => OCaml.Stdlib.int_of_string port
        end in
      return_some (Https.make_base host port))
  | (_, _, _, _) =>
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Only one the following environment variable must be defined: TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST"
            % string
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Flush_newline
            CamlinternalFormatBasics.End_of_format))
        "Only one the following environment variable must be defined: TEZOS_SIGNER_UNIX_PATH, TEZOS_SIGNER_TCP_HOST, TEZOS_SIGNER_HTTP_HOST, TEZOS_SIGNER_HTTPS_HOST@."
          % string)
  end.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition parse_base_uri (s : string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Uri.t) :=
  apply (trace (Tezos_base__TzPervasives.Invalid_remote_signer s))
    (* ❌ Try-with are not handled *)
    (try
      (let uri := Uri.of_string s in
      match Uri.scheme uri with
      | Some "http" % string => _return uri
      | Some "https" % string => _return uri
      | Some "tcp" % string => _return uri
      | Some "unix" % string => _return uri
      | Some scheme =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Unknown scheme: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Unknown scheme: %s" % string) scheme
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Unknown scheme: <empty>" % string
              CamlinternalFormatBasics.End_of_format)
            "Unknown scheme: <empty>" % string)
      end)).

src/lib_signer_backends/unix/socket.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_keys
open Signer_messages

let tcp_scheme = "tcp"

let unix_scheme = "unix"

module Make (P : sig
  val authenticate :
    Signature.Public_key_hash.t list -> Bytes.t -> Signature.t tzresult Lwt.t
end) =
struct
  type request_type =
    | Sign_request
    | Deterministic_nonce_request
    | Deterministic_nonce_hash_request

  let build_request pkh data signature = function
    | Sign_request ->
        Request.Sign {Sign.Request.pkh; data; signature}
    | Deterministic_nonce_request ->
        Request.Deterministic_nonce
          {Deterministic_nonce.Request.pkh; data; signature}
    | Deterministic_nonce_hash_request ->
        Request.Deterministic_nonce_hash
          {Deterministic_nonce_hash.Request.pkh; data; signature}

  let signer_operation path pkh msg request_type =
    Lwt_utils_unix.Socket.connect path
    >>=? (fun conn ->
           Lwt_utils_unix.Socket.send
             conn
             Request.encoding
             Request.Authorized_keys
           >>=? fun () ->
           Lwt_utils_unix.Socket.recv
             conn
             (result_encoding Authorized_keys.Response.encoding)
           >>=? fun authorized_keys ->
           Lwt.return authorized_keys
           >>=? fun authorized_keys ->
           Lwt_unix.close conn
           >>= fun () ->
           match authorized_keys with
           | No_authentication ->
               return_none
           | Authorized_keys authorized_keys ->
               P.authenticate
                 authorized_keys
                 (Sign.Request.to_sign ~pkh ~data:msg)
               >>=? fun signature -> return_some signature)
    >>=? fun signature ->
    Lwt_utils_unix.Socket.connect path
    >>=? fun conn ->
    let req = build_request pkh msg signature request_type in
    Lwt_utils_unix.Socket.send conn Request.encoding req
    >>=? fun () -> return conn

  let sign ?watermark path pkh msg =
    let msg =
      match watermark with
      | None ->
          msg
      | Some watermark ->
          Bytes.cat (Signature.bytes_of_watermark watermark) msg
    in
    signer_operation path pkh msg Sign_request
    >>=? fun conn ->
    Lwt_utils_unix.Socket.recv conn (result_encoding Sign.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let deterministic_nonce path pkh msg =
    signer_operation path pkh msg Deterministic_nonce_request
    >>=? fun conn ->
    Lwt_utils_unix.Socket.recv
      conn
      (result_encoding Deterministic_nonce.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let deterministic_nonce_hash path pkh msg =
    signer_operation path pkh msg Deterministic_nonce_hash_request
    >>=? fun conn ->
    Lwt_utils_unix.Socket.recv
      conn
      (result_encoding Deterministic_nonce_hash.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let supports_deterministic_nonces path pkh =
    Lwt_utils_unix.Socket.connect path
    >>=? fun conn ->
    Lwt_utils_unix.Socket.send
      conn
      Request.encoding
      (Request.Supports_deterministic_nonces pkh)
    >>=? fun () ->
    Lwt_utils_unix.Socket.recv
      conn
      (result_encoding Supports_deterministic_nonces.Response.encoding)
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  let public_key path pkh =
    Lwt_utils_unix.Socket.connect path
    >>=? fun conn ->
    Lwt_utils_unix.Socket.send conn Request.encoding (Request.Public_key pkh)
    >>=? fun () ->
    let encoding = result_encoding Public_key.Response.encoding in
    Lwt_utils_unix.Socket.recv conn encoding
    >>=? fun res -> Lwt_unix.close conn >>= fun () -> Lwt.return res

  module Unix = struct
    let scheme = unix_scheme

    let title =
      "Built-in tezos-signer using remote signer through hardcoded unix socket."

    let description =
      "Valid locators are of the form\n - unix:/path/to/socket?pkh=tz1..."

    let parse uri =
      assert (Uri.scheme uri = Some scheme) ;
      trace (Invalid_uri uri)
      @@
      match Uri.get_query_param uri "pkh" with
      | None ->
          failwith "Missing the query parameter: 'pkh=tz1...'"
      | Some key ->
          Lwt.return (Signature.Public_key_hash.of_b58check key)
          >>=? fun key ->
          return (Lwt_utils_unix.Socket.Unix (Uri.path uri), key)

    let public_key uri =
      parse (uri : pk_uri :> Uri.t) >>=? fun (path, pkh) -> public_key path pkh

    let neuterize uri =
      return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))

    let public_key_hash uri =
      public_key uri
      >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

    let import_secret_key ~io:_ = public_key_hash

    let sign ?watermark uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> sign ?watermark path pkh msg

    let deterministic_nonce uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce path pkh msg

    let deterministic_nonce_hash uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce_hash path pkh msg

    let supports_deterministic_nonces uri =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> supports_deterministic_nonces path pkh
  end

  module Tcp = struct
    let scheme = tcp_scheme

    let title =
      "Built-in tezos-signer using remote signer through hardcoded tcp socket."

    let description =
      "Valid locators are of the form\n - tcp://host:port/tz1..."

    let parse uri =
      assert (Uri.scheme uri = Some scheme) ;
      trace (Invalid_uri uri)
      @@
      match (Uri.host uri, Uri.port uri) with
      | (None, _) ->
          failwith "Missing host address"
      | (_, None) ->
          failwith "Missing host port"
      | (Some path, Some port) ->
          let pkh = Uri.path uri in
          let pkh = try String.(sub pkh 1 (length pkh - 1)) with _ -> "" in
          Lwt.return (Signature.Public_key_hash.of_b58check pkh)
          >>=? fun pkh ->
          return
            ( Lwt_utils_unix.Socket.Tcp
                (path, string_of_int port, [Lwt_unix.AI_SOCKTYPE SOCK_STREAM]),
              pkh )

    let public_key uri =
      parse (uri : pk_uri :> Uri.t) >>=? fun (path, pkh) -> public_key path pkh

    let neuterize uri =
      return (Client_keys.make_pk_uri (uri : sk_uri :> Uri.t))

    let public_key_hash uri =
      public_key uri
      >>=? fun pk -> return (Signature.Public_key.hash pk, Some pk)

    let import_secret_key ~io:_ = public_key_hash

    let sign ?watermark uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> sign ?watermark path pkh msg

    let deterministic_nonce uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce path pkh msg

    let deterministic_nonce_hash uri msg =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> deterministic_nonce_hash path pkh msg

    let supports_deterministic_nonces uri =
      parse (uri : sk_uri :> Uri.t)
      >>=? fun (path, pkh) -> supports_deterministic_nonces path pkh
  end
end

let make_unix_base path = Uri.make ~scheme:unix_scheme ~path ()

let make_tcp_base host port = Uri.make ~scheme:tcp_scheme ~host ~port ()
src/lib_signer_backends/unix/socket.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_keys.

Import Signer_messages.

Definition tcp_scheme : string := "tcp" % string.

Definition unix_scheme : string := "unix" % string.

(* ❌ Functors are not handled. *)
functor

Definition make_unix_base (path : string) : Uri.t :=
  Uri.make (Some unix_scheme) None None None (Some path) None None tt.

Definition make_tcp_base (host : string) (port : Z) : Uri.t :=
  Uri.make (Some tcp_scheme) None (Some host) (Some port) None None None tt.

src/lib_signer_backends/unix/test/test_crouching.ml 5 errors
let test_example () =
  let name = Ledger_names.crouching_tiger "12345" in
  assert (
    name = {c = "calculating"; t = "meerkat"; h = "straight"; d = "beetle"} )

let tests = [Alcotest.test_case "print_example" `Quick test_example]

let () = Alcotest.run "tezos-signed-backends" [("ledger-names", tests)]
src/lib_signer_backends/unix/test/test_crouching.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition test_example (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  let name := Ledger_names.crouching_tiger "12345" % string in
  (* ❌ Assert instruction is not handled. *)
  assert
    (equiv_decb name
      {| c := "calculating" % string; t := "meerkat" % string;
        h := "straight" % string; d := "beetle" % string |}).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "print_example" % string
      (* ❌ Variants not supported *)
      variant test_example) [].



src/lib_signer_services/signer_messages.ml 17 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type Authenticated_request = sig
  type t = {
    pkh : Signature.Public_key_hash.t;
    data : Bytes.t;
    signature : Signature.t option;
  }

  val to_sign : pkh:Signature.Public_key_hash.t -> data:Bytes.t -> Bytes.t

  val encoding : t Data_encoding.t
end

module type Tag = sig
  val tag : int
end

module Make_authenticated_request (T : Tag) : Authenticated_request = struct
  type t = {
    pkh : Signature.Public_key_hash.t;
    data : Bytes.t;
    signature : Signature.t option;
  }

  let to_sign ~pkh ~data =
    let tag = Bytes.make 1 '0' in
    TzEndian.set_int8 tag 0 T.tag ;
    Bytes.concat
      (Bytes.of_string "")
      [ Bytes.of_string "\x04";
        tag;
        Signature.Public_key_hash.to_bytes pkh;
        data ]

  let encoding =
    let open Data_encoding in
    conv
      (fun {pkh; data; signature} -> (pkh, data, signature))
      (fun (pkh, data, signature) -> {pkh; data; signature})
      (obj3
         (req "pkh" Signature.Public_key_hash.encoding)
         (req "data" bytes)
         (opt "signature" Signature.encoding))
end

module Sign = struct
  module Request = Make_authenticated_request (struct
    let tag = 1
  end)

  module Response = struct
    type t = Signature.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.sign.response"
      @@ obj1 (req "signature" Signature.encoding)
  end
end

module Deterministic_nonce = struct
  module Request = Make_authenticated_request (struct
    let tag = 2
  end)

  module Response = struct
    type t = Bigstring.t

    let bigstring =
      let open Data_encoding in
      conv Bigstring.to_bytes Bigstring.of_bytes bytes

    let encoding =
      let open Data_encoding in
      def "signer_messages.deterministic_nonce.response"
      @@ obj1 (req "deterministic_nonce" bigstring)
  end
end

module Deterministic_nonce_hash = struct
  module Request = Make_authenticated_request (struct
    let tag = 3
  end)

  module Response = struct
    type t = Bytes.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.deterministic_nonce_hash.response"
      @@ obj1 (req "deterministic_nonce_hash" bytes)
  end
end

module Supports_deterministic_nonces = struct
  module Request = struct
    type t = Signature.Public_key_hash.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.supports_deterministic_nonces.request"
      @@ obj1 (req "pkh" Signature.Public_key_hash.encoding)
  end

  module Response = struct
    type t = bool

    let encoding =
      let open Data_encoding in
      def "signer_messages.supports_deterministic_nonces.response"
      @@ obj1 (req "bool" bool)
  end
end

module Public_key = struct
  module Request = struct
    type t = Signature.Public_key_hash.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.public_key.request"
      @@ obj1 (req "pkh" Signature.Public_key_hash.encoding)
  end

  module Response = struct
    type t = Signature.Public_key.t

    let encoding =
      let open Data_encoding in
      def "signer_messages.public_key.response"
      @@ obj1 (req "pubkey" Signature.Public_key.encoding)
  end
end

module Authorized_keys = struct
  module Response = struct
    type t =
      | No_authentication
      | Authorized_keys of Signature.Public_key_hash.t list

    let encoding =
      let open Data_encoding in
      union
        [ case
            (Tag 0)
            ~title:"No_authentication"
            (constant "no_authentication_required")
            (function No_authentication -> Some () | _ -> None)
            (fun () -> No_authentication);
          case
            (Tag 1)
            ~title:"Authorized_keys"
            (list Signature.Public_key_hash.encoding)
            (function Authorized_keys l -> Some l | _ -> None)
            (fun l -> Authorized_keys l) ]
  end
end

module Request = struct
  type t =
    | Sign of Sign.Request.t
    | Public_key of Public_key.Request.t
    | Authorized_keys
    | Deterministic_nonce of Deterministic_nonce.Request.t
    | Deterministic_nonce_hash of Deterministic_nonce_hash.Request.t
    | Supports_deterministic_nonces of Supports_deterministic_nonces.Request.t

  let encoding =
    let open Data_encoding in
    def "signer_messages.request"
    @@ union
         [ case
             (Tag 0)
             ~title:"Sign"
             (merge_objs
                (obj1 (req "kind" (constant "sign")))
                Sign.Request.encoding)
             (function Sign req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Sign req);
           case
             (Tag 1)
             ~title:"Public_key"
             (merge_objs
                (obj1 (req "kind" (constant "public_key")))
                Public_key.Request.encoding)
             (function Public_key req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Public_key req);
           case
             (Tag 2)
             ~title:"Authorized_keys"
             (obj1 (req "kind" (constant "authorized_keys")))
             (function Authorized_keys -> Some () | _ -> None)
             (fun () -> Authorized_keys);
           case
             (Tag 3)
             ~title:"Deterministic_nonce"
             (merge_objs
                (obj1 (req "kind" (constant "deterministic_nonce")))
                Deterministic_nonce.Request.encoding)
             (function Deterministic_nonce req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Deterministic_nonce req);
           case
             (Tag 4)
             ~title:"Deterministic_nonce_hash"
             (merge_objs
                (obj1 (req "kind" (constant "deterministic_nonce_hash")))
                Deterministic_nonce_hash.Request.encoding)
             (function
               | Deterministic_nonce_hash req -> Some ((), req) | _ -> None)
             (fun ((), req) -> Deterministic_nonce_hash req);
           case
             (Tag 5)
             ~title:"Supports_deterministic_nonces"
             (merge_objs
                (obj1 (req "kind" (constant "supports_deterministic_nonces")))
                Supports_deterministic_nonces.Request.encoding)
             (function
               | Supports_deterministic_nonces req ->
                   Some ((), req)
               | _ ->
                   None)
             (fun ((), req) -> Supports_deterministic_nonces req) ]
end

let () =
  let open Tezos_data_encoding in
  Data_encoding.Registration.register Request.encoding ;
  Data_encoding.Registration.register Sign.Response.encoding ;
  Data_encoding.Registration.register Deterministic_nonce.Response.encoding ;
  Data_encoding.Registration.register
    Deterministic_nonce_hash.Response.encoding ;
  Data_encoding.Registration.register
    Supports_deterministic_nonces.Response.encoding ;
  Data_encoding.Registration.register Public_key.Response.encoding
src/lib_signer_services/signer_messages.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Authenticated_request.
  Record signature {t : Type} := {
    t := t;
    to_sign : Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
      Stdlib.Bytes.t -> Stdlib.Bytes.t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End Authenticated_request.

Module Tag.
  Record signature := {
    tag : Z;
  }.
End Tag.

(* ❌ Functors are not handled. *)
functor

Module Sign.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Module Response.
    Definition t := Tezos_base__TzPervasives.Signature.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.t :=
      apply
        (let arg := def "signer_messages.sign.response" % string in
        fun eta => arg None None eta)
        (obj1 (req None None "signature" % string Signature.encoding)).
  End Response.
End Sign.

Module Deterministic_nonce.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Module Response.
    Definition t := Bigstring.t.
    
    Definition bigstring
      : Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
      conv Bigstring.to_bytes Bigstring.of_bytes None bytes.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
      apply
        (let arg := def "signer_messages.deterministic_nonce.response" % string
          in
        fun eta => arg None None eta)
        (obj1 (req None None "deterministic_nonce" % string bigstring)).
  End Response.
End Deterministic_nonce.

Module Deterministic_nonce_hash.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Module Response.
    Definition t := Stdlib.Bytes.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding Stdlib.Bytes.t :=
      apply
        (let arg :=
          def "signer_messages.deterministic_nonce_hash.response" % string in
        fun eta => arg None None eta)
        (obj1 (req None None "deterministic_nonce_hash" % string bytes)).
  End Response.
End Deterministic_nonce_hash.

Module Supports_deterministic_nonces.
  Module Request.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.Public_key_hash.t :=
      apply
        (let arg :=
          def "signer_messages.supports_deterministic_nonces.request" % string
          in
        fun eta => arg None None eta)
        (obj1 (req None None "pkh" % string Signature.Public_key_hash.encoding)).
  End Request.
  
  Module Response.
    Definition t := bool.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding bool :=
      apply
        (let arg :=
          def "signer_messages.supports_deterministic_nonces.response" % string
          in
        fun eta => arg None None eta)
        (obj1 (req None None "bool" % string bool)).
  End Response.
End Supports_deterministic_nonces.

Module Public_key.
  Module Request.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key_hash.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.Public_key_hash.t :=
      apply
        (let arg := def "signer_messages.public_key.request" % string in
        fun eta => arg None None eta)
        (obj1 (req None None "pkh" % string Signature.Public_key_hash.encoding)).
  End Request.
  
  Module Response.
    Definition t := Tezos_base__TzPervasives.Signature.Public_key.t.
    
    Definition encoding
      : Tezos_base__TzPervasives.Data_encoding.encoding
        Tezos_base__TzPervasives.Signature.Public_key.t :=
      apply
        (let arg := def "signer_messages.public_key.response" % string in
        fun eta => arg None None eta)
        (obj1 (req None None "pubkey" % string Signature.Public_key.encoding)).
  End Response.
End Public_key.

Module Authorized_keys.
  Module Response.
    Inductive t : Type :=
    | No_authentication : t
    | Authorized_keys :
      (list Tezos_base__TzPervasives.Signature.Public_key_hash.t) -> t.
    
    Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
      union None
        (cons
          (case "No_authentication" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 0)
            (constant "no_authentication_required" % string)
            (fun function_parameter =>
              match function_parameter with
              | No_authentication => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              No_authentication))
          (cons
            (case "Authorized_keys" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 1)
              (list None Signature.Public_key_hash.encoding)
              (fun function_parameter =>
                match function_parameter with
                | Authorized_keys l => Some l
                | _ => None
                end) (fun l => Authorized_keys l)) [])).
  End Response.
End Authorized_keys.

Module Request.
  Inductive t : Type :=
  | Sign : Sign.Request.(Authenticated_request.t) -> t
  | Public_key : Public_key.Request.t -> t
  | Authorized_keys : t
  | Deterministic_nonce : Deterministic_nonce.Request.(Authenticated_request.t)
    -> t
  | Deterministic_nonce_hash :
    Deterministic_nonce_hash.Request.(Authenticated_request.t) -> t
  | Supports_deterministic_nonces : Supports_deterministic_nonces.Request.t -> t.
  
  Definition encoding : Tezos_base__TzPervasives.Data_encoding.encoding t :=
    apply
      (let arg := def "signer_messages.request" % string in
      fun eta => arg None None eta)
      (union None
        (cons
          (case "Sign" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 0)
            (merge_objs
              (obj1 (req None None "kind" % string (constant "sign" % string)))
              Sign.Request.(Authenticated_request.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Sign req => Some (tt, req)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, req) := function_parameter in
              Sign req))
          (cons
            (case "Public_key" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 1)
              (merge_objs
                (obj1
                  (req None None "kind" % string
                    (constant "public_key" % string)))
                Public_key.Request.encoding)
              (fun function_parameter =>
                match function_parameter with
                | Public_key req => Some (tt, req)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, req) := function_parameter in
                Public_key req))
            (cons
              (case "Authorized_keys" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 2)
                (obj1
                  (req None None "kind" % string
                    (constant "authorized_keys" % string)))
                (fun function_parameter =>
                  match function_parameter with
                  | Authorized_keys => Some tt
                  | _ => None
                  end)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Authorized_keys))
              (cons
                (case "Deterministic_nonce" % string None
                  (Tezos_base__TzPervasives.Data_encoding.Tag 3)
                  (merge_objs
                    (obj1
                      (req None None "kind" % string
                        (constant "deterministic_nonce" % string)))
                    Deterministic_nonce.Request.(Authenticated_request.encoding))
                  (fun function_parameter =>
                    match function_parameter with
                    | Deterministic_nonce req => Some (tt, req)
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let '(tt, req) := function_parameter in
                    Deterministic_nonce req))
                (cons
                  (case "Deterministic_nonce_hash" % string None
                    (Tezos_base__TzPervasives.Data_encoding.Tag 4)
                    (merge_objs
                      (obj1
                        (req None None "kind" % string
                          (constant "deterministic_nonce_hash" % string)))
                      Deterministic_nonce_hash.Request.(Authenticated_request.encoding))
                    (fun function_parameter =>
                      match function_parameter with
                      | Deterministic_nonce_hash req => Some (tt, req)
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let '(tt, req) := function_parameter in
                      Deterministic_nonce_hash req))
                  (cons
                    (case "Supports_deterministic_nonces" % string None
                      (Tezos_base__TzPervasives.Data_encoding.Tag 5)
                      (merge_objs
                        (obj1
                          (req None None "kind" % string
                            (constant "supports_deterministic_nonces" % string)))
                        Supports_deterministic_nonces.Request.encoding)
                      (fun function_parameter =>
                        match function_parameter with
                        | Supports_deterministic_nonces req => Some (tt, req)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        let '(tt, req) := function_parameter in
                        Supports_deterministic_nonces req)) []))))))).
End Request.



src/lib_signer_services/signer_services.ml 20 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let query =
  let open RPC_query in
  query (fun signature -> signature)
  |+ opt_field
       ~descr:
         "Must be provided if the signer requires authentication. In this \
          case, it must be the signature of the public key hash and message \
          concatenated, by one of the keys authorized by the signer."
       "authentication"
       Signature.rpc_arg
       (fun signature -> signature)
  |> seal

let sign =
  RPC_service.post_service
    ~description:"Sign a piece of data with a given remote key"
    ~query
    ~input:Data_encoding.bytes
    ~output:Data_encoding.(obj1 (req "signature" Signature.encoding))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let bigstring =
  let open Data_encoding in
  conv Bigstring.to_bytes Bigstring.of_bytes bytes

let deterministic_nonce =
  RPC_service.post_service
    ~description:
      "Obtain some random data generated deterministically from some piece of \
       data with a given remote key"
    ~query
    ~input:Data_encoding.bytes
    ~output:Data_encoding.(obj1 (req "deterministic_nonce" bigstring))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let deterministic_nonce_hash =
  RPC_service.post_service
    ~description:
      "Obtain the hash of some random data generated deterministically from \
       some piece of data with a given remote key"
    ~query
    ~input:Data_encoding.bytes
    ~output:Data_encoding.(obj1 (req "deterministic_nonce_hash" bytes))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let supports_deterministic_nonces =
  RPC_service.get_service
    ~description:
      "Obtain whether the signing service suppports the determinstic nonces \
       functionality"
    ~query:RPC_query.empty
    ~output:Data_encoding.(obj1 (req "supports_deterministic_nonces" bool))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let public_key =
  RPC_service.get_service
    ~description:"Retrieve the public key of a given remote key"
    ~query:RPC_query.empty
    ~output:
      Data_encoding.(obj1 (req "public_key" Signature.Public_key.encoding))
    RPC_path.(root / "keys" /: Signature.Public_key_hash.rpc_arg)

let authorized_keys =
  RPC_service.get_service
    ~description:
      "Retrieve the public keys that can be used to authenticate signing \
       commands.\n\
       If the empty object is returned, the signer has been set to accept \
       unsigned commands."
    ~query:RPC_query.empty
    ~output:
      Data_encoding.(
        obj1 (opt "authorized_keys" (list Signature.Public_key_hash.encoding)))
    RPC_path.(root / "authorized_keys")
src/lib_signer_services/signer_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition query
  : Tezos_rpc.RPC_query.t (option Tezos_base__TzPervasives.Signature.t) :=
  OCaml.Stdlib.reverse_apply
    (op_pipeplus (query (fun signature => signature))
      (opt_field
        (Some
          "Must be provided if the signer requires authentication. In this case, it must be the signature of the public key hash and message concatenated, by one of the keys authorized by the signer."
            % string) "authentication" % string Signature.rpc_arg
        (fun signature => signature))) seal.

Definition sign
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t
    Tezos_base__TzPervasives.Signature.t :=
  RPC_service.post_service
    (Some "Sign a piece of data with a given remote key" % string) query
    Data_encoding.bytes
    (obj1 (req None None "signature" % string Signature.encoding))
    (op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).

Definition bigstring
  : Tezos_base__TzPervasives.Data_encoding.encoding Bigstring.t :=
  conv Bigstring.to_bytes Bigstring.of_bytes None bytes.

Definition deterministic_nonce
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Bigstring.t :=
  RPC_service.post_service
    (Some
      "Obtain some random data generated deterministically from some piece of data with a given remote key"
        % string) query Data_encoding.bytes
    (obj1 (req None None "deterministic_nonce" % string bigstring))
    (op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).

Definition deterministic_nonce_hash
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t)
    (option Tezos_base__TzPervasives.Signature.t) Stdlib.Bytes.t Stdlib.Bytes.t :=
  RPC_service.post_service
    (Some
      "Obtain the hash of some random data generated deterministically from some piece of data with a given remote key"
        % string) query Data_encoding.bytes
    (obj1 (req None None "deterministic_nonce_hash" % string bytes))
    (op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).

Definition supports_deterministic_nonces
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit bool :=
  RPC_service.get_service
    (Some
      "Obtain whether the signing service suppports the determinstic nonces functionality"
        % string) RPC_query.empty
    (obj1 (req None None "supports_deterministic_nonces" % string bool))
    (op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).

Definition public_key
  : Tezos_rpc.RPC_service.service variant unit
    (unit * Tezos_base__TzPervasives.Signature.Public_key_hash.t) unit unit
    Tezos_base__TzPervasives.Signature.Public_key.t :=
  RPC_service.get_service
    (Some "Retrieve the public key of a given remote key" % string)
    RPC_query.empty
    (obj1 (req None None "public_key" % string Signature.Public_key.encoding))
    (op_divcolon (op_div root "keys" % string) Signature.Public_key_hash.rpc_arg).

Definition authorized_keys
  : Tezos_rpc.RPC_service.service variant unit unit unit unit
    (option (list Tezos_base__TzPervasives.Signature.Public_key_hash.t)) :=
  RPC_service.get_service
    (Some
      "Retrieve the public keys that can be used to authenticate signing commands.
If the empty object is returned, the signer has been set to accept unsigned commands."
        % string) RPC_query.empty
    (obj1
      (opt None None "authorized_keys" % string
        (list None Signature.Public_key_hash.encoding)))
    (op_div root "authorized_keys" % string).

src/lib_stdlib/bytes_encodings.ml success
(**************************************************************************)
(*                                                                        *)
(*                                 OCaml                                  *)
(*                                                                        *)
(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
(*                                                                        *)
(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
(*     en Automatique.                                                    *)
(*                                                                        *)
(*   All rights reserved.  This file is distributed under the terms of    *)
(*   the GNU Lesser General Public License version 2.1, with the          *)
(*   special exception on linking described in the file LICENSE.          *)
(*                                                                        *)
(**************************************************************************)

(* this module is a temporary fix waiting for ocaml 4.08 *)

(** {1 Binary encoding/decoding of integers} *)

external get_uint8 : bytes -> int -> int = "%bytes_safe_get"

external get_uint16_ne : bytes -> int -> int = "%caml_bytes_get16"

external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"

external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64"

external set_int8 : bytes -> int -> int -> unit = "%bytes_safe_set"

external set_int16_ne : bytes -> int -> int -> unit = "%caml_bytes_set16"

external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32"

external set_int64_ne : bytes -> int -> int64 -> unit = "%caml_bytes_set64"

external swap16 : int -> int = "%bswap16"

external swap32 : int32 -> int32 = "%bswap_int32"

external swap64 : int64 -> int64 = "%bswap_int64"

let get_int8 b i = (get_uint8 b i lsl (Sys.int_size - 8)) asr (Sys.int_size - 8)

let get_uint16_le b i =
  if Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_uint16_be b i =
  if not Sys.big_endian then swap16 (get_uint16_ne b i) else get_uint16_ne b i

let get_int16_ne b i =
  (get_uint16_ne b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_le b i =
  (get_uint16_le b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int16_be b i =
  (get_uint16_be b i lsl (Sys.int_size - 16)) asr (Sys.int_size - 16)

let get_int32_le b i =
  if Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int32_be b i =
  if not Sys.big_endian then swap32 (get_int32_ne b i) else get_int32_ne b i

let get_int64_le b i =
  if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let get_int64_be b i =
  if not Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i

let set_int16_le b i x =
  if Sys.big_endian then set_int16_ne b i (swap16 x) else set_int16_ne b i x

let set_int16_be b i x =
  if not Sys.big_endian then set_int16_ne b i (swap16 x)
  else set_int16_ne b i x

let set_int32_le b i x =
  if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x

let set_int32_be b i x =
  if not Sys.big_endian then set_int32_ne b i (swap32 x)
  else set_int32_ne b i x

let set_int64_le b i x =
  if Sys.big_endian then set_int64_ne b i (swap64 x) else set_int64_ne b i x

let set_int64_be b i x =
  if not Sys.big_endian then set_int64_ne b i (swap64 x)
  else set_int64_ne b i x

let set_uint8 = set_int8

let set_uint16_ne = set_int16_ne

let set_uint16_be = set_int16_be

let set_uint16_le = set_int16_le

module type S = sig
  (** {1 Binary encoding/decoding of integers} *)

  (** The functions in this section binary encode and decode integers to
      and from byte sequences.
      All following functions raise [Invalid_argument] if the space
      needed at index [i] to decode or encode the integer is not
      available.
      Little-endian (resp. big-endian) encoding means that least
      (resp. most) significant bytes are stored first.  Big-endian is
      also known as network byte order.  Native-endian encoding is
      either little-endian or big-endian depending on {!Sys.big_endian}.
      32-bit and 64-bit integers are represented by the [int32] and
      [int64] types, which can be interpreted either as signed or
      unsigned numbers.
      8-bit and 16-bit integers are represented by the [int] type,
      which has more bits than the binary encoding.  These extra bits
      are handled as follows:
        {ul
          {- Functions that decode signed (resp. unsigned) 8-bit or 16-bit
          integers represented by [int] values sign-extend
          (resp. zero-extend) their result.}
          {- Functions that encode 8-bit or 16-bit integers represented by
          [int] values truncate their input to their least significant
          bytes.}
        }
  *)

  (** [get_uint8 b i] is [b]'s unsigned 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_uint8 : bytes -> int -> int

  (** [get_int8 b i] is [b]'s signed 8-bit integer starting at byte index [i].
      @since 4.08
  *)
  val get_int8 : bytes -> int -> int

  (** [get_uint16_ne b i] is [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_ne : bytes -> int -> int

  (** [get_uint16_be b i] is [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_be : bytes -> int -> int

  (** [get_uint16_le b i] is [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_uint16_le : bytes -> int -> int

  (** [get_int16_ne b i] is [b]'s native-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_ne : bytes -> int -> int

  (** [get_int16_be b i] is [b]'s big-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_be : bytes -> int -> int

  (** [get_int16_le b i] is [b]'s little-endian signed 16-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int16_le : bytes -> int -> int

  (** [get_int32_ne b i] is [b]'s native-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_ne : bytes -> int -> int32

  (** [get_int32_be b i] is [b]'s big-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_be : bytes -> int -> int32

  (** [get_int32_le b i] is [b]'s little-endian 32-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int32_le : bytes -> int -> int32

  (** [get_int64_ne b i] is [b]'s native-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_ne : bytes -> int -> int64

  (** [get_int64_be b i] is [b]'s big-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_be : bytes -> int -> int64

  (** [get_int64_le b i] is [b]'s little-endian 64-bit integer
      starting at byte index [i].
      @since 4.08
  *)
  val get_int64_le : bytes -> int -> int64

  (** [set_uint8 b i v] sets [b]'s unsigned 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_uint8 : bytes -> int -> int -> unit

  (** [set_int8 b i v] sets [b]'s signed 8-bit integer starting at byte index
      [i] to [v].
      @since 4.08
  *)
  val set_int8 : bytes -> int -> int -> unit

  (** [set_uint16_ne b i v] sets [b]'s native-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_ne : bytes -> int -> int -> unit

  (** [set_uint16_be b i v] sets [b]'s big-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_be : bytes -> int -> int -> unit

  (** [set_uint16_le b i v] sets [b]'s little-endian unsigned 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_uint16_le : bytes -> int -> int -> unit

  (** [set_int16_ne b i v] sets [b]'s native-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_ne : bytes -> int -> int -> unit

  (** [set_int16_be b i v] sets [b]'s big-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_be : bytes -> int -> int -> unit

  (** [set_int16_le b i v] sets [b]'s little-endian signed 16-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int16_le : bytes -> int -> int -> unit

  (** [set_int32_ne b i v] sets [b]'s native-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_ne : bytes -> int -> int32 -> unit

  (** [set_int32_be b i v] sets [b]'s big-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_be : bytes -> int -> int32 -> unit

  (** [set_int32_le b i v] sets [b]'s little-endian 32-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int32_le : bytes -> int -> int32 -> unit

  (** [set_int64_ne b i v] sets [b]'s native-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_ne : bytes -> int -> int64 -> unit

  (** [set_int64_be b i v] sets [b]'s big-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_be : bytes -> int -> int64 -> unit

  (** [set_int64_le b i v] sets [b]'s little-endian 64-bit integer
      starting at byte index [i] to [v].
      @since 4.08
  *)
  val set_int64_le : bytes -> int -> int64 -> unit
end
src/lib_stdlib/bytes_encodings.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Parameter get_uint8 : string -> Z -> Z.

Parameter get_uint16_ne : string -> Z -> Z.

Parameter get_int32_ne : string -> Z -> int32.

Parameter get_int64_ne : string -> Z -> int64.

Parameter set_int8 : string -> Z -> Z -> unit.

Parameter set_int16_ne : string -> Z -> Z -> unit.

Parameter set_int32_ne : string -> Z -> int32 -> unit.

Parameter set_int64_ne : string -> Z -> int64 -> unit.

Parameter swap16 : Z -> Z.

Parameter swap32 : int32 -> int32.

Parameter swap64 : int64 -> int64.

Definition get_int8 (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint8 b i) (Z.sub Sys.int_size 8))
    (Z.sub Sys.int_size 8).

Definition get_uint16_le (b : string) (i : Z) : Z :=
  if Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_uint16_be (b : string) (i : Z) : Z :=
  if negb Sys.big_endian then
    swap16 (get_uint16_ne b i)
  else
    get_uint16_ne b i.

Definition get_int16_ne (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_ne b i) (Z.sub Sys.int_size 16))
    (Z.sub Sys.int_size 16).

Definition get_int16_le (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_le b i) (Z.sub Sys.int_size 16))
    (Z.sub Sys.int_size 16).

Definition get_int16_be (b : string) (i : Z) : Z :=
  Stdlib.asr (Z.shiftl (get_uint16_be b i) (Z.sub Sys.int_size 16))
    (Z.sub Sys.int_size 16).

Definition get_int32_le (b : string) (i : Z) : int32 :=
  if Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int32_be (b : string) (i : Z) : int32 :=
  if negb Sys.big_endian then
    swap32 (get_int32_ne b i)
  else
    get_int32_ne b i.

Definition get_int64_le (b : string) (i : Z) : int64 :=
  if Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition get_int64_be (b : string) (i : Z) : int64 :=
  if negb Sys.big_endian then
    swap64 (get_int64_ne b i)
  else
    get_int64_ne b i.

Definition set_int16_le (b : string) (i : Z) (x : Z) : unit :=
  if Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int16_be (b : string) (i : Z) (x : Z) : unit :=
  if negb Sys.big_endian then
    set_int16_ne b i (swap16 x)
  else
    set_int16_ne b i x.

Definition set_int32_le (b : string) (i : Z) (x : int32) : unit :=
  if Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int32_be (b : string) (i : Z) (x : int32) : unit :=
  if negb Sys.big_endian then
    set_int32_ne b i (swap32 x)
  else
    set_int32_ne b i x.

Definition set_int64_le (b : string) (i : Z) (x : int64) : unit :=
  if Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_int64_be (b : string) (i : Z) (x : int64) : unit :=
  if negb Sys.big_endian then
    set_int64_ne b i (swap64 x)
  else
    set_int64_ne b i x.

Definition set_uint8 : string -> Z -> Z -> unit := set_int8.

Definition set_uint16_ne : string -> Z -> Z -> unit := set_int16_ne.

Definition set_uint16_be : string -> Z -> Z -> unit := set_int16_be.

Definition set_uint16_le : string -> Z -> Z -> unit := set_int16_le.

Module S.
  Record signature := {
    get_uint8 : string -> Z -> Z;
    get_int8 : string -> Z -> Z;
    get_uint16_ne : string -> Z -> Z;
    get_uint16_be : string -> Z -> Z;
    get_uint16_le : string -> Z -> Z;
    get_int16_ne : string -> Z -> Z;
    get_int16_be : string -> Z -> Z;
    get_int16_le : string -> Z -> Z;
    get_int32_ne : string -> Z -> int32;
    get_int32_be : string -> Z -> int32;
    get_int32_le : string -> Z -> int32;
    get_int64_ne : string -> Z -> int64;
    get_int64_be : string -> Z -> int64;
    get_int64_le : string -> Z -> int64;
    set_uint8 : string -> Z -> Z -> unit;
    set_int8 : string -> Z -> Z -> unit;
    set_uint16_ne : string -> Z -> Z -> unit;
    set_uint16_be : string -> Z -> Z -> unit;
    set_uint16_le : string -> Z -> Z -> unit;
    set_int16_ne : string -> Z -> Z -> unit;
    set_int16_be : string -> Z -> Z -> unit;
    set_int16_le : string -> Z -> Z -> unit;
    set_int32_ne : string -> Z -> int32 -> unit;
    set_int32_be : string -> Z -> int32 -> unit;
    set_int32_le : string -> Z -> int32 -> unit;
    set_int64_ne : string -> Z -> int64 -> unit;
    set_int64_be : string -> Z -> int64 -> unit;
    set_int64_le : string -> Z -> int64 -> unit;
  }.
End S.

src/lib_stdlib/compare.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type COMPARABLE = sig
  type t

  val compare : t -> t -> int
end

module type S = sig
  type t

  val ( = ) : t -> t -> bool

  val ( <> ) : t -> t -> bool

  val ( < ) : t -> t -> bool

  val ( <= ) : t -> t -> bool

  val ( >= ) : t -> t -> bool

  val ( > ) : t -> t -> bool

  val compare : t -> t -> int

  val equal : t -> t -> bool

  val max : t -> t -> t

  val min : t -> t -> t
end

module Make (P : COMPARABLE) = struct
  include P

  let compare = compare

  let ( = ) a b = compare a b = 0

  let ( <> ) a b = compare a b <> 0

  let ( < ) a b = compare a b < 0

  let ( <= ) a b = compare a b <= 0

  let ( >= ) a b = compare a b >= 0

  let ( > ) a b = compare a b > 0

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module List (P : COMPARABLE) = struct
  type t = P.t list

  let rec compare xs ys =
    match (xs, ys) with
    | ([], []) ->
        0
    | ([], _) ->
        -1
    | (_, []) ->
        1
    | (x :: xs, y :: ys) ->
        let hd = P.compare x y in
        if hd <> 0 then hd else compare xs ys

  let ( = ) xs ys = compare xs ys = 0

  let ( <> ) xs ys = compare xs ys <> 0

  let ( < ) xs ys = compare xs ys < 0

  let ( <= ) xs ys = compare xs ys <= 0

  let ( >= ) xs ys = compare xs ys >= 0

  let ( > ) xs ys = compare xs ys > 0

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module Option (P : COMPARABLE) = struct
  type t = P.t option

  let compare xs ys =
    match (xs, ys) with
    | (None, None) ->
        0
    | (None, _) ->
        -1
    | (_, None) ->
        1
    | (Some x, Some y) ->
        P.compare x y

  let ( = ) xs ys = compare xs ys = 0

  let ( <> ) xs ys = compare xs ys <> 0

  let ( < ) xs ys = compare xs ys < 0

  let ( <= ) xs ys = compare xs ys <= 0

  let ( >= ) xs ys = compare xs ys >= 0

  let ( > ) xs ys = compare xs ys > 0

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module Char = Make (Char)

module Bool = Make (struct
  type t = bool

  let compare = Pervasives.compare
end)

module Int = Make (struct
  type t = int

  let compare = Pervasives.compare
end)

module Int32 = Make (Int32)
module Int64 = Make (Int64)

module MakeUnsigned
    (Int : S) (Z : sig
      val zero : Int.t
    end) =
struct
  type t = Int.t

  let compare va vb =
    Int.(
      if va >= Z.zero then if vb >= Z.zero then compare va vb else -1
      else if vb >= Z.zero then 1
      else compare va vb)

  let ( = ) = (( = ) : t -> t -> bool)

  let ( <> ) = (( <> ) : t -> t -> bool)

  let ( < ) a b =
    Int.(if Z.zero <= a then a < b || b < Z.zero else b < Z.zero && a < b)

  let ( <= ) a b =
    Int.(if Z.zero <= a then a <= b || b < Z.zero else b < Z.zero && a <= b)

  let ( >= ) a b = b <= a

  let ( > ) a b = b < a

  let equal = ( = )

  let max x y = if x >= y then x else y

  let min x y = if x <= y then x else y
end

module Uint32 =
  MakeUnsigned
    (Int32)
    (struct
      let zero = 0l
    end)

module Uint64 =
  MakeUnsigned
    (Int64)
    (struct
      let zero = 0L
    end)

module Float = Make (struct
  type t = float

  let compare = Pervasives.compare
end)

module String = Make (String)
module Z = Make (Z)
src/lib_stdlib/compare.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module COMPARABLE.
  Record signature {t : Type} := {
    t := t;
    compare : t -> t -> Z;
  }.
  Arguments signature : clear implicits.
End COMPARABLE.

Module S.
  Record signature {t : Type} := {
    t := t;
    op_eq : t -> t -> bool;
    op_ltgt : t -> t -> bool;
    op_lt : t -> t -> bool;
    op_lteq : t -> t -> bool;
    op_gteq : t -> t -> bool;
    op_gt : t -> t -> bool;
    compare : t -> t -> Z;
    equal : t -> t -> bool;
    max : t -> t -> t;
    min : t -> t -> t;
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Functors are not handled. *)
functor

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

src/lib_stdlib/hashPtree.ml 28 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Ptree_sig = struct
  module type Value = sig
    type t

    val equal : t -> t -> bool

    val hash : t -> int
  end

  type prefix_order = Equal | Shorter | Longer | Different

  module type Prefix = sig
    type key (* bit sequence *)

    type prefix (* prefix of a bit sequence *)

    type mask (* integer length of a bit sequence *)

    val equal_key : key -> key -> bool

    val equal_mask : mask -> mask -> bool

    val equal_prefix : prefix -> prefix -> bool

    val hash_key : key -> int

    val hash_mask : mask -> int

    val hash_prefix : prefix -> int

    val full_length_mask : mask

    val strictly_shorter_mask : mask -> mask -> bool

    val key_prefix : key -> prefix

    (* Full length prefix *)
    val prefix_key : prefix -> mask -> key

    (* Some key matching the prefix with the given mask *)

    val match_prefix : key:key -> prefix:prefix -> mask:mask -> bool

    (* Does the prefix of length [mask] of [key] equals to [prefix] *)

    val select_bit : prefix:prefix -> mask:mask -> bool

    (* Get the bit of [prefix] at position [mask] assumes that [mask] is
       less than the length of prefix *)

    val common_mask : prefix -> prefix -> mask

    (* The length of the common part of given prefixes *)

    val apply_mask : prefix -> mask -> prefix

    (* Cut the prefix to the given length *)

    val compare_prefix : mask -> prefix -> mask -> prefix -> prefix_order

    (* [compare_prefix m1 p1 m2 p2]:
       let p1' (resp p2') be the sub-prefix of length m1 of p1 (resp m2 of p2)
       The result is
         Equal if p1' equal p2'
         Shorter if p1' is a prefix of p2'
         Longer if p2' is a prefix of p1'
         Different if those not ordered
    *)
  end

  module type S = sig
    type key

    type prefix

    type mask

    type value

    type not_empty = TNot_empty

    type empty = TEmpty

    type _ t = private
      | Leaf : {
          mutable id : int;
          (* Mutable to get a good sharing semantics *)
          mask : mask;
          key : key;
          value : value;
        }
          -> not_empty t
      | Node : {
          mutable id : int;
          mask : mask;
          prefix : prefix;
          true_ : not_empty t;
          false_ : not_empty t;
        }
          -> not_empty t
      | Empty : empty t

    val leaf : key:key -> mask:mask -> value -> not_empty t

    val node :
      prefix:prefix ->
      mask:mask ->
      true_:not_empty t ->
      false_:not_empty t ->
      not_empty t

    val empty : empty t

    val equal : not_empty t -> not_empty t -> bool

    val fast_partial_equal : not_empty t -> not_empty t -> bool

    (* if [fast_partial_equal x y] is true, then [equal x y] is true,
       but if fast_partial_equal returns false, nothing can be
       asserted. *)

    val id : not_empty t -> int
  end
end

module Shared_tree : sig
  module Hash_consed_tree (P : Ptree_sig.Prefix) (V : Ptree_sig.Value) :
    Ptree_sig.S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask

  module Simple_tree
      (P : Ptree_sig.Prefix) (V : sig
        type t

        val equal : t -> t -> bool
      end) :
    Ptree_sig.S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask
end = struct
  open Ptree_sig

  (*
  type int2 = { mutable i1 : int; mutable i2 : int }
  let h2 = { i1 = 0; i2 = 0 }
  let hash2int x1 x2 =
    h2.i1 <- x1; h2.i2 <- x2;
    Hashtbl.hash h2
*)
  type int3 = {mutable i1 : int; mutable i2 : int; mutable i3 : int}

  let h3 = {i1 = 0; i2 = 0; i3 = 0}

  let hash3int x1 x2 x3 =
    h3.i1 <- x1 ;
    h3.i2 <- x2 ;
    h3.i3 <- x3 ;
    Hashtbl.hash h3

  type int4 = {
    mutable i1 : int;
    mutable i2 : int;
    mutable i3 : int;
    mutable i4 : int;
  }

  let h4 = {i1 = 0; i2 = 0; i3 = 0; i4 = 0}

  let hash4int x1 x2 x3 x4 =
    h4.i1 <- x1 ;
    h4.i2 <- x2 ;
    h4.i3 <- x3 ;
    h4.i4 <- x4 ;
    Hashtbl.hash h4

  module Hash_consed_tree (P : Prefix) (V : Value) :
    S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask = struct
    type key = P.key

    type mask = P.mask

    type prefix = P.prefix

    type value = V.t

    type not_empty = TNot_empty

    type empty = TEmpty

    type _ t =
      | Leaf : {
          mutable id : int;
          (* Mutable to get a good sharing semantics *)
          mask : mask;
          key : key;
          value : value;
        }
          -> not_empty t
      | Node : {
          mutable id : int;
          mask : mask;
          prefix : prefix;
          true_ : not_empty t;
          false_ : not_empty t;
        }
          -> not_empty t
      | Empty : empty t

    let id : not_empty t -> int = function
      | Leaf {id; _} ->
          id
      | Node {id; _} ->
          id

    let set_id (n : not_empty t) id =
      match n with Leaf r -> r.id <- id | Node r -> r.id <- id

    (*let mask : not_empty t -> mask = function
      | Leaf { mask ; _ } -> mask
      | Node { mask ; _ } -> mask
    *)
    (* let prefix_table = WeakPrefixTbl.create 20 *)

    module Tree : Hashtbl.HashedType with type t = not_empty t = struct
      type nonrec t = not_empty t

      let equal (t1 : t) (t2 : t) =
        match (t1, t2) with
        | (Leaf _, Node _) | (Node _, Leaf _) ->
            false
        | ( Leaf {key = p1; value = v1; mask = m1; _},
            Leaf {key = p2; value = v2; mask = m2; _} ) ->
            P.equal_key p1 p2 && P.equal_mask m1 m2 && V.equal v1 v2
        | ( Node {prefix = p1; mask = m1; true_ = t1; false_ = f1; _},
            Node {prefix = p2; mask = m2; true_ = t2; false_ = f2; _} ) ->
            (* Assumes that only the head can be unshared: this means
               that structural equality implies physical one on children *)
            P.equal_prefix p1 p2 && P.equal_mask m1 m2 && t1 == t2 && f1 == f2

      let hash : t -> int = function
        | Leaf {key; value; mask; _} ->
            hash3int (P.hash_key key) (V.hash value) (P.hash_mask mask)
        | Node {mask; prefix; true_; false_; _} ->
            hash4int
              (P.hash_mask mask)
              (P.hash_prefix prefix)
              (id true_)
              (id false_)
    end

    module WeakTreeTbl = Weak.Make (Tree)

    (* Or move that to a state ? *)
    let weak_tree_tbl = WeakTreeTbl.create 10

    let next =
      let r = ref 0 in
      fun () -> incr r ; !r

    let leaf ~key ~mask value =
      let l = Leaf {id = 0; key; value; mask} in
      match WeakTreeTbl.find_opt weak_tree_tbl l with
      | None ->
          set_id l (next ()) ;
          WeakTreeTbl.add weak_tree_tbl l ;
          l
      | Some l ->
          l

    let node ~prefix ~mask ~true_ ~false_ =
      let l = Node {id = 0; mask; prefix; true_; false_} in
      match WeakTreeTbl.find_opt weak_tree_tbl l with
      | None ->
          set_id l (next ()) ;
          WeakTreeTbl.add weak_tree_tbl l ;
          l
      | Some l ->
          l

    let empty = Empty

    let equal (x : not_empty t) (y : not_empty t) = x == y

    let fast_partial_equal = equal
  end
  [@@inline]

  module Simple_tree
      (P : Ptree_sig.Prefix) (V : sig
        type t

        val equal : t -> t -> bool
      end) :
    S
      with type value = V.t
       and type key = P.key
       and type prefix = P.prefix
       and type mask = P.mask = struct
    type key = P.key

    type mask = P.mask

    type prefix = P.prefix

    type value = V.t

    type not_empty = TNot_empty

    type empty = TEmpty

    type _ t =
      | Leaf : {
          mutable id : int;
          (* Mutable to get a good sharing semantics *)
          mask : mask;
          key : key;
          value : value;
        }
          -> not_empty t
      | Node : {
          mutable id : int;
          mask : mask;
          prefix : prefix;
          true_ : not_empty t;
          false_ : not_empty t;
        }
          -> not_empty t
      | Empty : empty t

    let id : not_empty t -> int = function
      | Leaf {id; _} ->
          id
      | Node {id; _} ->
          id

    (*let set_id (n : not_empty t) id = match n with
      | Leaf r -> r.id <- id
      | Node r -> r.id <- id

      let mask : not_empty t -> mask = function
      | Leaf { mask ; _ } -> mask
      | Node { mask ; _ } -> mask
    *)
    let leaf ~key ~mask value = Leaf {id = 0; key; value; mask}

    let node ~prefix ~mask ~true_ ~false_ =
      Node {id = 0; mask; prefix; true_; false_}

    let empty = Empty

    let rec equal_not_empty (x : not_empty t) (y : not_empty t) =
      x == y
      ||
      match (x, y) with
      | (Leaf l1, Leaf l2) ->
          P.equal_key l1.key l2.key && V.equal l1.value l2.value
      | (Node n1, Node n2) ->
          P.equal_prefix n1.prefix n2.prefix
          && P.equal_mask n1.mask n2.mask
          && equal_not_empty n1.true_ n2.true_
          && equal_not_empty n1.false_ n2.false_
      | (Node _, Leaf _) | (Leaf _, Node _) ->
          false

    let equal : type a b. a t -> b t -> bool =
     fun x y ->
      match (x, y) with
      | (Empty, Empty) ->
          true
      | (Leaf _, Leaf _) ->
          equal_not_empty x y
      | (Node _, Node _) ->
          equal_not_empty x y
      | (_, _) ->
          false

    let fast_partial_equal (x : not_empty t) (y : not_empty t) = x == y
  end
  [@@inline]
end

module type Value = sig
  type t

  val equal : t -> t -> bool

  val hash : t -> int
end

module type Bits = sig
  type t

  val lnot : t -> t

  val ( land ) : t -> t -> t

  val ( lxor ) : t -> t -> t

  val ( lor ) : t -> t -> t

  val ( lsr ) : t -> int -> t

  val ( lsl ) : t -> int -> t

  val pred : t -> t

  val less_than : t -> t -> bool

  val highest_bit : t -> t

  val equal : t -> t -> bool

  val hash : t -> int

  val zero : t

  val one : t

  val size : int
end

module type Size = sig
  val size : int
end

module Bits (S : Size) = struct
  type t = Z.t

  let size = S.size

  let higher_bit = Z.shift_left Z.one size

  let mask = Z.pred higher_bit

  let mark n = Z.logor higher_bit n

  let unmark n = Z.logxor higher_bit n

  let one = mark Z.one

  let zero = higher_bit

  let hash = Z.hash

  let equal = Z.equal

  let less_than = Z.lt

  let highest_bit_unmarked n =
    if Z.equal Z.zero n then Z.zero
    else Z.(Z.one lsl Pervasives.pred (numbits n))

  let highest_bit n = mark (highest_bit_unmarked (unmark n))

  let lnot x = Z.logor (Z.lognot x) higher_bit

  let ( land ) = Z.logand

  let ( lxor ) a b = Z.logor (Z.logxor a b) higher_bit

  let ( lor ) = Z.logor

  let ( lsr ) a n =
    Z.logor (Z.shift_right_trunc (Z.logxor a higher_bit) n) higher_bit

  let ( lsl ) a n = Z.logor (Z.logand (Z.shift_left a n) mask) higher_bit

  let pred = Z.pred

  let of_z n = mark n

  let to_z n = unmark n
end

module BE_gen_prefix (Bits : Bits) :
  Ptree_sig.Prefix
    with type key = Bits.t
     and type prefix = Bits.t
     and type mask = Bits.t = struct
  type key = Bits.t

  type mask = Bits.t (* Only a single bit set *)

  type prefix = Bits.t

  let equal_key = Bits.equal

  let equal_mask = Bits.equal

  let equal_prefix = Bits.equal

  let hash_key x = Bits.hash x

  let hash_mask x = Bits.hash x

  let hash_prefix x = Bits.hash x

  open Bits

  let full_length_mask = Bits.one

  let strictly_shorter_mask (m1 : mask) m2 = Bits.less_than m2 m1

  let select_bit ~prefix ~mask = not (Bits.equal (prefix land mask) Bits.zero)

  let apply_mask prefix mask = prefix land lnot (pred mask)

  let match_prefix ~key ~prefix ~mask =
    equal_prefix (apply_mask key mask) prefix

  let common_mask p0 p1 = Bits.highest_bit (* [@inlined] *) (p0 lxor p1)

  let key_prefix x = x

  let prefix_key p _m = p

  let smaller_set_mask m1 m2 = lnot (pred m1) land lnot (pred m2)

  let compare_prefix m1 p1 m2 p2 =
    let min_mask = smaller_set_mask m1 m2 in
    let applied_p1 = p1 land min_mask in
    let applied_p2 = p2 land min_mask in
    if applied_p1 = applied_p2 then
      if m1 > m2 then Ptree_sig.Shorter
      else if m1 < m2 then Ptree_sig.Longer
      else Ptree_sig.Equal
    else Ptree_sig.Different
end

module LE_prefix :
  Ptree_sig.Prefix
    with type key = int
     and type prefix = int
     and type mask = int = struct
  type key = int

  type mask = int (* Only a single bit set *)

  type prefix = int

  let equal_key = ( == )

  let equal_mask = ( == )

  let equal_prefix = ( == )

  let hash_key x = x

  let hash_mask x = x

  let hash_prefix x = x

  let full_length_mask = -1 lxor (-1 lsr 1)

  let strictly_shorter_mask (m1 : mask) m2 = m1 < m2

  let select_bit ~prefix ~mask = prefix land mask != 0

  let apply_mask prefix mask = prefix land (mask - 1)

  let match_prefix ~key ~prefix ~mask = apply_mask key mask == prefix

  let lowest_bit x = x land -x

  let common_mask p0 p1 = lowest_bit (p0 lxor p1)

  let key_prefix x = x

  let prefix_key p _m = p

  let smaller_set_mask m1 m2 = (m1 - 1) land (m2 - 1)

  let compare_prefix m1 p1 m2 p2 =
    let min_mask = smaller_set_mask m1 m2 in
    let applied_p1 = p1 land min_mask in
    let applied_p2 = p2 land min_mask in
    if applied_p1 = applied_p2 then
      if m1 < m2 then Ptree_sig.Shorter
      else if m1 > m2 then Ptree_sig.Longer
      else Ptree_sig.Equal
    else Ptree_sig.Different
end

module BE_prefix :
  Ptree_sig.Prefix
    with type key = int
     and type prefix = int
     and type mask = int = struct
  type key = int

  type mask = int (* Only a single bit set *)

  type prefix = int

  let equal_key = ( == )

  let equal_mask = ( == )

  let equal_prefix = ( == )

  let hash_key x = x

  let hash_mask x = x

  let hash_prefix x = x

  let full_length_mask = 1

  let strictly_shorter_mask (m1 : mask) m2 = m1 > m2

  let select_bit ~prefix ~mask = prefix land mask != 0

  module Nativeint_infix = struct
    let ( lor ) = Nativeint.logor

    (*let (lsl) = Nativeint.shift_left*)
    let ( lsr ) = Nativeint.shift_right_logical

    (*let (asr) = Nativeint.shift_right*)
    let ( land ) = Nativeint.logand

    let lnot = Nativeint.lognot

    let ( lxor ) = Nativeint.logxor

    let ( - ) = Nativeint.sub
  end

  let apply_mask prefix mask =
    let open Nativeint_infix in
    let prefix = Nativeint.of_int prefix in
    let mask = Nativeint.of_int mask in
    Nativeint.to_int (prefix land lnot (mask - 1n))

  let match_prefix ~key ~prefix ~mask = apply_mask key mask == prefix

  let highest_bit x =
    Nativeint_infix.(
      let x = x lor (x lsr 1) in
      let x = x lor (x lsr 2) in
      let x = x lor (x lsr 4) in
      let x = x lor (x lsr 8) in
      let x = x lor (x lsr 16) in
      let x = if Sys.word_size > 32 then x lor (x lsr 32) else x in
      Nativeint.to_int (x - (x lsr 1)))

  let common_mask p0 p1 =
    let open Nativeint_infix in
    let p0 = Nativeint.of_int p0 in
    let p1 = Nativeint.of_int p1 in
    highest_bit (p0 lxor p1)

  let key_prefix x = x

  let prefix_key p _m = p

  let smaller_set_mask m1 m2 =
    let open Nativeint_infix in
    lnot (m1 - 1n) land lnot (m2 - 1n)

  let compare_prefix m1 p1 m2 p2 =
    let open Nativeint_infix in
    let m1 = Nativeint.of_int m1 in
    let m2 = Nativeint.of_int m2 in
    let p1 = Nativeint.of_int p1 in
    let p2 = Nativeint.of_int p2 in
    let min_mask = smaller_set_mask m1 m2 in
    let applied_p1 = p1 land min_mask in
    let applied_p2 = p2 land min_mask in
    if applied_p1 = applied_p2 then
      if m1 > m2 then Ptree_sig.Shorter
      else if m1 < m2 then Ptree_sig.Longer
      else Ptree_sig.Equal
    else Ptree_sig.Different
end

module Make (P : Ptree_sig.Prefix) (V : Value) = struct
  module T = Shared_tree.Hash_consed_tree (P) (V)

  type t = E : 'a T.t -> t [@@ocaml.unboxed]

  type key = T.key

  type value = T.value

  type mask = T.mask

  (*
  let (=) = `Do_not_use_polymorphic_equality
  let (<=) = `Do_not_use_polymorphic_comparison
  let (>=) = `Do_not_use_polymorphic_comparison
  let (<) = `Do_not_use_polymorphic_comparison
  let (>) = `Do_not_use_polymorphic_comparison
  let compare = `Do_not_use_polymorphic_comparison
   *)
  let equal (E t1) (E t2) =
    match (t1, t2) with
    | (T.Empty, T.Empty) ->
        true
    | (T.Empty, T.Leaf _) ->
        false
    | (T.Empty, T.Node _) ->
        false
    | (T.Leaf _, T.Empty) ->
        false
    | (T.Node _, T.Empty) ->
        false
    | (T.Node _, T.Node _) ->
        T.equal t1 t2
    | (T.Node _, T.Leaf _) ->
        T.equal t1 t2
    | (T.Leaf _, T.Node _) ->
        T.equal t1 t2
    | (T.Leaf _, T.Leaf _) ->
        T.equal t1 t2

  let select_key_bit k m = P.select_bit ~prefix:(P.key_prefix k) ~mask:m

  let matching_key k1 k2 mask =
    let p1 = P.apply_mask (P.key_prefix k1) mask in
    let p2 = P.apply_mask (P.key_prefix k2) mask in
    P.equal_prefix p1 p2

  let rec mem : type k. key -> k T.t -> bool =
   fun k -> function
    | T.Empty ->
        false
    | T.Leaf {key; mask; _} ->
        matching_key key k mask
    | T.Node {prefix = _; mask; true_; false_; _} ->
        mem k (if select_key_bit k mask then true_ else false_)

  let rec mem_exact : type k. key -> k T.t -> bool =
   fun k -> function
    | T.Empty ->
        false
    | T.Leaf {key; mask; _} ->
        P.equal_key k key && P.equal_mask mask P.full_length_mask
    | T.Node {prefix = _; mask; true_; false_; _} ->
        mem_exact k (if select_key_bit k mask then true_ else false_)

  let rec find_ne k (t : T.not_empty T.t) =
    match t with
    | T.Leaf {key; value; mask; _} ->
        if matching_key key k mask then Some value else None
    | T.Node {prefix = _; mask; true_; false_; _} ->
        find_ne k (if select_key_bit k mask then true_ else false_)

  let find : type k. key -> k T.t -> value option =
   fun k -> function
    | T.Empty ->
        None
    | T.Leaf _ as t ->
        find_ne k t
    | T.Node _ as t ->
        find_ne k t

  let singleton ~key ~value ~mask = T.leaf ~key value ~mask

  let join ~mask p0 t0 p1 t1 =
    (* assumes p0 <> p1 *)
    let c_mask = P.common_mask p0 p1 in
    let mask = if P.strictly_shorter_mask c_mask mask then c_mask else mask in
    let prefix = P.apply_mask p1 mask in
    let (true_, false_) =
      if P.select_bit ~prefix:p0 ~mask then (t0, t1) else (t1, t0)
    in
    T.node ~prefix ~mask ~true_ ~false_

  let rebuild_ne_branch node prefix mask ~node_true ~node_false ~true_ ~false_
      =
    if
      T.fast_partial_equal node_true true_
      && T.fast_partial_equal node_false false_
    then node
    else T.node ~prefix ~mask ~true_ ~false_

  let rec add_ne combine ~key ~value ?(mask = P.full_length_mask) t =
    match t with
    | T.Leaf leaf ->
        if
          P.equal_key key leaf.key && P.equal_mask leaf.mask P.full_length_mask
        then
          if value == leaf.value then t
          else T.leaf ~key (combine value leaf.value) ~mask
        else if
          P.strictly_shorter_mask leaf.mask mask
          && P.match_prefix
               ~key
               ~prefix:(P.key_prefix leaf.key)
               ~mask:leaf.mask
        then (* The previous leaf shadows the new one: no modification *)
          t
        else if
          P.strictly_shorter_mask mask leaf.mask
          && P.match_prefix ~key:leaf.key ~prefix:(P.key_prefix key) ~mask
        then
          (* The new leaf shadows the previous one: replace *)
          T.leaf ~key (combine value leaf.value) ~mask
        else
          join
            ~mask
            (P.key_prefix key)
            (T.leaf ~key value ~mask)
            (P.key_prefix leaf.key)
            t
    | T.Node node ->
        if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (add_ne combine ~key ~value ~mask node.true_, node.false_)
            else (node.true_, add_ne combine ~key ~value ~mask node.false_)
          in
          rebuild_ne_branch
            t
            node.prefix
            node.mask
            ~node_false:node.false_
            ~node_true:node.true_
            ~true_
            ~false_
        else
          join ~mask (P.key_prefix key) (T.leaf ~key value ~mask) node.prefix t

  let add :
      type k.
      (value -> value -> value) ->
      key:key ->
      value:value ->
      ?mask:P.mask ->
      k T.t ->
      T.not_empty T.t =
   fun combine ~key ~value ?(mask = P.full_length_mask) -> function
    | T.Empty ->
        singleton ~key ~value ~mask
    (* Should be merged by matcher *)
    | T.Leaf _ as t ->
        add_ne combine ~key ~value ~mask t
    | T.Node _ as t ->
        add_ne combine ~key ~value ~mask t

  let empty = E T.empty

  let rebuild_branch node prefix mask ~node_true ~node_false ~true_:(E true_)
      ~false_:(E false_) =
    match (true_, false_) with
    | (T.Empty, T.Empty) ->
        empty
    | (T.Empty, t) ->
        E t
    | (t, T.Empty) ->
        E t
    | ((T.Leaf _ as true_), (T.Leaf _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)
    | ((T.Leaf _ as true_), (T.Node _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)
    | ((T.Node _ as true_), (T.Leaf _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)
    | ((T.Node _ as true_), (T.Node _ as false_)) ->
        E
          (rebuild_ne_branch
             node
             prefix
             mask
             ~node_true
             ~node_false
             ~true_
             ~false_)

  let rec remove_ne : key -> T.not_empty T.t -> t =
   fun key t ->
    match t with
    | T.Leaf leaf ->
        if matching_key leaf.key key leaf.mask then E T.empty else E t
    | T.Node node ->
        if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (remove_ne key node.true_, E node.false_)
            else (E node.true_, remove_ne key node.false_)
          in
          rebuild_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_
        else E t

  let remove key (E t) =
    match t with
    | T.Empty ->
        empty
    | T.Leaf _ as t ->
        remove_ne key t
    | T.Node _ as t ->
        remove_ne key t

  let rec remove_prefix_ne : key -> mask -> T.not_empty T.t -> t =
   fun key mask t ->
    match t with
    | T.Leaf leaf ->
        if matching_key key leaf.key mask then E T.empty else E t
    | T.Node node -> (
      match P.compare_prefix mask (P.key_prefix key) node.mask node.prefix with
      | Different ->
          E t
      | Equal ->
          E T.empty
      | Shorter ->
          E T.empty
      | Longer ->
          let (true_, false_) =
            if select_key_bit key node.mask then
              (remove_prefix_ne key mask node.true_, E node.false_)
            else (E node.true_, remove_prefix_ne key mask node.false_)
          in
          rebuild_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_ )

  let remove_prefix key mask (E t) =
    match t with
    | T.Empty ->
        empty
    | T.Leaf _ as t ->
        remove_prefix_ne key mask t
    | T.Node _ as t ->
        remove_prefix_ne key mask t

  let rec remove_ne_exact : key -> T.not_empty T.t -> t =
   fun key t ->
    match t with
    | T.Leaf leaf ->
        if
          P.equal_key leaf.key key && P.equal_mask leaf.mask P.full_length_mask
        then E T.empty
        else E t
    | T.Node node ->
        if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (remove_ne_exact key node.true_, E node.false_)
            else (E node.true_, remove_ne_exact key node.false_)
          in
          rebuild_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_
        else E t

  let remove_exact key (E t) =
    match t with
    | T.Empty ->
        empty
    | T.Leaf _ as t ->
        remove_ne_exact key t
    | T.Node _ as t ->
        remove_ne_exact key t

  let rec replace_subtree_ne ~key ~id value t =
    match t with
    | T.Leaf leaf ->
        if leaf.id == id then T.leaf ~key:leaf.key ~mask:leaf.mask value else t
    | T.Node node ->
        if node.id == id then
          T.leaf
            ~key:(P.prefix_key node.prefix node.mask)
            ~mask:node.mask
            value
        else if P.match_prefix ~key ~prefix:node.prefix ~mask:node.mask then
          let (true_, false_) =
            if select_key_bit key node.mask then
              (replace_subtree_ne ~key ~id value node.true_, node.false_)
            else (node.true_, replace_subtree_ne ~key ~id value node.false_)
          in
          rebuild_ne_branch
            t
            node.prefix
            node.mask
            ~node_true:node.true_
            ~node_false:node.false_
            ~true_
            ~false_
        else t

  let replace_subtree ~replaced:(E replaced) value t =
    let replace_subtree_aux ~key ~id value (E t) =
      match t with
      | T.Empty ->
          empty
      | T.Leaf _ as t ->
          E (replace_subtree_ne ~key ~id value t)
      | T.Node _ as t ->
          E (replace_subtree_ne ~key ~id value t)
    in
    match replaced with
    | T.Empty ->
        t
    | T.Leaf leaf ->
        replace_subtree_aux ~key:leaf.key ~id:leaf.id value t
    | T.Node node ->
        replace_subtree_aux
          ~key:(P.prefix_key node.prefix node.mask)
          ~id:node.id
          value
          t

  let rec fold_ne :
      (key -> mask -> value -> 'a -> 'a) -> T.not_empty T.t -> 'a -> 'a =
   fun f t acc ->
    match t with
    | T.Leaf {key; mask; value; _} ->
        f key mask value acc
    | T.Node node ->
        let acc = fold_ne f node.false_ acc in
        fold_ne f node.true_ acc

  let fold f (E t) acc =
    match t with
    | T.Empty ->
        acc
    | T.Leaf _ as t ->
        fold_ne f t acc
    | T.Node _ as t ->
        fold_ne f t acc

  module T_id = struct
    type t = T.not_empty T.t

    let hash = T.id

    let equal t1 t2 = T.id t1 == T.id t2
  end

  module Map_cache = Ephemeron.K1.Make (T_id)

  module type Map_Reduce = sig
    type result

    val default : result

    val map : t -> key -> T.value -> result

    val reduce : t -> result -> result -> result
  end

  module Map_Reduce (M : Map_Reduce) = struct
    let cache : M.result Map_cache.t = Map_cache.create 10

    let rec map_reduce_ne t =
      match Map_cache.find_opt cache t with
      | Some v ->
          v
      | None ->
          let v =
            match t with
            | T.Leaf leaf ->
                M.map (E t) leaf.key leaf.value
            | T.Node node ->
                let v_true = map_reduce_ne node.true_ in
                let v_false = map_reduce_ne node.false_ in
                M.reduce (E t) v_true v_false
          in
          Map_cache.add cache t v ; v

    let run (E t) =
      match t with
      | T.Empty ->
          M.default
      | T.Leaf _ as t ->
          map_reduce_ne t
      | T.Node _ as t ->
          map_reduce_ne t

    let rec filter_ne f t =
      let result = map_reduce_ne t in
      if f result then E t
      else
        match t with
        | T.Leaf _ ->
            empty
        | T.Node node ->
            let true_ = filter_ne f node.true_ in
            let false_ = filter_ne f node.false_ in
            rebuild_branch
              t
              node.prefix
              node.mask
              ~node_true:node.true_
              ~node_false:node.false_
              ~true_
              ~false_

    let filter f (E t) =
      match t with
      | T.Empty ->
          empty
      | T.Leaf _ as t ->
          filter_ne f t
      | T.Node _ as t ->
          filter_ne f t
  end

  (* Packing in the existential *)

  let mem key (E t) = mem key t

  let mem_exact key (E t) = mem_exact key t

  let find key (E t) = find key t

  let singleton ~key ~value ~mask = E (singleton ~key ~value ~mask)

  let add combine ~key ~value ?mask (E t) = E (add combine ~key ~value ?mask t)
end
[@@inline]

module type S = sig
  type key

  type value

  type mask

  type t

  val equal : t -> t -> bool

  val empty : t

  val singleton : key:key -> value:value -> mask:mask -> t

  val add :
    (value -> value -> value) -> key:key -> value:value -> ?mask:mask -> t -> t

  val remove : key -> t -> t

  val remove_exact : key -> t -> t

  val remove_prefix : key -> mask -> t -> t

  val mem : key -> t -> bool

  val mem_exact : key -> t -> bool

  val find : key -> t -> value option

  val replace_subtree : replaced:t -> value -> t -> t

  val fold : (key -> mask -> value -> 'a -> 'a) -> t -> 'a -> 'a

  module type Map_Reduce = sig
    type result

    val default : result

    val map : t -> key -> value -> result

    val reduce : t -> result -> result -> result
  end

  module Map_Reduce (M : Map_Reduce) : sig
    val run : t -> M.result

    val filter : (M.result -> bool) -> t -> t
  end
end

module Make_LE (V : Value) = Make (LE_prefix) (V)
module Make_BE (V : Value) = Make (BE_prefix) (V)
module Make_BE_gen (V : Value) (B : Bits) = Make (BE_gen_prefix (B)) (V)
module Make_BE_sized (V : Value) (S : Size) =
  Make (BE_gen_prefix (Bits (S))) (V)
src/lib_stdlib/hashPtree.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Ptree_sig.
  Module Value.
    Record signature {t : Type} := {
      t := t;
      equal : t -> t -> bool;
      hash : t -> Z;
    }.
    Arguments signature : clear implicits.
  End Value.
  
  Inductive prefix_order : Type :=
  | Equal : prefix_order
  | Shorter : prefix_order
  | Longer : prefix_order
  | Different : prefix_order.
  
  Module Prefix.
    Record signature {key prefix mask : Type} := {
      key := key;
      prefix := prefix;
      mask := mask;
      equal_key : key -> key -> bool;
      equal_mask : mask -> mask -> bool;
      equal_prefix : prefix -> prefix -> bool;
      hash_key : key -> Z;
      hash_mask : mask -> Z;
      hash_prefix : prefix -> Z;
      full_length_mask : mask;
      strictly_shorter_mask : mask -> mask -> bool;
      key_prefix : key -> prefix;
      prefix_key : prefix -> mask -> key;
      match_prefix : key -> prefix -> mask -> bool;
      select_bit : prefix -> mask -> bool;
      common_mask : prefix -> prefix -> mask;
      apply_mask : prefix -> mask -> prefix;
      compare_prefix : mask -> prefix -> mask -> prefix -> prefix_order;
    }.
    Arguments signature : clear implicits.
  End Prefix.
  
  Module S.
    Record signature {key prefix mask value not_empty empty t : Type} := {
      key := key;
      prefix := prefix;
      mask := mask;
      value := value;
      not_empty := not_empty;
      empty := empty;
      polymorphic_abstract_type;
      leaf : key -> mask -> value -> t not_empty;
      node : prefix -> mask -> (t not_empty) -> (t not_empty) -> t not_empty;
      empty : t empty;
      equal : (t not_empty) -> (t not_empty) -> bool;
      fast_partial_equal : (t not_empty) -> (t not_empty) -> bool;
      id : (t not_empty) -> Z;
    }.
    Arguments signature : clear implicits.
  End S.
End Ptree_sig.

Module Shared_tree.
  Import Ptree_sig.
  
  Record int3 := {
    i1 : Z;
    i2 : Z;
    i3 : Z }.
  
  Definition h3 : int3 := {| i1 := 0; i2 := 0; i3 := 0 |}.
  
  Definition hash3int (x1 : Z) (x2 : Z) (x3 : Z) : Z :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h3 "i1" % string x1 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h3 "i2" % string x2 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h3 "i3" % string x3 in
    Hashtbl.hash h3.
  
  Record int4 := {
    i1 : Z;
    i2 : Z;
    i3 : Z;
    i4 : Z }.
  
  Definition h4 : int4 := {| i1 := 0; i2 := 0; i3 := 0; i4 := 0 |}.
  
  Definition hash4int (x1 : Z) (x2 : Z) (x3 : Z) (x4 : Z) : Z :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h4 "i1" % string x1 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h4 "i2" % string x2 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h4 "i3" % string x3 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field h4 "i4" % string x4 in
    Hashtbl.hash h4.
  
  (* ❌ Functors are not handled. *)
  functor
  
  (* ❌ Functors are not handled. *)
  functor
End Shared_tree.

Module Value.
  Record signature {t : Type} := {
    t := t;
    equal : t -> t -> bool;
    hash : t -> Z;
  }.
  Arguments signature : clear implicits.
End Value.

Module Bits.
  Record signature {t : Type} := {
    t := t;
    lnot : t -> t;
    land : t -> t -> t;
    lxor : t -> t -> t;
    lor : t -> t -> t;
    lsr : t -> Z -> t;
    lsl : t -> Z -> t;
    pred : t -> t;
    less_than : t -> t -> bool;
    highest_bit : t -> t;
    equal : t -> t -> bool;
    hash : t -> Z;
    zero : t;
    one : t;
    size : Z;
  }.
  Arguments signature : clear implicits.
End Bits.

Module Size.
  Record signature := {
    size : Z;
  }.
End Size.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

Module LE_prefix.
  Definition key := Z.
  
  Definition mask := Z.
  
  Definition prefix := Z.
  
  Definition equal_key {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
  
  Definition equal_mask {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
  
  Definition equal_prefix {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
  
  Definition hash_key {A : Type} (x : A) : A := x.
  
  Definition hash_mask {A : Type} (x : A) : A := x.
  
  Definition hash_prefix {A : Type} (x : A) : A := x.
  
  Definition full_length_mask : Z := Z.lxor (-1) (Z.shiftr (-1) 1).
  
  Definition strictly_shorter_mask (m1 : mask) (m2 : mask) : bool :=
    OCaml.Stdlib.lt m1 m2.
  
  Definition select_bit (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_exclamationeq (Z.land prefix mask) 0.
  
  Definition apply_mask (prefix : Z) (mask : Z) : Z :=
    Z.land prefix (Z.sub mask 1).
  
  Definition match_prefix (key : Z) (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_eqeq (apply_mask key mask) prefix.
  
  Definition lowest_bit (x : Z) : Z := Z.land x (Z.opp x).
  
  Definition common_mask (p0 : Z) (p1 : Z) : Z := lowest_bit (Z.lxor p0 p1).
  
  Definition key_prefix {A : Type} (x : A) : A := x.
  
  Definition prefix_key {A B : Type} (p : A) (_m : B) : A := p.
  
  Definition smaller_set_mask (m1 : Z) (m2 : Z) : Z :=
    Z.land (Z.sub m1 1) (Z.sub m2 1).
  
  Definition compare_prefix (m1 : Z) (p1 : Z) (m2 : Z) (p2 : Z)
    : Ptree_sig.prefix_order :=
    let min_mask := smaller_set_mask m1 m2 in
    let applied_p1 := Z.land p1 min_mask in
    let applied_p2 := Z.land p2 min_mask in
    if equiv_decb applied_p1 applied_p2 then
      if OCaml.Stdlib.lt m1 m2 then
        Ptree_sig.Shorter
      else
        if OCaml.Stdlib.gt m1 m2 then
          Ptree_sig.Longer
        else
          Ptree_sig.Equal
    else
      Ptree_sig.Different.
End LE_prefix.

Module BE_prefix.
  Definition key := Z.
  
  Definition mask := Z.
  
  Definition prefix := Z.
  
  Definition equal_key {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
  
  Definition equal_mask {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
  
  Definition equal_prefix {A : Type} : A -> A -> bool := Stdlib.op_eqeq.
  
  Definition hash_key {A : Type} (x : A) : A := x.
  
  Definition hash_mask {A : Type} (x : A) : A := x.
  
  Definition hash_prefix {A : Type} (x : A) : A := x.
  
  Definition full_length_mask : Z := 1.
  
  Definition strictly_shorter_mask (m1 : mask) (m2 : mask) : bool :=
    OCaml.Stdlib.gt m1 m2.
  
  Definition select_bit (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_exclamationeq (Z.land prefix mask) 0.
  
  Module Nativeint_infix.
    Definition lor : nativeint -> nativeint -> nativeint := Nativeint.logor.
    
    Definition lsr : nativeint -> Z -> nativeint :=
      Nativeint.shift_right_logical.
    
    Definition land : nativeint -> nativeint -> nativeint := Nativeint.logand.
    
    Definition lnot : nativeint -> nativeint := Nativeint.lognot.
    
    Definition lxor : nativeint -> nativeint -> nativeint := Nativeint.logxor.
    
    Definition op_minus : nativeint -> nativeint -> nativeint := Nativeint.sub.
  End Nativeint_infix.
  
  Definition apply_mask (prefix : Z) (mask : Z) : Z :=
    let prefix := Nativeint.of_int prefix in
    let mask := Nativeint.of_int mask in
    Nativeint.to_int
      (land prefix
        (lnot
          (op_minus mask
            (* ❌ Constant of type nativeint is converted to int *)
            1))).
  
  Definition match_prefix (key : Z) (prefix : Z) (mask : Z) : bool :=
    Stdlib.op_eqeq (apply_mask key mask) prefix.
  
  Definition highest_bit (x : nativeint) : Z :=
    let x := lor x (lsr x 1) in
    let x := lor x (lsr x 2) in
    let x := lor x (lsr x 4) in
    let x := lor x (lsr x 8) in
    let x := lor x (lsr x 16) in
    let x :=
      if OCaml.Stdlib.gt Sys.word_size 32 then
        lor x (lsr x 32)
      else
        x in
    Nativeint.to_int (op_minus x (lsr x 1)).
  
  Definition common_mask (p0 : Z) (p1 : Z) : Z :=
    let p0 := Nativeint.of_int p0 in
    let p1 := Nativeint.of_int p1 in
    highest_bit (lxor p0 p1).
  
  Definition key_prefix {A : Type} (x : A) : A := x.
  
  Definition prefix_key {A B : Type} (p : A) (_m : B) : A := p.
  
  Definition smaller_set_mask (m1 : nativeint) (m2 : nativeint) : nativeint :=
    land
      (lnot
        (op_minus m1
          (* ❌ Constant of type nativeint is converted to int *)
          1))
      (lnot
        (op_minus m2
          (* ❌ Constant of type nativeint is converted to int *)
          1)).
  
  Definition compare_prefix (m1 : Z) (p1 : Z) (m2 : Z) (p2 : Z)
    : Ptree_sig.prefix_order :=
    let m1 := Nativeint.of_int m1 in
    let m2 := Nativeint.of_int m2 in
    let p1 := Nativeint.of_int p1 in
    let p2 := Nativeint.of_int p2 in
    let min_mask := smaller_set_mask m1 m2 in
    let applied_p1 := land p1 min_mask in
    let applied_p2 := land p2 min_mask in
    if equiv_decb applied_p1 applied_p2 then
      if OCaml.Stdlib.gt m1 m2 then
        Ptree_sig.Shorter
      else
        if OCaml.Stdlib.lt m1 m2 then
          Ptree_sig.Longer
        else
          Ptree_sig.Equal
    else
      Ptree_sig.Different.
End BE_prefix.

(* ❌ Functors are not handled. *)
functor

Module S.
  Record signature {key value mask t : Type} := {
    key := key;
    value := value;
    mask := mask;
    t := t;
    equal : t -> t -> bool;
    empty : t;
    singleton : key -> value -> mask -> t;
    add : (value -> value -> value) -> key -> value -> (option mask) -> t -> t;
    remove : key -> t -> t;
    remove_exact : key -> t -> t;
    remove_prefix : key -> mask -> t -> t;
    mem : key -> t -> bool;
    mem_exact : key -> t -> bool;
    find : key -> t -> option value;
    replace_subtree : t -> value -> t -> t;
    fold : forall {a : Type}, (key -> mask -> value -> a -> a) -> t -> a -> a;
    module_type;
    Map_Reduce : functor;
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

src/lib_stdlib/lwt_canceler.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = {
  cancellation : unit Lwt_condition.t;
  cancellation_complete : unit Lwt_condition.t;
  mutable cancel_hook : unit -> unit Lwt.t;
  mutable canceling : bool;
  mutable canceled : bool;
}

let create () =
  let cancellation = Lwt_condition.create () in
  let cancellation_complete = Lwt_condition.create () in
  {
    cancellation;
    cancellation_complete;
    cancel_hook = (fun () -> Lwt.return_unit);
    canceling = false;
    canceled = false;
  }

let cancel st =
  if st.canceled then Lwt.return_unit
  else if st.canceling then Lwt_condition.wait st.cancellation_complete
  else (
    st.canceling <- true ;
    Lwt_condition.broadcast st.cancellation () ;
    Lwt.finalize st.cancel_hook (fun () ->
        st.canceled <- true ;
        Lwt_condition.broadcast st.cancellation_complete () ;
        Lwt.return_unit) )

let on_cancel st cb =
  let hook = st.cancel_hook in
  st.cancel_hook <- (fun () -> hook () >>= cb)

let cancellation st =
  if st.canceling then Lwt.return_unit else Lwt_condition.wait st.cancellation

let canceled st = st.canceling
src/lib_stdlib/lwt_canceler.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t := {
  cancellation : Lwt_condition.t unit;
  cancellation_complete : Lwt_condition.t unit;
  cancel_hook : unit -> Lwt.t unit;
  canceling : bool;
  canceled : bool }.

Definition create (function_parameter : unit) : t :=
  let 'tt := function_parameter in
  let cancellation := Lwt_condition.create tt in
  let cancellation_complete := Lwt_condition.create tt in
  {| cancellation := cancellation;
    cancellation_complete := cancellation_complete;
    cancel_hook :=
      fun function_parameter =>
        let 'tt := function_parameter in
        Lwt.return_unit; canceling := false; canceled := false |}.

Definition cancel (st : t) : Lwt.t unit :=
  if canceled st then
    Lwt.return_unit
  else
    if canceling st then
      Lwt_condition.wait None (cancellation_complete st)
    else
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field st "canceling" % string true in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Lwt_condition.broadcast (cancellation st) tt in
      Lwt.finalize (cancel_hook st)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field st "canceled" % string true in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt_condition.broadcast (cancellation_complete st) tt in
          Lwt.return_unit).

Definition on_cancel (st : t) (cb : unit -> Lwt.t unit) : unit :=
  let hook := cancel_hook st in
  (* ❌ Set record field not handled. *)
  set_record_field st "cancel_hook" % string
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (hook tt) cb).

Definition cancellation (st : t) : Lwt.t unit :=
  if canceling st then
    Lwt.return_unit
  else
    Lwt_condition.wait None (cancellation st).

Definition canceled (st : t) : bool := canceling st.

src/lib_stdlib/lwt_dropbox.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

exception Closed

type 'a t = {
  mutable data : 'a option;
  mutable closed : bool;
  mutable put_waiter : (unit Lwt.t * unit Lwt.u) option;
}

let create () = {data = None; closed = false; put_waiter = None}

let notify_put dropbox =
  match dropbox.put_waiter with
  | None ->
      ()
  | Some (_waiter, wakener) ->
      dropbox.put_waiter <- None ;
      Lwt.wakeup_later wakener ()

let put dropbox elt =
  if dropbox.closed then raise Closed
  else (
    dropbox.data <- Some elt ;
    notify_put dropbox )

let peek dropbox = dropbox.data

let close dropbox =
  if not dropbox.closed then (
    dropbox.closed <- true ;
    notify_put dropbox )

let wait_put ~timeout dropbox =
  match dropbox.put_waiter with
  | Some (waiter, _wakener) ->
      Lwt.choose [timeout; Lwt.protected waiter]
  | None ->
      let (waiter, wakener) = Lwt.wait () in
      dropbox.put_waiter <- Some (waiter, wakener) ;
      Lwt.choose [timeout; Lwt.protected waiter]

let rec take dropbox =
  match dropbox.data with
  | Some elt ->
      dropbox.data <- None ;
      Lwt.return elt
  | None ->
      if dropbox.closed then Lwt.fail Closed
      else
        wait_put ~timeout:(Lwt_utils.never_ending ()) dropbox
        >>= fun () -> take dropbox

let rec take_with_timeout timeout dropbox =
  match dropbox.data with
  | Some elt ->
      Lwt.cancel timeout ;
      dropbox.data <- None ;
      Lwt.return_some elt
  | None ->
      if Lwt.is_sleeping timeout then
        if dropbox.closed then Lwt.fail Closed
        else
          wait_put ~timeout dropbox
          >>= fun () -> take_with_timeout timeout dropbox
      else Lwt.return_none
src/lib_stdlib/lwt_dropbox.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

(* ❌ The definition of exceptions is not handled. *)
exception

Record t {a : Type} := {
  data : option a;
  closed : bool;
  put_waiter : option ((Lwt.t unit) * (Lwt.u unit)) }.
Arguments t : clear implicits.

Definition create {A : Type} (function_parameter : unit) : t A :=
  let 'tt := function_parameter in
  {| data := None; closed := false; put_waiter := None |}.

Definition notify_put {A : Type} (dropbox : t A) : unit :=
  match put_waiter dropbox with
  | None => tt
  | Some (_waiter, wakener) =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field dropbox "put_waiter" % string None in
    Lwt.wakeup_later wakener tt
  end.

Definition put {A : Type} (dropbox : t A) (elt : A) : unit :=
  if closed dropbox then
    Stdlib.raise Closed
  else
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field dropbox "data" % string (Some elt) in
    notify_put dropbox.

Definition peek {A : Type} (dropbox : t A) : option A := data dropbox.

Definition close {A : Type} (dropbox : t A) : unit :=
  if negb (closed dropbox) then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field dropbox "closed" % string true in
    notify_put dropbox
  else
    tt.

Definition wait_put {A : Type} (timeout : Lwt.t unit) (dropbox : t A)
  : Lwt.t unit :=
  match put_waiter dropbox with
  | Some (waiter, _wakener) =>
    Lwt.choose (cons timeout (cons (Lwt.protected waiter) []))
  | None =>
    let '(waiter, wakener) := Lwt.wait tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field dropbox "put_waiter" % string (Some (waiter, wakener)) in
    Lwt.choose (cons timeout (cons (Lwt.protected waiter) []))
  end.

Fixpoint take {A : Type} (dropbox : t A) : Lwt.t A :=
  match data dropbox with
  | Some elt =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field dropbox "data" % string None in
    Lwt._return elt
  | None =>
    if closed dropbox then
      Lwt.fail Closed
    else
      op_gtgteq (wait_put (Lwt_utils.never_ending tt) dropbox)
        (fun function_parameter =>
          let 'tt := function_parameter in
          take dropbox)
  end.

Fixpoint take_with_timeout {A : Type} (timeout : Lwt.t unit) (dropbox : t A)
  : Lwt.t (option A) :=
  match data dropbox with
  | Some elt =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Lwt.cancel timeout in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field dropbox "data" % string None in
    Lwt.return_some elt
  | None =>
    if Lwt.is_sleeping timeout then
      if closed dropbox then
        Lwt.fail Closed
      else
        op_gtgteq (wait_put timeout dropbox)
          (fun function_parameter =>
            let 'tt := function_parameter in
            take_with_timeout timeout dropbox)
    else
      Lwt.return_none
  end.

src/lib_stdlib/lwt_idle_waiter.ml 26 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = {
  mutable pending_tasks : unit Lwt.u list;
  mutable pending_idle : (unit -> unit Lwt.t) list;
  mutable running_tasks : int;
  mutable running_idle : bool;
  mutable prevent_tasks : bool;
}

let create () =
  {
    pending_tasks = [];
    pending_idle = [];
    running_tasks = 0;
    running_idle = false;
    prevent_tasks = false;
  }

let rec may_run_idle_tasks w =
  if w.running_tasks = 0 && not w.running_idle then
    match w.pending_idle with
    | [] ->
        ()
    | pending_idle ->
        w.running_idle <- true ;
        w.prevent_tasks <- false ;
        w.pending_idle <- [] ;
        Lwt.async (fun () ->
            let pending_idle = List.rev pending_idle in
            Lwt_list.iter_s (fun f -> f ()) pending_idle
            >>= fun () ->
            w.running_idle <- false ;
            let pending_tasks = List.rev w.pending_tasks in
            w.pending_tasks <- [] ;
            List.iter (fun u -> Lwt.wakeup u ()) pending_tasks ;
            may_run_idle_tasks w ;
            Lwt.return_unit)

let wrap_error f =
  Lwt.catch
    (fun () -> f () >>= fun r -> Lwt.return_ok r)
    (fun exn -> Lwt.return_error exn)

let unwrap_error = function Ok r -> Lwt.return r | Error exn -> Lwt.fail exn

let wakeup_error u = function
  | Ok r ->
      Lwt.wakeup u r
  | Error exn ->
      Lwt.wakeup_exn u exn

let rec task w f =
  if w.running_idle || w.prevent_tasks then (
    let (t, u) = Lwt.task () in
    w.pending_tasks <- u :: w.pending_tasks ;
    t >>= fun () -> task w f )
  else (
    w.running_tasks <- w.running_tasks + 1 ;
    wrap_error f
    >>= fun res ->
    w.running_tasks <- w.running_tasks - 1 ;
    may_run_idle_tasks w ;
    unwrap_error res )

let when_idle w f =
  let (t, u) = Lwt.task () in
  let canceled = ref false in
  Lwt.on_cancel t (fun () -> canceled := true) ;
  let f () =
    if !canceled then Lwt.return_unit
    else wrap_error f >>= fun res -> wakeup_error u res ; Lwt.return_unit
  in
  w.pending_idle <- f :: w.pending_idle ;
  may_run_idle_tasks w ;
  t

let force_idle w f =
  w.prevent_tasks <- true ;
  when_idle w f
src/lib_stdlib/lwt_idle_waiter.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t := {
  pending_tasks : list (Lwt.u unit);
  pending_idle : list (unit -> Lwt.t unit);
  running_tasks : Z;
  running_idle : bool;
  prevent_tasks : bool }.

Definition create (function_parameter : unit) : t :=
  let 'tt := function_parameter in
  {| pending_tasks := []; pending_idle := []; running_tasks := 0;
    running_idle := false; prevent_tasks := false |}.

Fixpoint may_run_idle_tasks (w : t) : unit :=
  if andb (equiv_decb (running_tasks w) 0) (negb (running_idle w)) then
    match pending_idle w with
    | [] => tt
    | pending_idle =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field w "running_idle" % string true in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field w "prevent_tasks" % string false in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field w "pending_idle" % string [] in
      Lwt.async
        (fun function_parameter =>
          let 'tt := function_parameter in
          let pending_idle := List.rev pending_idle in
          op_gtgteq (Lwt_list.iter_s (fun f => f tt) pending_idle)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field w "running_idle" % string false in
              let pending_tasks := List.rev (pending_tasks w) in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Set record field not handled. *)
                set_record_field w "pending_tasks" % string [] in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Stdlib.List.iter (fun u => Lwt.wakeup u tt) pending_tasks
                in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := may_run_idle_tasks w in
              Lwt.return_unit))
    end
  else
    tt.

Definition wrap_error {A : Type} (f : unit -> Lwt.t A)
  : Lwt.t (Result.result A exn) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (f tt) (fun r => Lwt.return_ok r))
    (fun exn => Lwt.return_error exn).

Definition unwrap_error {A : Type} (function_parameter : sum A exn) : Lwt.t A :=
  match function_parameter with
  | Stdlib.Ok r => Lwt._return r
  | Stdlib.Error exn => Lwt.fail exn
  end.

Definition wakeup_error {A : Type}
  (u : Lwt.u A) (function_parameter : sum A exn) : unit :=
  match function_parameter with
  | Stdlib.Ok r => Lwt.wakeup u r
  | Stdlib.Error exn => Lwt.wakeup_exn u exn
  end.

Fixpoint task {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
  if orb (running_idle w) (prevent_tasks w) then
    let '(t, u) := Lwt.task tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field w "pending_tasks" % string (cons u (pending_tasks w)) in
    op_gtgteq t
      (fun function_parameter =>
        let 'tt := function_parameter in
        task w f)
  else
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field w "running_tasks" % string (Z.add (running_tasks w) 1) in
    op_gtgteq (wrap_error f)
      (fun res =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field w "running_tasks" % string
            (Z.sub (running_tasks w) 1) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := may_run_idle_tasks w in
        unwrap_error res).

Definition when_idle {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
  let '(t, u) := Lwt.task tt in
  let canceled := Stdlib.ref false in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Lwt.on_cancel t
      (fun function_parameter =>
        let 'tt := function_parameter in
        Stdlib.op_coloneq canceled true) in
  let f (function_parameter : unit) : Lwt.t unit :=
    let 'tt := function_parameter in
    if Stdlib.op_exclamation canceled then
      Lwt.return_unit
    else
      op_gtgteq (wrap_error f)
        (fun res =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := wakeup_error u res in
          Lwt.return_unit) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field w "pending_idle" % string (cons f (pending_idle w)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := may_run_idle_tasks w in
  t.

Definition force_idle {A : Type} (w : t) (f : unit -> Lwt.t A) : Lwt.t A :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field w "prevent_tasks" % string true in
  when_idle w f.

src/lib_stdlib/lwt_pipe.ml 37 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type 'a t = {
  queue : (int * 'a) Queue.t;
  mutable current_size : int;
  max_size : int;
  compute_size : 'a -> int;
  mutable closed : bool;
  mutable push_waiter : (unit Lwt.t * unit Lwt.u) option;
  mutable pop_waiter : (unit Lwt.t * unit Lwt.u) option;
  empty : unit Lwt_condition.t;
}

let push_overhead = 4 * (Sys.word_size / 8)

let create ?size () =
  let (max_size, compute_size) =
    match size with
    | None ->
        (max_int, fun _ -> 0)
    | Some (max_size, compute_size) ->
        (max_size, compute_size)
  in
  {
    queue = Queue.create ();
    current_size = 0;
    max_size;
    compute_size;
    closed = false;
    push_waiter = None;
    pop_waiter = None;
    empty = Lwt_condition.create ();
  }

let notify_push q =
  match q.push_waiter with
  | None ->
      ()
  | Some (_, w) ->
      q.push_waiter <- None ;
      Lwt.wakeup_later w ()

let notify_pop q =
  match q.pop_waiter with
  | None ->
      ()
  | Some (_, w) ->
      q.pop_waiter <- None ;
      Lwt.wakeup_later w ()

let wait_push q =
  match q.push_waiter with
  | Some (t, _) ->
      Lwt.protected t
  | None ->
      let (waiter, wakener) = Lwt.wait () in
      q.push_waiter <- Some (waiter, wakener) ;
      Lwt.protected waiter

let wait_pop q =
  match q.pop_waiter with
  | Some (t, _) ->
      Lwt.protected t
  | None ->
      let (waiter, wakener) = Lwt.wait () in
      q.pop_waiter <- Some (waiter, wakener) ;
      Lwt.protected waiter

let length {queue; _} = Queue.length queue

let is_empty {queue; _} = Queue.is_empty queue

let rec empty q =
  if is_empty q then Lwt.return_unit
  else Lwt_condition.wait q.empty >>= fun () -> empty q

exception Closed

let rec push ({closed; queue; current_size; max_size; compute_size; _} as q)
    elt =
  let elt_size = compute_size elt in
  if closed then Lwt.fail Closed
  else if current_size + elt_size < max_size || Queue.is_empty queue then (
    Queue.push (elt_size, elt) queue ;
    q.current_size <- current_size + elt_size ;
    notify_push q ;
    Lwt.return_unit )
  else wait_pop q >>= fun () -> push q elt

let push_now ({closed; queue; compute_size; current_size; max_size; _} as q)
    elt =
  if closed then raise Closed ;
  let elt_size = compute_size elt in
  (current_size + elt_size < max_size || Queue.is_empty queue)
  &&
  ( Queue.push (elt_size, elt) queue ;
    q.current_size <- current_size + elt_size ;
    notify_push q ;
    true )

exception Full

let push_now_exn q elt = if not (push_now q elt) then raise Full

let safe_push_now q elt = try push_now_exn q elt with _ -> ()

let rec pop ({closed; queue; empty; current_size; _} as q) =
  if not (Queue.is_empty queue) then (
    let (elt_size, elt) = Queue.pop queue in
    notify_pop q ;
    q.current_size <- current_size - elt_size ;
    if Queue.length queue = 0 then Lwt_condition.signal empty () ;
    Lwt.return elt )
  else if closed then Lwt.fail Closed
  else wait_push q >>= fun () -> pop q

let rec pop_with_timeout timeout q =
  if not (Queue.is_empty q.queue) then (
    Lwt.cancel timeout ;
    pop q >>= Lwt.return_some )
  else if Lwt.is_sleeping timeout then
    if q.closed then (Lwt.cancel timeout ; Lwt.fail Closed)
    else
      let waiter = wait_push q in
      Lwt.choose [timeout; Lwt.protected waiter]
      >>= fun () -> pop_with_timeout timeout q
  else Lwt.return_none

let rec peek ({closed; queue; _} as q) =
  if not (Queue.is_empty queue) then
    let (_elt_size, elt) = Queue.peek queue in
    Lwt.return elt
  else if closed then Lwt.fail Closed
  else wait_push q >>= fun () -> peek q

let peek_all {queue; closed; _} =
  if closed then []
  else List.rev (Queue.fold (fun acc (_, e) -> e :: acc) [] queue)

exception Empty

let pop_now_exn ({closed; queue; empty; current_size; _} as q) =
  if Queue.is_empty queue then if closed then raise Closed else raise Empty ;
  let (elt_size, elt) = Queue.pop queue in
  if Queue.length queue = 0 then Lwt_condition.signal empty () ;
  q.current_size <- current_size - elt_size ;
  notify_pop q ;
  elt

let pop_now q =
  match pop_now_exn q with exception Empty -> None | elt -> Some elt

let rec values_available q =
  if is_empty q then
    if q.closed then raise Closed
    else wait_push q >>= fun () -> values_available q
  else Lwt.return_unit

let rec pop_all_loop q acc =
  match pop_now_exn q with
  | exception Empty ->
      List.rev acc
  | e ->
      pop_all_loop q (e :: acc)

let pop_all q = pop q >>= fun e -> Lwt.return (pop_all_loop q [e])

let pop_all_now q = pop_all_loop q []

let close q =
  if not q.closed then (
    q.closed <- true ;
    notify_push q ;
    notify_pop q )

let rec iter q ~f =
  Lwt.catch
    (fun () -> pop q >>= fun elt -> f elt >>= fun () -> iter q ~f)
    (function Closed -> Lwt.return_unit | exn -> Lwt.fail exn)
src/lib_stdlib/lwt_pipe.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Record t {a : Type} := {
  queue : Stdlib.Queue.t (Z * a);
  current_size : Z;
  max_size : Z;
  compute_size : a -> Z;
  closed : bool;
  push_waiter : option ((Lwt.t unit) * (Lwt.u unit));
  pop_waiter : option ((Lwt.t unit) * (Lwt.u unit));
  empty : Lwt_condition.t unit }.
Arguments t : clear implicits.

Definition push_overhead : Z := Z.mul 4 (Z.div Sys.word_size 8).

Definition create {A : Type}
  (size : option (Z * (A -> Z))) (function_parameter : unit) : t A :=
  let 'tt := function_parameter in
  let '(max_size, compute_size) :=
    match size with
    | None =>
      (Stdlib.max_int,
        (fun function_parameter =>
          let '_ := function_parameter in
          0))
    | Some (max_size, compute_size) => (max_size, compute_size)
    end in
  {| queue := Queue.create tt; current_size := 0; max_size := max_size;
    compute_size := compute_size; closed := false; push_waiter := None;
    pop_waiter := None; empty := Lwt_condition.create tt |}.

Definition notify_push {A : Type} (q : t A) : unit :=
  match push_waiter q with
  | None => tt
  | Some (_, w) =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field q "push_waiter" % string None in
    Lwt.wakeup_later w tt
  end.

Definition notify_pop {A : Type} (q : t A) : unit :=
  match pop_waiter q with
  | None => tt
  | Some (_, w) =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field q "pop_waiter" % string None in
    Lwt.wakeup_later w tt
  end.

Definition wait_push {A : Type} (q : t A) : Lwt.t unit :=
  match push_waiter q with
  | Some (t, _) => Lwt.protected t
  | None =>
    let '(waiter, wakener) := Lwt.wait tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field q "push_waiter" % string (Some (waiter, wakener)) in
    Lwt.protected waiter
  end.

Definition wait_pop {A : Type} (q : t A) : Lwt.t unit :=
  match pop_waiter q with
  | Some (t, _) => Lwt.protected t
  | None =>
    let '(waiter, wakener) := Lwt.wait tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field q "pop_waiter" % string (Some (waiter, wakener)) in
    Lwt.protected waiter
  end.

Definition length {A : Type} (function_parameter : t A) : Z :=
  let '{| queue := queue |} := function_parameter in
  Queue.length queue.

Definition is_empty {A : Type} (function_parameter : t A) : bool :=
  let '{| queue := queue |} := function_parameter in
  Queue.is_empty queue.

Fixpoint empty {A : Type} (q : t A) : Lwt.t unit :=
  if is_empty q then
    Lwt.return_unit
  else
    op_gtgteq (Lwt_condition.wait None (empty q))
      (fun function_parameter =>
        let 'tt := function_parameter in
        empty q).

(* ❌ The definition of exceptions is not handled. *)
exception

Fixpoint push {A : Type} (function_parameter : t A) : A -> Lwt.t unit :=
  let
    '{|
      queue := queue;
        current_size := current_size;
        max_size := max_size;
        compute_size := compute_size;
        closed := closed
        |} as q := function_parameter in
  fun elt =>
    let elt_size := compute_size elt in
    if closed then
      Lwt.fail Closed
    else
      if
        orb (OCaml.Stdlib.lt (Z.add current_size elt_size) max_size)
          (Queue.is_empty queue) then
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Queue.push (elt_size, elt) queue in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field q "current_size" % string
            (Z.add current_size elt_size) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := notify_push q in
        Lwt.return_unit
      else
        op_gtgteq (wait_pop q)
          (fun function_parameter =>
            let 'tt := function_parameter in
            push q elt).

Definition push_now {A : Type} (function_parameter : t A) : A -> bool :=
  let
    '{|
      queue := queue;
        current_size := current_size;
        max_size := max_size;
        compute_size := compute_size;
        closed := closed
        |} as q := function_parameter in
  fun elt =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if closed then
        Stdlib.raise Closed
      else
        tt in
    let elt_size := compute_size elt in
    andb
      (orb (OCaml.Stdlib.lt (Z.add current_size elt_size) max_size)
        (Queue.is_empty queue))
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (let _ := Queue.push (elt_size, elt) queue in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field q "current_size" % string (Z.add current_size elt_size)
        in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := notify_push q in
      true).

(* ❌ The definition of exceptions is not handled. *)
exception

Definition push_now_exn {A : Type} (q : t A) (elt : A) : unit :=
  if negb (push_now q elt) then
    Stdlib.raise Full
  else
    tt.

Definition safe_push_now {A : Type} (q : t A) (elt : A) : unit :=
  (* ❌ Try-with are not handled *)
  try (push_now_exn q elt).

Fixpoint pop {A : Type} (function_parameter : t A) : Lwt.t A :=
  let
    '{|
      queue := queue;
        current_size := current_size;
        closed := closed;
        empty := empty
        |} as q := function_parameter in
  if negb (Queue.is_empty queue) then
    let '(elt_size, elt) := Queue.pop queue in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := notify_pop q in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field q "current_size" % string (Z.sub current_size elt_size)
      in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if equiv_decb (Queue.length queue) 0 then
        Lwt_condition.signal empty tt
      else
        tt in
    Lwt._return elt
  else
    if closed then
      Lwt.fail Closed
    else
      op_gtgteq (wait_push q)
        (fun function_parameter =>
          let 'tt := function_parameter in
          pop q).

Fixpoint pop_with_timeout {A : Type} (timeout : Lwt.t unit) (q : t A)
  : Lwt.t (option A) :=
  if negb (Queue.is_empty (queue q)) then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Lwt.cancel timeout in
    op_gtgteq (pop q) Lwt.return_some
  else
    if Lwt.is_sleeping timeout then
      if closed q then
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt.cancel timeout in
        Lwt.fail Closed
      else
        let waiter := wait_push q in
        op_gtgteq (Lwt.choose (cons timeout (cons (Lwt.protected waiter) [])))
          (fun function_parameter =>
            let 'tt := function_parameter in
            pop_with_timeout timeout q)
    else
      Lwt.return_none.

Fixpoint peek {A : Type} (function_parameter : t A) : Lwt.t A :=
  let '{| queue := queue; closed := closed |} as q := function_parameter in
  if negb (Queue.is_empty queue) then
    let '(_elt_size, elt) := Queue.peek queue in
    Lwt._return elt
  else
    if closed then
      Lwt.fail Closed
    else
      op_gtgteq (wait_push q)
        (fun function_parameter =>
          let 'tt := function_parameter in
          peek q).

Definition peek_all {A : Type} (function_parameter : t A) : list A :=
  let '{| queue := queue; closed := closed |} := function_parameter in
  if closed then
    []
  else
    List.rev
      (Queue.fold
        (fun acc =>
          fun function_parameter =>
            let '(_, e) := function_parameter in
            cons e acc) [] queue).

(* ❌ The definition of exceptions is not handled. *)
exception

Definition pop_now_exn {A : Type} (function_parameter : t A) : A :=
  let
    '{|
      queue := queue;
        current_size := current_size;
        closed := closed;
        empty := empty
        |} as q := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if Queue.is_empty queue then
      if closed then
        Stdlib.raise Closed
      else
        Stdlib.raise Empty
    else
      tt in
  let '(elt_size, elt) := Queue.pop queue in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if equiv_decb (Queue.length queue) 0 then
      Lwt_condition.signal empty tt
    else
      tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field q "current_size" % string (Z.sub current_size elt_size) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := notify_pop q in
  elt.

Definition pop_now {A : Type} (q : t A) : option A :=
  let 'elt := pop_now_exn q in
  Some elt.

Fixpoint values_available {A : Type} (q : t A) : Lwt.t unit :=
  if is_empty q then
    if closed q then
      Stdlib.raise Closed
    else
      op_gtgteq (wait_push q)
        (fun function_parameter =>
          let 'tt := function_parameter in
          values_available q)
  else
    Lwt.return_unit.

Fixpoint pop_all_loop {A : Type} (q : t A) (acc : list A) : list A :=
  let 'e := pop_now_exn q in
  pop_all_loop q (cons e acc).

Definition pop_all {A : Type} (q : t A) : Lwt.t (list A) :=
  op_gtgteq (pop q) (fun e => Lwt._return (pop_all_loop q (cons e []))).

Definition pop_all_now {A : Type} (q : t A) : list A := pop_all_loop q [].

Definition close {A : Type} (q : t A) : unit :=
  if negb (closed q) then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field q "closed" % string true in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := notify_push q in
    notify_pop q
  else
    tt.

Fixpoint iter {A : Type} (q : t A) (f : A -> Lwt.t unit) : Lwt.t unit :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (pop q)
        (fun elt =>
          op_gtgteq (f elt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              iter q f)))
    (fun function_parameter =>
      match function_parameter with
      | Closed => Lwt.return_unit
      | exn => Lwt.fail exn
      end).

src/lib_stdlib/lwt_utils.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module LC = Lwt_condition
open Lwt.Infix

let may ~f = function None -> Lwt.return_unit | Some x -> f x

let never_ending () = fst (Lwt.wait ())

type trigger = Absent | Present | Waiting of unit Lwt.t * unit Lwt.u

let trigger () : (unit -> unit) * (unit -> unit Lwt.t) =
  let state = ref Absent in
  let trigger () =
    match !state with
    | Absent ->
        state := Present
    | Present ->
        ()
    | Waiting (_waiter, wakener) ->
        state := Absent ;
        Lwt.wakeup wakener ()
  in
  let wait () =
    match !state with
    | Absent ->
        let (waiter, wakener) = Lwt.wait () in
        state := Waiting (waiter, wakener) ;
        waiter
    | Present ->
        state := Absent ;
        Lwt.return_unit
    | Waiting (waiter, _wakener) ->
        waiter
  in
  (trigger, wait)

(* A worker launcher, takes a cancel callback to call upon *)
let worker name ~on_event ~run ~cancel =
  let stop = LC.create () in
  let fail e =
    on_event
      name
      (`Failed (Printf.sprintf "Exception: %s" (Printexc.to_string e)))
    >>= fun () -> cancel ()
  in
  let waiter = LC.wait stop in
  on_event name `Started
  >>= fun () ->
  Lwt.async (fun () ->
      Lwt.catch run fail >>= fun () -> LC.signal stop () ; Lwt.return_unit) ;
  waiter >>= fun () -> on_event name `Ended >>= fun () -> Lwt.return_unit

let rec chop k l =
  if k = 0 then l
  else match l with _ :: t -> chop (k - 1) t | _ -> assert false

let stable_sort cmp l =
  let rec rev_merge l1 l2 accu =
    match (l1, l2) with
    | ([], l2) ->
        Lwt.return (List.rev_append l2 accu)
    | (l1, []) ->
        Lwt.return (List.rev_append l1 accu)
    | (h1 :: t1, h2 :: t2) -> (
        cmp h1 h2
        >>= function
        | x when x <= 0 ->
            rev_merge t1 l2 (h1 :: accu)
        | _ ->
            rev_merge l1 t2 (h2 :: accu) )
  in
  let rec rev_merge_rev l1 l2 accu =
    match (l1, l2) with
    | ([], l2) ->
        Lwt.return (List.rev_append l2 accu)
    | (l1, []) ->
        Lwt.return (List.rev_append l1 accu)
    | (h1 :: t1, h2 :: t2) -> (
        cmp h1 h2
        >>= function
        | x when x > 0 ->
            rev_merge_rev t1 l2 (h1 :: accu)
        | _ ->
            rev_merge_rev l1 t2 (h2 :: accu) )
  in
  let rec sort n l =
    match (n, l) with
    | (2, x1 :: x2 :: _) -> (
        cmp x1 x2 >|= function x when x <= 0 -> [x1; x2] | _ -> [x2; x1] )
    | (3, x1 :: x2 :: x3 :: _) -> (
        cmp x1 x2
        >>= function
        | x when x <= 0 -> (
            cmp x2 x3
            >>= function
            | x when x <= 0 ->
                Lwt.return [x1; x2; x3]
            | _ -> (
                cmp x1 x3
                >|= function x when x <= 0 -> [x1; x3; x2] | _ -> [x3; x1; x2]
                ) )
        | _ -> (
            cmp x1 x3
            >>= function
            | x when x <= 0 ->
                Lwt.return [x2; x1; x3]
            | _ -> (
                cmp x2 x3
                >|= function x when x <= 0 -> [x2; x3; x1] | _ -> [x3; x2; x1]
                ) ) )
    | (n, l) ->
        let n1 = n asr 1 in
        let n2 = n - n1 in
        let l2 = chop n1 l in
        rev_sort n1 l
        >>= fun s1 -> rev_sort n2 l2 >>= fun s2 -> rev_merge_rev s1 s2 []
  and rev_sort n l =
    match (n, l) with
    | (2, x1 :: x2 :: _) -> (
        cmp x1 x2 >|= function x when x > 0 -> [x1; x2] | _ -> [x2; x1] )
    | (3, x1 :: x2 :: x3 :: _) -> (
        cmp x1 x2
        >>= function
        | x when x > 0 -> (
            cmp x2 x3
            >>= function
            | x when x > 0 ->
                Lwt.return [x1; x2; x3]
            | _ -> (
                cmp x1 x3
                >|= function x when x > 0 -> [x1; x3; x2] | _ -> [x3; x1; x2] )
            )
        | _ -> (
            cmp x1 x3
            >>= function
            | x when x > 0 ->
                Lwt.return [x2; x1; x3]
            | _ -> (
                cmp x2 x3
                >|= function x when x > 0 -> [x2; x3; x1] | _ -> [x3; x2; x1] )
            ) )
    | (n, l) ->
        let n1 = n asr 1 in
        let n2 = n - n1 in
        let l2 = chop n1 l in
        sort n1 l >>= fun s1 -> sort n2 l2 >>= fun s2 -> rev_merge s1 s2 []
  in
  let len = List.length l in
  if len < 2 then Lwt.return l else sort len l

let sort = stable_sort

let unless cond f = if cond then Lwt.return_unit else f ()

let rec fold_left_s_n ~n f acc l =
  if n = 0 then Lwt.return (acc, l)
  else
    match l with
    | [] ->
        Lwt.return (acc, [])
    | x :: l ->
        f acc x
        >>= fun acc -> (fold_left_s_n [@ocaml.tailcall]) f ~n:(n - 1) acc l
src/lib_stdlib/lwt_utils.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ This kind of module is not handled. *)
unhandled_module

Import Lwt.Infix.

Definition may {A : Type} (f : A -> Lwt.t unit) (function_parameter : option A)
  : Lwt.t unit :=
  match function_parameter with
  | None => Lwt.return_unit
  | Some x => f x
  end.

Definition never_ending {A : Type} (function_parameter : unit) : Lwt.t A :=
  let 'tt := function_parameter in
  fst (Lwt.wait tt).

Inductive trigger : Type :=
| Absent : trigger
| Present : trigger
| Waiting : (Lwt.t unit) -> (Lwt.u unit) -> trigger.

Definition trigger (function_parameter : unit)
  : (unit -> unit) * (unit -> Lwt.t unit) :=
  let 'tt := function_parameter in
  let state := Stdlib.ref Absent in
  let trigger (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    match Stdlib.op_exclamation state with
    | Absent => Stdlib.op_coloneq state Present
    | Present => tt
    | Waiting _waiter wakener =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq state Absent in
      Lwt.wakeup wakener tt
    end in
  let wait (function_parameter : unit) : Lwt.t unit :=
    let 'tt := function_parameter in
    match Stdlib.op_exclamation state with
    | Absent =>
      let '(waiter, wakener) := Lwt.wait tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq state (Waiting waiter wakener) in
      waiter
    | Present =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.op_coloneq state Absent in
      Lwt.return_unit
    | Waiting waiter _wakener => waiter
    end in
  (trigger, wait).

Definition worker {A : Type}
  (name : A) (on_event : A -> variant -> Lwt.t unit) (run : unit -> Lwt.t unit)
  (cancel : unit -> Lwt.t unit) : Lwt.t unit :=
  let stop := LC.create tt in
  let fail (e : exn) : Lwt.t unit :=
    op_gtgteq
      (on_event name
        (* ❌ Variants not supported *)
        variant)
      (fun function_parameter =>
        let 'tt := function_parameter in
        cancel tt) in
  let waiter := LC.wait None stop in
  op_gtgteq
    (on_event name
      (* ❌ Variants not supported *)
      variant)
    (fun function_parameter =>
      let 'tt := function_parameter in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Lwt.async
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Lwt.catch run fail)
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := LC.signal stop tt in
                Lwt.return_unit)) in
      op_gtgteq waiter
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (on_event name
              (* ❌ Variants not supported *)
              variant)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.return_unit))).

Fixpoint chop {A : Type} (k : Z) (l : list A) : list A :=
  if equiv_decb k 0 then
    l
  else
    match l with
    | cons _ t => chop (Z.sub k 1) t
    | _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end.

Definition stable_sort {A : Type} (cmp : A -> A -> Lwt.t Z) (l : list A)
  : Lwt.t (list A) :=
  let fix rev_merge (l1 : list A) (l2 : list A) (accu : list A)
    : Lwt.t (list A) :=
    match (l1, l2) with
    | ([], l2) => Lwt._return (Stdlib.List.rev_append l2 accu)
    | (l1, []) => Lwt._return (Stdlib.List.rev_append l1 accu)
    | (cons h1 t1, cons h2 t2) =>
      op_gtgteq (cmp h1 h2)
        (fun function_parameter =>
          match function_parameter with
          | x => rev_merge t1 l2 (cons h1 accu)
          | _ => rev_merge l1 t2 (cons h2 accu)
          end)
    end in
  let fix rev_merge_rev (l1 : list A) (l2 : list A) (accu : list A)
    : Lwt.t (list A) :=
    match (l1, l2) with
    | ([], l2) => Lwt._return (Stdlib.List.rev_append l2 accu)
    | (l1, []) => Lwt._return (Stdlib.List.rev_append l1 accu)
    | (cons h1 t1, cons h2 t2) =>
      op_gtgteq (cmp h1 h2)
        (fun function_parameter =>
          match function_parameter with
          | x => rev_merge_rev t1 l2 (cons h1 accu)
          | _ => rev_merge_rev l1 t2 (cons h2 accu)
          end)
    end in
  let fix sort (n : Z) (l : list A) : Lwt.t (list A) :=
    match (n, l) with
    | (2, cons x1 (cons x2 _)) =>
      op_gtpipeeq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x => cons x1 (cons x2 [])
          | _ => cons x2 (cons x1 [])
          end)
    | (3, cons x1 (cons x2 (cons x3 _))) =>
      op_gtgteq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x =>
            op_gtgteq (cmp x2 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x1 (cons x2 (cons x3 [])))
                | _ =>
                  op_gtpipeeq (cmp x1 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x1 (cons x3 (cons x2 []))
                      | _ => cons x3 (cons x1 (cons x2 []))
                      end)
                end)
          | _ =>
            op_gtgteq (cmp x1 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x2 (cons x1 (cons x3 [])))
                | _ =>
                  op_gtpipeeq (cmp x2 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x2 (cons x3 (cons x1 []))
                      | _ => cons x3 (cons x2 (cons x1 []))
                      end)
                end)
          end)
    | (n, l) =>
      let n1 := Stdlib.asr n 1 in
      let n2 := Z.sub n n1 in
      let l2 := chop n1 l in
      op_gtgteq (rev_sort n1 l)
        (fun s1 => op_gtgteq (rev_sort n2 l2) (fun s2 => rev_merge_rev s1 s2 []))
    end
  with rev_sort (n : Z) (l : list A) : Lwt.t (list A) :=
    match (n, l) with
    | (2, cons x1 (cons x2 _)) =>
      op_gtpipeeq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x => cons x1 (cons x2 [])
          | _ => cons x2 (cons x1 [])
          end)
    | (3, cons x1 (cons x2 (cons x3 _))) =>
      op_gtgteq (cmp x1 x2)
        (fun function_parameter =>
          match function_parameter with
          | x =>
            op_gtgteq (cmp x2 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x1 (cons x2 (cons x3 [])))
                | _ =>
                  op_gtpipeeq (cmp x1 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x1 (cons x3 (cons x2 []))
                      | _ => cons x3 (cons x1 (cons x2 []))
                      end)
                end)
          | _ =>
            op_gtgteq (cmp x1 x3)
              (fun function_parameter =>
                match function_parameter with
                | x => Lwt._return (cons x2 (cons x1 (cons x3 [])))
                | _ =>
                  op_gtpipeeq (cmp x2 x3)
                    (fun function_parameter =>
                      match function_parameter with
                      | x => cons x2 (cons x3 (cons x1 []))
                      | _ => cons x3 (cons x2 (cons x1 []))
                      end)
                end)
          end)
    | (n, l) =>
      let n1 := Stdlib.asr n 1 in
      let n2 := Z.sub n n1 in
      let l2 := chop n1 l in
      op_gtgteq (sort n1 l)
        (fun s1 => op_gtgteq (sort n2 l2) (fun s2 => rev_merge s1 s2 []))
    end in
  let len := OCaml.List.length l in
  if OCaml.Stdlib.lt len 2 then
    Lwt._return l
  else
    sort len l.

Definition sort {A : Type}
  : (A -> A -> Lwt.t Z) -> (list A) -> Lwt.t (list A) := stable_sort.

Definition unless (cond : bool) (f : unit -> Lwt.t unit) : Lwt.t unit :=
  if cond then
    Lwt.return_unit
  else
    f tt.

Fixpoint fold_left_s_n {A B : Type}
  (n : Z) (f : A -> B -> Lwt.t A) (acc : A) (l : list B)
  : Lwt.t (A * (list B)) :=
  if equiv_decb n 0 then
    Lwt._return (acc, l)
  else
    match l with
    | [] => Lwt._return (acc, [])
    | cons x l =>
      op_gtgteq (f acc x) (fun acc => fold_left_s_n (Z.sub n 1) f acc l)
    end.

src/lib_stdlib/lwt_watcher.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a inner_stopper = {
  id : int;
  push : 'a option -> unit;
  mutable active : bool;
  input : 'a input;
}

and 'a input = {mutable watchers : 'a inner_stopper list; mutable cpt : int}

type stopper = unit -> unit

let create_input () = {watchers = []; cpt = 0}

let shutdown_input input =
  let {watchers; _} = input in
  List.iter
    (fun w ->
      w.active <- false ;
      w.push None)
    watchers ;
  input.cpt <- 0 ;
  input.watchers <- []

let create_fake_stream () =
  let (str, push) = Lwt_stream.create () in
  (str, fun () -> push None)

let notify input info = List.iter (fun w -> w.push (Some info)) input.watchers

let shutdown_output output =
  if output.active then (
    output.active <- false ;
    output.push None ;
    output.input.watchers <-
      List.filter (fun w -> w.id <> output.id) output.input.watchers )

let create_stream input =
  input.cpt <- input.cpt + 1 ;
  let id = input.cpt in
  let (stream, push) = Lwt_stream.create () in
  let output = {id; push; input; active = true} in
  input.watchers <- output :: input.watchers ;
  (stream, fun () -> shutdown_output output)

let shutdown f = f ()
src/lib_stdlib/lwt_watcher.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

.

Definition stopper := unit -> unit.

Definition create_input {A : Type} (function_parameter : unit) : input A :=
  let 'tt := function_parameter in
  {| watchers := []; cpt := 0 |}.

Definition shutdown_input {A : Type} (input : input A) : unit :=
  let '{| watchers := watchers |} := input in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Stdlib.List.iter
      (fun w =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field w "active" % string false in
        (push w) None) watchers in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field input "cpt" % string 0 in
  (* ❌ Set record field not handled. *)
  set_record_field input "watchers" % string [].

Definition create_fake_stream {A : Type} (function_parameter : unit)
  : (Lwt_stream.t A) * (unit -> unit) :=
  let 'tt := function_parameter in
  let '(str, push) := Lwt_stream.create tt in
  (str,
    (fun function_parameter =>
      let 'tt := function_parameter in
      push None)).

Definition notify {A : Type} (input : input A) (info : A) : unit :=
  Stdlib.List.iter (fun w => (push w) (Some info)) (watchers input).

Definition shutdown_output {A : Type} (output : inner_stopper A) : unit :=
  if active output then
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Set record field not handled. *)
      set_record_field output "active" % string false in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := (push output) None in
    (* ❌ Set record field not handled. *)
    set_record_field (input output) "watchers" % string
      (Stdlib.List.filter (fun w => nequiv_decb (id w) (id output))
        (watchers (input output)))
  else
    tt.

Definition create_stream {A : Type} (input : input A)
  : (Lwt_stream.t A) * (unit -> unit) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field input "cpt" % string (Z.add (cpt input) 1) in
  let id := cpt input in
  let '(stream, push) := Lwt_stream.create tt in
  let output := {| id := id; push := push; active := true; input := input |} in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field input "watchers" % string (cons output (watchers input)) in
  (stream,
    (fun function_parameter =>
      let 'tt := function_parameter in
      shutdown_output output)).

Definition shutdown {A : Type} (f : unit -> A) : A := f tt.

src/lib_stdlib/mBytes.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = bytes

let create = Bytes.create

let length = Bytes.length

let copy = Bytes.copy

let sub = Bytes.sub

let blit = Bytes.blit

let blit_of_string = Bytes.blit_string

let blit_to_bytes = Bytes.blit

let of_string = Bytes.of_string

let to_string = Bytes.to_string

let sub_string = Bytes.sub_string

let get_char = Bytes.get

let set_char = Bytes.set

include TzEndian

module LE = struct
  let get_uint16 = Bytes_encodings.get_uint16_le

  let get_int16 = Bytes_encodings.get_int16_le

  let get_int32 = Bytes_encodings.get_int32_le

  let get_int64 = Bytes_encodings.get_int64_le

  let set_int16 = Bytes_encodings.set_int16_le

  let set_int32 = Bytes_encodings.set_int32_le

  let set_int64 = Bytes_encodings.set_int64_le
end

let ( = ) = Pervasives.( = )

let ( <> ) = Pervasives.( <> )

let ( < ) = Pervasives.( < )

let ( <= ) = Pervasives.( <= )

let ( >= ) = Pervasives.( >= )

let ( > ) = Pervasives.( > )

let compare = Bytes.compare

let concat s bs = Bytes.concat (Bytes.of_string s) bs

let to_hex t = Hex.of_bytes t

let of_hex hex = Hex.to_bytes hex
src/lib_stdlib/mBytes.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := string.

Definition create : Z -> string := Stdlib.Bytes.create.

Definition length : string -> Z := String.length.

Definition copy : string -> string := Stdlib.Bytes.copy.

Definition sub : string -> Z -> Z -> string := String.sub.

Definition blit : string -> Z -> string -> Z -> Z -> unit := Stdlib.Bytes.blit.

Definition blit_of_string : string -> Z -> string -> Z -> Z -> unit :=
  Stdlib.Bytes.blit_string.

Definition blit_to_bytes : string -> Z -> string -> Z -> Z -> unit :=
  Stdlib.Bytes.blit.

Definition of_string : string -> string := Stdlib.Bytes.of_string.

Definition to_string : string -> string := Stdlib.Bytes.to_string.

Definition sub_string : string -> Z -> Z -> string := Stdlib.Bytes.sub_string.

Definition get_char : string -> Z -> ascii := Stdlib.Bytes.get.

Definition set_char : string -> Z -> ascii -> unit := Stdlib.Bytes.set.

(* ❌ Structure item `include` not handled. *)
include

Module LE.
  Definition get_uint16 : string -> Z -> Z := Bytes_encodings.get_uint16_le.
  
  Definition get_int16 : string -> Z -> Z := Bytes_encodings.get_int16_le.
  
  Definition get_int32 : string -> Z -> int32 := Bytes_encodings.get_int32_le.
  
  Definition get_int64 : string -> Z -> int64 := Bytes_encodings.get_int64_le.
  
  Definition set_int16 : string -> Z -> Z -> unit :=
    Bytes_encodings.set_int16_le.
  
  Definition set_int32 : string -> Z -> int32 -> unit :=
    Bytes_encodings.set_int32_le.
  
  Definition set_int64 : string -> Z -> int64 -> unit :=
    Bytes_encodings.set_int64_le.
End LE.

Definition op_eq {A : Type} : A -> A -> bool := Pervasives.op_eq.

Definition op_ltgt {A : Type} : A -> A -> bool := Pervasives.op_ltgt.

Definition op_lt {A : Type} : A -> A -> bool := Pervasives.op_lt.

Definition op_lteq {A : Type} : A -> A -> bool := Pervasives.op_lteq.

Definition op_gteq {A : Type} : A -> A -> bool := Pervasives.op_gteq.

Definition op_gt {A : Type} : A -> A -> bool := Pervasives.op_gt.

Definition compare : Stdlib.Bytes.t -> Stdlib.Bytes.t -> Z :=
  Stdlib.Bytes.compare.

Definition concat (s : string) (bs : list string) : string :=
  String.concat (Stdlib.Bytes.of_string s) bs.

Definition to_hex (t : string) : Hex.t := Hex.of_bytes None t.

Definition of_hex (hex : Hex.t) : string := Hex.to_bytes hex.

src/lib_stdlib/memory.ml success
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type proc_statm = {
  page_size : int;
  size : int64;
  resident : int64;
  shared : int64;
  text : int64;
  lib : int64;
  data : int64;
  dt : int64;
}

type ps_stats = {page_size : int; mem : float; resident : int64}

type mem_stats = Statm of proc_statm | Ps of ps_stats
src/lib_stdlib/memory.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record proc_statm := {
  page_size : Z;
  size : int64;
  resident : int64;
  shared : int64;
  text : int64;
  lib : int64;
  data : int64;
  dt : int64 }.

Record ps_stats := {
  page_size : Z;
  mem : Z;
  resident : int64 }.

Inductive mem_stats : Type :=
| Statm : proc_statm -> mem_stats
| Ps : ps_stats -> mem_stats.

src/lib_stdlib/option.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let map ~f = function None -> None | Some x -> Some (f x)

let apply ~f = function None -> None | Some x -> f x

let ( >>= ) x f = apply ~f x

let ( >>| ) x f = map ~f x

let iter ~f = function None -> () | Some x -> f x

let unopt ~default = function None -> default | Some x -> x

let unopt_map ~f ~default = function None -> default | Some x -> f x

let unopt_exn err = function Some x -> x | _ -> raise err

let unopt_assert ~loc:(name, line, pos, _) = function
  | Some v ->
      v
  | None ->
      raise (Assert_failure (name, line, pos))

let first_some a b =
  match (a, b) with
  | (None, None) ->
      None
  | (None, Some v) ->
      Some v
  | (Some v, _) ->
      Some v

let try_with f = try Some (f ()) with _ -> None

let some x = Some x

let pp ?(default = "None") pp fmt = function
  | Some value ->
      pp fmt value
  | None ->
      Format.pp_print_text fmt default
src/lib_stdlib/option.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition map {A B : Type} (f : A -> B) (function_parameter : option A)
  : option B :=
  match function_parameter with
  | None => None
  | Some x => Some (f x)
  end.

Definition apply {A B : Type}
  (f : A -> option B) (function_parameter : option A) : option B :=
  match function_parameter with
  | None => None
  | Some x => f x
  end.

Definition op_gtgteq {A B : Type} (x : option A) (f : A -> option B)
  : option B := apply f x.

Definition op_gtgtpipe {A B : Type} (x : option A) (f : A -> B) : option B :=
  map f x.

Definition iter {A : Type} (f : A -> unit) (function_parameter : option A)
  : unit :=
  match function_parameter with
  | None => tt
  | Some x => f x
  end.

Definition unopt {A : Type} (default : A) (function_parameter : option A) : A :=
  match function_parameter with
  | None => default
  | Some x => x
  end.

Definition unopt_map {A B : Type}
  (f : A -> B) (default : B) (function_parameter : option A) : B :=
  match function_parameter with
  | None => default
  | Some x => f x
  end.

Definition unopt_exn {A : Type} (err : exn) (function_parameter : option A)
  : A :=
  match function_parameter with
  | Some x => x
  | _ => Stdlib.raise err
  end.

Definition unopt_assert {A B : Type} (function_parameter : string * Z * Z * A)
  : (option B) -> B :=
  let '(name, line, pos, _) := function_parameter in
  fun function_parameter =>
    match function_parameter with
    | Some v => v
    | None => Stdlib.raise (OCaml.Assert_failure (name, line, pos))
    end.

Definition first_some {A : Type} (a : option A) (b : option A) : option A :=
  match (a, b) with
  | (None, None) => None
  | (None, Some v) => Some v
  | (Some v, _) => Some v
  end.

Definition try_with {A : Type} (f : unit -> A) : option A :=
  (* ❌ Try-with are not handled *)
  try (Some (f tt)).

Definition some {A : Type} (x : A) : option A := Some x.

Definition pp {A : Type} (op_staroptstar : option string)
  : (Stdlib.Format.formatter -> A -> unit) ->
    Stdlib.Format.formatter -> (option A) -> unit :=
  let default :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "None" % string
    end in
  fun pp =>
    fun fmt =>
      fun function_parameter =>
        match function_parameter with
        | Some value => pp fmt value
        | None => Format.pp_print_text fmt default
        end.

src/lib_stdlib/registry.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type S = sig
  type k

  type v

  val register : k -> v -> unit

  val alter : k -> (v -> v) -> unit

  val remove : k -> unit

  val query : k -> v option

  val iter_p : (k -> v -> unit Lwt.t) -> unit Lwt.t

  val fold : (k -> v -> 'a -> 'a) -> 'a -> 'a
end

module Make (M : sig
  type v

  include Map.OrderedType
end) : S with type k = M.t and type v = M.v = struct
  module Reg = Map.Make (M)

  type v = M.v

  type k = Reg.key

  let registry : v Reg.t ref = ref Reg.empty

  let register k v = registry := Reg.add k v !registry

  let alter k f =
    match Reg.find_opt k !registry with
    | None ->
        ()
    | Some v ->
        registry := Reg.add k (f v) !registry

  let remove k = registry := Reg.remove k !registry

  let query k = Reg.find_opt k !registry

  let iter_p f = Lwt.join (Reg.fold (fun k v acc -> f k v :: acc) !registry [])

  let fold f a = Reg.fold f !registry a
end
src/lib_stdlib/registry.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Record signature {k v : Type} := {
    k := k;
    v := v;
    register : k -> v -> unit;
    alter : k -> (v -> v) -> unit;
    remove : k -> unit;
    query : k -> option v;
    iter_p : (k -> v -> Lwt.t unit) -> Lwt.t unit;
    fold : forall {a : Type}, (k -> v -> a -> a) -> a -> a;
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

src/lib_stdlib/ring.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Ring = struct
  type 'a raw = Empty of int | Inited of {data : 'a array; mutable pos : int}

  type 'a t = 'a raw ref

  let create size =
    if size <= 0 then invalid_arg "Ring.create: size must be positive"
    else ref (Empty size)

  let add r v =
    match !r with
    | Empty size ->
        r := Inited {data = Array.make size v; pos = 0}
    | Inited s ->
        s.pos <-
          ( if s.pos = (2 * Array.length s.data) - 1 then Array.length s.data
          else s.pos + 1 ) ;
        s.data.(s.pos mod Array.length s.data) <- v

  let add_and_return_erased r v =
    let replaced =
      match !r with
      | Empty _ ->
          None
      | Inited s ->
          if s.pos >= Array.length s.data - 1 then
            Some s.data.((s.pos + 1) mod Array.length s.data)
          else None
    in
    add r v ; replaced

  let clear r =
    match !r with
    | Empty _ ->
        ()
    | Inited {data; _} ->
        r := Empty (Array.length data)

  let add_list r l = List.iter (add r) l

  let last r =
    match !r with
    | Empty _ ->
        None
    | Inited {data; pos} ->
        Some data.(pos mod Array.length data)

  let fold r ~init ~f =
    match !r with
    | Empty _ ->
        init
    | Inited {data; pos} ->
        let size = Array.length data in
        let acc = ref init in
        for i = 0 to min pos (size - 1) do
          acc := f !acc data.((pos - i) mod size)
        done ;
        !acc

  let elements t = fold t ~init:[] ~f:(fun acc elt -> elt :: acc)

  exception Empty

  let last_exn r = match last r with None -> raise Empty | Some d -> d
end

include Ring

(** Ring Buffer Table *)
module type TABLE = sig
  type t

  type v

  val create : int -> t

  val add : t -> v -> unit

  val add_and_return_erased : t -> v -> v option

  val mem : t -> v -> bool

  val remove : t -> v -> unit

  val clear : t -> unit

  val elements : t -> v list
end

(* fixed size set of Peers id. If the set exceed the maximal allowed capacity, the
   element that was added first is removed when a new one is added *)
module MakeTable (V : Hashtbl.HashedType) = struct
  module Table = Hashtbl.Make (V)

  type raw = {size : int; ring : V.t Ring.t; table : unit Table.t}

  type t = raw ref

  type v = V.t

  let create size =
    ref {size; ring = Ring.create size; table = Table.create size}

  let add {contents = t} v =
    Option.iter (Ring.add_and_return_erased t.ring v) ~f:(Table.remove t.table) ;
    Table.add t.table v ()

  let add_and_return_erased {contents = t} v =
    match Ring.add_and_return_erased t.ring v with
    | None ->
        Table.add t.table v () ; None
    | Some erased ->
        Table.remove t.table erased ;
        Table.add t.table v () ;
        Some erased

  let mem {contents = t} v = Table.mem t.table v

  let remove {contents = t} v = Table.remove t.table v

  let clear ({contents = t} as tt) =
    tt := {t with ring = Ring.create t.size; table = Table.create t.size}

  let elements {contents = t} = Table.fold (fun k _ acc -> k :: acc) t.table []
end
src/lib_stdlib/ring.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Ring.
  Inductive raw (a : Type) : Type :=
  | Empty : Z -> raw a
  | Inited : (array a) -> Z -> raw a.
  
  Arguments Empty {_}.
  Arguments Inited {_}.
  
  Definition t (a : Type) := Stdlib.ref (raw a).
  
  Definition create {A : Type} (size : Z) : Stdlib.ref (raw A) :=
    if OCaml.Stdlib.le size 0 then
      OCaml.Stdlib.invalid_arg "Ring.create: size must be positive" % string
    else
      Stdlib.ref (Empty size).
  
  Definition add {A : Type} (r : Stdlib.ref (raw A)) (v : A) : unit :=
    match Stdlib.op_exclamation r with
    | Empty size =>
      Stdlib.op_coloneq r (Inited {| data := Array.make size v; pos := 0 |})
    | Inited s =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Set record field not handled. *)
        set_record_field s "pos" % string
          (if equiv_decb (pos s) (Z.sub (Z.mul 2 (Array.length (data s))) 1)
            then
            Array.length (data s)
          else
            Z.add (pos s) 1) in
      Array.set (data s) (Z.modulo (pos s) (Array.length (data s))) v
    end.
  
  Definition add_and_return_erased {A : Type} (r : Stdlib.ref (raw A)) (v : A)
    : option A :=
    let replaced :=
      match Stdlib.op_exclamation r with
      | Empty _ => None
      | Inited s =>
        if OCaml.Stdlib.ge (pos s) (Z.sub (Array.length (data s)) 1) then
          Some
            (Array.get (data s)
              (Z.modulo (Z.add (pos s) 1) (Array.length (data s))))
        else
          None
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := add r v in
    replaced.
  
  Definition clear {A : Type} (r : Stdlib.ref (raw A)) : unit :=
    match Stdlib.op_exclamation r with
    | Empty _ => tt
    | Inited {| data := data |} =>
      Stdlib.op_coloneq r (Empty (Array.length data))
    end.
  
  Definition add_list {A : Type} (r : Stdlib.ref (raw A)) (l : list A) : unit :=
    Stdlib.List.iter (add r) l.
  
  Definition last {A : Type} (r : Stdlib.ref (raw A)) : option A :=
    match Stdlib.op_exclamation r with
    | Empty _ => None
    | Inited {| data := data; pos := pos |} =>
      Some (Array.get data (Z.modulo pos (Array.length data)))
    end.
  
  Definition fold {A B : Type}
    (r : Stdlib.ref (raw A)) (init : B) (f : B -> A -> B) : B :=
    match Stdlib.op_exclamation r with
    | Empty _ => init
    | Inited {| data := data; pos := pos |} =>
      let size := Array.length data in
      let acc := Stdlib.ref init in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ For loops not handled. *)
        for in
      Stdlib.op_exclamation acc
    end.
  
  Definition elements {A : Type} (t : Stdlib.ref (raw A)) : list A :=
    fold t [] (fun acc => fun elt => cons elt acc).
  
  (* ❌ The definition of exceptions is not handled. *)
  exception
  
  Definition last_exn {A : Type} (r : Stdlib.ref (raw A)) : A :=
    match last r with
    | None => Stdlib.raise Empty
    | Some d => d
    end.
End Ring.

(* ❌ Structure item `include` not handled. *)
include

Module TABLE.
  Record signature {t v : Type} := {
    t := t;
    v := v;
    create : Z -> t;
    add : t -> v -> unit;
    add_and_return_erased : t -> v -> option v;
    mem : t -> v -> bool;
    remove : t -> v -> unit;
    clear : t -> unit;
    elements : t -> list v;
  }.
  Arguments signature : clear implicits.
End TABLE.

(* ❌ Functors are not handled. *)
functor

src/lib_stdlib/tag.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type _ selector = ..

module type DEF_ARG = sig
  val name : string

  type t

  val doc : string

  val pp : Format.formatter -> t -> unit
end

module type DEF = sig
  include DEF_ARG

  type id

  val id : id

  type _ selector += Me : t selector

  val uid : int
end

module Def (X : DEF_ARG) : DEF with type t = X.t = struct
  include X

  type id = Id

  let id = Id

  type _ selector += Me : t selector

  let uid = Obj.(extension_id @@ extension_constructor @@ Me)
end

type 'a def = (module DEF with type t = 'a)

let def (type a) ?(doc = "undocumented") name pp =
  ( module Def (struct
    let name = name

    type t = a

    let doc = doc

    let pp = pp
  end) : DEF
    with type t = a )

type (_, _) eq = Refl : ('a, 'a) eq

let maybe_eq : type a b. a def -> b def -> (a, b) eq option =
 fun s t ->
  let module S = (val s) in
  let module T = (val t) in
  match S.Me with T.Me -> Some Refl | _ -> None

let selector_of : type a. a def -> a selector =
 fun d ->
  let module D = (val d) in
  D.Me

let name : type a. a def -> string =
 fun d ->
  let module D = (val d) in
  D.name

let doc : type a. a def -> string =
 fun d ->
  let module D = (val d) in
  D.doc

let printer : type a. a def -> Format.formatter -> a -> unit =
 fun d ->
  let module D = (val d) in
  D.pp

let pp_def ppf d = Format.fprintf ppf "tag:%s" (name d)

module Key = struct
  type t = V : 'a def -> t

  type s = S : 'a selector -> s

  let compare (V k0) (V k1) = compare (S (selector_of k0)) (S (selector_of k1))
end

module TagSet = Map.Make (Key)

type t = V : 'a def * 'a -> t

type binding = t

type set = binding TagSet.t

let pp ppf (V (tag, v)) =
  Format.fprintf ppf "@[<1>(%a@ @[%a@])@]" pp_def tag (printer tag) v

let option_map f = function None -> None | Some v -> Some (f v)

let option_bind f = function None -> None | Some v -> f v

let reveal2 : type a b. a def -> b def -> b -> a option =
 fun t u v -> match maybe_eq t u with None -> None | Some Refl -> Some v

let reveal : 'a. 'a def -> binding -> 'a option =
 fun tag -> function V (another, v) -> reveal2 tag another v

let unveil : 'a. 'a def -> binding option -> 'a option =
 fun tag -> option_bind @@ reveal tag

let conceal : 'a. 'a def -> 'a -> binding = fun tag v -> V (tag, v)

let veil : 'a. 'a def -> 'a option -> binding option =
 fun tag -> option_map @@ conceal tag

let empty = TagSet.empty

let is_empty = TagSet.is_empty

let mem tag = TagSet.mem (Key.V tag)

let add tag v = TagSet.add (Key.V tag) (V (tag, v))

let update tag f =
  TagSet.update (Key.V tag) (fun b -> veil tag @@ f @@ unveil tag b)

let singleton tag v = TagSet.singleton (Key.V tag) (V (tag, v))

let remove tag = TagSet.remove (Key.V tag)

let rem = remove

type merger = {merger : 'a. 'a def -> 'a option -> 'a option -> 'a option}

let merge f =
  TagSet.merge
  @@ function
  | Key.V tag ->
      fun a b -> veil tag @@ f.merger tag (unveil tag a) (unveil tag b)

type unioner = {unioner : 'a. 'a def -> 'a -> 'a -> 'a}

let union f =
  merge
    {
      merger =
        (fun tag a b ->
          match (a, b) with
          | (Some aa, Some bb) ->
              Some (f.unioner tag aa bb)
          | (Some _, None) ->
              a
          | (None, _) ->
              b);
    }

(* no compare and equal, compare especially makes little sense *)
let iter f = TagSet.iter (fun _ -> f)

let fold f = TagSet.fold (fun _ -> f)

let for_all p = TagSet.for_all (fun _ -> p)

let exists p = TagSet.exists (fun _ -> p)

let filter p = TagSet.filter (fun _ -> p)

let partition p = TagSet.partition (fun _ -> p)

let cardinal = TagSet.cardinal

let bindings s = List.map snd @@ TagSet.bindings s

let min_binding s = snd @@ TagSet.min_binding s

let min_binding_opt s = option_map snd @@ TagSet.min_binding_opt s

let max_binding s = snd @@ TagSet.max_binding s

let max_binding_opt s = option_map snd @@ TagSet.max_binding_opt s

let choose s = snd @@ TagSet.choose s

let choose_opt s = option_map snd @@ TagSet.choose_opt s

let split tag s =
  (fun (l, m, r) -> (l, unveil tag m, r)) @@ TagSet.split (Key.V tag) s

(* In order to match the usual interface for maps, `find` should be different from
   `find_opt` but `Logs` has `find_opt` called `find` so we favor that. *)
let find tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s

let find_opt tag s = option_bind (reveal tag) @@ TagSet.find_opt (Key.V tag) s

(* This would usually be called `find` but `Logs` has it with this name.  We can't
   have it at both named because `Logs` has `find_opt` as `find`. *)
let get tag s =
  find_opt tag s
  |> function
  | None ->
      invalid_arg (Format.asprintf "tag named %s not found in set" (name tag))
  | Some v ->
      v

let find_first p s = snd @@ TagSet.find_first p s

let find_first_opt p s = option_map snd @@ TagSet.find_first_opt p s

let find_last p s = snd @@ TagSet.find_last p s

let find_last_opt p s = option_map snd @@ TagSet.find_last_opt p s

let map = TagSet.map

let mapi = TagSet.map

let pp_set ppf s =
  Format.(
    fprintf ppf "@[<1>{" ;
    pp_print_list pp ppf (bindings s) ;
    Format.fprintf ppf "}@]")

module DSL = struct
  type (_, _, _, _) arg =
    | A : ('x def * 'x) -> (('b -> 'x -> 'c) -> 'x -> 'd, 'b, 'c, 'd) arg
    | S : ('x def * 'x) -> ('x -> 'd, 'b, 'c, 'd) arg
    | T : ('x def * 'x) -> ('d, 'b, 'c, 'd) arg

  let a tag v = A (tag, v)

  let s tag v = S (tag, v)

  let t tag v = T (tag, v)

  let pp_of_def (type a) tag =
    let module Tg = (val tag : DEF with type t = a) in
    Tg.pp

  let ( -% ) :
      type a d.
      (?tags:set -> a) -> (a, Format.formatter, unit, d) arg -> ?tags:set -> d
      =
   fun f -> function
    | A (tag, v) ->
        fun [@warning "-16"] ?(tags = empty) ->
          f ~tags:(add tag v tags) (pp_of_def tag) v
    | S (tag, v) ->
        fun [@warning "-16"] ?(tags = empty) -> f ~tags:(add tag v tags) v
    | T (tag, v) ->
        fun [@warning "-16"] ?(tags = empty) -> f ~tags:(add tag v tags)
end
src/lib_stdlib/tag.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition selector := False.

Module DEF_ARG.
  Record signature {t : Type} := {
    name : string;
    t := t;
    doc : string;
    pp : Stdlib.Format.formatter -> t -> unit;
  }.
  Arguments signature : clear implicits.
End DEF_ARG.

Module DEF.
  Record signature {t id : Type} := {
    include;
    id := id;
    id : id;
    extensible_type;
    uid : Z;
  }.
  Arguments signature : clear implicits.
End DEF.

(* ❌ Functors are not handled. *)
functor

Definition def (a : Type) := {id : _ & DEF.signature a id}.

Definition def {A : Type} (op_staroptstar : option string)
  : string ->
    (Stdlib.Format.formatter -> A -> unit) -> {id : _ & DEF.signature A id} :=
  let doc :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "undocumented" % string
    end in
  fun name =>
    fun pp =>
      (* ❌ Applications of functors are not supported for first-class module values *)
      unsupported_functor_application.

Inductive eq : forall (_ _ : Type), Type :=
| Refl : forall {a : Type}, eq a a.

Definition maybe_eq {a b : Type} (s : def a) (t : def b) : option (eq a b) :=
  let S := projT2 s in
  let T := projT2 t in
  match Me with
  | Me => Some Refl
  | _ => None
  end.

Definition selector_of {a : Type} (d : def a) : selector a :=
  let D := projT2 d in
  Me.

Definition name {a : Type} (d : def a) : string :=
  let D := projT2 d in
  D.(DEF.name).

Definition doc {a : Type} (d : def a) : string :=
  let D := projT2 d in
  D.(DEF.doc).

Definition printer {a : Type} (d : def a)
  : Stdlib.Format.formatter -> a -> unit :=
  let D := projT2 d in
  D.(DEF.pp).

Definition pp_def {A : Type} (ppf : Stdlib.Format.formatter) (d : def A)
  : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "tag:" % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format)) "tag:%s" % string) (name d).

Module Key.
  Inductive t : Type :=
  | V : forall {a : Type}, (def a) -> t.
  
  Inductive s : Type :=
  | S : forall {a : Type}, (selector a) -> s.
  
  Definition compare (function_parameter : t) : t -> Z :=
    let 'V k0 := function_parameter in
    fun function_parameter =>
      let 'V k1 := function_parameter in
      OCaml.Stdlib.compare (S (selector_of k0)) (S (selector_of k1)).
End Key.

(* ❌ Applications of functors are not handled. *)
functor_application

Inductive t : Type :=
| V : forall {a : Type}, (def a) -> a -> t.

Definition binding := t.

Definition set := TagSet.t binding.

Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t) : unit :=
  let 'V tag v := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<1>" % string
              CamlinternalFormatBasics.End_of_format) "<1>" % string))
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[<1>(%a@ @[%a@])@]" % string) pp_def tag (printer tag) v.

Definition option_map {A B : Type} (f : A -> B) (function_parameter : option A)
  : option B :=
  match function_parameter with
  | None => None
  | Some v => Some (f v)
  end.

Definition option_bind {A B : Type}
  (f : A -> option B) (function_parameter : option A) : option B :=
  match function_parameter with
  | None => None
  | Some v => f v
  end.

Definition reveal2 {a b : Type} (t : def a) (u : def b) (v : b) : option a :=
  match maybe_eq t u with
  | None => None
  | Some Refl => Some v
  end.

Definition reveal {a : Type} (tag : def a) (function_parameter : binding)
  : option a :=
  let 'V another v := function_parameter in
  reveal2 tag another v.

Definition unveil {a : Type} (tag : def a) : (option binding) -> option a :=
  apply option_bind (reveal tag).

Definition conceal {a : Type} (tag : def a) (v : a) : binding := V tag v.

Definition veil {a : Type} (tag : def a) : (option a) -> option binding :=
  apply option_map (conceal tag).

Definition empty {A : Type} : TagSet.t A := TagSet.empty.

Definition is_empty {A : Type} : (TagSet.t A) -> bool := TagSet.is_empty.

Definition mem {A B : Type} (tag : def A) : (TagSet.t B) -> bool :=
  TagSet.mem (Key.V tag).

Definition add {A : Type} (tag : def A) (v : A) : (TagSet.t t) -> TagSet.t t :=
  TagSet.add (Key.V tag) (V tag v).

Definition update {A : Type} (tag : def A) (f : (option A) -> option A)
  : (TagSet.t binding) -> TagSet.t binding :=
  TagSet.update (Key.V tag) (fun b => apply (veil tag) (apply f (unveil tag b))).

Definition singleton {A : Type} (tag : def A) (v : A) : TagSet.t t :=
  TagSet.singleton (Key.V tag) (V tag v).

Definition remove {A B : Type} (tag : def A) : (TagSet.t B) -> TagSet.t B :=
  TagSet.remove (Key.V tag).

Definition rem {A B : Type} : (def A) -> (TagSet.t B) -> TagSet.t B := remove.

Record merger := {
  merger : ((def a) -> (option a) -> (option a) -> option a) * (a) }.

Definition merge (f : merger)
  : (TagSet.t binding) -> (TagSet.t binding) -> TagSet.t binding :=
  apply TagSet.merge
    (fun function_parameter =>
      let 'Key.V tag := function_parameter in
      fun a =>
        fun b => apply (veil tag) ((merger f) tag (unveil tag a) (unveil tag b))).

Record unioner := {
  unioner : ((def a) -> a -> a -> a) * (a) }.

Definition union (f : unioner)
  : (TagSet.t binding) -> (TagSet.t binding) -> TagSet.t binding :=
  merge
    {|
      merger :=
        fun tag =>
          fun a =>
            fun b =>
              match (a, b) with
              | (Some aa, Some bb) => Some ((unioner f) tag aa bb)
              | (Some _, None) => a
              | (None, _) => b
              end |}.

Definition iter {A : Type} (f : A -> unit) : (TagSet.t A) -> unit :=
  TagSet.iter
    (fun function_parameter =>
      let '_ := function_parameter in
      f).

Definition fold {A B : Type} (f : A -> B -> B) : (TagSet.t A) -> B -> B :=
  TagSet.fold
    (fun function_parameter =>
      let '_ := function_parameter in
      f).

Definition for_all {A : Type} (p : A -> bool) : (TagSet.t A) -> bool :=
  TagSet.for_all
    (fun function_parameter =>
      let '_ := function_parameter in
      p).

Definition _exists {A : Type} (p : A -> bool) : (TagSet.t A) -> bool :=
  TagSet._exists
    (fun function_parameter =>
      let '_ := function_parameter in
      p).

Definition filter {A : Type} (p : A -> bool) : (TagSet.t A) -> TagSet.t A :=
  TagSet.filter
    (fun function_parameter =>
      let '_ := function_parameter in
      p).

Definition partition {A : Type} (p : A -> bool)
  : (TagSet.t A) -> (TagSet.t A) * (TagSet.t A) :=
  TagSet.partition
    (fun function_parameter =>
      let '_ := function_parameter in
      p).

Definition cardinal {A : Type} : (TagSet.t A) -> Z := TagSet.cardinal.

Definition bindings {A : Type} (s : TagSet.t A) : list A :=
  apply (List.map snd) (TagSet.bindings s).

Definition min_binding {A : Type} (s : TagSet.t A) : A :=
  apply snd (TagSet.min_binding s).

Definition min_binding_opt {A : Type} (s : TagSet.t A) : option A :=
  apply (option_map snd) (TagSet.min_binding_opt s).

Definition max_binding {A : Type} (s : TagSet.t A) : A :=
  apply snd (TagSet.max_binding s).

Definition max_binding_opt {A : Type} (s : TagSet.t A) : option A :=
  apply (option_map snd) (TagSet.max_binding_opt s).

Definition choose {A : Type} (s : TagSet.t A) : A := apply snd (TagSet.choose s).

Definition choose_opt {A : Type} (s : TagSet.t A) : option A :=
  apply (option_map snd) (TagSet.choose_opt s).

Definition split {A : Type} (tag : def A) (s : TagSet.t binding)
  : (TagSet.t binding) * (option A) * (TagSet.t binding) :=
  apply
    (fun function_parameter =>
      let '(l, m, r) := function_parameter in
      (l, (unveil tag m), r)) (TagSet.split (Key.V tag) s).

Definition find {A : Type} (tag : def A) (s : TagSet.t binding) : option A :=
  apply (option_bind (reveal tag)) (TagSet.find_opt (Key.V tag) s).

Definition find_opt {A : Type} (tag : def A) (s : TagSet.t binding)
  : option A := apply (option_bind (reveal tag)) (TagSet.find_opt (Key.V tag) s).

Definition get {A : Type} (tag : def A) (s : TagSet.t binding) : A :=
  OCaml.Stdlib.reverse_apply (find_opt tag s)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        OCaml.Stdlib.invalid_arg
          (Format.asprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "tag named " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " not found in set" % string
                    CamlinternalFormatBasics.End_of_format)))
              "tag named %s not found in set" % string) (name tag))
      | Some v => v
      end).

Definition find_first {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
  : A := apply snd (TagSet.find_first p s).

Definition find_first_opt {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
  : option A := apply (option_map snd) (TagSet.find_first_opt p s).

Definition find_last {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A) : A :=
  apply snd (TagSet.find_last p s).

Definition find_last_opt {A : Type} (p : TagSet.key -> bool) (s : TagSet.t A)
  : option A := apply (option_map snd) (TagSet.find_last_opt p s).

Definition map {A B : Type} : (A -> B) -> (TagSet.t A) -> TagSet.t B :=
  TagSet.map.

Definition mapi {A B : Type} : (A -> B) -> (TagSet.t A) -> TagSet.t B :=
  TagSet.map.

Definition pp_set (ppf : Stdlib.Format.formatter) (s : TagSet.t t) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<1>" % string
                CamlinternalFormatBasics.End_of_format) "<1>" % string))
          (CamlinternalFormatBasics.Char_literal "{" % char
            CamlinternalFormatBasics.End_of_format)) "@[<1>{" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := pp_print_list None pp ppf (bindings s) in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "}" % char
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Close_box
          CamlinternalFormatBasics.End_of_format)) "}@]" % string).

Module DSL.
  Inductive arg : forall (_ _ _ _ : Type), Type :=
  | A : forall {b c d x : Type}, ((def x) * x) ->
    arg ((b -> x -> c) -> x -> d) b c d
  | S : forall {b c d x : Type}, ((def x) * x) -> arg (x -> d) b c d
  | T : forall {b c d x : Type}, ((def x) * x) -> arg d b c d.
  
  Definition a {A B C D : Type} (tag : def A) (v : A)
    : arg ((B -> A -> C) -> A -> D) B C D := A (tag, v).
  
  Definition s {A B C D : Type} (tag : def A) (v : A) : arg (A -> B) C D B :=
    S (tag, v).
  
  Definition t {A B C D : Type} (tag : def A) (v : A) : arg B C D B :=
    T (tag, v).
  
  Definition pp_of_def {A : Type} (tag : {id : _ & DEF.signature A id})
    : Stdlib.Format.formatter -> A -> unit :=
    let Tg := projT2 tag in
    Tg.(DEF.pp).
  
  Definition op_minuspercent {a d : Type}
    (f : (option set) -> a)
    (function_parameter : arg a Stdlib.Format.formatter unit d)
    : (option set) -> d :=
    match function_parameter with
    | A (tag, v) =>
      fun op_staroptstar =>
        let tags :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => empty
          end in
        f (Some (add tag v tags)) (pp_of_def tag) v
    | S (tag, v) =>
      fun op_staroptstar =>
        let tags :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => empty
          end in
        f (Some (add tag v tags)) v
    | T (tag, v) =>
      fun op_staroptstar =>
        let tags :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => empty
          end in
        f (Some (add tag v tags))
    end.
End DSL.

src/lib_stdlib/test/assert.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf failwith "@[%s@ expected: %s@ got: %s@]" msg expected given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg
src/lib_stdlib/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf OCaml.Stdlib.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let prn :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

src/lib_stdlib/test/test_lwt_pipe.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

let rec producer queue = function
  | 0 ->
      Format.eprintf "Done producing." ;
      Lwt.return_unit
  | n ->
      Lwt_pipe.push queue () >>= fun () -> producer queue (pred n)

let rec consumer queue = function
  | 0 ->
      Format.eprintf "Done consuming." ;
      Lwt.return_unit
  | n ->
      Lwt_pipe.pop queue >>= fun _ -> consumer queue (pred n)

let rec gen acc f = function 0 -> acc | n -> gen (f () :: acc) f (pred n)

let run qsize nbp nbc p c =
  let q = Lwt_pipe.create ~size:(qsize, fun () -> qsize) () in
  let producers = gen [] (fun () -> producer q p) nbp in
  let consumers = gen [] (fun () -> consumer q c) nbc in
  Lwt.join producers <&> Lwt.join consumers

let main () =
  let qsize = ref 10 in
  let nb_producers = ref 10 in
  let nb_consumers = ref 10 in
  let produced_per_producer = ref 10 in
  let consumed_per_consumer = ref 10 in
  let spec =
    Arg.
      [ ("-qsize", Set_int qsize, "<int> Size of the pipe");
        ("-nc", Set_int nb_consumers, "<int> Number of consumers");
        ("-np", Set_int nb_producers, "<int> Number of producers");
        ( "-n",
          Set_int consumed_per_consumer,
          "<int> Number of consumed items per consumers" );
        ( "-p",
          Set_int produced_per_producer,
          "<int> Number of produced items per producers" );
        ( "-v",
          Unit (fun () -> Lwt_log_core.(add_rule "*" Info)),
          " Log up to info msgs" );
        ( "-vv",
          Unit (fun () -> Lwt_log_core.(add_rule "*" Debug)),
          " Log up to debug msgs" ) ]
  in
  let anon_fun _ = () in
  let usage_msg = "Usage: %s <num_peers>.\nArguments are:" in
  Arg.parse spec anon_fun usage_msg ;
  run
    !qsize
    !nb_producers
    !nb_consumers
    !produced_per_producer
    !consumed_per_consumer

let () = Lwt_main.run @@ main ()
src/lib_stdlib/test/test_lwt_pipe.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Fixpoint producer
  (queue : Tezos_stdlib.Lwt_pipe.t unit) (function_parameter : Z)
  : Lwt.t unit :=
  match function_parameter with
  | 0 =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Done producing." % string
            CamlinternalFormatBasics.End_of_format) "Done producing." % string)
      in
    Lwt.return_unit
  | n =>
    op_gtgteq (Lwt_pipe.push queue tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        producer queue (Z.pred n))
  end.

Fixpoint consumer {A : Type}
  (queue : Tezos_stdlib.Lwt_pipe.t A) (function_parameter : Z) : Lwt.t unit :=
  match function_parameter with
  | 0 =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Done consuming." % string
            CamlinternalFormatBasics.End_of_format) "Done consuming." % string)
      in
    Lwt.return_unit
  | n =>
    op_gtgteq (Lwt_pipe.pop queue)
      (fun function_parameter =>
        let '_ := function_parameter in
        consumer queue (Z.pred n))
  end.

Fixpoint gen {A : Type} (acc : list A) (f : unit -> A) (function_parameter : Z)
  : list A :=
  match function_parameter with
  | 0 => acc
  | n => gen (cons (f tt) acc) f (Z.pred n)
  end.

Definition run (qsize : Z) (nbp : Z) (nbc : Z) (p : Z) (c : Z) : Lwt.t unit :=
  let q :=
    Lwt_pipe.create
      (Some
        (qsize,
          (fun function_parameter =>
            let 'tt := function_parameter in
            qsize))) tt in
  let producers :=
    gen []
      (fun function_parameter =>
        let 'tt := function_parameter in
        producer q p) nbp in
  let consumers :=
    gen []
      (fun function_parameter =>
        let 'tt := function_parameter in
        consumer q c) nbc in
  op_ltandgt (Lwt.join producers) (Lwt.join consumers).

Definition main (function_parameter : unit) : Lwt.t unit :=
  let 'tt := function_parameter in
  let qsize := Stdlib.ref 10 in
  let nb_producers := Stdlib.ref 10 in
  let nb_consumers := Stdlib.ref 10 in
  let produced_per_producer := Stdlib.ref 10 in
  let consumed_per_consumer := Stdlib.ref 10 in
  let spec :=
    cons
      ("-qsize" % string, (Stdlib.Arg.Set_int qsize),
        "<int> Size of the pipe" % string)
      (cons
        ("-nc" % string, (Stdlib.Arg.Set_int nb_consumers),
          "<int> Number of consumers" % string)
        (cons
          ("-np" % string, (Stdlib.Arg.Set_int nb_producers),
            "<int> Number of producers" % string)
          (cons
            ("-n" % string, (Stdlib.Arg.Set_int consumed_per_consumer),
              "<int> Number of consumed items per consumers" % string)
            (cons
              ("-p" % string, (Stdlib.Arg.Set_int produced_per_producer),
                "<int> Number of produced items per producers" % string)
              (cons
                ("-v" % string,
                  (Stdlib.Arg.Unit
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_startypeminuserrorstar)),
                  " Log up to info msgs" % string)
                (cons
                  ("-vv" % string,
                    (Stdlib.Arg.Unit
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_startypeminuserrorstar)),
                    " Log up to debug msgs" % string) [])))))) in
  let anon_fun {A : Type} (function_parameter : A) : unit :=
    let '_ := function_parameter in
    tt in
  let usage_msg := "Usage: %s <num_peers>.
Arguments are:" % string in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Arg.parse spec anon_fun usage_msg in
  run (Stdlib.op_exclamation qsize) (Stdlib.op_exclamation nb_producers)
    (Stdlib.op_exclamation nb_consumers)
    (Stdlib.op_exclamation produced_per_producer)
    (Stdlib.op_exclamation consumed_per_consumer).



src/lib_stdlib/test/test_tzList.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rec permut = function
  | [] ->
      [[]]
  | x :: xs ->
      let insert xs =
        let rec loop acc left right =
          match right with
          | [] ->
              List.rev (x :: left) :: acc
          | y :: ys ->
              loop (List.rev_append left (x :: right) :: acc) (y :: left) ys
        in
        loop [] [] xs
      in
      List.concat (List.map insert (permut xs))

let test_take_n _ =
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs -> Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 1 xs) [9]) ;
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs ->
      Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 3 xs) [7; 8; 9]) ;
  let inv_compare x y = compare y x in
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs ->
      Assert.equal
        ~msg:__LOC__
        (TzList.take_n ~compare:inv_compare 3 xs)
        [3; 2; 1]) ;
  (* less elements than the bound. *)
  ListLabels.iter
    (permut [1; 2; 3; 4; 5; 6; 7; 8; 9])
    ~f:(fun xs ->
      Assert.equal
        ~msg:__LOC__
        (TzList.take_n ~compare 12 xs)
        [1; 2; 3; 4; 5; 6; 7; 8; 9]) ;
  (* with duplicates. *)
  ListLabels.iter
    (permut [1; 2; 3; 3; 4; 5; 5; 5; 6])
    ~f:(fun xs ->
      Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 3 xs) [5; 5; 6]) ;
  ListLabels.iter
    (permut [1; 2; 3; 3; 4; 5; 5; 5; 6])
    ~f:(fun xs ->
      Assert.equal ~msg:__LOC__ (TzList.take_n ~compare 5 xs) [4; 5; 5; 5; 6])

let tests = [("take_n", `Quick, test_take_n)]

let () = Alcotest.run "stdlib" [("tzList", tests)]
src/lib_stdlib/test/test_tzList.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint permut {A : Type} (function_parameter : list A) : list (list A) :=
  match function_parameter with
  | [] => cons [] []
  | cons x xs =>
    let insert (xs : list A) : list (list A) :=
      let fix loop (acc : list (list A)) (left : list A) (right : list A)
        : list (list A) :=
        match right with
        | [] => cons (List.rev (cons x left)) acc
        | cons y ys =>
          loop (cons (Stdlib.List.rev_append left (cons x right)) acc)
            (cons y left) ys
        end in
      loop [] [] xs in
    Stdlib.List.concat (List.map insert (permut xs))
  end.

Definition test_take_n {A : Type} (function_parameter : A) : unit :=
  let '_ := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    ListLabels.iter
      (fun xs =>
        op_startypeminuserrorstar Stdlib.__LOC__
          (TzList.take_n (Some OCaml.Stdlib.compare) 1 xs) (cons 9 []))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    ListLabels.iter
      (fun xs =>
        op_startypeminuserrorstar Stdlib.__LOC__
          (TzList.take_n (Some OCaml.Stdlib.compare) 3 xs)
          (cons 7 (cons 8 (cons 9 []))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
    in
  let inv_compare {B : Type} (x : B) (y : B) : Z :=
    OCaml.Stdlib.compare y x in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    ListLabels.iter
      (fun xs =>
        op_startypeminuserrorstar Stdlib.__LOC__
          (TzList.take_n (Some inv_compare) 3 xs) (cons 3 (cons 2 (cons 1 []))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    ListLabels.iter
      (fun xs =>
        op_startypeminuserrorstar Stdlib.__LOC__
          (TzList.take_n (Some OCaml.Stdlib.compare) 12 xs)
          (cons 1
            (cons 2
              (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 4 (cons 5 (cons 6 (cons 7 (cons 8 (cons 9 []))))))))))
    in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    ListLabels.iter
      (fun xs =>
        op_startypeminuserrorstar Stdlib.__LOC__
          (TzList.take_n (Some OCaml.Stdlib.compare) 3 xs)
          (cons 5 (cons 5 (cons 6 []))))
      (permut
        (cons 1
          (cons 2
            (cons 3 (cons 3 (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))))))
    in
  ListLabels.iter
    (fun xs =>
      op_startypeminuserrorstar Stdlib.__LOC__
        (TzList.take_n (Some OCaml.Stdlib.compare) 5 xs)
        (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 []))))))
    (permut
      (cons 1
        (cons 2
          (cons 3 (cons 3 (cons 4 (cons 5 (cons 5 (cons 5 (cons 6 [])))))))))).

Definition tests {A : Type} : list (string * variant * (A -> unit)) :=
  cons
    ("take_n" % string,
      (* ❌ Variants not supported *)
      variant, test_take_n) [].



src/lib_stdlib/tzEndian.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Bytes_encodings

let set_int32 = set_int32_be

let get_int32 = get_int32_be

let set_int8 = set_int8

let get_int8 = get_int8

let set_int16 = set_int16_be

let get_int16 = get_int16_be

let set_int64 = set_int64_be

let get_int64 = get_int64_be

let get_uint8 = get_uint8

let get_uint16 = get_uint16_be

let get_double buff i = Int64.float_of_bits (get_int64_be buff i)

let set_double buff i v = set_int64_be buff i (Int64.bits_of_float v)
src/lib_stdlib/tzEndian.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Bytes_encodings.

Definition set_int32 : string -> Z -> int32 -> unit := set_int32_be.

Definition get_int32 : string -> Z -> int32 := get_int32_be.

Definition set_int8 : string -> Z -> Z -> unit := set_int8.

Definition get_int8 : string -> Z -> Z := get_int8.

Definition set_int16 : string -> Z -> Z -> unit := set_int16_be.

Definition get_int16 : string -> Z -> Z := get_int16_be.

Definition set_int64 : string -> Z -> int64 -> unit := set_int64_be.

Definition get_int64 : string -> Z -> int64 := get_int64_be.

Definition get_uint8 : string -> Z -> Z := get_uint8.

Definition get_uint16 : string -> Z -> Z := get_uint16_be.

Definition get_double (buff : string) (i : Z) : Z :=
  Int64.float_of_bits (get_int64_be buff i).

Definition set_double (buff : string) (i : Z) (v : Z) : unit :=
  set_int64_be buff i (Int64.bits_of_float v).

src/lib_stdlib/tzList.ml 5 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let may_cons xs x = match x with None -> xs | Some x -> x :: xs

let filter_map f l =
  List.rev @@ List.fold_left (fun acc x -> may_cons acc (f x)) [] l

let rev_sub l n =
  if n < 0 then invalid_arg "Utils.rev_sub: `n` must be non-negative." ;
  let rec append_rev_sub acc l = function
    | 0 ->
        acc
    | n -> (
      match l with
      | [] ->
          acc
      | hd :: tl ->
          append_rev_sub (hd :: acc) tl (n - 1) )
  in
  append_rev_sub [] l n

let sub l n = rev_sub l n |> List.rev

let hd_opt = function [] -> None | h :: _ -> Some h

let rec last_exn = function
  | [] ->
      raise Not_found
  | [x] ->
      x
  | _ :: xs ->
      last_exn xs

let merge_filter2 ?(finalize = List.rev) ?(compare = compare)
    ?(f = Option.first_some) l1 l2 =
  let sort = List.sort compare in
  let rec merge_aux acc = function
    | ([], []) ->
        finalize acc
    | (r1, []) ->
        finalize acc @ filter_map (fun x1 -> f (Some x1) None) r1
    | ([], r2) ->
        finalize acc @ filter_map (fun x2 -> f None (Some x2)) r2
    | ((h1 :: t1 as r1), (h2 :: t2 as r2)) ->
        if compare h1 h2 > 0 then
          merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
        else if compare h1 h2 < 0 then
          merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
        else
          (* m1 = m2 *)
          merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
  in
  merge_aux [] (sort l1, sort l2)

let merge2 ?finalize ?compare ?(f = fun x1 _x1 -> x1) l1 l2 =
  merge_filter2
    ?finalize
    ?compare
    ~f:(fun x1 x2 ->
      match (x1, x2) with
      | (None, None) ->
          assert false
      | (Some x1, None) ->
          Some x1
      | (None, Some x2) ->
          Some x2
      | (Some x1, Some x2) ->
          Some (f x1 x2))
    l1
    l2

let rec remove nb = function
  | [] ->
      []
  | l when nb <= 0 ->
      l
  | _ :: tl ->
      remove (nb - 1) tl

let rec repeat n x = if n <= 0 then [] else x :: repeat (pred n) x

let split_n n l =
  let rec loop acc n = function
    | [] ->
        (l, [])
    | rem when n <= 0 ->
        (List.rev acc, rem)
    | x :: xs ->
        loop (x :: acc) (pred n) xs
  in
  loop [] n l

let take_n_unsorted n l = fst (split_n n l)

module Bounded (E : Set.OrderedType) : sig
  type t

  val create : int -> t

  val insert : E.t -> t -> unit

  val get : t -> E.t list
end = struct
  (* TODO one day replace the list by an heap array *)

  type t = {bound : int; mutable size : int; mutable data : E.t list}

  let create bound =
    if bound <= 0 then invalid_arg "Utils.Bounded(_).create" ;
    {bound; size = 0; data = []}

  let rec push x = function
    | [] ->
        [x]
    | y :: xs as ys ->
        if E.compare x y <= 0 then x :: ys else y :: push x xs

  let insert x t =
    if t.size < t.bound then (
      t.size <- t.size + 1 ;
      t.data <- push x t.data )
    else
      match t.data with
      | [] ->
          assert false
      | hd :: tl ->
          if E.compare hd x < 0 then t.data <- push x tl

  let get {data; _} = data
end

let take_n_sorted (type a) compare n l =
  let module B = Bounded (struct
    type t = a

    let compare = compare
  end) in
  let t = B.create n in
  List.iter (fun x -> B.insert x t) l ;
  B.get t

let take_n ?compare n l =
  match compare with
  | None ->
      take_n_unsorted n l
  | Some compare ->
      take_n_sorted compare n l

let select n l =
  let rec loop n acc = function
    | [] ->
        invalid_arg "Utils.select"
    | x :: xs when n <= 0 ->
        (x, List.rev_append acc xs)
    | x :: xs ->
        loop (pred n) (x :: acc) xs
  in
  loop n [] l

let shift = function [] -> [] | hd :: tl -> tl @ [hd]

let rec product a b =
  match a with
  | [] ->
      []
  | hd :: tl ->
      List.map (fun x -> (hd, x)) b @ product tl b

let shuffle l =
  l
  |> List.map (fun d -> (Random.bits (), d))
  |> List.sort (fun (x, _) (y, _) -> compare x y)
  |> List.map snd
src/lib_stdlib/tzList.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition may_cons {A : Type} (xs : list A) (x : option A) : list A :=
  match x with
  | None => xs
  | Some x => cons x xs
  end.

Definition filter_map {A B : Type} (f : A -> option B) (l : list A) : list B :=
  apply List.rev
    (Stdlib.List.fold_left (fun acc => fun x => may_cons acc (f x)) [] l).

Definition rev_sub {A : Type} (l : list A) (n : Z) : list A :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if OCaml.Stdlib.lt n 0 then
      OCaml.Stdlib.invalid_arg
        "Utils.rev_sub: `n` must be non-negative." % string
    else
      tt in
  let fix append_rev_sub {B : Type}
    (acc : list B) (l : list B) (function_parameter : Z) : list B :=
    match function_parameter with
    | 0 => acc
    | n =>
      match l with
      | [] => acc
      | cons hd tl => append_rev_sub (cons hd acc) tl (Z.sub n 1)
      end
    end in
  append_rev_sub [] l n.

Definition sub {A : Type} (l : list A) (n : Z) : list A :=
  OCaml.Stdlib.reverse_apply (rev_sub l n) List.rev.

Definition hd_opt {A : Type} (function_parameter : list A) : option A :=
  match function_parameter with
  | [] => None
  | cons h _ => Some h
  end.

Fixpoint last_exn {A : Type} (function_parameter : list A) : A :=
  match function_parameter with
  | [] => Stdlib.raise OCaml.Not_found
  | cons x [] => x
  | cons _ xs => last_exn xs
  end.

Definition merge_filter2 {A : Type}
  (op_staroptstar : option ((list A) -> list A))
  : (option (A -> A -> Z)) ->
    (option ((option A) -> (option A) -> option A)) ->
      (list A) -> (list A) -> list A :=
  let finalize :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => List.rev
    end in
  fun op_staroptstar =>
    let compare :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => OCaml.Stdlib.compare
      end in
    fun op_staroptstar =>
      let f :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => Option.first_some
        end in
      fun l1 =>
        fun l2 =>
          let sort := Stdlib.List.sort compare in
          let fix merge_aux
            (acc : list A) (function_parameter : (list A) * (list A))
            : list A :=
            match function_parameter with
            | ([], []) => finalize acc
            | (r1, []) =>
              OCaml.Stdlib.app (finalize acc)
                (filter_map (fun x1 => f (Some x1) None) r1)
            | ([], r2) =>
              OCaml.Stdlib.app (finalize acc)
                (filter_map (fun x2 => f None (Some x2)) r2)
            | ((cons h1 t1) as r1, (cons h2 t2) as r2) =>
              if OCaml.Stdlib.gt (compare h1 h2) 0 then
                merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
              else
                if OCaml.Stdlib.lt (compare h1 h2) 0 then
                  merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
                else
                  merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
            end in
          merge_aux [] ((sort l1), (sort l2)).

Definition merge2 {A : Type}
  (finalize : option ((list A) -> list A)) (compare : option (A -> A -> Z))
  (op_staroptstar : option (A -> A -> A)) : (list A) -> (list A) -> list A :=
  let f :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => fun x1 => fun _x1 => x1
    end in
  fun l1 =>
    fun l2 =>
      merge_filter2 finalize compare
        (Some
          (fun x1 =>
            fun x2 =>
              match (x1, x2) with
              | (None, None) =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              | (Some x1, None) => Some x1
              | (None, Some x2) => Some x2
              | (Some x1, Some x2) => Some (f x1 x2)
              end)) l1 l2.

Fixpoint remove {A : Type} (nb : Z) (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => []
  | l => l
  | cons _ tl => remove (Z.sub nb 1) tl
  end.

Fixpoint repeat {A : Type} (n : Z) (x : A) : list A :=
  if OCaml.Stdlib.le n 0 then
    []
  else
    cons x (repeat (Z.pred n) x).

Definition split_n {A : Type} (n : Z) (l : list A) : (list A) * (list A) :=
  let fix loop (acc : list A) (n : Z) (function_parameter : list A)
    : (list A) * (list A) :=
    match function_parameter with
    | [] => (l, [])
    | rem => ((List.rev acc), rem)
    | cons x xs => loop (cons x acc) (Z.pred n) xs
    end in
  loop [] n l.

Definition take_n_unsorted {A : Type} (n : Z) (l : list A) : list A :=
  fst (split_n n l).

(* ❌ Functors are not handled. *)
functor

Definition take_n_sorted {A : Type} (compare : A -> A -> Z) (n : Z) (l : list A)
  : list A :=
  let B :=
    (* ❌ Applications of functors are not supported for first-class module values *)
    unsupported_functor_application in
  let t := B.create n in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Stdlib.List.iter (fun x => B.insert x t) l in
  B.get t.

Definition take_n {A : Type}
  (compare : option (A -> A -> Z)) (n : Z) (l : list A) : list A :=
  match compare with
  | None => take_n_unsorted n l
  | Some compare => take_n_sorted compare n l
  end.

Definition select {A : Type} (n : Z) (l : list A) : A * (list A) :=
  let fix loop {B : Type} (n : Z) (acc : list B) (function_parameter : list B)
    : B * (list B) :=
    match function_parameter with
    | [] => OCaml.Stdlib.invalid_arg "Utils.select" % string
    | cons x xs => (x, (Stdlib.List.rev_append acc xs))
    | cons x xs => loop (Z.pred n) (cons x acc) xs
    end in
  loop n [] l.

Definition shift {A : Type} (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => []
  | cons hd tl => OCaml.Stdlib.app tl (cons hd [])
  end.

Fixpoint product {A B : Type} (a : list A) (b : list B) : list (A * B) :=
  match a with
  | [] => []
  | cons hd tl =>
    OCaml.Stdlib.app (List.map (fun x => (hd, x)) b) (product tl b)
  end.

Definition shuffle {A : Type} (l : list A) : list A :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply l (List.map (fun d => ((Random.bits tt), d))))
      (Stdlib.List.sort
        (fun function_parameter =>
          let '(x, _) := function_parameter in
          fun function_parameter =>
            let '(y, _) := function_parameter in
            OCaml.Stdlib.compare x y))) (List.map snd).

src/lib_stdlib/tzString.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Set = Set.Make (String)
module Map = Map.Make (String)

let split delim ?(dup = true) ?(limit = max_int) path =
  let l = String.length path in
  let rec do_slashes acc limit i =
    if i >= l then List.rev acc
    else if path.[i] = delim then
      if dup then do_slashes acc limit (i + 1) else do_split acc limit (i + 1)
    else do_split acc limit i
  and do_split acc limit i =
    if limit <= 0 then
      if i = l then List.rev acc
      else List.rev (String.sub path i (l - i) :: acc)
    else do_component acc (pred limit) i i
  and do_component acc limit i j =
    if j >= l then
      if i = j then List.rev acc
      else List.rev (String.sub path i (j - i) :: acc)
    else if path.[j] = delim then
      do_slashes (String.sub path i (j - i) :: acc) limit j
    else do_component acc limit i (j + 1)
  in
  if limit > 0 then do_slashes [] limit 0 else [path]

let split_path path = split '/' path

let has_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  n >= x && String.sub s 0 x = prefix

let remove_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  if n >= x && String.sub s 0 x = prefix then Some (String.sub s x (n - x))
  else None

let common_prefix s1 s2 =
  let last = min (String.length s1) (String.length s2) in
  let rec loop i =
    if last <= i then last else if s1.[i] = s2.[i] then loop (i + 1) else i
  in
  loop 0

let mem_char s c = String.index_opt s c <> None

let fold_left f init s =
  let acc = ref init in
  String.iter (fun c -> acc := f !acc c) s ;
  !acc

let is_hex s =
  let len = String.length s in
  len mod 2 = 0
  &&
  try
    for i = 0 to len - 1 do
      match s.[i] with
      | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' ->
          ()
      | _ ->
          raise Exit
    done ;
    true
  with Exit -> false
src/lib_stdlib/tzString.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Definition split (delim : ascii) (op_staroptstar : option bool)
  : (option Z) -> string -> list string :=
  let dup :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun op_staroptstar =>
    let limit :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Stdlib.max_int
      end in
    fun path =>
      let l := OCaml.String.length path in
      let fix do_slashes (acc : list string) (limit : Z) (i : Z)
        : list string :=
        if OCaml.Stdlib.ge i l then
          List.rev acc
        else
          if equiv_decb (Stdlib.String.get path i) delim then
            if dup then
              do_slashes acc limit (Z.add i 1)
            else
              do_split acc limit (Z.add i 1)
          else
            do_split acc limit i
      with do_split (acc : list string) (limit : Z) (i : Z) : list string :=
        if OCaml.Stdlib.le limit 0 then
          if equiv_decb i l then
            List.rev acc
          else
            List.rev (cons (Stdlib.String.sub path i (Z.sub l i)) acc)
        else
          do_component acc (Z.pred limit) i i
      with do_component (acc : list string) (limit : Z) (i : Z) (j : Z)
        : list string :=
        if OCaml.Stdlib.ge j l then
          if equiv_decb i j then
            List.rev acc
          else
            List.rev (cons (Stdlib.String.sub path i (Z.sub j i)) acc)
        else
          if equiv_decb (Stdlib.String.get path j) delim then
            do_slashes (cons (Stdlib.String.sub path i (Z.sub j i)) acc) limit j
          else
            do_component acc limit i (Z.add j 1) in
      if OCaml.Stdlib.gt limit 0 then
        do_slashes [] limit 0
      else
        cons path [].

Definition split_path (path : string) : list string :=
  split "/" % char None None path.

Definition has_prefix (prefix : string) (s : string) : bool :=
  let x := OCaml.String.length prefix in
  let n := OCaml.String.length s in
  andb (OCaml.Stdlib.ge n x) (equiv_decb (Stdlib.String.sub s 0 x) prefix).

Definition remove_prefix (prefix : string) (s : string) : option string :=
  let x := OCaml.String.length prefix in
  let n := OCaml.String.length s in
  if andb (OCaml.Stdlib.ge n x) (equiv_decb (Stdlib.String.sub s 0 x) prefix)
    then
    Some (Stdlib.String.sub s x (Z.sub n x))
  else
    None.

Definition common_prefix (s1 : string) (s2 : string) : Z :=
  let last := OCaml.Stdlib.min (OCaml.String.length s1) (OCaml.String.length s2)
    in
  let fix loop (i : Z) : Z :=
    if OCaml.Stdlib.le last i then
      last
    else
      if equiv_decb (Stdlib.String.get s1 i) (Stdlib.String.get s2 i) then
        loop (Z.add i 1)
      else
        i in
  loop 0.

Definition mem_char (s : string) (c : ascii) : bool :=
  nequiv_decb (Stdlib.String.index_opt s c) None.

Definition fold_left {A : Type} (f : A -> ascii -> A) (init : A) (s : string)
  : A :=
  let acc := Stdlib.ref init in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Stdlib.String.iter
      (fun c => Stdlib.op_coloneq acc (f (Stdlib.op_exclamation acc) c)) s in
  Stdlib.op_exclamation acc.

Definition is_hex (s : string) : bool :=
  let len := OCaml.String.length s in
  andb (equiv_decb (Z.modulo len 2) 0)
    (* ❌ Try-with are not handled *)
    (try
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      (let _ :=
        (* ❌ For loops not handled. *)
        for in
      true)).

src/lib_stdlib/utils.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Infix = struct
  let ( -- ) i j = List.init (j - i + 1) (fun x -> x + i)
end

let cut ?(copy = false) sz bytes =
  let length = Bytes.length bytes in
  if length <= sz then [bytes] (* if the result fits in the given sz *)
  else
    let may_copy = if copy then Bytes.copy else fun t -> t in
    let nb_full = length / sz in
    (* nb of blocks of size sz *)
    let sz_full = nb_full * sz in
    (* size of the full part *)
    let acc =
      (* eventually init acc with a non-full block *)
      if sz_full = length then []
      else [may_copy (Bytes.sub bytes sz_full (length - sz_full))]
    in
    let rec split_full_blocks curr_upper_limit acc =
      let start = curr_upper_limit - sz in
      assert (start >= 0) ;
      (* copy the block [ start, curr_upper_limit [ of size sz *)
      let acc = may_copy (Bytes.sub bytes start sz) :: acc in
      if start = 0 then acc else split_full_blocks start acc
    in
    split_full_blocks sz_full acc

let nbsp = Re.(compile (str "\xC2\xA0"))

let display_paragraph ppf description =
  Format.fprintf
    ppf
    "@[%a@]"
    (Format.pp_print_list ~pp_sep:Format.pp_print_newline (fun ppf line ->
         Format.pp_print_list
           ~pp_sep:Format.pp_print_space
           (fun ppf w ->
             (* replace &nbsp; by real spaces... *)
             Format.fprintf
               ppf
               "%s@ "
               (Re.replace ~all:true nbsp ~f:(fun _ -> " ") w))
           ppf
           (TzString.split ' ' line)))
    (TzString.split ~dup:false '\n' description)

let finalize f g =
  try
    let res = f () in
    g () ; res
  with exn -> g () ; raise exn
src/lib_stdlib/utils.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Infix.
  Definition op_minusminus (i : Z) (j : Z) : list Z :=
    Stdlib.List.init (Z.add (Z.sub j i) 1) (fun x => Z.add x i).
End Infix.

Definition cut (op_staroptstar : option bool) : Z -> string -> list string :=
  let copy :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun sz =>
    fun bytes =>
      let length := String.length string in
      if OCaml.Stdlib.le length sz then
        cons string []
      else
        let may_copy :=
          if copy then
            Stdlib.Bytes.copy
          else
            fun t => t in
        let nb_full := Z.div length sz in
        let sz_full := Z.mul nb_full sz in
        let acc :=
          if equiv_decb sz_full length then
            []
          else
            cons (may_copy (String.sub string sz_full (Z.sub length sz_full)))
              [] in
        let fix split_full_blocks (curr_upper_limit : Z) (acc : list string)
          : list string :=
          let start := Z.sub curr_upper_limit sz in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (OCaml.Stdlib.ge start 0) in
          let acc := cons (may_copy (String.sub string start sz)) acc in
          if equiv_decb start 0 then
            acc
          else
            split_full_blocks start acc in
        split_full_blocks sz_full acc.

Definition nbsp : Re.re := compile (str " " % string).

Definition display_paragraph
  (ppf : Stdlib.Format.formatter) (description : string) : unit :=
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[%a@]" % string)
    (Format.pp_print_list (Some Format.pp_print_newline)
      (fun ppf =>
        fun line =>
          Format.pp_print_list (Some Format.pp_print_space)
            (fun ppf =>
              fun w =>
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format)) "%s@ " % string)
                  (Re.replace None None (Some true) nbsp
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      " " % string) w)) ppf
            (TzString.split " " % char None None line)))
    (TzString.split "010" % char (Some false) None description).

Definition finalize {A : Type} (f : unit -> A) (g : unit -> unit) : A :=
  (* ❌ Try-with are not handled *)
  try
    (let res := f tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := g tt in
    res).

src/lib_stdlib/weakRingTable.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, Inc. <contact@nomadic-labs.com>          *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
module type S = sig
  type 'a t

  type key

  val create : int -> 'a t

  val add : 'a t -> key -> 'a -> unit

  val add_and_return_erased : 'a t -> key -> 'a -> key option

  val iter : (key -> 'a -> unit) -> 'a t -> unit

  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b

  val find_opt : 'a t -> key -> 'a option

  val remove : 'a t -> key -> unit

  val length : 'a t -> int
end

module Make (M : Hashtbl.HashedType) = struct
  module Table = Ephemeron.K1.Make (struct
    type t = int

    let hash a = a

    let equal = ( = )
  end)

  module Ring = Ring.MakeTable (struct
    type t = int * M.t

    let hash (i, _) = i

    let equal = ( = )
  end)

  type key = M.t

  module Visit_tracking = Set.Make (struct
    type t = int

    let compare = Pervasives.compare
  end)

  type 'a t = {table : 'a Table.t; ring : Ring.t}

  let create n = {table = Table.create n; ring = Ring.create n}

  let add {ring; table} k v =
    let i = M.hash k in
    Ring.add ring (i, k) ;
    Table.replace table i v

  let add_and_return_erased {ring; table} k v =
    let i = M.hash k in
    let erased = Option.map ~f:snd (Ring.add_and_return_erased ring (i, k)) in
    Table.replace table i v ; erased

  let find_opt {table; _} k =
    let i = M.hash k in
    Table.find_opt table i

  let fold f {table; ring} acc =
    let elts = Ring.elements ring in
    let (res, _) =
      List.fold_left
        (fun (acc, visited) (i, k) ->
          if Visit_tracking.mem i visited then (acc, visited)
          else
            match Table.find_opt table i with
            | None ->
                (acc, visited)
            | Some elt ->
                (f k elt acc, Visit_tracking.add i visited))
        (acc, Visit_tracking.empty)
        elts
    in
    res

  let iter f t = fold (fun k v () -> f k v) t ()

  let remove t k =
    let i = M.hash k in
    Table.remove t.table i

  let length {table; _} = Table.length table
end
src/lib_stdlib/weakRingTable.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module S.
  Record signature {t key : Type} := {
    polymorphic_abstract_type;
    key := key;
    create : forall {a : Type}, Z -> t a;
    add : forall {a : Type}, (t a) -> key -> a -> unit;
    add_and_return_erased : forall {a : Type}, (t a) -> key -> a -> option key;
    iter : forall {a : Type}, (key -> a -> unit) -> (t a) -> unit;
    fold : forall {a b : Type}, (key -> a -> b -> b) -> (t a) -> b -> b;
    find_opt : forall {a : Type}, (t a) -> key -> option a;
    remove : forall {a : Type}, (t a) -> key -> unit;
    length : forall {a : Type}, (t a) -> Z;
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

src/lib_stdlib_unix/animation.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let animation =
  [| "|.....|";
     "|o....|";
     "|oo...|";
     "|ooo..|";
     "|.ooo.|";
     "|..ooo|";
     "|...oo|";
     "|....o|";
     "|.....|";
     "|.....|";
     "|.....|";
     "|.....|" |]

let init = String.make (String.length animation.(0)) ' '

let clean = String.make (String.length animation.(0)) '\b'

let animation = Array.map (fun x -> clean ^ x) animation

let number_of_frames = Array.length animation

let make_with_animation ppf ~make ~on_retry seed =
  Format.fprintf ppf "%s%!" init ;
  let rec loop n seed =
    let start = Mtime_clock.counter () in
    Format.fprintf ppf "%s%!" animation.(n mod number_of_frames) ;
    match make seed with
    | Ok v ->
        v
    | Error r ->
        let time = Mtime_clock.count start in
        let v = on_retry time r in
        loop (n + 1) v
  in
  let result = loop 0 seed in
  Format.fprintf ppf "%s%s\n%!" clean init ;
  result
src/lib_stdlib_unix/animation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition animation : array string :=
  (* ❌ Arrays not handled. *)
  [
    "|.....|" % string;
    "|o....|" % string;
    "|oo...|" % string;
    "|ooo..|" % string;
    "|.ooo.|" % string;
    "|..ooo|" % string;
    "|...oo|" % string;
    "|....o|" % string;
    "|.....|" % string;
    "|.....|" % string;
    "|.....|" % string;
    "|.....|" % string
  ].

Definition init : string :=
  Stdlib.String.make (OCaml.String.length (Array.get animation 0)) " " % char.

Definition clean : string :=
  Stdlib.String.make (OCaml.String.length (Array.get animation 0)) "008" % char.

Definition animation : array string :=
  Array.map (fun x => String.append clean x) animation.

Definition number_of_frames : Z := Array.length animation.

Definition make_with_animation {A B C : Type}
  (ppf : Stdlib.Format.formatter) (make : A -> sum B C)
  (on_retry : Mtime.span -> C -> A) (seed : A) : B :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Flush CamlinternalFormatBasics.End_of_format))
        "%s%!" % string) init in
  let fix loop (n : Z) (seed : A) : B :=
    let start := Mtime_clock.counter tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Flush
              CamlinternalFormatBasics.End_of_format)) "%s%!" % string)
        (Array.get animation (Z.modulo n number_of_frames)) in
    match make seed with
    | Stdlib.Ok v => v
    | Stdlib.Error r =>
      let time := Mtime_clock.count start in
      let v := on_retry time r in
      loop (Z.add n 1) v
    end in
  let result := loop 0 seed in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              (CamlinternalFormatBasics.Flush
                CamlinternalFormatBasics.End_of_format)))) "%s%s
%!" % string)
      clean init in
  result.

src/lib_stdlib_unix/file_descriptor_sink.ml 14 errors
(******************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

type t = {
  output : Lwt_unix.file_descr;
  format : [`One_per_line | `Netstring];
  (* Hopefully temporary hack to handle event which are emitted with
     the non-cooperative log functions in `Legacy_logging`: *)
  lwt_bad_citizen_hack : Data_encoding.json list ref;
  level_at_least : Internal_event.Level.t;
}

type 'event wrapped = {
  time_stamp : float;
  section : Internal_event.Section.t;
  event : 'event;
}

let wrap time_stamp section event = {time_stamp; section; event}

let wrapped_encoding event_encoding =
  let open Data_encoding in
  let v0 =
    conv
      (fun {time_stamp; section; event} -> (time_stamp, section, event))
      (fun (time_stamp, section, event) -> {time_stamp; section; event})
      (obj3
         (req "time_stamp" float)
         (req "section" Internal_event.Section.encoding)
         (req "event" event_encoding))
  in
  With_version.(encoding ~name:"fd-sink-item" (first_version v0))

module Make_sink (K : sig
  val kind : [`Path | `Stdout | `Stderr]
end) : Internal_event.SINK with type t = t = struct
  type nonrec t = t

  let uri_scheme =
    match K.kind with
    | `Path ->
        "file-descriptor-path"
    | `Stdout ->
        "file-descriptor-stdout"
    | `Stderr ->
        "file-descriptor-stderr"

  let configure uri =
    let level_at_least =
      Option.(
        Uri.get_query_param uri "level-at-least"
        >>= Internal_event.Level.of_string)
      |> Option.unopt ~default:Internal_event.Level.default
    in
    let fail_parsing fmt =
      Format.kasprintf (failwith "Parsing URI: %s: %s" (Uri.to_string uri)) fmt
    in
    ( match Uri.get_query_param uri "format" with
    | Some "netstring" ->
        return `Netstring
    | None | Some "one-per-line" ->
        return `One_per_line
    | Some other ->
        fail_parsing "Unknown format: %S" other )
    >>=? fun format ->
    ( match K.kind with
    | `Path -> (
        let flag name =
          match Uri.get_query_param uri name with
          | Some "true" ->
              true
          | _ ->
              false
        in
        let with_pid = flag "with-pid" in
        let fresh = flag "fresh" in
        ( match Uri.get_query_param uri "chmod" with
        | Some n -> (
          try return (int_of_string n)
          with _ ->
            fail_parsing "Access-rights parameter should be an integer: %S" n )
        | None ->
            return 0o600 )
        >>=? fun rights ->
        match Uri.path uri with
        | "" | "/" ->
            fail_parsing "Missing path configuration."
        | path ->
            let fixed_path =
              if with_pid then
                let ext = Filename.extension path in
                let chopped =
                  if ext = "" then path else Filename.chop_extension path
                in
                Fmt.strf "%s-%d%s" chopped (Unix.getpid ()) ext
              else path
            in
            protect (fun () ->
                Lwt_unix.(
                  let flags =
                    [O_WRONLY; O_CREAT]
                    @ if fresh then [O_TRUNC] else [O_APPEND]
                  in
                  openfile fixed_path flags rights)
                >>= fun fd -> return fd) )
    | `Stdout ->
        return Lwt_unix.stdout
    | `Stderr ->
        return Lwt_unix.stderr )
    >>=? fun output ->
    let t = {output; lwt_bad_citizen_hack = ref []; level_at_least; format} in
    return t

  let output_one output format event_json =
    let to_write =
      match format with
      | `One_per_line ->
          Ezjsonm.value_to_string ~minify:true event_json ^ "\n"
      | `Netstring ->
          let bytes = Ezjsonm.value_to_string ~minify:true event_json in
          Fmt.str "%d:%s," (String.length bytes) bytes
    in
    protect (fun () ->
        (* 
           If the write does happen at once (i.e. returns the same number of bytes),
           POSIX (and Linux >= 3.14) ensure this is atomic.
           Cf. http://man7.org/linux/man-pages/man2/write.2.html#BUGS
           and `https://github.com/ocsigen/lwt/blob/master/src/unix/unix_c/unix_write.c` *)
        Lwt_utils_unix.write_string output to_write >>= fun () -> return_unit)

  let handle (type a) {output; lwt_bad_citizen_hack; level_at_least; format; _}
      m ?(section = Internal_event.Section.empty) (v : unit -> a) =
    let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in
    let now = Unix.gettimeofday () in
    let forced_event = v () in
    let level = M.level forced_event in
    if Internal_event.Level.compare level level_at_least >= 0 then (
      let wrapped_event = wrap now section forced_event in
      let event_json =
        Data_encoding.Json.construct
          (wrapped_encoding M.encoding)
          wrapped_event
      in
      lwt_bad_citizen_hack := event_json :: !lwt_bad_citizen_hack ;
      output_one output format event_json
      >>=? fun () ->
      lwt_bad_citizen_hack :=
        List.filter (( = ) event_json) !lwt_bad_citizen_hack ;
      return_unit )
    else return_unit

  let close {lwt_bad_citizen_hack; output; format; _} =
    iter_s
      (fun event_json -> output_one output format event_json)
      !lwt_bad_citizen_hack
    >>=? fun () -> Lwt_unix.close output >>= fun () -> return_unit
end

module Sink_implementation_path = Make_sink (struct
  let kind = `Path
end)

module Sink_implementation_stdout = Make_sink (struct
  let kind = `Stdout
end)

module Sink_implementation_stderr = Make_sink (struct
  let kind = `Stderr
end)

let () = Internal_event.All_sinks.register (module Sink_implementation_path)

let () = Internal_event.All_sinks.register (module Sink_implementation_stdout)

let () = Internal_event.All_sinks.register (module Sink_implementation_stderr)
src/lib_stdlib_unix/file_descriptor_sink.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Record t := {
  output : Lwt_unix.file_descr;
  format : variant;
  lwt_bad_citizen_hack :
    Stdlib.ref (list Tezos_data_encoding.Data_encoding.json);
  level_at_least : Tezos_event_logging.Internal_event.Level.t }.

Record wrapped {event : Type} := {
  time_stamp : Z;
  section : Tezos_event_logging.Internal_event.Section.t;
  event : event }.
Arguments wrapped : clear implicits.

Definition wrap {A : Type}
  (time_stamp : Z) (section : Tezos_event_logging.Internal_event.Section.t)
  (event : A) : wrapped A :=
  {| time_stamp := time_stamp; section := section; event := event |}.

Definition wrapped_encoding {A : Type}
  (event_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding__Data_encoding.encoding (wrapped A) :=
  let v0 :=
    conv
      (fun function_parameter =>
        let '{|
          time_stamp := time_stamp; section := section; event := event |} :=
          function_parameter in
        (time_stamp, section, event))
      (fun function_parameter =>
        let '(time_stamp, section, event) := function_parameter in
        {| time_stamp := time_stamp; section := section; event := event |}) None
      (obj3 (req None None "time_stamp" % string float)
        (req None None "section" % string Internal_event.Section.encoding)
        (req None None "event" % string event_encoding)) in
  encoding "fd-sink-item" % string (first_version v0).

(* ❌ Functors are not handled. *)
functor

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application







src/lib_stdlib_unix/file_event_sink.ml 103 errors
(******************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module Micro_seconds : sig
  (** Module with time-stamps with “at least micro-seconds” precision. *)
  type t = private float

  val now : unit -> t

  val of_float : float -> t

  val encoding : t Data_encoding.t

  val date_string : t -> string * string
end = struct
  (* Time.t is in seconds, we want more precision. *)
  type t = float

  let now () = Unix.gettimeofday ()

  let of_float f = f

  let encoding =
    let open Data_encoding in
    conv (* Cf. https://github.com/OCamlPro/ocplib-json-typed/issues/25 *)
      (fun f -> f *. 1_000_000. |> Int64.of_float)
      (fun i64 -> Int64.to_float i64 /. 1_000_000.)
      int64

  let date_string time_value =
    let open Unix in
    let open Printf in
    let tm = gmtime time_value in
    ( sprintf "%04d%02d%02d" (1900 + tm.tm_year) (tm.tm_mon + 1) tm.tm_mday,
      sprintf
        "%02d%02d%02d-%06d"
        tm.tm_hour
        tm.tm_min
        tm.tm_sec
        ((time_value -. floor time_value) *. 1_000_000. |> int_of_float) )
end

module Event_filter = struct
  type t =
    | True
    | False
    | Or of t list
    | And of t list
    | Name of string
    | Name_matches of Re.re
    | Level_in of Internal_event.level list
    | Section_in of Internal_event.Section.t list

  let rec run ~section ~level ~name filter =
    let continue = run ~section ~level ~name in
    match filter with
    | True ->
        true
    | False ->
        false
    | Or l ->
        List.exists continue l
    | And l ->
        List.for_all continue l
    | Name s ->
        String.equal s name
    | Name_matches re ->
        Re.execp re name
    | Level_in l ->
        List.mem level l
    | Section_in l ->
        List.mem section l

  let rec pp fmt filter =
    let open Format in
    match filter with
    | True ->
        pp_print_string fmt "true"
    | False ->
        pp_print_string fmt "false"
    | Or l ->
        fprintf
          fmt
          "(or@ @[<2>%a@]"
          (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp)
          l
    | And l ->
        fprintf
          fmt
          "(and@ @[<2>%a@]"
          (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ") pp)
          l
    | Name s ->
        fprintf fmt "(name-is@ %S)" s
    | Name_matches re ->
        fprintf fmt "(name-matches@ %a)" Re.pp_re re
    | Level_in l ->
        fprintf
          fmt
          "(level-in@ [%s])"
          (String.concat "," (List.map Internal_event.Level.to_string l))
    | Section_in l ->
        fprintf
          fmt
          "(section-in@ [%a])"
          (pp_print_list
             ~pp_sep:(fun fmt () -> fprintf fmt ",@ ")
             (fun fmt s ->
               fprintf
                 fmt
                 "(Some %s)"
                 (String.concat "," (Internal_event.Section.to_string_list s))))
          l
    [@@warning "-32"]

  (* -> The "unused value" warning. *)

  let t = True

  let f = False [@@warning "-32"]

  (* -> The "unused value" warning. *)

  let any l = Or l

  let all l = And l [@@warning "-32"]

  (* -> The "unused value" warning. *)

  let name_is s = Name s

  let name_matches s = Name_matches s

  let name_matches_posix s = name_matches (Re.Posix.compile_pat s)

  let level_in l = Level_in l

  let section_in l = Section_in l

  let levels_in_order =
    Internal_event.[Debug; Info; Notice; Warning; Error; Fatal]

  let level_at_least lvl =
    List.fold_left
      (function
        | None -> (
            function l when l = lvl -> Some [l] | _ -> None )
        | Some s ->
            fun l -> Some (l :: s))
      None
      levels_in_order
    |> Option.unopt_exn (Failure "level_at_least not found")
    |> level_in
end

type t = {
  path : string;
  (* Hopefully temporary hack to handle event which are emitted with
     the non-cooperative log functions in `Legacy_logging`: *)
  lwt_bad_citizen_hack : (string * Data_encoding.json) list ref;
  event_filter : Event_filter.t;
}

type 'event wrapped = {
  time_stamp : Micro_seconds.t;
  section : Internal_event.Section.t;
  event : 'event;
}

let wrap time_stamp section event = {time_stamp; section; event}

let wrapped_encoding event_encoding =
  let open Data_encoding in
  let v0 =
    conv
      (fun {time_stamp; section; event} -> (time_stamp, section, event))
      (fun (time_stamp, section, event) -> {time_stamp; section; event})
      (obj3
         (req "time_stamp" Micro_seconds.encoding)
         (req "section" Internal_event.Section.encoding)
         (req "event" event_encoding))
  in
  With_version.(encoding ~name:"file-event-sink-item" (first_version v0))

module Section_dir = struct
  let of_section (section : Internal_event.Section.t) =
    String.concat "." (Internal_event.Section.to_string_list section)

  let section_name = function
    | "no-section" ->
        Ok None
    | other -> (
      match TzString.remove_prefix ~prefix:"section-" other with
      | None ->
          Error "wrong-dir-name"
      | Some s ->
          Ok (Some s) )
end

module Sink_implementation : Internal_event.SINK with type t = t = struct
  type nonrec t = t

  let uri_scheme = "unix-files"

  let configure uri =
    let event_filter =
      let name_res =
        Uri.get_query_param' uri "name-matches" |> Option.unopt ~default:[]
      in
      let names =
        Uri.get_query_param' uri "name" |> Option.unopt ~default:[]
      in
      let levels =
        Option.(
          Uri.get_query_param uri "level-at-least"
          >>= Internal_event.Level.of_string
          >>= fun l ->
          (* some (fun all more -> all [Event_filter.level_at_least l ; more ]) *)
          some [Event_filter.level_at_least l])
        |> Option.unopt ~default:[]
      in
      let sections =
        let somes =
          Uri.get_query_param' uri "section"
          |> Option.unopt ~default:[]
          |> List.map (fun s ->
                 Internal_event.Section.make_sanitized
                   (String.split_on_char '.' s))
        in
        let none =
          match Uri.get_query_param uri "no-section" with
          | Some "true" ->
              [Internal_event.Section.empty]
          | _ ->
              []
        in
        match somes @ none with
        | [] ->
            []
        | more ->
            [Event_filter.section_in more]
      in
      Event_filter.(
        match
          levels @ sections
          @ List.map name_matches_posix name_res
          @ List.map name_is names
        with
        | [] ->
            t
        | more ->
            any more)
    in
    let t =
      {path = Uri.path uri; lwt_bad_citizen_hack = ref []; event_filter}
    in
    return t

  let output_json ~pp file_path event_json =
    Lwt.catch
      (fun () ->
        Lwt_utils_unix.create_dir ~perm:0o700 (Filename.dirname file_path)
        >>= fun () ->
        Lwt_utils_unix.Json.write_file file_path event_json
        >>= function
        | Ok () ->
            return_unit
        | Error el ->
            failwith
              "ERROR while Handling %a,@ cannot write JSON to %s:@ %a\n%!"
              pp
              ()
              file_path
              Error_monad.pp_print_error
              el)
      (function
        | e ->
            failwith
              "ERROR while Handling %a: %a\n%!"
              pp
              ()
              Error_monad.pp_exn
              e)

  let handle (type a) {path; lwt_bad_citizen_hack; event_filter} m
      ?(section = Internal_event.Section.empty) (v : unit -> a) =
    let module M = (val m : Internal_event.EVENT_DEFINITION with type t = a) in
    let now = Micro_seconds.now () in
    let (date, time) = Micro_seconds.date_string now in
    let forced = v () in
    let level = M.level forced in
    match Event_filter.run ~section ~level ~name:M.name event_filter with
    | true ->
        let event_json =
          Data_encoding.Json.construct
            (wrapped_encoding M.encoding)
            (wrap now section forced)
        in
        let tag =
          let hash =
            Marshal.to_string event_json [] |> Digest.string |> Digest.to_hex
          in
          String.sub hash 0 8
        in
        let section_dir = Section_dir.of_section section in
        let dir_path =
          List.fold_left Filename.concat path [section_dir; M.name; date; time]
        in
        let file_path =
          Filename.concat
            dir_path
            (Printf.sprintf "%s_%s_%s.json" date time tag)
        in
        lwt_bad_citizen_hack :=
          (file_path, event_json) :: !lwt_bad_citizen_hack ;
        output_json file_path event_json ~pp:(fun fmt () -> M.pp fmt forced)
        >>=? fun () ->
        lwt_bad_citizen_hack :=
          List.filter (fun (f, _) -> f <> file_path) !lwt_bad_citizen_hack ;
        return_unit
    | false ->
        return_unit

  let close {lwt_bad_citizen_hack; _} =
    iter_s
      (fun (f, j) ->
        output_json f j ~pp:(fun fmt () ->
            Format.fprintf fmt "Destacking: %s" f))
      !lwt_bad_citizen_hack
    >>=? fun () -> return_unit
end

let () = Internal_event.All_sinks.register (module Sink_implementation)

open Sink_implementation

module Query = struct
  let with_file_kind dir p =
    protect (fun () ->
        Lwt_unix.stat (Filename.concat dir p)
        >>= fun {Lwt_unix.st_kind; _} -> return st_kind)
    >>=? function
    | Unix.S_DIR ->
        return (`Directory p)
    | Unix.S_REG ->
        return (`Regular_file p)
    | (Unix.S_CHR | Unix.S_BLK | Unix.S_LNK | Unix.S_FIFO | Unix.S_SOCK) as k
      ->
        return (`Special (k, p))

  let fold_directory path ~init ~f =
    protect (fun () ->
        Lwt_unix.opendir path >>= fun dirhandle -> return dirhandle)
    >>=? fun dirhandle ->
    let rec iter prev =
      protect (fun () ->
          Lwt.catch
            (fun () ->
              Lwt_unix.readdir dirhandle
              >>= fun d -> with_file_kind path d >>=? fun wk -> return_some wk)
            (function
              | End_of_file ->
                  Lwt_unix.closedir dirhandle >>= fun () -> return_none
              | (e : exn) ->
                  failwith
                    "ERROR while folding %s: %s"
                    path
                    (Printexc.to_string e)))
      >>=? fun opt ->
      prev
      >>=? fun p ->
      match opt with Some more -> iter (f p more) | None -> prev
    in
    iter init

  let ( // ) = Filename.concat

  module Time_constraint = struct
    type op = [`Lt | `Le | `Ge | `Gt]

    type t =
      [ `Date of op * float
      | `Time of op * float
      | `And of t * t
      | `Or of t * t
      | `All ]

    let rec check_logic check_terminal (t : t) string =
      let continue = check_logic check_terminal in
      match t with
      | `All ->
          true
      | `And (a, b) ->
          continue a string && continue b string
      | `Or (a, b) ->
          continue a string || continue b string
      | (`Date _ | `Time _) as term ->
          check_terminal term

    let op_with_string = function
      | `Lt ->
          fun a b -> String.compare a b > 0
      | `Gt ->
          fun a b -> String.compare a b < 0
      | `Le ->
          fun a b -> String.compare a b >= 0
      | `Ge ->
          fun a b -> String.compare a b <= 0

    let check_date (t : t) date_string =
      check_logic
        (function
          | `Date (op, f) ->
              let s = Micro_seconds.(date_string (of_float f) |> fst) in
              op_with_string op s date_string
          | `Time _ ->
              true)
        t
        date_string

    let check_time (t : t) string =
      check_logic
        (function
          | `Time (op, f) ->
              let s = Micro_seconds.(date_string (of_float f) |> snd) in
              op_with_string op s string
          | `Date _ ->
              true)
        t
        Micro_seconds.date_string
  end

  module Report = struct
    type item =
      [ `Error of
        [ `Parsing_event of
          [`Encoding of string * exn | `Json of string * error list]
        | `Cannot_recognize_section of string ]
      | `Warning of
        [ `Expecting_regular_file_at of string
        | `Expecting_directory_at of string
        | `Unknown_event_name_at of string * string ] ]

    let pp fmt (x : item) =
      let open Format in
      let error fmt = function
        | `Parsing_event e -> (
          match e with
          | `Encoding (path, exn) ->
              fprintf
                fmt
                "@[Parse error:@ wrong encoding for %S: %a@]"
                path
                pp_exn
                exn
          | `Json (path, el) ->
              fprintf
                fmt
                "@[Parse error:@ wrong JSON for %S: %a@]"
                path
                pp_print_error
                el )
        | `Cannot_recognize_section sec ->
            fprintf
              fmt
              "@[Directory error:@ cannot recognize section directory@ %S@]"
              sec
      in
      let warning fmt = function
        | `Expecting_regular_file_at path ->
            fprintf fmt "%S@ is not a regular file" path
        | `Expecting_directory_at path ->
            fprintf fmt "%S@ is not a directory" path
        | `Unknown_event_name_at (name, path) ->
            fprintf fmt "Unknown event name@ %S@ at@ %S" name path
      in
      match x with
      | `Error e ->
          fprintf fmt "@[Error:@ %a@]" error e
      | `Warning e ->
          fprintf fmt "@[Warning:@ %a@]" warning e

    let make_return m ((prev : item list), value) warning =
      return (m warning :: prev, value)

    let return_with_warning v e = make_return (fun e -> `Warning e) v e

    let return_with_error v e = make_return (fun e -> `Error e) v e
  end

  open Report

  let fold_event_kind_directory ~time_query path ~init ~f =
    fold_directory path ~init:(return init) ~f:(fun previous ->
      function
      | `Directory "." | `Directory ".." ->
          return previous
      | `Directory date when Time_constraint.check_date time_query date ->
          fold_directory
            (path // date)
            ~init:(return previous)
            ~f:(fun previous ->
            function
            | `Directory "." | `Directory ".." ->
                return previous
            | `Directory time when Time_constraint.check_time time_query time
              ->
                fold_directory
                  (path // date // time)
                  ~init:(return previous)
                  ~f:(fun previous -> function
                    | `Directory "." | `Directory ".." -> return previous
                    | `Regular_file file ->
                        f previous (path // date // time // file)
                    | `Directory p | `Special (_, p) ->
                        return_with_warning
                          previous
                          (`Expecting_regular_file_at
                            (path // date // time // p)))
            | `Directory _ (* filtered out *) ->
                return previous
            | `Regular_file p | `Special (_, p) ->
                return_with_warning
                  previous
                  (`Expecting_directory_at (path // date // p)))
      | `Directory _ (* filtered out *) ->
          return previous
      | `Regular_file p | `Special (_, p) ->
          return_with_warning previous (`Expecting_directory_at (path // p)))

  let handle_event_kind_directory (type a) ~time_query ~section_path ~init ~f
      ev =
    let module Event = ( val ev : Internal_event.EVENT_DEFINITION
                           with type t = a )
    in
    let handle_event_file previous path =
      Lwt_utils_unix.Json.read_file path
      >>= function
      | Ok json -> (
        try
          let {time_stamp; event; _} =
            Data_encoding.Json.destruct (wrapped_encoding Event.encoding) json
          in
          f
            (snd previous)
            ~time_stamp:(time_stamp :> float)
            (Internal_event.Generic.Event (Event.name, ev, event))
          >>=? fun user_return -> return (fst previous, user_return)
        with e ->
          return_with_error previous (`Parsing_event (`Encoding (path, e))) )
      | Error el ->
          return_with_error previous (`Parsing_event (`Json (path, el)))
    in
    fold_event_kind_directory
      ~time_query
      (section_path // Event.name)
      ~init
      ~f:(fun prev file -> handle_event_file prev file)

  let fold ?on_unknown ?only_sections ?only_names ?(time_query = `All) uri
      ~init ~f =
    let name_matches =
      match only_names with
      | None ->
          fun _ -> true
      | Some l ->
          fun name -> List.mem name l
    in
    let section_matches =
      match only_sections with
      | None ->
          fun _ -> true
      | Some l ->
          fun name -> List.mem name l
    in
    configure uri
    >>=? fun {path = sink_path; _} ->
    fold_directory
      sink_path
      ~init:(return ([], init))
      ~f:(fun previous -> function `Directory ("." | "..") -> return previous
        | `Directory dir -> (
          match Section_dir.section_name dir with
          | Ok sec when section_matches sec ->
              fold_directory
                (sink_path // dir)
                ~init:(return ([], init))
                ~f:(fun previous -> function `Directory ("." | "..") ->
                      return previous
                  | `Directory event_name when name_matches event_name -> (
                      let open Internal_event in
                      match All_definitions.find (( = ) event_name) with
                      | Some (Generic.Definition (_, ev)) ->
                          handle_event_kind_directory
                            ~time_query
                            ev
                            ~section_path:(sink_path // dir)
                            ~init:previous
                            ~f
                      | None -> (
                        match on_unknown with
                        | None ->
                            return_with_warning
                              previous
                              (`Unknown_event_name_at
                                (event_name, sink_path // dir))
                        | Some f ->
                            fold_event_kind_directory
                              ~time_query
                              (sink_path // dir // event_name)
                              ~init:previous
                              ~f:(fun prev file ->
                                f file >>=? fun () -> return prev) ) )
                  | `Directory _ (* filtered out *) -> return previous
                  | `Regular_file p | `Special (_, p) ->
                      return_with_warning
                        previous
                        (`Expecting_directory_at (sink_path // p)))
          | Ok _ (* section does not match *) ->
              return previous
          | Error _ ->
              return_with_error previous (`Cannot_recognize_section dir) )
        | `Regular_file p | `Special (_, p) ->
            return_with_warning
              previous
              (`Expecting_directory_at (sink_path // p)))
end
src/lib_stdlib_unix/file_event_sink.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module Micro_seconds.
  Definition t := Z.
  
  Definition now (function_parameter : unit) : Z :=
    let 'tt := function_parameter in
    Unix.gettimeofday tt.
  
  Definition of_float {A : Type} (f : A) : A := f.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding Z :=
    conv
      (fun f =>
        OCaml.Stdlib.reverse_apply
          (Stdlib.op_starpoint f
            (* ❌ Float constant 1_000_000. is approximated by the integer 1000000 *)
            1000000) Int64.of_float)
      (fun i64 =>
        Stdlib.op_divpoint (Int64.to_float i64)
          (* ❌ Float constant 1_000_000. is approximated by the integer 1000000 *)
          1000000) None int64.
  
  Definition date_string (time_value : Z) : string * string :=
    let tm := gmtime time_value in
    ((sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
          (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros 4)
          CamlinternalFormatBasics.No_precision
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
              2) CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 2)
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))) "%04d%02d%02d" % string)
      (Z.add 1900 (tm_year tm)) (Z.add (tm_mon tm) 1) (tm_mday tm)),
      (sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            (CamlinternalFormatBasics.Lit_padding CamlinternalFormatBasics.Zeros
              2) CamlinternalFormatBasics.No_precision
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              (CamlinternalFormatBasics.Lit_padding
                CamlinternalFormatBasics.Zeros 2)
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                (CamlinternalFormatBasics.Lit_padding
                  CamlinternalFormatBasics.Zeros 2)
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal "-" % char
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    (CamlinternalFormatBasics.Lit_padding
                      CamlinternalFormatBasics.Zeros 6)
                    CamlinternalFormatBasics.No_precision
                    CamlinternalFormatBasics.End_of_format)))))
          "%02d%02d%02d-%06d" % string) (tm_hour tm) (tm_min tm) (tm_sec tm)
        (OCaml.Stdlib.reverse_apply
          (Stdlib.op_starpoint
            (Stdlib.op_minuspoint time_value (Stdlib.floor time_value))
            (* ❌ Float constant 1_000_000. is approximated by the integer 1000000 *)
            1000000) Stdlib.int_of_float))).
End Micro_seconds.

Module Event_filter.
  Inductive t : Type :=
  | True : t
  | False : t
  | Or : (list t) -> t
  | And : (list t) -> t
  | Name : string -> t
  | Name_matches : Re.re -> t
  | Level_in : (list Tezos_event_logging.Internal_event.level) -> t
  | Section_in : (list Tezos_event_logging.Internal_event.Section.t) -> t.
  
  Fixpoint run
    (section : Tezos_event_logging.Internal_event.Section.t)
    (level : Tezos_event_logging.Internal_event.level) (name : Stdlib.String.t)
    (filter : t) : bool :=
    let continue := run section level name in
    match filter with
    | True => true
    | False => false
    | Or l => Stdlib.List._exists continue l
    | And l => Stdlib.List.for_all continue l
    | Name s => Stdlib.String.equal s name
    | Name_matches re => Re.execp None None re name
    | Level_in l => Stdlib.List.mem level l
    | Section_in l => Stdlib.List.mem section l
    end.
  
  Fixpoint pp (fmt : Stdlib.Format.formatter) (filter : t) : unit :=
    match filter with
    | True => pp_print_string fmt "true" % string
    | False => pp_print_string fmt "false" % string
    | Or l =>
      fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(or" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<2>" % string
                      CamlinternalFormatBasics.End_of_format) "<2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "(or@ @[<2>%a@]" % string)
        (pp_print_list
          (Some
            (fun fmt =>
              fun function_parameter =>
                let 'tt := function_parameter in
                fprintf fmt
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      CamlinternalFormatBasics.End_of_format) "@ " % string)))
          pp) l
    | And l =>
      fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(and" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<2>" % string
                      CamlinternalFormatBasics.End_of_format) "<2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format)))))
          "(and@ @[<2>%a@]" % string)
        (pp_print_list
          (Some
            (fun fmt =>
              fun function_parameter =>
                let 'tt := function_parameter in
                fprintf fmt
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      CamlinternalFormatBasics.End_of_format) "@ " % string)))
          pp) l
    | Name s =>
      fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(name-is" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "(name-is@ %S)" % string) s
    | Name_matches re =>
      fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(name-matches" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format))))
          "(name-matches@ %a)" % string) Re.pp_re re
    | Level_in l =>
      fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(level-in" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Char_literal "[" % char
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal "])" % string
                    CamlinternalFormatBasics.End_of_format)))))
          "(level-in@ [%s])" % string)
        (Stdlib.String.concat "," % string
          (List.map Internal_event.Level.to_string l))
    | Section_in l =>
      fprintf fmt
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(section-in" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Char_literal "[" % char
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "])" % string
                    CamlinternalFormatBasics.End_of_format)))))
          "(section-in@ [%a])" % string)
        (pp_print_list
          (Some
            (fun fmt =>
              fun function_parameter =>
                let 'tt := function_parameter in
                fprintf fmt
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Char_literal "," % char
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        CamlinternalFormatBasics.End_of_format)) ",@ " % string)))
          (fun fmt =>
            fun s =>
              fprintf fmt
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "(Some " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "(Some %s)" % string)
                (Stdlib.String.concat "," % string
                  (Internal_event.Section.to_string_list s)))) l
    end.
  
  Definition t : t := True.
  
  Definition f : t := False.
  
  Definition any (l : list t) : t := Or l.
  
  Definition all (l : list t) : t := And l.
  
  Definition name_is (s : string) : t := Name s.
  
  Definition name_matches (s : Re.re) : t := Name_matches s.
  
  Definition name_matches_posix (s : string) : t :=
    name_matches (Re.Posix.compile_pat None s).
  
  Definition level_in (l : list Tezos_event_logging.Internal_event.level) : t :=
    Level_in l.
  
  Definition section_in (l : list Tezos_event_logging.Internal_event.Section.t)
    : t := Section_in l.
  
  Definition levels_in_order : list Tezos_event_logging.Internal_event.level :=
    cons Tezos_event_logging.Internal_event.Debug
      (cons Tezos_event_logging.Internal_event.Info
        (cons Tezos_event_logging.Internal_event.Notice
          (cons Tezos_event_logging.Internal_event.Warning
            (cons Tezos_event_logging.Internal_event.Error
              (cons Tezos_event_logging.Internal_event.Fatal []))))).
  
  Definition level_at_least (lvl : Tezos_event_logging.Internal_event.level)
    : t :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (Stdlib.List.fold_left
          (fun function_parameter =>
            match function_parameter with
            | None =>
              fun function_parameter =>
                match function_parameter with
                | l => Some (cons l [])
                | _ => None
                end
            | Some s => fun l => Some (cons l s)
            end) None levels_in_order)
        (Option.unopt_exn (OCaml.Failure "level_at_least not found" % string)))
      level_in.
End Event_filter.

Record t := {
  path : string;
  lwt_bad_citizen_hack :
    Stdlib.ref (list (string * Tezos_data_encoding.Data_encoding.json));
  event_filter : Event_filter.t }.

Record wrapped {event : Type} := {
  time_stamp : Micro_seconds.t;
  section : Tezos_event_logging.Internal_event.Section.t;
  event : event }.
Arguments wrapped : clear implicits.

Definition wrap {A : Type}
  (time_stamp : Micro_seconds.t)
  (section : Tezos_event_logging.Internal_event.Section.t) (event : A)
  : wrapped A :=
  {| time_stamp := time_stamp; section := section; event := event |}.

Definition wrapped_encoding {A : Type}
  (event_encoding : Tezos_data_encoding.Data_encoding.encoding A)
  : Tezos_data_encoding__Data_encoding.encoding (wrapped A) :=
  let v0 :=
    conv
      (fun function_parameter =>
        let '{|
          time_stamp := time_stamp; section := section; event := event |} :=
          function_parameter in
        (time_stamp, section, event))
      (fun function_parameter =>
        let '(time_stamp, section, event) := function_parameter in
        {| time_stamp := time_stamp; section := section; event := event |}) None
      (obj3 (req None None "time_stamp" % string Micro_seconds.encoding)
        (req None None "section" % string Internal_event.Section.encoding)
        (req None None "event" % string event_encoding)) in
  encoding "file-event-sink-item" % string (first_version v0).

Module Section_dir.
  Definition of_section (section : Tezos_event_logging.Internal_event.Section.t)
    : string :=
    Stdlib.String.concat "." % string
      (Internal_event.Section.to_string_list section).
  
  Definition section_name (function_parameter : string)
    : sum (option string) string :=
    match function_parameter with
    | "no-section" % string => Stdlib.Ok None
    | other =>
      match TzString.remove_prefix "section-" % string other with
      | None => Stdlib.Error "wrong-dir-name" % string
      | Some s => Stdlib.Ok (Some s)
      end
    end.
End Section_dir.

Module Sink_implementation.
  Definition t := t.
  
  Definition uri_scheme : string := "unix-files" % string.
  
  Definition configure (uri : Uri.t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult t) :=
    let event_filter :=
      let name_res :=
        OCaml.Stdlib.reverse_apply
          (Uri.get_query_param' uri "name-matches" % string) (Option.unopt [])
        in
      let names :=
        OCaml.Stdlib.reverse_apply (Uri.get_query_param' uri "name" % string)
          (Option.unopt []) in
      let levels :=
        OCaml.Stdlib.reverse_apply
          (op_gtgteq
            (op_gtgteq (Uri.get_query_param uri "level-at-least" % string)
              Internal_event.Level.of_string)
            (fun l => some (cons (Event_filter.level_at_least l) [])))
          (Option.unopt []) in
      let sections :=
        let somes :=
          OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (Uri.get_query_param' uri "section" % string) (Option.unopt []))
            (List.map
              (fun s =>
                Internal_event.Section.make_sanitized
                  (Stdlib.String.split_on_char "." % char s))) in
        let none :=
          match Uri.get_query_param uri "no-section" % string with
          | Some "true" % string => cons Internal_event.Section.empty []
          | _ => []
          end in
        match OCaml.Stdlib.app somes none with
        | [] => []
        | more => cons (Event_filter.section_in more) []
        end in
      match
        OCaml.Stdlib.app levels
          (OCaml.Stdlib.app sections
            (OCaml.Stdlib.app (List.map name_matches_posix name_res)
              (List.map name_is names))) with
      | [] => t
      | more => any more
      end in
    let t :=
      {| path := Uri.path uri; lwt_bad_citizen_hack := Stdlib.ref [];
        event_filter := event_filter |} in
    _return t.
  
  Definition output_json
    (pp : Stdlib.Format.formatter -> unit -> unit) (file_path : string)
    (event_json : Tezos_data_encoding.Data_encoding.json)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    Lwt.catch
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (Lwt_utils_unix.create_dir (Some 448) (Filename.dirname file_path))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Lwt_utils_unix.Json.write_file file_path event_json)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok tt => return_unit
                | Stdlib.Error el =>
                  failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "ERROR while Handling " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "," % char
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.String_literal
                                "cannot write JSON to " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Char_literal
                                    ":" % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "010" % char
                                          (CamlinternalFormatBasics.Flush
                                            CamlinternalFormatBasics.End_of_format)))))))))))
                      "ERROR while Handling %a,@ cannot write JSON to %s:@ %a
%!"
                        % string) pp tt file_path Error_monad.pp_print_error el
                end)))
      (fun e =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "ERROR while Handling " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal ": " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal "010" % char
                      (CamlinternalFormatBasics.Flush
                        CamlinternalFormatBasics.End_of_format))))))
            "ERROR while Handling %a: %a
%!" % string) pp tt Error_monad.pp_exn
          e).
  
  Definition handle {A : Type} (function_parameter : t)
    : {_ : unit &
      Tezos_event_logging.Internal_event.EVENT_DEFINITION.signature A} ->
      (option Tezos_event_logging.Internal_event.Section.t) ->
        (unit -> A) -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let '{|
      path := path;
        lwt_bad_citizen_hack := lwt_bad_citizen_hack;
        event_filter := event_filter
        |} := function_parameter in
    fun m =>
      fun op_staroptstar =>
        let section :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => Internal_event.Section.empty
          end in
        fun v =>
          let M := projT2 m in
          let now := Micro_seconds.now tt in
          let '(date, time) := Micro_seconds.date_string now in
          let forced := v tt in
          let level :=
            M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.level)
              forced in
          match
            Event_filter.run section level
              M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
              event_filter with
          | true =>
            let event_json :=
              Data_encoding.Json.construct
                (wrapped_encoding
                  M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.encoding))
                (wrap now section forced) in
            let tag :=
              let hash :=
                OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply (Marshal.to_string event_json [])
                    Digest.string) Digest.to_hex in
              Stdlib.String.sub hash 0 8 in
            let section_dir := Section_dir.of_section section in
            let dir_path :=
              Stdlib.List.fold_left Filename.concat path
                (cons section_dir
                  (cons
                    M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)
                    (cons date (cons time [])))) in
            let file_path :=
              Filename.concat dir_path
                (Printf.sprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "_" % char
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal "_" % char
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                ".json" % string
                                CamlinternalFormatBasics.End_of_format))))))
                    "%s_%s_%s.json" % string) date time tag) in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Stdlib.op_coloneq lwt_bad_citizen_hack
                (cons (file_path, event_json)
                  (Stdlib.op_exclamation lwt_bad_citizen_hack)) in
            op_gtgteqquestion
              (output_json
                (fun fmt =>
                  fun function_parameter =>
                    let 'tt := function_parameter in
                    M.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.pp)
                      fmt forced) file_path event_json)
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  Stdlib.op_coloneq lwt_bad_citizen_hack
                    (Stdlib.List.filter
                      (fun function_parameter =>
                        let '(f, _) := function_parameter in
                        nequiv_decb f file_path)
                      (Stdlib.op_exclamation lwt_bad_citizen_hack)) in
                return_unit)
          | false => return_unit
          end.
  
  Definition close (function_parameter : t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let '{| lwt_bad_citizen_hack := lwt_bad_citizen_hack |} :=
      function_parameter in
    op_gtgteqquestion
      (iter_s
        (fun function_parameter =>
          let '(f, j) := function_parameter in
          output_json
            (fun fmt =>
              fun function_parameter =>
                let 'tt := function_parameter in
                Format.fprintf fmt
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Destacking: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "Destacking: %s" % string) f) f j)
        (Stdlib.op_exclamation lwt_bad_citizen_hack))
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit).
End Sink_implementation.



Import Sink_implementation.

Module Query.
  Definition with_file_kind (dir : string) (p : string)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult variant) :=
    op_gtgteqquestion
      (protect None None
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Lwt_unix.stat (Filename.concat dir p))
            (fun function_parameter =>
              let '{| Lwt_unix.st_kind := st_kind |} := function_parameter in
              _return st_kind)))
      (fun function_parameter =>
        match function_parameter with
        | Unix.S_DIR =>
          _return
            (* ❌ Variants not supported *)
            variant
        | Unix.S_REG =>
          _return
            (* ❌ Variants not supported *)
            variant
        |
          (Unix.S_CHR | Unix.S_BLK | Unix.S_LNK | Unix.S_FIFO | Unix.S_SOCK) as
            k =>
          _return
            (* ❌ Variants not supported *)
            variant
        end).
  
  Definition fold_directory {A : Type}
    (path : string) (init : Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
    (f : A -> variant -> Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
    op_gtgteqquestion
      (protect None None
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Lwt_unix.opendir path) (fun dirhandle => _return dirhandle)))
      (fun dirhandle =>
        let fix iter (prev : Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
          : Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
          op_gtgteqquestion
            (protect None None
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.catch
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (Lwt_unix.readdir dirhandle)
                      (fun d =>
                        op_gtgteqquestion (with_file_kind path d)
                          (fun wk => return_some wk)))
                  (fun function_parameter =>
                    match function_parameter with
                    | OCaml.End_of_file =>
                      op_gtgteq (Lwt_unix.closedir dirhandle)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_none)
                    | _ as e =>
                      failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "ERROR while folding " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                ": " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format))))
                          "ERROR while folding %s: %s" % string) path
                        (Printexc.to_string e)
                    end)))
            (fun opt =>
              op_gtgteqquestion prev
                (fun p =>
                  match opt with
                  | Some more => iter (f p more)
                  | None => prev
                  end)) in
        iter init).
  
  Definition op_divdiv : string -> string -> string := Filename.concat.
  
  Module Time_constraint.
    Definition op := variant.
    
    Definition t := variant.
    
    Fixpoint check_logic {A : Type}
      (check_terminal : variant -> bool) (t : t) (string : A) : bool :=
      let continue := check_logic check_terminal in
      match t with
      | All => true
      | And (a, b) => andb (continue a string) (continue b string)
      | Or (a, b) => orb (continue a string) (continue b string)
      | (Date _ | Time _) as term => check_terminal term
      end.
    
    Definition op_with_string (function_parameter : variant)
      : Stdlib.String.t -> Stdlib.String.t -> bool :=
      match function_parameter with
      | Lt => fun a => fun b => OCaml.Stdlib.gt (Stdlib.String.compare a b) 0
      | Gt => fun a => fun b => OCaml.Stdlib.lt (Stdlib.String.compare a b) 0
      | Le => fun a => fun b => OCaml.Stdlib.ge (Stdlib.String.compare a b) 0
      | Ge => fun a => fun b => OCaml.Stdlib.le (Stdlib.String.compare a b) 0
      end.
    
    Definition check_date (t : t) (date_string : Stdlib.String.t) : bool :=
      check_logic
        (fun function_parameter =>
          match function_parameter with
          | Date (op, f) =>
            let s := OCaml.Stdlib.reverse_apply (date_string (of_float f)) fst
              in
            op_with_string op s date_string
          | Time _ => true
          end) t date_string.
    
    Definition check_time (t : t) (string : Stdlib.String.t) : bool :=
      check_logic
        (fun function_parameter =>
          match function_parameter with
          | Time (op, f) =>
            let s := OCaml.Stdlib.reverse_apply (date_string (of_float f)) snd
              in
            op_with_string op s string
          | Date _ => true
          end) t Micro_seconds.date_string.
  End Time_constraint.
  
  Module Report.
    Definition item := variant.
    
    Definition pp (fmt : Stdlib.Format.formatter) (x : item) : unit :=
      let error (fmt : Stdlib.Format.formatter) (function_parameter : variant)
        : unit :=
        match function_parameter with
        | Parsing_event e =>
          match e with
          | Encoding (path, exn) =>
            fprintf fmt
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Parse error:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "wrong encoding for " % string
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal ": " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[Parse error:@ wrong encoding for %S: %a@]" % string) path
              pp_exn exn
          | Json (path, el) =>
            fprintf fmt
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Parse error:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "wrong JSON for " % string
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal ": " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format))))))))
                "@[Parse error:@ wrong JSON for %S: %a@]" % string) path
              pp_print_error el
          end
        | Cannot_recognize_section sec =>
          fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.String_literal
                  "Directory error:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal
                      "cannot recognize section directory" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))))
              "@[Directory error:@ cannot recognize section directory@ %S@]" %
                string) sec
        end in
      let warning (fmt : Stdlib.Format.formatter) (function_parameter : variant)
        : unit :=
        match function_parameter with
        | Expecting_regular_file_at path =>
          fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal
                    "is not a regular file" % string
                    CamlinternalFormatBasics.End_of_format)))
              "%S@ is not a regular file" % string) path
        | Expecting_directory_at path =>
          fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Caml_string
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal
                    "is not a directory" % string
                    CamlinternalFormatBasics.End_of_format)))
              "%S@ is not a directory" % string) path
        | Unknown_event_name_at (name, path) =>
          fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Unknown event name" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Caml_string
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal "at" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Caml_string
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.End_of_format)))))))
              "Unknown event name@ %S@ at@ %S" % string) name path
        end in
      match x with
      | Error e =>
        fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.String_literal "Error:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[Error:@ %a@]" % string) error e
      | Warning e =>
        fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  CamlinternalFormatBasics.End_of_format "" % string))
              (CamlinternalFormatBasics.String_literal "Warning:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[Warning:@ %a@]" % string) warning e
      end.
    
    Definition make_return {A B : Type}
      (m : A -> item) (function_parameter : (list item) * B)
      : A -> Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * B)) :=
      let '(_ as prev, value) := function_parameter in
      fun warning => _return ((cons (m warning) prev), value).
    
    Definition return_with_warning {A : Type}
      (v : (list item) * A) (e : variant)
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * A)) :=
      make_return
        (fun e =>
          (* ❌ Variants not supported *)
          variant) v e.
    
    Definition return_with_error {A : Type} (v : (list item) * A) (e : variant)
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list item) * A)) :=
      make_return
        (fun e =>
          (* ❌ Variants not supported *)
          variant) v e.
  End Report.
  
  Import Report.
  
  Definition fold_event_kind_directory {A : Type}
    (time_query : Time_constraint.t) (path : string)
    (init : (list Report.item) * A)
    (f :
      ((list Report.item) * A) ->
        string ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)))
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
    fold_directory path (_return init)
      (fun previous =>
        fun function_parameter =>
          match function_parameter with
          | Directory "." % string | Directory ".." % string => _return previous
          | Directory date =>
            fold_directory (op_divdiv path date) (_return previous)
              (fun previous =>
                fun function_parameter =>
                  match function_parameter with
                  | Directory "." % string | Directory ".." % string =>
                    _return previous
                  | Directory time =>
                    fold_directory (op_divdiv (op_divdiv path date) time)
                      (_return previous)
                      (fun previous =>
                        fun function_parameter =>
                          match function_parameter with
                          | Directory "." % string | Directory ".." % string =>
                            _return previous
                          | Regular_file file =>
                            f previous
                              (op_divdiv (op_divdiv (op_divdiv path date) time)
                                file)
                          | Directory p | Special (_, p) =>
                            return_with_warning previous
                              (* ❌ Variants not supported *)
                              variant
                          end)
                  | Directory _ => _return previous
                  | Regular_file p | Special (_, p) =>
                    return_with_warning previous
                      (* ❌ Variants not supported *)
                      variant
                  end)
          | Directory _ => _return previous
          | Regular_file p | Special (_, p) =>
            return_with_warning previous
              (* ❌ Variants not supported *)
              variant
          end).
  
  Definition handle_event_kind_directory {A B : Type}
    (time_query : Time_constraint.t) (section_path : string)
    (init : (list Report.item) * A)
    (f :
      A ->
        Z ->
          Tezos_event_logging.Internal_event.Generic.event ->
            Lwt.t (Tezos_error_monad.Error_monad.tzresult A))
    (ev :
      {_ : unit &
        Tezos_event_logging.Internal_event.EVENT_DEFINITION.signature B})
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
    let Event := projT2 ev in
    let handle_event_file (previous : (list Report.item) * A) (path : string)
      : Lwt.t (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
      op_gtgteq (Lwt_utils_unix.Json.read_file path)
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok json =>
            (* ❌ Try-with are not handled *)
            try
              (let '{| time_stamp := time_stamp; event := event |} :=
                Data_encoding.Json.destruct
                  (wrapped_encoding
                    Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.encoding))
                  json in
              op_gtgteqquestion
                (f (snd previous) time_stamp
                  (Tezos_event_logging.Internal_event.Generic.Event
                    (Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name),
                      ev, event)))
                (fun user_return => _return ((fst previous), user_return)))
          | Stdlib.Error el =>
            return_with_error previous
              (* ❌ Variants not supported *)
              variant
          end) in
    fold_event_kind_directory time_query
      (op_divdiv section_path
        Event.(Tezos_event_logging__Internal_event.EVENT_DEFINITION.name)) init
      (fun prev => fun file => handle_event_file prev file).
  
  Definition fold {A : Type}
    (on_unknown :
      option (string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit)))
    (only_sections : option (list (option string)))
    (only_names : option (list string)) (op_staroptstar : option variant)
    : Uri.t ->
      A ->
        (A ->
          Z ->
            Tezos_event_logging.Internal_event.Generic.event ->
              Lwt.t (Tezos_error_monad.Error_monad.tzresult A)) ->
          Lwt.t
            (Tezos_error_monad.Error_monad.tzresult ((list Report.item) * A)) :=
    let time_query :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None =>
        (* ❌ Variants not supported *)
        variant
      end in
    fun uri =>
      fun init =>
        fun f =>
          let name_matches :=
            match only_names with
            | None =>
              fun function_parameter =>
                let '_ := function_parameter in
                true
            | Some l => fun name => Stdlib.List.mem name l
            end in
          let section_matches :=
            match only_sections with
            | None =>
              fun function_parameter =>
                let '_ := function_parameter in
                true
            | Some l => fun name => Stdlib.List.mem name l
            end in
          op_gtgteqquestion
            (Sink_implementation.(Tezos_event_logging__Internal_event.SINK.configure)
              uri)
            (fun function_parameter =>
              let '{| path := sink_path |} := function_parameter in
              fold_directory sink_path (_return ([], init))
                (fun previous =>
                  fun function_parameter =>
                    match function_parameter with
                    | Directory ("." % string | ".." % string) =>
                      _return previous
                    | Directory dir =>
                      match Section_dir.section_name dir with
                      | Stdlib.Ok sec =>
                        fold_directory (op_divdiv sink_path dir)
                          (_return ([], init))
                          (fun previous =>
                            fun function_parameter =>
                              match function_parameter with
                              | Directory ("." % string | ".." % string) =>
                                _return previous
                              | Directory event_name =>
                                match
                                  All_definitions.find (equiv_decb event_name)
                                  with
                                |
                                  Some
                                    (Tezos_event_logging.Internal_event.Generic.Definition
                                      (_, ev)) =>
                                  handle_event_kind_directory time_query
                                    (op_divdiv sink_path dir) previous f ev
                                | None =>
                                  match on_unknown with
                                  | None =>
                                    return_with_warning previous
                                      (* ❌ Variants not supported *)
                                      variant
                                  | Some f =>
                                    fold_event_kind_directory time_query
                                      (op_divdiv (op_divdiv sink_path dir)
                                        event_name) previous
                                      (fun prev =>
                                        fun file =>
                                          op_gtgteqquestion (f file)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              _return prev))
                                  end
                                end
                              | Directory _ => _return previous
                              | Regular_file p | Special (_, p) =>
                                return_with_warning previous
                                  (* ❌ Variants not supported *)
                                  variant
                              end)
                      | Stdlib.Ok _ => _return previous
                      | Stdlib.Error _ =>
                        return_with_error previous
                          (* ❌ Variants not supported *)
                          variant
                      end
                    | Regular_file p | Special (_, p) =>
                      return_with_warning previous
                        (* ❌ Variants not supported *)
                        variant
                    end)).
End Query.

src/lib_stdlib_unix/internal_event_unix.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

module Configuration = struct
  type t = {activate : Uri.t list}

  let default =
    {activate = [Uri.make ~scheme:Internal_event.Lwt_log_sink.uri_scheme ()]}

  let encoding =
    let open Data_encoding in
    conv
      (fun {activate} -> List.map Uri.to_string activate)
      (fun activate -> {activate = List.map Uri.of_string activate})
      (obj1
         (dft
            "activate"
            ~description:"List of URIs to activate/configure sinks."
            (list string)
            []))

  let of_file path =
    Lwt_utils_unix.Json.read_file path
    >>=? fun json ->
    protect (fun () -> return (Data_encoding.Json.destruct encoding json))

  let apply {activate} =
    List.fold_left
      (fun prev uri ->
        prev >>=? fun () -> Internal_event.All_sinks.activate uri)
      return_unit
      activate
end

let env_var_name = "TEZOS_EVENTS_CONFIG"

let init ?lwt_log_sink ?(configuration = Configuration.default) () =
  let _ =
    (* This is just here to force the linking (and hence
       initialization) of all these modules: *)
    [ File_descriptor_sink.Sink_implementation_path.uri_scheme;
      File_event_sink.Sink_implementation.uri_scheme ]
  in
  Lwt_log_sink_unix.initialize ?cfg:lwt_log_sink ()
  >>= fun () ->
  ( match Sys.(getenv_opt env_var_name) with
  | None ->
      return_unit
  | Some s ->
      let uris =
        TzString.split ' ' s
        |> List.map (TzString.split '\n')
        |> List.concat
        |> List.map (TzString.split '\t')
        |> List.concat
        |> List.filter (( <> ) "")
        |> List.map Uri.of_string
      in
      List.fold_left
        (fun prev uri ->
          prev
          >>=? fun () ->
          match Uri.scheme uri with
          | None ->
              Configuration.of_file (Uri.path uri)
              >>=? fun cfg -> Configuration.apply cfg
          | Some _ ->
              Internal_event.All_sinks.activate uri)
        return_unit
        uris
      >>=? fun () ->
      Internal_event.Debug_event.(
        emit
          (make
             "Loaded URIs from environment"
             ~attach:
               (`O [("variable", `String env_var_name); ("value", `String s)])))
  )
  >>=? (fun () -> Configuration.apply configuration)
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error el ->
      Format.kasprintf
        Lwt.fail_with
        "ERROR@ Initializing Internal_event_unix:@ %a\n%!"
        Error_monad.pp_print_error
        el

let close () =
  Internal_event.All_sinks.close ()
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error el ->
      Format.kasprintf
        Lwt.fail_with
        "ERROR@ closing Internal_event_unix:@ %a\n%!"
        Error_monad.pp_print_error
        el
src/lib_stdlib_unix/internal_event_unix.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Module Configuration.
  Record t := {
    activate : list Uri.t }.
  
  Definition default : t :=
    {|
      activate :=
        cons
          (Uri.make (Some Internal_event.Lwt_log_sink.uri_scheme) None None None
            None None None tt) [] |}.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    conv
      (fun function_parameter =>
        let '{| activate := activate |} := function_parameter in
        List.map Uri.to_string activate)
      (fun activate => {| activate := List.map Uri.of_string activate |}) None
      (obj1
        (dft None (Some "List of URIs to activate/configure sinks." % string)
          "activate" % string (list None string) [])).
  
  Definition of_file (path : string)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult t) :=
    op_gtgteqquestion (Lwt_utils_unix.Json.read_file path)
      (fun json =>
        protect None None
          (fun function_parameter =>
            let 'tt := function_parameter in
            _return (Data_encoding.Json.destruct encoding json))).
  
  Definition apply (function_parameter : t)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let '{| activate := activate |} := function_parameter in
    Stdlib.List.fold_left
      (fun prev =>
        fun uri =>
          op_gtgteqquestion prev
            (fun function_parameter =>
              let 'tt := function_parameter in
              Internal_event.All_sinks.activate uri)) return_unit activate.
End Configuration.

Definition env_var_name : string := "TEZOS_EVENTS_CONFIG" % string.

Definition init
  (lwt_log_sink : option Tezos_stdlib_unix.Lwt_log_sink_unix.cfg)
  (op_staroptstar : option Configuration.t) : unit -> Lwt.t unit :=
  let configuration :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Configuration.default
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    let '_ :=
      cons File_descriptor_sink.Sink_implementation_path.uri_scheme
        (cons File_event_sink.Sink_implementation.uri_scheme []) in
    op_gtgteq (Lwt_log_sink_unix.initialize lwt_log_sink tt)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq
          (op_gtgteqquestion
            match getenv_opt env_var_name with
            | None => return_unit
            | Some s =>
              let uris :=
                OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply
                    (OCaml.Stdlib.reverse_apply
                      (OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply
                          (OCaml.Stdlib.reverse_apply
                            (TzString.split " " % char None None s)
                            (List.map
                              (let arg := TzString.split "010" % char in
                              fun eta => arg None None eta))) Stdlib.List.concat)
                        (List.map
                          (let arg := TzString.split "009" % char in
                          fun eta => arg None None eta))) Stdlib.List.concat)
                    (Stdlib.List.filter (nequiv_decb "" % string)))
                  (List.map Uri.of_string) in
              op_gtgteqquestion
                (Stdlib.List.fold_left
                  (fun prev =>
                    fun uri =>
                      op_gtgteqquestion prev
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          match Uri.scheme uri with
                          | None =>
                            op_gtgteqquestion
                              (Configuration.of_file (Uri.path uri))
                              (fun cfg => Configuration.apply cfg)
                          | Some _ => Internal_event.All_sinks.activate uri
                          end)) return_unit uris)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  emit None
                    (make
                      (Some
                        (* ❌ Variants not supported *)
                        variant) "Loaded URIs from environment" % string))
            end
            (fun function_parameter =>
              let 'tt := function_parameter in
              Configuration.apply configuration))
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok tt => Lwt.return_unit
            | Stdlib.Error el =>
              Format.kasprintf Lwt.fail_with
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "ERROR" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "Initializing Internal_event_unix:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal "010" % char
                              (CamlinternalFormatBasics.Flush
                                CamlinternalFormatBasics.End_of_format)))))))
                  "ERROR@ Initializing Internal_event_unix:@ %a
%!" % string)
                Error_monad.pp_print_error el
            end)).

Definition close (function_parameter : unit) : Lwt.t unit :=
  let 'tt := function_parameter in
  op_gtgteq (Internal_event.All_sinks.close tt)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => Lwt.return_unit
      | Stdlib.Error el =>
        Format.kasprintf Lwt.fail_with
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "ERROR" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.String_literal
                  "closing Internal_event_unix:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "010" % char
                        (CamlinternalFormatBasics.Flush
                          CamlinternalFormatBasics.End_of_format)))))))
            "ERROR@ closing Internal_event_unix:@ %a
%!" % string)
          Error_monad.pp_print_error el
      end).

src/lib_stdlib_unix/lwt_exit.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

exception Exit

let (termination_thread, exit_wakener) = Lwt.wait ()

let exit x = Lwt.wakeup exit_wakener x ; raise Exit

let () =
  Lwt.async_exception_hook :=
    function
    | Exit ->
        ()
    | e ->
        let backtrace = Printexc.get_backtrace () in
        let pp_exn_trace ppf backtrace =
          if String.length backtrace <> 0 then
            Format.fprintf
              ppf
              "@,Backtrace:@,  @[<h>%a@]"
              Format.pp_print_text
              backtrace
        in
        (* TODO Improve this *)
        Format.eprintf
          "@[<v 2>@[Uncaught (asynchronous) exception (%d):@ %s@]%a@]@.%!"
          (Unix.getpid ())
          (Printexc.to_string e)
          pp_exn_trace
          backtrace ;
        Lwt.wakeup exit_wakener 1

let signals =
  let open Sys in
  [ (sigabrt, "ABRT");
    (sigalrm, "ALRM");
    (sigfpe, "FPE");
    (sighup, "HUP");
    (sigill, "ILL");
    (sigint, "INT");
    (sigkill, "KILL");
    (sigpipe, "PIPE");
    (sigquit, "QUIT");
    (sigsegv, "SEGV");
    (sigterm, "TERM");
    (sigusr1, "USR1");
    (sigusr2, "USR2");
    (sigchld, "CHLD");
    (sigcont, "CONT");
    (sigstop, "STOP");
    (sigtstp, "TSTP");
    (sigttin, "TTIN");
    (sigttou, "TTOU");
    (sigvtalrm, "VTALRM");
    (sigprof, "PROF");
    (sigbus, "BUS");
    (sigpoll, "POLL");
    (sigsys, "SYS");
    (sigtrap, "TRAP");
    (sigurg, "URG");
    (sigxcpu, "XCPU");
    (sigxfsz, "XFSZ") ]

let set_exit_handler ?(log = Format.eprintf "%s\n%!") signal =
  match List.assoc_opt signal signals with
  | None ->
      Format.kasprintf
        invalid_arg
        "Killable.set_exit_handler: unknown signal %d"
        signal
  | Some name ->
      let handler signal =
        try
          Format.kasprintf
            log
            "Received the %s signal, triggering shutdown."
            name ;
          exit signal
        with _ -> ()
      in
      ignore (Lwt_unix.on_signal signal handler : Lwt_unix.signal_handler_id)

(* Which signals is the program meant to exit on *)
let signals_to_exit_on = ref []

let exit_on ?log signal =
  if List.mem signal !signals_to_exit_on then
    Format.kasprintf
      Pervasives.failwith
      "Killable.exit_on: already registered signal %d"
      signal
  else (
    signals_to_exit_on := signal :: !signals_to_exit_on ;
    set_exit_handler ?log signal )

type outcome = Resolved of int | Exited of int

let retcode_of_unit_result_lwt p =
  let open Lwt.Infix in
  p
  >>= function
  | Error e ->
      (* TODO: print *) ignore e ; Lwt.return 1
  | Ok () ->
      Lwt.return 0

let wrap_promise (p : int Lwt.t) =
  let open Lwt.Infix in
  Lwt.choose
    [(p >|= fun v -> Resolved v); (termination_thread >|= fun s -> Exited s)]
  >>= function
  | Resolved r ->
      Lwt.return r
  | Exited s ->
      (*TODO: what are the correct expected behaviour here?*)
      if List.mem s !signals_to_exit_on then (
        (* Exit because of signal *)
        Lwt.cancel p ;
        Lwt.return 2 )
      else (* Other exit *)
        Pervasives.exit 3
src/lib_stdlib_unix/lwt_exit.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ The definition of exceptions is not handled. *)
exception



Definition exit {A : Type} (x : Z) : A :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Lwt.wakeup exit_wakener x in
  Stdlib.raise Exit.



Definition signals : list (Z * string) :=
  cons (sigabrt, "ABRT" % string)
    (cons (sigalrm, "ALRM" % string)
      (cons (sigfpe, "FPE" % string)
        (cons (sighup, "HUP" % string)
          (cons (sigill, "ILL" % string)
            (cons (sigint, "INT" % string)
              (cons (sigkill, "KILL" % string)
                (cons (sigpipe, "PIPE" % string)
                  (cons (sigquit, "QUIT" % string)
                    (cons (sigsegv, "SEGV" % string)
                      (cons (sigterm, "TERM" % string)
                        (cons (sigusr1, "USR1" % string)
                          (cons (sigusr2, "USR2" % string)
                            (cons (sigchld, "CHLD" % string)
                              (cons (sigcont, "CONT" % string)
                                (cons (sigstop, "STOP" % string)
                                  (cons (sigtstp, "TSTP" % string)
                                    (cons (sigttin, "TTIN" % string)
                                      (cons (sigttou, "TTOU" % string)
                                        (cons (sigvtalrm, "VTALRM" % string)
                                          (cons (sigprof, "PROF" % string)
                                            (cons (sigbus, "BUS" % string)
                                              (cons (sigpoll, "POLL" % string)
                                                (cons (sigsys, "SYS" % string)
                                                  (cons
                                                    (sigtrap, "TRAP" % string)
                                                    (cons
                                                      (sigurg, "URG" % string)
                                                      (cons
                                                        (sigxcpu,
                                                          "XCPU" % string)
                                                        (cons
                                                          (sigxfsz,
                                                            "XFSZ" % string) []))))))))))))))))))))))))))).

Definition set_exit_handler (op_staroptstar : option (string -> unit))
  : Z -> unit :=
  let log :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "010" % char
              (CamlinternalFormatBasics.Flush
                CamlinternalFormatBasics.End_of_format))) "%s
%!" % string)
    end in
  fun signal =>
    match Stdlib.List.assoc_opt signal signals with
    | None =>
      Format.kasprintf OCaml.Stdlib.invalid_arg
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Killable.set_exit_handler: unknown signal " % string
            (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              CamlinternalFormatBasics.End_of_format))
          "Killable.set_exit_handler: unknown signal %d" % string) signal
    | Some name =>
      let handler (signal : Z) : unit :=
        (* ❌ Try-with are not handled *)
        try
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          (let _ :=
            Format.kasprintf log
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Received the " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " signal, triggering shutdown." % string
                      CamlinternalFormatBasics.End_of_format)))
                "Received the %s signal, triggering shutdown." % string) name in
          exit signal) in
      OCaml.Stdlib.ignore (Lwt_unix.on_signal signal handler)
    end.

Definition signals_to_exit_on : Stdlib.ref (list Z) := Stdlib.ref [].

Definition exit_on (log : option (string -> unit)) (signal : Z) : unit :=
  if Stdlib.List.mem signal (Stdlib.op_exclamation signals_to_exit_on) then
    Format.kasprintf Pervasives.failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Killable.exit_on: already registered signal " % string
          (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
            CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.No_precision
            CamlinternalFormatBasics.End_of_format))
        "Killable.exit_on: already registered signal %d" % string) signal
  else
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Stdlib.op_coloneq signals_to_exit_on
        (cons signal (Stdlib.op_exclamation signals_to_exit_on)) in
    set_exit_handler log signal.

Inductive outcome : Type :=
| Resolved : Z -> outcome
| Exited : Z -> outcome.

Definition retcode_of_unit_result_lwt {A : Type} (p : Lwt.t (sum unit A))
  : Lwt.t Z :=
  op_gtgteq p
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error e =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := OCaml.Stdlib.ignore e in
        Lwt._return 1
      | Stdlib.Ok tt => Lwt._return 0
      end).

Definition wrap_promise (p : Lwt.t Z) : Lwt.t Z :=
  op_gtgteq
    (Lwt.choose
      (cons (op_gtpipeeq p (fun v => Resolved v))
        (cons (op_gtpipeeq termination_thread (fun s => Exited s)) [])))
    (fun function_parameter =>
      match function_parameter with
      | Resolved r => Lwt._return r
      | Exited s =>
        if Stdlib.List.mem s (Stdlib.op_exclamation signals_to_exit_on) then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := Lwt.cancel p in
          Lwt._return 2
        else
          Pervasives.exit 3
      end).

src/lib_stdlib_unix/lwt_lock_file.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

let create_inner lock_command ?(close_on_exec = true) ?(unlink_on_exit = false)
    fn =
  protect (fun () ->
      Lwt_unix.openfile fn Unix.[O_CREAT; O_WRONLY; O_TRUNC] 0o644
      >>= fun fd ->
      if close_on_exec then Lwt_unix.set_close_on_exec fd ;
      Lwt_unix.lockf fd lock_command 0
      >>= fun () ->
      if unlink_on_exit then Lwt_main.at_exit (fun () -> Lwt_unix.unlink fn) ;
      let pid_str = string_of_int @@ Unix.getpid () in
      Lwt_unix.write_string fd pid_str 0 (String.length pid_str)
      >>= fun _ -> return_unit)

let create = create_inner Unix.F_TLOCK

let blocking_create ?timeout ?(close_on_exec = true) ?(unlink_on_exit = false)
    fn =
  let create () = create_inner Unix.F_LOCK ~close_on_exec ~unlink_on_exit fn in
  match timeout with
  | None ->
      create ()
  | Some duration ->
      with_timeout (Lwt_unix.sleep duration) (fun _ -> create ())

let is_locked fn =
  if not @@ Sys.file_exists fn then return_false
  else
    protect (fun () ->
        Lwt_unix.openfile fn [Unix.O_RDONLY] 0o644
        >>= fun fd ->
        Lwt.finalize
          (fun () ->
            Lwt.try_bind
              (fun () -> Lwt_unix.(lockf fd F_TEST 0))
              (fun () -> return_false)
              (fun _ -> return_true))
          (fun () -> Lwt_unix.close fd))

let get_pid fn =
  let open Lwt_io in
  protect (fun () ->
      with_file ~mode:Input fn (fun ic ->
          read ic >>= fun content -> return (int_of_string content)))
src/lib_stdlib_unix/lwt_lock_file.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.

Definition create_inner
  (lock_command : Lwt_unix.lock_command) (op_staroptstar : option bool)
  : (option bool) ->
    string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let close_on_exec :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun op_staroptstar =>
    let unlink_on_exit :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun fn =>
      protect None None
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq
            (Lwt_unix.openfile fn
              (cons Unix.O_CREAT (cons Unix.O_WRONLY (cons Unix.O_TRUNC [])))
              420)
            (fun fd =>
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                if close_on_exec then
                  Lwt_unix.set_close_on_exec fd
                else
                  tt in
              op_gtgteq (Lwt_unix.lockf fd lock_command 0)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    if unlink_on_exit then
                      Lwt_main.at_exit
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Lwt_unix.unlink fn)
                    else
                      tt in
                  let pid_str :=
                    apply OCaml.Stdlib.string_of_int (Unix.getpid tt) in
                  op_gtgteq
                    (Lwt_unix.write_string fd pid_str 0
                      (OCaml.String.length pid_str))
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      return_unit)))).

Definition create
  : (option bool) ->
    (option bool) ->
      string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  create_inner Unix.F_TLOCK.

Definition blocking_create (timeout : option Z) (op_staroptstar : option bool)
  : (option bool) ->
    string -> Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
  let close_on_exec :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun op_staroptstar =>
    let unlink_on_exit :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun fn =>
      let create (function_parameter : unit)
        : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
        let 'tt := function_parameter in
        create_inner Unix.F_LOCK (Some close_on_exec) (Some unlink_on_exit) fn
        in
      match timeout with
      | None => create tt
      | Some duration =>
        with_timeout None (Lwt_unix.sleep duration)
          (fun function_parameter =>
            let '_ := function_parameter in
            create tt)
      end.

Definition is_locked (fn : string)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult bool) :=
  if apply negb (Sys.file_exists fn) then
    return_false
  else
    protect None None
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (Lwt_unix.openfile fn (cons Unix.O_RDONLY []) 420)
          (fun fd =>
            Lwt.finalize
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.try_bind
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    lockf fd Lwt_unix.F_TEST 0)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_false)
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    return_true))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt_unix.close fd))).

Definition get_pid (fn : Lwt_io.file_name)
  : Lwt.t (Tezos_error_monad.Error_monad.tzresult Z) :=
  protect None None
    (fun function_parameter =>
      let 'tt := function_parameter in
      with_file None None None Lwt_io.Input fn
        (fun ic =>
          op_gtgteq (read None ic)
            (fun content => _return (OCaml.Stdlib.int_of_string content)))).

src/lib_stdlib_unix/lwt_log_sink_unix.ml 67 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module Output = struct
  type t =
    | Null
    | Stdout
    | Stderr
    | File of string
    | Syslog of Lwt_log.syslog_facility

  let to_string : t -> string = function
    | Null ->
        "/dev/null"
    | Stdout ->
        "stdout"
    | Stderr ->
        "stderr"
    | File fp ->
        fp
    | Syslog `Auth ->
        "syslog:auth"
    | Syslog `Authpriv ->
        "syslog:authpriv"
    | Syslog `Cron ->
        "syslog:cron"
    | Syslog `Daemon ->
        "syslog:daemon"
    | Syslog `FTP ->
        "syslog:ftp"
    | Syslog `Kernel ->
        "syslog:kernel"
    | Syslog `Local0 ->
        "syslog:local0"
    | Syslog `Local1 ->
        "syslog:local1"
    | Syslog `Local2 ->
        "syslog:local2"
    | Syslog `Local3 ->
        "syslog:local3"
    | Syslog `Local4 ->
        "syslog:local4"
    | Syslog `Local5 ->
        "syslog:local5"
    | Syslog `Local6 ->
        "syslog:local6"
    | Syslog `Local7 ->
        "syslog:local7"
    | Syslog `LPR ->
        "syslog:lpr"
    | Syslog `Mail ->
        "syslog:mail"
    | Syslog `News ->
        "syslog:news"
    | Syslog `Syslog ->
        "syslog:syslog"
    | Syslog `User ->
        "syslog:user"
    | Syslog `UUCP ->
        "syslog:uucp"
    | Syslog `NTP ->
        "syslog:ntp"
    | Syslog `Security ->
        "syslog:security"
    | Syslog `Console ->
        "syslog:console"

  let of_string : string -> t = function
    | "/dev/null" | "null" ->
        Null
    | "stdout" ->
        Stdout
    | "stderr" ->
        Stderr
    | "syslog:auth" ->
        Syslog `Auth
    | "syslog:authpriv" ->
        Syslog `Authpriv
    | "syslog:cron" ->
        Syslog `Cron
    | "syslog:daemon" ->
        Syslog `Daemon
    | "syslog:ftp" ->
        Syslog `FTP
    | "syslog:kernel" ->
        Syslog `Kernel
    | "syslog:local0" ->
        Syslog `Local0
    | "syslog:local1" ->
        Syslog `Local1
    | "syslog:local2" ->
        Syslog `Local2
    | "syslog:local3" ->
        Syslog `Local3
    | "syslog:local4" ->
        Syslog `Local4
    | "syslog:local5" ->
        Syslog `Local5
    | "syslog:local6" ->
        Syslog `Local6
    | "syslog:local7" ->
        Syslog `Local7
    | "syslog:lpr" ->
        Syslog `LPR
    | "syslog:mail" ->
        Syslog `Mail
    | "syslog:news" ->
        Syslog `News
    | "syslog:syslog" ->
        Syslog `Syslog
    | "syslog:user" ->
        Syslog `User
    | "syslog:uucp" ->
        Syslog `UUCP
    | "syslog:ntp" ->
        Syslog `NTP
    | "syslog:security" ->
        Syslog `Security
    | "syslog:console" ->
        Syslog `Console
    (* | s when start_with "syslog:" FIXME error or warning. *)
    | fp ->
        (* TODO check absolute path *)
        File fp

  let encoding =
    let open Data_encoding in
    conv to_string of_string string

  let of_string str =
    try Some (Data_encoding.Json.destruct encoding (`String str))
    with _ -> None

  let to_string output =
    match Data_encoding.Json.construct encoding output with
    | `String res ->
        res
    | #Data_encoding.json ->
        assert false

  let pp fmt output = Format.fprintf fmt "%s" (to_string output)
end

let default_template = "$(date) - $(section): $(message)"

type cfg = {
  output : Output.t;
  default_level : Internal_event.level;
  rules : string option;
  template : Lwt_log_core.template;
}

let create_cfg ?(output = Output.Stderr)
    ?(default_level = Internal_event.Notice) ?rules
    ?(template = default_template) () =
  {output; default_level; rules; template}

let default_cfg = create_cfg ()

let cfg_encoding =
  let open Data_encoding in
  conv
    (fun {output; default_level; rules; template} ->
      (output, default_level, rules, template))
    (fun (output, default_level, rules, template) ->
      {output; default_level; rules; template})
    (obj4
       (dft
          "output"
          ~description:
            "Output for the logging function. Either 'stdout', 'stderr' or \
             the name of a log file ."
          Output.encoding
          default_cfg.output)
       (dft
          "level"
          ~description:
            "Verbosity level: one of 'fatal', 'error', 'warn','notice', \
             'info', 'debug'."
          Internal_event.Level.encoding
          default_cfg.default_level)
       (opt
          "rules"
          ~description:
            "Fine-grained logging instructions. Same format as described in \
             `tezos-node run --help`, DEBUG section. In the example below, \
             sections 'p2p' and all sections starting by 'client' will have \
             their messages logged up to the debug level, whereas the rest of \
             log sections will be logged up to the notice level."
          string)
       (dft
          "template"
          ~description:
            "Format for the log file, see \
             http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
          string
          default_cfg.template))

let init ?(template = default_template) output =
  let open Output in
  ( match output with
  | Stderr ->
      Lwt.return
      @@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stderr ()
  | Stdout ->
      Lwt.return
      @@ Lwt_log.channel ~template ~close_mode:`Keep ~channel:Lwt_io.stdout ()
  | File file_name ->
      Lwt_log.file ~file_name ~template ()
  | Null ->
      Lwt.return @@ Lwt_log.null
  | Syslog facility ->
      Lwt.return @@ Lwt_log.syslog ~template ~facility () )
  >>= fun logger ->
  Lwt_log.default := logger ;
  Lwt.return_unit

let find_log_rules default =
  match Sys.(getenv_opt "TEZOS_LOG", getenv_opt "LWT_LOG") with
  | (Some rules, None) ->
      ("environment variable TEZOS_LOG", Some rules)
  | (None, Some rules) ->
      ("environment variable LWT_LOG", Some rules)
  | (None, None) ->
      ("configuration file", default)
  | (Some rules, Some _) ->
      Format.eprintf
        "@[<v 2>@{<warning>@{<title>Warning@}@} Both environment variables \
         TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@\n\
         @." ;
      ("environment varible TEZOS_LOG", Some rules)

let initialize ?(cfg = default_cfg) () =
  Lwt_log_core.add_rule "*" (Internal_event.Level.to_lwt_log cfg.default_level) ;
  let (origin, rules) = find_log_rules cfg.rules in
  ( match rules with
  | None ->
      Lwt.return_unit
  | Some rules -> (
    try
      Lwt_log_core.load_rules rules ~fail_on_error:true ;
      Lwt.return_unit
    with _ ->
      Printf.ksprintf Lwt.fail_with "Incorrect log rules defined in %s" origin
    ) )
  >>= fun () -> init ~template:cfg.template cfg.output
src/lib_stdlib_unix/lwt_log_sink_unix.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

Module Output.
  Inductive t : Type :=
  | Null : t
  | Stdout : t
  | Stderr : t
  | File : string -> t
  | Syslog : Lwt_log.syslog_facility -> t.
  
  Definition to_string (function_parameter : t) : string :=
    match function_parameter with
    | Null => "/dev/null" % string
    | Stdout => "stdout" % string
    | Stderr => "stderr" % string
    | File fp => fp
    | Syslog Auth => "syslog:auth" % string
    | Syslog Authpriv => "syslog:authpriv" % string
    | Syslog Cron => "syslog:cron" % string
    | Syslog Daemon => "syslog:daemon" % string
    | Syslog FTP => "syslog:ftp" % string
    | Syslog Kernel => "syslog:kernel" % string
    | Syslog Local0 => "syslog:local0" % string
    | Syslog Local1 => "syslog:local1" % string
    | Syslog Local2 => "syslog:local2" % string
    | Syslog Local3 => "syslog:local3" % string
    | Syslog Local4 => "syslog:local4" % string
    | Syslog Local5 => "syslog:local5" % string
    | Syslog Local6 => "syslog:local6" % string
    | Syslog Local7 => "syslog:local7" % string
    | Syslog LPR => "syslog:lpr" % string
    | Syslog Mail => "syslog:mail" % string
    | Syslog News => "syslog:news" % string
    | Syslog Syslog => "syslog:syslog" % string
    | Syslog User => "syslog:user" % string
    | Syslog UUCP => "syslog:uucp" % string
    | Syslog NTP => "syslog:ntp" % string
    | Syslog Security => "syslog:security" % string
    | Syslog Console => "syslog:console" % string
    end.
  
  Definition of_string (function_parameter : string) : t :=
    match function_parameter with
    | "/dev/null" % string | "null" % string => Null
    | "stdout" % string => Stdout
    | "stderr" % string => Stderr
    | "syslog:auth" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:authpriv" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:cron" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:daemon" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:ftp" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:kernel" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local0" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local1" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local2" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local3" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local4" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local5" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local6" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:local7" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:lpr" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:mail" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:news" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:syslog" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:user" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:uucp" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:ntp" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:security" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | "syslog:console" % string =>
      Syslog
        (* ❌ Variants not supported *)
        variant
    | fp => File fp
    end.
  
  Definition encoding : Tezos_data_encoding.Data_encoding.encoding t :=
    conv to_string of_string None string.
  
  Definition of_string (str : string) : option t :=
    (* ❌ Try-with are not handled *)
    try
      (Some
        (Data_encoding.Json.destruct encoding
          (* ❌ Variants not supported *)
          variant)).
  
  Definition to_string (output : t) : string :=
    match Data_encoding.Json.construct encoding output with
    | String res => res
    | Bool _ | Null | O _ | Float _ | String _ | A _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end.
  
  Definition pp (fmt : Stdlib.Format.formatter) (output : t) : unit :=
    Format.fprintf fmt
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      (to_string output).
End Output.

Definition default_template : string :=
  "$(date) - $(section): $(message)" % string.

Record cfg := {
  output : Output.t;
  default_level : Tezos_event_logging.Internal_event.level;
  rules : option string;
  template : Lwt_log_core.template }.

Definition create_cfg (op_staroptstar : option Output.t)
  : (option Tezos_event_logging.Internal_event.level) ->
    (option string) -> (option string) -> unit -> cfg :=
  let output :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Output.Stderr
    end in
  fun op_staroptstar =>
    let default_level :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Tezos_event_logging.Internal_event.Notice
      end in
    fun rules =>
      fun op_staroptstar =>
        let template :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => default_template
          end in
        fun function_parameter =>
          let 'tt := function_parameter in
          {| output := output; default_level := default_level; rules := rules;
            template := template |}.

Definition default_cfg : cfg := create_cfg None None None None tt.

Definition cfg_encoding : Tezos_data_encoding.Data_encoding.encoding cfg :=
  conv
    (fun function_parameter =>
      let '{|
        output := output;
          default_level := default_level;
          rules := rules;
          template := template
          |} := function_parameter in
      (output, default_level, rules, template))
    (fun function_parameter =>
      let '(output, default_level, rules, template) := function_parameter in
      {| output := output; default_level := default_level; rules := rules;
        template := template |}) None
    (obj4
      (dft None
        (Some
          "Output for the logging function. Either 'stdout', 'stderr' or the name of a log file ."
            % string) "output" % string Output.encoding (output default_cfg))
      (dft None
        (Some
          "Verbosity level: one of 'fatal', 'error', 'warn','notice', 'info', 'debug'."
            % string) "level" % string Internal_event.Level.encoding
        (default_level default_cfg))
      (opt None
        (Some
          "Fine-grained logging instructions. Same format as described in `tezos-node run --help`, DEBUG section. In the example below, sections 'p2p' and all sections starting by 'client' will have their messages logged up to the debug level, whereas the rest of log sections will be logged up to the notice level."
            % string) "rules" % string string)
      (dft None
        (Some
          "Format for the log file, see http://ocsigen.org/lwt/dev/api/Lwt_log_core#2_Logtemplates."
            % string) "template" % string string (template default_cfg))).

Definition init (op_staroptstar : option string) : Output.t -> Lwt.t unit :=
  let template :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => default_template
    end in
  fun output =>
    op_gtgteq
      match output with
      | Output.Stderr =>
        apply Lwt._return
          (Lwt_log.channel (Some template)
            (* ❌ Variants not supported *)
            variant Lwt_io.stderr tt)
      | Output.Stdout =>
        apply Lwt._return
          (Lwt_log.channel (Some template)
            (* ❌ Variants not supported *)
            variant Lwt_io.stdout tt)
      | Output.File file_name =>
        Lwt_log.file (Some template) None None file_name tt
      | Output.Null => apply Lwt._return Lwt_log.null
      | Output.Syslog facility =>
        apply Lwt._return (Lwt_log.syslog (Some template) None facility tt)
      end
      (fun logger =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Stdlib.op_coloneq Lwt_log.default logger in
        Lwt.return_unit).

Definition find_log_rules (default : option string)
  : string * (option string) :=
  match ((getenv_opt "TEZOS_LOG" % string), (getenv_opt "LWT_LOG" % string))
    with
  | (Some rules, None) =>
    ("environment variable TEZOS_LOG" % string, (Some rules))
  | (None, Some rules) =>
    ("environment variable LWT_LOG" % string, (Some rules))
  | (None, None) => ("configuration file" % string, default)
  | (Some rules, Some _) =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.eprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_tag
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<warning>" % string
                    CamlinternalFormatBasics.End_of_format) "<warning>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_tag
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<title>" % string
                      CamlinternalFormatBasics.End_of_format) "<title>" % string))
                (CamlinternalFormatBasics.String_literal "Warning" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_tag
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_tag
                      (CamlinternalFormatBasics.String_literal
                        " Both environment variables TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG."
                          % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Force_newline
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))))))))
          "@[<v 2>@{<warning>@{<title>Warning@}@} Both environment variables TEZOS_LOG and LWT_LOG defined, using TEZOS_LOG.@]@
@."
            % string) in
    ("environment varible TEZOS_LOG" % string, (Some rules))
  end.

Definition initialize (op_staroptstar : option cfg) : unit -> Lwt.t unit :=
  let cfg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => default_cfg
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Lwt_log_core.add_rule "*" % string
        (Internal_event.Level.to_lwt_log (default_level cfg)) in
    let '(origin, rules) := find_log_rules (rules cfg) in
    op_gtgteq
      match rules with
      | None => Lwt.return_unit
      | Some rules =>
        (* ❌ Try-with are not handled *)
        try
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          (let _ := Lwt_log_core.load_rules (Some true) rules in
          Lwt.return_unit)
      end
      (fun function_parameter =>
        let 'tt := function_parameter in
        init (Some (template cfg)) (output cfg)).

src/lib_stdlib_unix/lwt_utils_unix.ml 32 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Error_monad

let () =
  register_error_kind
    `Temporary
    ~id:"unix_error"
    ~title:"Unix error"
    ~description:"An unhandled unix exception"
    ~pp:Format.pp_print_string
    Data_encoding.(obj1 (req "msg" string))
    (function
      | Exn (Unix.Unix_error (err, fn, _)) ->
          Some ("Unix error in " ^ fn ^ ": " ^ Unix.error_message err)
      | _ ->
          None)
    (fun msg -> Exn (Failure msg))

let read_bytes ?(pos = 0) ?len fd buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.read fd buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_read ->
          inner (pos + nb_read) (len - nb_read)
  in
  inner pos len

let read_string ~len fd =
  let b = Bytes.create len in
  read_bytes fd b >>= fun () -> Lwt.return @@ Bytes.to_string b

let read_mbytes ?(pos = 0) ?len fd buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.read fd buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_read ->
          inner (pos + nb_read) (len - nb_read)
  in
  inner pos len

let write_mbytes ?(pos = 0) ?len descr buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.write descr buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_written ->
          inner (pos + nb_written) (len - nb_written)
  in
  inner pos len

let write_bytes ?(pos = 0) ?len descr buf =
  let len = match len with None -> Bytes.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.write descr buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_written ->
          inner (pos + nb_written) (len - nb_written)
  in
  inner pos len

let write_string ?(pos = 0) ?len descr buf =
  let len = match len with None -> String.length buf - pos | Some l -> l in
  let rec inner pos len =
    if len = 0 then Lwt.return_unit
    else
      Lwt_unix.write_string descr buf pos len
      >>= function
      | 0 ->
          Lwt.fail End_of_file
          (* other endpoint cleanly closed its connection *)
      | nb_written ->
          inner (pos + nb_written) (len - nb_written)
  in
  inner pos len

let ( >>= ) = Lwt.bind

let remove_dir dir =
  let rec remove dir =
    let files = Lwt_unix.files_of_directory dir in
    Lwt_stream.iter_s
      (fun file ->
        if file = "." || file = ".." then Lwt.return_unit
        else
          let file = Filename.concat dir file in
          if Sys.is_directory file then remove file else Lwt_unix.unlink file)
      files
    >>= fun () -> Lwt_unix.rmdir dir
  in
  if Sys.file_exists dir && Sys.is_directory dir then remove dir
  else Lwt.return_unit

let rec create_dir ?(perm = 0o755) dir =
  Lwt_unix.file_exists dir
  >>= function
  | false ->
      create_dir (Filename.dirname dir)
      >>= fun () ->
      Lwt.catch
        (fun () -> Lwt_unix.mkdir dir perm)
        (function
          | Unix.Unix_error (Unix.EEXIST, _, _) ->
              (* This is the case where the directory has been created
                 by another Lwt.t, after the call to Lwt_unix.file_exists. *)
              Lwt.return_unit
          | e ->
              Lwt.fail e)
  | true -> (
      Lwt_unix.stat dir
      >>= function
      | {st_kind = S_DIR; _} ->
          Lwt.return_unit
      | _ ->
          Pervasives.failwith "Not a directory" )

let create_file ?(perm = 0o644) name content =
  Lwt_unix.openfile name Unix.[O_TRUNC; O_CREAT; O_WRONLY] perm
  >>= fun fd ->
  Lwt_unix.write_string fd content 0 (String.length content)
  >>= fun _ -> Lwt_unix.close fd

let read_file fn = Lwt_io.with_file fn ~mode:Input (fun ch -> Lwt_io.read ch)

let safe_close fd =
  Lwt.catch (fun () -> Lwt_unix.close fd) (fun _ -> Lwt.return_unit)

let of_sockaddr = function
  | Unix.ADDR_UNIX _ ->
      None
  | Unix.ADDR_INET (addr, port) -> (
    match Ipaddr_unix.of_inet_addr addr with
    | V4 addr ->
        Some (Ipaddr.v6_of_v4 addr, port)
    | V6 addr ->
        Some (addr, port) )

let getaddrinfo ~passive ~node ~service =
  let open Lwt_unix in
  getaddrinfo
    node
    service
    (AI_SOCKTYPE SOCK_STREAM :: (if passive then [AI_PASSIVE] else []))
  >>= fun addr ->
  let points =
    TzList.filter_map (fun {ai_addr; _} -> of_sockaddr ai_addr) addr
  in
  Lwt.return points

let getpass () =
  let open Unix in
  (* Turn echoing off and fail if we can't. *)
  let tio = tcgetattr stdin in
  let old_echo = tio.c_echo in
  let old_echonl = tio.c_echonl in
  tio.c_echo <- false ;
  tio.c_echonl <- true ;
  tcsetattr stdin TCSAFLUSH tio ;
  (* Read the passwd. *)
  let passwd = read_line () in
  (* Restore terminal. *)
  tio.c_echo <- old_echo ;
  tio.c_echonl <- old_echonl ;
  tcsetattr stdin TCSAFLUSH tio ;
  passwd

module Json = struct
  let to_root = function
    | `O ctns ->
        `O ctns
    | `A ctns ->
        `A ctns
    | `Null ->
        `O []
    | oth ->
        `A [oth]

  let write_file file json =
    let json = to_root json in
    protect (fun () ->
        Lwt_io.with_file ~mode:Output file (fun chan ->
            let str = Data_encoding.Json.to_string ~minify:false json in
            Lwt_io.write chan str >>= fun _ -> return_unit))

  let read_file file =
    protect (fun () ->
        Lwt_io.with_file ~mode:Input file (fun chan ->
            Lwt_io.read chan
            >>= fun str ->
            return (Ezjsonm.from_string str :> Data_encoding.json)))
end

let with_tempdir name f =
  let base_dir = Filename.temp_file name "" in
  Lwt_unix.unlink base_dir
  >>= fun () ->
  Lwt_unix.mkdir base_dir 0o700
  >>= fun () ->
  Lwt.finalize (fun () -> f base_dir) (fun () -> remove_dir base_dir)

module Socket = struct
  type addr =
    | Unix of string
    | Tcp of string * string * Unix.getaddrinfo_option list

  let handle_litteral_ipv6 host =
    (* To strip '[' and ']' when a litteral IPv6 is provided *)
    match Ipaddr.of_string host with
    | Error (`Msg _) ->
        host
    | Ok ipaddr ->
        Ipaddr.to_string ipaddr

  let connect ?(timeout = 5.) = function
    | Unix path ->
        let addr = Lwt_unix.ADDR_UNIX path in
        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
        Lwt_unix.connect sock addr >>= fun () -> return sock
    | Tcp (host, service, opts) -> (
        let host = handle_litteral_ipv6 host in
        Lwt_unix.getaddrinfo host service opts
        >>= function
        | [] ->
            failwith "could not resolve host '%s'" host
        | addrs ->
            let rec try_connect acc = function
              | [] ->
                  Lwt.return
                    (Error
                       ( failure "could not connect to '%s'" host
                       :: List.rev acc ))
              | {Unix.ai_family; ai_socktype; ai_protocol; ai_addr; _} :: addrs
                -> (
                  let sock =
                    Lwt_unix.socket ai_family ai_socktype ai_protocol
                  in
                  protect
                    ~on_error:(fun e ->
                      Lwt_unix.close sock >>= fun () -> Lwt.return_error e)
                    (fun () ->
                      with_timeout (Lwt_unix.sleep timeout) (fun _c ->
                          Lwt_unix.connect sock ai_addr
                          >>= fun () -> return sock))
                  >>= function
                  | Ok sock ->
                      return sock
                  | Error e ->
                      try_connect (e @ acc) addrs )
            in
            try_connect [] addrs )

  let bind ?(backlog = 10) = function
    | Unix path ->
        let addr = Lwt_unix.ADDR_UNIX path in
        let sock = Lwt_unix.socket PF_UNIX SOCK_STREAM 0 in
        Lwt_unix.bind sock addr
        >>= fun () ->
        Lwt_unix.listen sock backlog ;
        return [sock]
    | Tcp (host, service, opts) -> (
        Lwt_unix.getaddrinfo
          (handle_litteral_ipv6 host)
          service
          (AI_PASSIVE :: opts)
        >>= function
        | [] ->
            failwith "could not resolve host '%s'" host
        | addrs ->
            let do_bind {Unix.ai_family; ai_socktype; ai_protocol; ai_addr; _}
                =
              let sock = Lwt_unix.socket ai_family ai_socktype ai_protocol in
              Lwt_unix.setsockopt sock SO_REUSEADDR true ;
              Lwt_unix.bind sock ai_addr
              >>= fun () ->
              Lwt_unix.listen sock backlog ;
              return sock
            in
            map_s do_bind addrs )

  type error += Encoding_error | Decoding_error

  let () =
    register_error_kind
      `Permanent
      ~id:"signer.encoding_error"
      ~title:"Encoding_error"
      ~description:"Error while encoding a remote signer message"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "Could not encode a remote signer message")
      Data_encoding.empty
      (function Encoding_error -> Some () | _ -> None)
      (fun () -> Encoding_error) ;
    register_error_kind
      `Permanent
      ~id:"signer.decoding_error"
      ~title:"Decoding_error"
      ~description:"Error while decoding a remote signer message"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "Could not decode a remote signer message")
      Data_encoding.empty
      (function Decoding_error -> Some () | _ -> None)
      (fun () -> Decoding_error)

  let message_len_size = 2

  let send fd encoding message =
    let encoded_message_len = Data_encoding.Binary.length encoding message in
    fail_unless
      (encoded_message_len < 1 lsl (message_len_size * 8))
      Encoding_error
    >>=? fun () ->
    (* len is the length of int16 plus the length of the message we want to send *)
    let len = message_len_size + encoded_message_len in
    let buf = Bytes.create len in
    match
      Data_encoding.Binary.write
        encoding
        message
        buf
        message_len_size
        encoded_message_len
    with
    | None ->
        fail Encoding_error
    | Some last ->
        fail_unless (last = len) Encoding_error
        >>=? fun () ->
        (* we set the beginning of the buf with the length of what is next *)
        TzEndian.set_int16 buf 0 encoded_message_len ;
        write_mbytes fd buf >>= fun () -> return_unit

  let recv fd encoding =
    let header_buf = Bytes.create message_len_size in
    read_mbytes ~len:message_len_size fd header_buf
    >>= fun () ->
    let len = TzEndian.get_uint16 header_buf 0 in
    let buf = Bytes.create len in
    read_mbytes ~len fd buf
    >>= fun () ->
    match Data_encoding.Binary.read encoding buf 0 len with
    | None ->
        fail Decoding_error
    | Some (read_len, message) ->
        if read_len <> len then fail Decoding_error else return message
end

let rec retry ?(log = fun _ -> Lwt.return_unit) ?(n = 5) ?(sleep = 1.) f =
  f ()
  >>= function
  | Ok r ->
      Lwt.return_ok r
  | Error error as x ->
      if n > 0 then
        log error
        >>= fun () ->
        Lwt_unix.sleep sleep >>= fun () -> retry ~log ~n:(n - 1) ~sleep f
      else Lwt.return x
src/lib_stdlib_unix/lwt_utils_unix.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Error_monad.



Definition read_bytes (op_staroptstar : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun len =>
    fun fd =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            op_gtgteq (Lwt_unix.read fd buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_read => inner (Z.add pos nb_read) (Z.sub len nb_read)
                end) in
        inner pos len.

Definition read_string (len : Z) (fd : Lwt_unix.file_descr) : Lwt.t string :=
  let b := Stdlib.Bytes.create len in
  op_gtgteq (read_bytes None None fd b)
    (fun function_parameter =>
      let 'tt := function_parameter in
      apply Lwt._return (Stdlib.Bytes.to_string b)).

Definition read_mbytes (op_staroptstar : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun len =>
    fun fd =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            op_gtgteq (Lwt_unix.read fd buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_read => inner (Z.add pos nb_read) (Z.sub len nb_read)
                end) in
        inner pos len.

Definition write_mbytes (op_staroptstar : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun len =>
    fun descr =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            op_gtgteq (Lwt_unix.write descr buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_written =>
                  inner (Z.add pos nb_written) (Z.sub len nb_written)
                end) in
        inner pos len.

Definition write_bytes (op_staroptstar : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun len =>
    fun descr =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            op_gtgteq (Lwt_unix.write descr buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_written =>
                  inner (Z.add pos nb_written) (Z.sub len nb_written)
                end) in
        inner pos len.

Definition write_string (op_staroptstar : option Z)
  : (option Z) -> Lwt_unix.file_descr -> string -> Lwt.t unit :=
  let pos :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun len =>
    fun descr =>
      fun buf =>
        let len :=
          match len with
          | None => Z.sub (OCaml.String.length buf) pos
          | Some l => l
          end in
        let fix inner (pos : Z) (len : Z) : Lwt.t unit :=
          if equiv_decb len 0 then
            Lwt.return_unit
          else
            op_gtgteq (Lwt_unix.write_string descr buf pos len)
              (fun function_parameter =>
                match function_parameter with
                | 0 => Lwt.fail OCaml.End_of_file
                | nb_written =>
                  inner (Z.add pos nb_written) (Z.sub len nb_written)
                end) in
        inner pos len.

Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition remove_dir (dir : string) : Lwt.t unit :=
  let fix remove (dir : string) : Lwt.t unit :=
    let files := Lwt_unix.files_of_directory dir in
    op_gtgteq
      (Lwt_stream.iter_s
        (fun file =>
          if orb (equiv_decb file "." % string) (equiv_decb file ".." % string)
            then
            Lwt.return_unit
          else
            let file := Filename.concat dir file in
            if Sys.is_directory file then
              remove file
            else
              Lwt_unix.unlink file) files)
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_unix.rmdir dir) in
  if andb (Sys.file_exists dir) (Sys.is_directory dir) then
    remove dir
  else
    Lwt.return_unit.

Fixpoint create_dir (op_staroptstar : option Z) : string -> Lwt.t unit :=
  let perm :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 493
    end in
  fun dir =>
    op_gtgteq (Lwt_unix.file_exists dir)
      (fun function_parameter =>
        match function_parameter with
        | false =>
          op_gtgteq (create_dir None (Filename.dirname dir))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.catch
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt_unix.mkdir dir perm)
                (fun function_parameter =>
                  match function_parameter with
                  | Unix_error Unix.EEXIST _ _ => Lwt.return_unit
                  | e => Lwt.fail e
                  end))
        | true =>
          op_gtgteq (Lwt_unix.stat dir)
            (fun function_parameter =>
              match function_parameter with
              | {| st_kind := Lwt_unix.S_DIR |} => Lwt.return_unit
              | _ => Pervasives.failwith "Not a directory" % string
              end)
        end).

Definition create_file (op_staroptstar : option Lwt_unix.file_perm)
  : string -> string -> Lwt.t unit :=
  let perm :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 420
    end in
  fun name =>
    fun content =>
      op_gtgteq
        (Lwt_unix.openfile name
          (cons Unix.O_TRUNC (cons Unix.O_CREAT (cons Unix.O_WRONLY []))) perm)
        (fun fd =>
          op_gtgteq
            (Lwt_unix.write_string fd content 0 (OCaml.String.length content))
            (fun function_parameter =>
              let '_ := function_parameter in
              Lwt_unix.close fd)).

Definition read_file (fn : Lwt_io.file_name) : Lwt.t string :=
  Lwt_io.with_file None None None Lwt_io.Input fn
    (fun ch => Lwt_io.read None ch).

Definition safe_close (fd : Lwt_unix.file_descr) : Lwt.t unit :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      Lwt_unix.close fd)
    (fun function_parameter =>
      let '_ := function_parameter in
      Lwt.return_unit).

Definition of_sockaddr (function_parameter : Unix.sockaddr)
  : option (Ipaddr.V6.t * Z) :=
  match function_parameter with
  | Unix.ADDR_UNIX _ => None
  | Unix.ADDR_INET addr port =>
    match Ipaddr_unix.of_inet_addr addr with
    | Ipaddr.V4 addr => Some ((Ipaddr.v6_of_v4 addr), port)
    | Ipaddr.V6 addr => Some (addr, port)
    end
  end.

Definition getaddrinfo (passive : bool) (node : string) (service : string)
  : Lwt.t (list (Ipaddr.V6.t * Z)) :=
  op_gtgteq
    (getaddrinfo node service
      (cons (Lwt_unix.AI_SOCKTYPE Lwt_unix.SOCK_STREAM)
        (if passive then
          cons Lwt_unix.AI_PASSIVE []
        else
          [])))
    (fun addr =>
      let points :=
        TzList.filter_map
          (fun function_parameter =>
            let '{| ai_addr := ai_addr |} := function_parameter in
            of_sockaddr ai_addr) addr in
      Lwt._return points).

Definition getpass (function_parameter : unit) : string :=
  let 'tt := function_parameter in
  let tio := tcgetattr stdin in
  let old_echo := c_echo tio in
  let old_echonl := c_echonl tio in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field tio "c_echo" % string false in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field tio "c_echonl" % string true in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := tcsetattr stdin Unix.TCSAFLUSH tio in
  let passwd := OCaml.Stdlib.read_line tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field tio "c_echo" % string old_echo in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field tio "c_echonl" % string old_echonl in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := tcsetattr stdin Unix.TCSAFLUSH tio in
  passwd.

Module Json.
  Definition to_root (function_parameter : variant) : variant :=
    match function_parameter with
    | O ctns =>
      (* ❌ Variants not supported *)
      variant
    | A ctns =>
      (* ❌ Variants not supported *)
      variant
    | Null =>
      (* ❌ Variants not supported *)
      variant
    | oth =>
      (* ❌ Variants not supported *)
      variant
    end.
  
  Definition write_file (file : Lwt_io.file_name) (json : variant)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let json := to_root json in
    protect None None
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_io.with_file None None None Lwt_io.Output file
          (fun chan =>
            let str := Data_encoding.Json.to_string None (Some false) json in
            op_gtgteq (Lwt_io.write chan str)
              (fun function_parameter =>
                let '_ := function_parameter in
                return_unit))).
  
  Definition read_file (file : Lwt_io.file_name)
    : Lwt.t
      (Tezos_error_monad.Error_monad.tzresult
        Tezos_data_encoding.Data_encoding.json) :=
    protect None None
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_io.with_file None None None Lwt_io.Input file
          (fun chan =>
            op_gtgteq (Lwt_io.read None chan)
              (fun str => _return (Ezjsonm.from_string str)))).
End Json.

Definition with_tempdir {A : Type} (name : string) (f : string -> Lwt.t A)
  : Lwt.t A :=
  let base_dir := Filename.temp_file None name "" % string in
  op_gtgteq (Lwt_unix.unlink base_dir)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_unix.mkdir base_dir 448)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt.finalize
            (fun function_parameter =>
              let 'tt := function_parameter in
              f base_dir)
            (fun function_parameter =>
              let 'tt := function_parameter in
              remove_dir base_dir))).

Module Socket.
  Inductive addr : Type :=
  | Unix : string -> addr
  | Tcp : string -> string -> (list Unix.getaddrinfo_option) -> addr.
  
  Definition handle_litteral_ipv6 (host : string) : string :=
    match Ipaddr.of_string host with
    | Stdlib.Error (Msg _) => host
    | Stdlib.Ok ipaddr => Ipaddr.to_string ipaddr
    end.
  
  Definition connect (op_staroptstar : option Z)
    : addr -> Lwt.t (Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr) :=
    let timeout :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None =>
        (* ❌ Float constant 5. is approximated by the integer 5 *)
        5
      end in
    fun function_parameter =>
      match function_parameter with
      | Unix path =>
        let addr := Lwt_unix.ADDR_UNIX path in
        let sock := Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in
        op_gtgteq (Lwt_unix.connect sock addr)
          (fun function_parameter =>
            let 'tt := function_parameter in
            _return sock)
      | Tcp host service opts =>
        let host := handle_litteral_ipv6 host in
        op_gtgteq (Lwt_unix.getaddrinfo host service opts)
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not resolve host '" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "'" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "could not resolve host '%s'" % string) host
            | addrs =>
              let fix try_connect
                (acc : list Tezos_error_monad.Error_monad.error)
                (function_parameter : list Unix.addr_info)
                : Lwt.t
                  (sum Lwt_unix.file_descr Tezos_error_monad.Error_monad.trace) :=
                match function_parameter with
                | [] =>
                  Lwt._return
                    (Stdlib.Error
                      (cons
                        (failure
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "could not connect to '" % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Char_literal
                                  "'" % char
                                  CamlinternalFormatBasics.End_of_format)))
                            "could not connect to '%s'" % string) host)
                        (List.rev acc)))
                |
                  cons {|
                    Unix.ai_family := ai_family;
                      Unix.ai_socktype := ai_socktype;
                      Unix.ai_protocol := ai_protocol;
                      Unix.ai_addr := ai_addr
                      |} addrs =>
                  let sock := Lwt_unix.socket ai_family ai_socktype ai_protocol
                    in
                  op_gtgteq
                    (protect
                      (Some
                        (fun e =>
                          op_gtgteq (Lwt_unix.close sock)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              Lwt.return_error e))) None
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        with_timeout None (Lwt_unix.sleep timeout)
                          (fun _c =>
                            op_gtgteq (Lwt_unix.connect sock ai_addr)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                _return sock))))
                    (fun function_parameter =>
                      match function_parameter with
                      | Stdlib.Ok sock => _return sock
                      | Stdlib.Error e =>
                        try_connect (OCaml.Stdlib.app e acc) addrs
                      end)
                end in
              try_connect [] addrs
            end)
      end.
  
  Definition bind (op_staroptstar : option Z)
    : addr ->
      Lwt.t (Tezos_error_monad.Error_monad.tzresult (list Lwt_unix.file_descr)) :=
    let backlog :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => 10
      end in
    fun function_parameter =>
      match function_parameter with
      | Unix path =>
        let addr := Lwt_unix.ADDR_UNIX path in
        let sock := Lwt_unix.socket Lwt_unix.PF_UNIX Lwt_unix.SOCK_STREAM 0 in
        op_gtgteq (Lwt_unix.bind sock addr)
          (fun function_parameter =>
            let 'tt := function_parameter in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ := Lwt_unix.listen sock backlog in
            _return (cons sock []))
      | Tcp host service opts =>
        op_gtgteq
          (Lwt_unix.getaddrinfo (handle_litteral_ipv6 host) service
            (cons Lwt_unix.AI_PASSIVE opts))
          (fun function_parameter =>
            match function_parameter with
            | [] =>
              failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "could not resolve host '" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal "'" % char
                        CamlinternalFormatBasics.End_of_format)))
                  "could not resolve host '%s'" % string) host
            | addrs =>
              let do_bind (function_parameter : Unix.addr_info)
                : Lwt.t
                  (Tezos_error_monad.Error_monad.tzresult Lwt_unix.file_descr) :=
                let '{|
                  Unix.ai_family := ai_family;
                    Unix.ai_socktype := ai_socktype;
                    Unix.ai_protocol := ai_protocol;
                    Unix.ai_addr := ai_addr
                    |} := function_parameter in
                let sock := Lwt_unix.socket ai_family ai_socktype ai_protocol in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := Lwt_unix.setsockopt sock Lwt_unix.SO_REUSEADDR true in
                op_gtgteq (Lwt_unix.bind sock ai_addr)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Lwt_unix.listen sock backlog in
                    _return sock) in
              map_s do_bind addrs
            end)
      end.
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  
  
  Definition message_len_size : Z := 2.
  
  Definition send {A : Type}
    (fd : Lwt_unix.file_descr)
    (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) (message : A)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult unit) :=
    let encoded_message_len := Data_encoding.Binary.length encoding message in
    op_gtgteqquestion
      (fail_unless
        (OCaml.Stdlib.lt encoded_message_len
          (Z.shiftl 1 (Z.mul message_len_size 8)))
        Tezos_error_monad.Error_monad.Encoding_error)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let len := Z.add message_len_size encoded_message_len in
        let buf := Stdlib.Bytes.create len in
        match
          Data_encoding.Binary.write encoding message buf message_len_size
            encoded_message_len with
        | None => fail Tezos_error_monad.Error_monad.Encoding_error
        | Some last =>
          op_gtgteqquestion
            (fail_unless (equiv_decb last len)
              Tezos_error_monad.Error_monad.Encoding_error)
            (fun function_parameter =>
              let 'tt := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := TzEndian.set_int16 buf 0 encoded_message_len in
              op_gtgteq (write_mbytes None None fd buf)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit))
        end).
  
  Definition recv {A : Type}
    (fd : Lwt_unix.file_descr)
    (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A)
    : Lwt.t (Tezos_error_monad.Error_monad.tzresult A) :=
    let header_buf := Stdlib.Bytes.create message_len_size in
    op_gtgteq (read_mbytes None (Some message_len_size) fd header_buf)
      (fun function_parameter =>
        let 'tt := function_parameter in
        let len := TzEndian.get_uint16 header_buf 0 in
        let buf := Stdlib.Bytes.create len in
        op_gtgteq (read_mbytes None (Some len) fd buf)
          (fun function_parameter =>
            let 'tt := function_parameter in
            match Data_encoding.Binary.read encoding buf 0 len with
            | None => fail Tezos_error_monad.Error_monad.Decoding_error
            | Some (read_len, message) =>
              if nequiv_decb read_len len then
                fail Tezos_error_monad.Error_monad.Decoding_error
              else
                _return message
            end)).
End Socket.

Fixpoint retry {A B : Type} (op_staroptstar : option (A -> Lwt.t unit))
  : (option Z) ->
    (option Z) -> (unit -> Lwt.t (sum B A)) -> Lwt.t (Result.result B A) :=
  let log :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      fun function_parameter =>
        let '_ := function_parameter in
        Lwt.return_unit
    end in
  fun op_staroptstar =>
    let n :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => 5
      end in
    fun op_staroptstar =>
      let sleep :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Float constant 1. is approximated by the integer 1 *)
          1
        end in
      fun f =>
        op_gtgteq (f tt)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok r => Lwt.return_ok r
            | (Stdlib.Error error) as x =>
              if OCaml.Stdlib.gt n 0 then
                op_gtgteq (log error)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteq (Lwt_unix.sleep sleep)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        retry (Some log) (Some (Z.sub n 1)) (Some sleep) f))
              else
                Lwt._return x
            end).

src/lib_stdlib_unix/moving_average.ml 18 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module Inttbl = Hashtbl.Make (struct
  type t = int

  let equal (x : int) (y : int) = x = y

  let hash = Hashtbl.hash
end)

type t = {
  id : int;
  alpha : int;
  mutable total : int64;
  mutable current : int;
  mutable average : int;
}

let counters = Inttbl.create 51

let updated = Lwt_condition.create ()

let update_hook = ref []

let on_update f = update_hook := f :: !update_hook

let worker_loop () =
  let prev = ref @@ Mtime_clock.elapsed () in
  let rec inner sleep =
    sleep
    >>= fun () ->
    let sleep = Lwt_unix.sleep 1. in
    let now = Mtime_clock.elapsed () in
    let elapsed = int_of_float Mtime.Span.(to_ms now -. to_ms !prev) in
    prev := now ;
    Inttbl.iter
      (fun _ c ->
        c.average <-
          (c.alpha * c.current / elapsed)
          + ((1000 - c.alpha) * c.average / 1000) ;
        c.current <- 0)
      counters ;
    List.iter (fun f -> f ()) !update_hook ;
    Lwt_condition.broadcast updated () ;
    inner sleep
  in
  inner (Lwt_unix.sleep 1.)

let worker =
  lazy
    (Lwt.async (fun () ->
         Lwt_utils.worker
           "counter"
           ~on_event:Internal_event.Lwt_worker_event.on_event
           ~run:worker_loop
           ~cancel:(fun _ -> Lwt.return_unit)))

let create =
  let cpt = ref 0 in
  fun ~init ~alpha ->
    Lazy.force worker ;
    let id = !cpt in
    incr cpt ;
    assert (0. < alpha && alpha <= 1.) ;
    let alpha = int_of_float (1000. *. alpha) in
    let c = {id; alpha; total = 0L; current = 0; average = init} in
    Inttbl.add counters id c ; c

let add c x =
  c.total <- Int64.(add c.total (of_int x)) ;
  c.current <- c.current + x

let destroy c = Inttbl.remove counters c.id

type stat = {total : int64; average : int}

let stat ({total; average; _} : t) : stat = {total; average}
src/lib_stdlib_unix/moving_average.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Lwt.Infix.

(* ❌ Applications of functors are not handled. *)
functor_application

Record t := {
  id : Z;
  alpha : Z;
  total : int64;
  current : Z;
  average : Z }.

Definition counters : Inttbl.t t := Inttbl.create 51.

Definition updated : Lwt_condition.t unit := Lwt_condition.create tt.

Definition update_hook : Stdlib.ref (list (unit -> unit)) := Stdlib.ref [].

Definition on_update (f : unit -> unit) : unit :=
  Stdlib.op_coloneq update_hook (cons f (Stdlib.op_exclamation update_hook)).

Definition worker_loop {A : Type} (function_parameter : unit) : Lwt.t A :=
  let 'tt := function_parameter in
  let prev := apply Stdlib.ref (Mtime_clock.elapsed tt) in
  let fix inner {B : Type} (sleep : Lwt.t unit) : Lwt.t B :=
    op_gtgteq sleep
      (fun function_parameter =>
        let 'tt := function_parameter in
        let sleep :=
          Lwt_unix.sleep
            (* ❌ Float constant 1. is approximated by the integer 1 *)
            1 in
        let now := Mtime_clock.elapsed tt in
        let elapsed :=
          Stdlib.int_of_float
            (Stdlib.op_minuspoint (to_ms now)
              (to_ms (Stdlib.op_exclamation prev))) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Stdlib.op_coloneq prev now in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Inttbl.iter
            (fun function_parameter =>
              let '_ := function_parameter in
              fun c =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  (* ❌ Set record field not handled. *)
                  set_record_field c "average" % string
                    (Z.add (Z.div (Z.mul (alpha c) (current c)) elapsed)
                      (Z.div (Z.mul (Z.sub 1000 (alpha c)) (average c)) 1000))
                  in
                (* ❌ Set record field not handled. *)
                set_record_field c "current" % string 0) counters in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          Stdlib.List.iter (fun f => f tt) (Stdlib.op_exclamation update_hook)
          in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Lwt_condition.broadcast updated tt in
        inner sleep) in
  inner
    (Lwt_unix.sleep
      (* ❌ Float constant 1. is approximated by the integer 1 *)
      1).

Definition worker : lazy_t unit :=
  (* ❌ Lazy expressions are not handled *)
  lazy
    (Lwt.async
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt_utils.worker "counter" % string
          Internal_event.Lwt_worker_event.on_event worker_loop
          (fun function_parameter =>
            let '_ := function_parameter in
            Lwt.return_unit))).

Definition create : Z -> Z -> t :=
  let cpt := Stdlib.ref 0 in
  fun init =>
    fun alpha =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Lazy.force worker in
      let id := Stdlib.op_exclamation cpt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Stdlib.incr cpt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (andb
            (OCaml.Stdlib.lt
              (* ❌ Float constant 0. is approximated by the integer 0 *)
              0 alpha)
            (OCaml.Stdlib.le alpha
              (* ❌ Float constant 1. is approximated by the integer 1 *)
              1)) in
      let alpha :=
        Stdlib.int_of_float
          (Stdlib.op_starpoint
            (* ❌ Float constant 1000. is approximated by the integer 1000 *)
            1000 alpha) in
      let c :=
        {| id := id; alpha := alpha;
          total :=
            (* ❌ Constant of type int64 is converted to int *)
            0; current := 0; average := init |} in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := Inttbl.add counters id c in
      c.

Definition add (c : t) (x : Z) : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Set record field not handled. *)
    set_record_field c "total" % string (add (total c) (of_int x)) in
  (* ❌ Set record field not handled. *)
  set_record_field c "current" % string (Z.add (current c) x).

Definition destroy (c : t) : unit := Inttbl.remove counters (id c).

Record stat := {
  total : int64;
  average : Z }.

Definition stat (function_parameter : t) : stat :=
  let '{| total := total; average := average |} := function_parameter in
  {| total := total; average := average |}.

src/lib_stdlib_unix/sys_info.ml 13 errors
(*****************************************************************************)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Memory
open Error_monad

type Error_monad.error += Unix_system_info_failure of string

let () =
  Error_monad.register_error_kind
    `Temporary
    ~id:"unix.system_info"
    ~title:"Unix System_info failure"
    ~description:"Unix System_info failure"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "@[<v 2>Unix system_info failure %s@]" s)
    Data_encoding.(obj1 (req "failure" string))
    (function Unix_system_info_failure s -> Some s | _ -> None)
    (fun s -> Unix_system_info_failure s)

let error_info process error =
  Unix_system_info_failure
    (Format.asprintf "Unix_system_info_failure (%s: %s)" process error)

type sysname = Linux | Darwin | Unknown of string

let uname =
  Lwt.catch
    (fun () ->
      Lwt_process.with_process_in
        ~env:[|"LC_ALL=C"|]
        ("uname", [|"uname"|])
        (fun pc -> Lwt_io.read_line pc#stdout)
      >>= function
      | "Linux" ->
          Lwt.return_ok Linux
      | "Darwin" ->
          Lwt.return_ok Darwin
      | os ->
          Lwt.return_ok (Unknown os))
    (function
      | exn -> Lwt.return_error (error_info "uname" (Printexc.to_string exn)))

let page_size () =
  let get_conf_process =
    uname
    >>= function
    | Ok Linux ->
        Lwt.return_ok ("getconf", [|"getconf"; "PAGE_SIZE"|])
    | Ok Darwin ->
        Lwt.return_ok ("pagesize", [|"pagesize"|])
    | Ok (Unknown _) ->
        Lwt.return_error (error_info "pagesize" "Unknown unix system")
    | Error (Unix_system_info_failure e) ->
        Lwt.return_error (error_info "pagesize" e)
    | Error e ->
        Lwt.return_error e
  in
  get_conf_process
  >>= function
  | Error e ->
      Lwt.return_error e
  | Ok process ->
      Lwt.catch
        (fun () ->
          Lwt_process.with_process_in process ~env:[|"LC_ALL=C"|] (fun pc ->
              Lwt_io.read_line pc#stdout
              >>= fun ps -> Lwt.return_ok (int_of_string ps)))
        (function
          | exn ->
              Lwt.return_error (error_info "pagesize" (Printexc.to_string exn)))

let linux_statm pid =
  Lwt.catch
    (fun () ->
      let fname = Format.asprintf "/proc/%d/statm" pid in
      Lwt_unix.file_exists fname
      >>= function
      | true ->
          Lwt_io.with_file ~mode:Input fname (fun ic ->
              Lwt_io.read_line ic
              >>= fun line ->
              match List.map Int64.of_string @@ TzString.split ' ' line with
              | size :: resident :: shared :: text :: lib :: data :: dt :: _
                -> (
                  page_size ()
                  >>= function
                  | Error e ->
                      Lwt.return_error e
                  | Ok page_size ->
                      Lwt.return_ok
                        (Statm
                           {
                             page_size;
                             size;
                             resident;
                             shared;
                             text;
                             lib;
                             data;
                             dt;
                           }) )
              | _ ->
                  Lwt.return_error
                    (error_info
                       "procfs statm"
                       "Unexpected proc/<pid>/statm format"))
      | false ->
          Lwt.return_error
            (error_info "procfs statm" (Format.asprintf "%s not found" fname)))
    (function
      | exn ->
          Lwt.return_error (error_info "procfs statm" (Printexc.to_string exn)))

let darwin_ps pid =
  Lwt.catch
    (fun () ->
      Lwt_process.with_process_in
        ~env:[|"LC_ALL=C"|]
        ("ps", [|"ps"; "-o"; "pid,%mem,rss"; "-p"; string_of_int pid|])
        (fun pc ->
          Lwt_io.read_line_opt pc#stdout
          >>= function
          | None ->
              Lwt.return_error
                (error_info "ps" "Unexpected ps answer (1st line)")
          | Some _ -> (
              (* first line is useless *)
              Lwt_io.read_line_opt pc#stdout
              >>= function
              | None ->
                  Lwt.return_error
                    (error_info "ps" "Unexpected ps answer (2nd line)")
              | Some ps_stats -> (
                match TzString.split ' ' ps_stats with
                | _pid :: mem :: resident :: _ -> (
                    page_size ()
                    >>= function
                    | Error e ->
                        Lwt.return_error e
                    | Ok page_size ->
                        Lwt.return_ok
                          (Ps
                             {
                               page_size;
                               mem = float_of_string mem;
                               resident = Int64.of_string resident;
                             }) )
                | _ ->
                    Lwt.return_error (error_info "ps" "Unexpected answer") ) )))
    (function
      | exn -> Lwt.return_error (error_info "ps" (Printexc.to_string exn)))

let memory_stats () =
  let pid = Unix.getpid () in
  uname
  >>= function
  | Error e ->
      Lwt.return_error e
  | Ok Linux ->
      linux_statm pid
  | Ok Darwin ->
      darwin_ps pid
  | _ ->
      Lwt.return_error (error_info "memory_stats" "Unknown unix system")
src/lib_stdlib_unix/sys_info.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Memory.

Import Error_monad.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition error_info (process : string) (error : string)
  : Tezos_error_monad.Error_monad.error :=
  Tezos_error_monad.Error_monad.Unix_system_info_failure
    (Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Unix_system_info_failure (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal ": " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ")" % char
                  CamlinternalFormatBasics.End_of_format)))))
        "Unix_system_info_failure (%s: %s)" % string) process error).

Inductive sysname : Type :=
| Linux : sysname
| Darwin : sysname
| Unknown : string -> sysname.

Definition uname
  : Lwt.t (Result.result sysname Tezos_error_monad.Error_monad.error) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        (Lwt_process.with_process_in None
          (Some
            (* ❌ Arrays not handled. *)
            [ "LC_ALL=C" % string ]) None None
          ("uname" % string,
            (* ❌ Arrays not handled. *)
            [ "uname" % string ])
          (fun pc =>
            Lwt_io.read_line
              (* ❌ Sending method message is not handled *)
              send))
        (fun function_parameter =>
          match function_parameter with
          | "Linux" % string => Lwt.return_ok Linux
          | "Darwin" % string => Lwt.return_ok Darwin
          | os => Lwt.return_ok (Unknown os)
          end))
    (fun exn =>
      Lwt.return_error (error_info "uname" % string (Printexc.to_string exn))).

Definition page_size (function_parameter : unit)
  : Lwt.t (Result.result Z Tezos_error_monad.Error_monad.error) :=
  let 'tt := function_parameter in
  let get_conf_process :=
    op_gtgteq uname
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok Linux =>
          Lwt.return_ok
            ("getconf" % string,
              (* ❌ Arrays not handled. *)
              [ "getconf" % string; "PAGE_SIZE" % string ])
        | Stdlib.Ok Darwin =>
          Lwt.return_ok
            ("pagesize" % string,
              (* ❌ Arrays not handled. *)
              [ "pagesize" % string ])
        | Stdlib.Ok (Unknown _) =>
          Lwt.return_error
            (error_info "pagesize" % string "Unknown unix system" % string)
        |
          Stdlib.Error
            (Tezos_error_monad.Error_monad.Unix_system_info_failure e) =>
          Lwt.return_error (error_info "pagesize" % string e)
        | Stdlib.Error e => Lwt.return_error e
        end) in
  op_gtgteq get_conf_process
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error e => Lwt.return_error e
      | Stdlib.Ok process =>
        Lwt.catch
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt_process.with_process_in None
              (Some
                (* ❌ Arrays not handled. *)
                [ "LC_ALL=C" % string ]) None None process
              (fun pc =>
                op_gtgteq
                  (Lwt_io.read_line
                    (* ❌ Sending method message is not handled *)
                    send)
                  (fun ps => Lwt.return_ok (OCaml.Stdlib.int_of_string ps))))
          (fun exn =>
            Lwt.return_error
              (error_info "pagesize" % string (Printexc.to_string exn)))
      end).

Definition linux_statm (pid : Z)
  : Lwt.t
    (Result.result Tezos_stdlib.Memory.mem_stats
      Tezos_error_monad.Error_monad.error) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      let fname :=
        Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "/proc/" % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal "/statm" % string
                  CamlinternalFormatBasics.End_of_format)))
            "/proc/%d/statm" % string) pid in
      op_gtgteq (Lwt_unix.file_exists fname)
        (fun function_parameter =>
          match function_parameter with
          | true =>
            Lwt_io.with_file None None None Lwt_io.Input fname
              (fun ic =>
                op_gtgteq (Lwt_io.read_line ic)
                  (fun line =>
                    match
                      apply (List.map Int64.of_string)
                        (TzString.split " " % char None None line) with
                    |
                      cons size
                        (cons resident
                          (cons shared
                            (cons text (cons lib (cons data (cons dt _)))))) =>
                      op_gtgteq (page_size tt)
                        (fun function_parameter =>
                          match function_parameter with
                          | Stdlib.Error e => Lwt.return_error e
                          | Stdlib.Ok page_size =>
                            Lwt.return_ok
                              (Tezos_stdlib.Memory.Statm
                                {| page_size := page_size; size := size;
                                  resident := resident; shared := shared;
                                  text := text; lib := lib; data := data;
                                  dt := dt |})
                          end)
                    | _ =>
                      Lwt.return_error
                        (error_info "procfs statm" % string
                          "Unexpected proc/<pid>/statm format" % string)
                    end))
          | false =>
            Lwt.return_error
              (error_info "procfs statm" % string
                (Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " not found" % string
                        CamlinternalFormatBasics.End_of_format))
                    "%s not found" % string) fname))
          end))
    (fun exn =>
      Lwt.return_error
        (error_info "procfs statm" % string (Printexc.to_string exn))).

Definition darwin_ps (pid : Z)
  : Lwt.t
    (Result.result Tezos_stdlib.Memory.mem_stats
      Tezos_error_monad.Error_monad.error) :=
  Lwt.catch
    (fun function_parameter =>
      let 'tt := function_parameter in
      Lwt_process.with_process_in None
        (Some
          (* ❌ Arrays not handled. *)
          [ "LC_ALL=C" % string ]) None None
        ("ps" % string,
          (* ❌ Arrays not handled. *)
          [
            "ps" % string;
            "-o" % string;
            "pid,%mem,rss" % string;
            "-p" % string;
            OCaml.Stdlib.string_of_int pid
          ])
        (fun pc =>
          op_gtgteq
            (Lwt_io.read_line_opt
              (* ❌ Sending method message is not handled *)
              send)
            (fun function_parameter =>
              match function_parameter with
              | None =>
                Lwt.return_error
                  (error_info "ps" % string
                    "Unexpected ps answer (1st line)" % string)
              | Some _ =>
                op_gtgteq
                  (Lwt_io.read_line_opt
                    (* ❌ Sending method message is not handled *)
                    send)
                  (fun function_parameter =>
                    match function_parameter with
                    | None =>
                      Lwt.return_error
                        (error_info "ps" % string
                          "Unexpected ps answer (2nd line)" % string)
                    | Some ps_stats =>
                      match TzString.split " " % char None None ps_stats with
                      | cons _pid (cons mem (cons resident _)) =>
                        op_gtgteq (page_size tt)
                          (fun function_parameter =>
                            match function_parameter with
                            | Stdlib.Error e => Lwt.return_error e
                            | Stdlib.Ok page_size =>
                              Lwt.return_ok
                                (Tezos_stdlib.Memory.Ps
                                  {| page_size := page_size;
                                    mem := Stdlib.float_of_string mem;
                                    resident := Int64.of_string resident |})
                            end)
                      | _ =>
                        Lwt.return_error
                          (error_info "ps" % string "Unexpected answer" % string)
                      end
                    end)
              end)))
    (fun exn =>
      Lwt.return_error (error_info "ps" % string (Printexc.to_string exn))).

Definition memory_stats (function_parameter : unit)
  : Lwt.t
    (Result.result Tezos_stdlib.Memory.mem_stats
      Tezos_error_monad.Error_monad.error) :=
  let 'tt := function_parameter in
  let pid := Unix.getpid tt in
  op_gtgteq uname
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error e => Lwt.return_error e
      | Stdlib.Ok Linux => linux_statm pid
      | Stdlib.Ok Darwin => darwin_ps pid
      | _ =>
        Lwt.return_error
          (error_info "memory_stats" % string "Unknown unix system" % string)
      end).

src/lib_stdlib_unix/systime_os.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let now () = Ptime_clock.now ()

let sleep s = Lwt_unix.sleep (Ptime.Span.to_float_s s)
src/lib_stdlib_unix/systime_os.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition now (function_parameter : unit) : Ptime.t :=
  let 'tt := function_parameter in
  Ptime_clock.now tt.

Definition sleep (s : Ptime.span) : Lwt.t unit :=
  Lwt_unix.sleep (Ptime.Span.to_float_s s).

src/lib_stdlib_unix/utils.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let hide_progress_line s =
  let len = String.length s in
  if len > 0 then Printf.eprintf "\r%*s\r" len ""

let display_progress ?(refresh_rate = (1, 1)) fmt =
  let prnt s =
    if Unix.isatty Unix.stderr then
      let (index, rate) = refresh_rate in
      if index mod rate == 0 then (
        hide_progress_line s ; Format.eprintf "%s%!" s )
  in
  Format.kasprintf prnt fmt

let display_progress_end () =
  if Unix.isatty Unix.stderr then Format.eprintf "@."
src/lib_stdlib_unix/utils.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition hide_progress_line (s : string) : unit :=
  let len := OCaml.String.length s in
  if OCaml.Stdlib.gt len 0 then
    Printf.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "013" % char
          (CamlinternalFormatBasics.String
            (CamlinternalFormatBasics.Arg_padding CamlinternalFormatBasics.Right)
            (CamlinternalFormatBasics.Char_literal "013" % char
              CamlinternalFormatBasics.End_of_format))) "
%*s
" % string) len
      "" % string
  else
    tt.

Definition display_progress {A : Type} (op_staroptstar : option (Z * Z))
  : (Stdlib.format4 A Stdlib.Format.formatter unit unit) -> A :=
  let refresh_rate :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => (1, 1)
    end in
  fun fmt =>
    let prnt (s : string) : unit :=
      if Unix.isatty Unix.stderr then
        let '(index, rate) := refresh_rate in
        if Stdlib.op_eqeq (Z.modulo index rate) 0 then
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := hide_progress_line s in
          Format.eprintf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Flush
                  CamlinternalFormatBasics.End_of_format)) "%s%!" % string) s
        else
          tt
      else
        tt in
    Format.kasprintf prnt fmt.

Definition display_progress_end (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  if Unix.isatty Unix.stderr then
    Format.eprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Flush_newline
          CamlinternalFormatBasics.End_of_format) "@." % string)
  else
    tt.

src/lib_storage/context_dump.ml 17 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let current_version = "tezos-snapshot-1.0.0"

(*****************************************************************************)
module type Dump_interface = sig
  type index

  type context

  type tree

  type hash

  type step = string

  type key = step list

  type commit_info

  type batch

  val batch : index -> (batch -> 'a Lwt.t) -> 'a Lwt.t

  val commit_info_encoding : commit_info Data_encoding.t

  val hash_encoding : hash Data_encoding.t

  module Block_header : sig
    type t = Block_header.t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val equal : t -> t -> bool

    val encoding : t Data_encoding.t
  end

  module Pruned_block : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val header : t -> Block_header.t

    val encoding : t Data_encoding.t
  end

  module Block_data : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val header : t -> Block_header.t

    val encoding : t Data_encoding.t
  end

  module Protocol_data : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t option

    val encoding : t Data_encoding.t
  end

  module Commit_hash : sig
    type t

    val to_bytes : t -> Bytes.t

    val of_bytes : Bytes.t -> t tzresult

    val encoding : t Data_encoding.t
  end

  (* commit manipulation (for parents) *)
  val context_parents : context -> Commit_hash.t list

  (* Commit info *)
  val context_info : context -> commit_info

  (* block header manipulation *)
  val get_context : index -> Block_header.t -> context option Lwt.t

  val set_context :
    info:commit_info ->
    parents:Commit_hash.t list ->
    context ->
    Block_header.t ->
    Block_header.t option Lwt.t

  (* for dumping *)
  val context_tree : context -> tree

  val tree_hash : tree -> hash

  val sub_tree : tree -> key -> tree option Lwt.t

  val tree_list : tree -> (step * [`Contents | `Node]) list Lwt.t

  val tree_content : tree -> string option Lwt.t

  (* for restoring *)
  val make_context : index -> context

  val update_context : context -> tree -> context

  val add_string : batch -> string -> tree Lwt.t

  val add_dir : batch -> (step * hash) list -> tree option Lwt.t
end

module type S = sig
  type index

  type context

  type block_header

  type block_data

  type pruned_block

  type protocol_data

  val dump_contexts_fd :
    index ->
    block_header
    * block_data
    * History_mode.t
    * (block_header ->
      (pruned_block option * protocol_data option) tzresult Lwt.t) ->
    fd:Lwt_unix.file_descr ->
    unit tzresult Lwt.t

  val restore_contexts_fd :
    index ->
    fd:Lwt_unix.file_descr ->
    ((Block_hash.t * pruned_block) list -> unit tzresult Lwt.t) ->
    (block_header option ->
    Block_hash.t ->
    pruned_block ->
    unit tzresult Lwt.t) ->
    ( block_header
    * block_data
    * History_mode.t
    * Block_header.t option
    * Block_hash.t list
    * protocol_data list )
    tzresult
    Lwt.t
end

type error += System_write_error of string

type error += Bad_hash of string * Bytes.t * Bytes.t

type error += Context_not_found of Bytes.t

type error += System_read_error of string

type error += Inconsistent_snapshot_file

type error += Inconsistent_snapshot_data

type error += Missing_snapshot_data

type error += Invalid_snapshot_version of string * string

type error += Restore_context_failure

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"Writing_error"
    ~title:"Writing error"
    ~description:"Cannot write in file for context dump"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Unable to write file for context dumping: %s" s)
    (obj1 (req "context_dump_no_space" string))
    (function System_write_error s -> Some s | _ -> None)
    (fun s -> System_write_error s) ;
  register_error_kind
    `Permanent
    ~id:"Bad_hash"
    ~title:"Bad hash"
    ~description:"Wrong hash given"
    ~pp:(fun ppf (ty, his, hshould) ->
      Format.fprintf
        ppf
        "Wrong hash [%s] given: %s, should be %s"
        ty
        (Bytes.to_string his)
        (Bytes.to_string hshould))
    (obj3
       (req "hash_ty" string)
       (req "hash_is" bytes)
       (req "hash_should" bytes))
    (function
      | Bad_hash (ty, his, hshould) -> Some (ty, his, hshould) | _ -> None)
    (fun (ty, his, hshould) -> Bad_hash (ty, his, hshould)) ;
  register_error_kind
    `Permanent
    ~id:"Context_not_found"
    ~title:"Context not found"
    ~description:"Cannot find context corresponding to hash"
    ~pp:(fun ppf mb ->
      Format.fprintf ppf "No context with hash: %s" (Bytes.to_string mb))
    (obj1 (req "context_not_found" bytes))
    (function Context_not_found mb -> Some mb | _ -> None)
    (fun mb -> Context_not_found mb) ;
  register_error_kind
    `Permanent
    ~id:"System_read_error"
    ~title:"System read error"
    ~description:"Failed to read file"
    ~pp:(fun ppf uerr ->
      Format.fprintf
        ppf
        "Error while reading file for context dumping: %s"
        uerr)
    (obj1 (req "system_read_error" string))
    (function System_read_error e -> Some e | _ -> None)
    (fun e -> System_read_error e) ;
  register_error_kind
    `Permanent
    ~id:"Inconsistent_snapshot_file"
    ~title:"Inconsistent snapshot file"
    ~description:"Error while opening snapshot file"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Failed to read snapshot file. The provided file is inconsistent.")
    empty
    (function Inconsistent_snapshot_file -> Some () | _ -> None)
    (fun () -> Inconsistent_snapshot_file) ;
  register_error_kind
    `Permanent
    ~id:"Inconsistent_snapshot_data"
    ~title:"Inconsistent snapshot data"
    ~description:"The data provided by the snapshot is inconsistent"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The data provided by the snapshot file is inconsistent (context_hash \
         does not correspond for block).")
    empty
    (function Inconsistent_snapshot_data -> Some () | _ -> None)
    (fun () -> Inconsistent_snapshot_data) ;
  register_error_kind
    `Permanent
    ~id:"Missing_snapshot_data"
    ~title:"Missing data in imported snapshot"
    ~description:"Mandatory data missing while reaching end of snapshot file."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Mandatory data is missing is the provided snapshot file.")
    empty
    (function Missing_snapshot_data -> Some () | _ -> None)
    (fun () -> Missing_snapshot_data) ;
  register_error_kind
    `Permanent
    ~id:"Invalid_snapshot_version"
    ~title:"Invalid snapshot version"
    ~description:"The version of the snapshot to import is not valid"
    ~pp:(fun ppf (found, expected) ->
      Format.fprintf
        ppf
        "The snapshot to import has version \"%s\" but \"%s\" was expected."
        found
        expected)
    (obj2 (req "found" string) (req "expected" string))
    (function
      | Invalid_snapshot_version (found, expected) ->
          Some (found, expected)
      | _ ->
          None)
    (fun (found, expected) -> Invalid_snapshot_version (found, expected)) ;
  register_error_kind
    `Permanent
    ~id:"Restore_context_failure"
    ~title:"Failed to restore context"
    ~description:"Internal error while restoring the context"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Internal error while restoring the context.")
    empty
    (function Restore_context_failure -> Some () | _ -> None)
    (fun () -> Restore_context_failure)

module Make (I : Dump_interface) = struct
  type command =
    | Root of {
        block_header : I.Block_header.t;
        info : I.commit_info;
        parents : I.Commit_hash.t list;
        block_data : I.Block_data.t;
      }
    | Node of (string * I.hash) list
    | Blob of string
    | Proot of I.Pruned_block.t
    | Loot of I.Protocol_data.t
    | End

  (* Command encoding. *)

  let blob_encoding =
    let open Data_encoding in
    case
      ~title:"blob"
      (Tag (Char.code 'b'))
      string
      (function Blob string -> Some string | _ -> None)
      (function string -> Blob string)

  let node_encoding =
    let open Data_encoding in
    case
      ~title:"node"
      (Tag (Char.code 'd'))
      (list (obj2 (req "name" string) (req "hash" I.hash_encoding)))
      (function Node x -> Some x | _ -> None)
      (function x -> Node x)

  let end_encoding =
    let open Data_encoding in
    case
      ~title:"end"
      (Tag (Char.code 'e'))
      empty
      (function End -> Some () | _ -> None)
      (fun () -> End)

  let loot_encoding =
    let open Data_encoding in
    case
      ~title:"loot"
      (Tag (Char.code 'l'))
      I.Protocol_data.encoding
      (function Loot protocol_data -> Some protocol_data | _ -> None)
      (fun protocol_data -> Loot protocol_data)

  let proot_encoding =
    let open Data_encoding in
    case
      ~title:"proot"
      (Tag (Char.code 'p'))
      (obj1 (req "pruned_block" I.Pruned_block.encoding))
      (function Proot pruned_block -> Some pruned_block | _ -> None)
      (fun pruned_block -> Proot pruned_block)

  let root_encoding =
    let open Data_encoding in
    case
      ~title:"root"
      (Tag (Char.code 'r'))
      (obj4
         (req "block_header" (dynamic_size I.Block_header.encoding))
         (req "info" I.commit_info_encoding)
         (req "parents" (list I.Commit_hash.encoding))
         (req "block_data" I.Block_data.encoding))
      (function
        | Root {block_header; info; parents; block_data} ->
            Some (block_header, info, parents, block_data)
        | _ ->
            None)
      (fun (block_header, info, parents, block_data) ->
        Root {block_header; info; parents; block_data})

  let command_encoding =
    Data_encoding.union
      ~tag_size:`Uint8
      [ blob_encoding;
        node_encoding;
        end_encoding;
        loot_encoding;
        proot_encoding;
        root_encoding ]

  (* IO toolkit. *)

  let rec read_string rbuf ~len =
    let (fd, buf, ofs, total) = !rbuf in
    if Bytes.length buf - ofs < len then (
      let blen = Bytes.length buf - ofs in
      let neu = Bytes.create (blen + 1_000_000) in
      Bytes.blit buf ofs neu 0 blen ;
      Lwt_unix.read fd neu blen 1_000_000
      >>= fun bread ->
      total := !total + bread ;
      if bread = 0 then fail Inconsistent_snapshot_file
      else
        let neu =
          if bread <> 1_000_000 then Bytes.sub neu 0 (blen + bread) else neu
        in
        rbuf := (fd, neu, 0, total) ;
        read_string rbuf ~len )
    else
      let res = Bytes.sub_string buf ofs len in
      rbuf := (fd, buf, ofs + len, total) ;
      return res

  let read_mbytes rbuf b =
    read_string rbuf ~len:(Bytes.length b)
    >>=? fun string ->
    Bytes.blit_string string 0 b 0 (Bytes.length b) ;
    return ()

  let set_int64 buf i =
    let b = Bytes.create 8 in
    EndianBytes.BigEndian.set_int64 b 0 i ;
    Buffer.add_bytes buf b

  let get_int64 rbuf =
    read_string ~len:8 rbuf
    >>=? fun s -> return @@ EndianString.BigEndian.get_int64 s 0

  let set_mbytes buf b =
    set_int64 buf (Int64.of_int (Bytes.length b)) ;
    Buffer.add_bytes buf b

  let get_mbytes rbuf =
    get_int64 rbuf >>|? Int64.to_int
    >>=? fun l ->
    let b = Bytes.create l in
    read_mbytes rbuf b >>=? fun () -> return b

  (* Getter and setters *)

  let get_command rbuf =
    get_mbytes rbuf
    >>|? fun bytes -> Data_encoding.Binary.of_bytes_exn command_encoding bytes

  let set_root buf block_header info parents block_data =
    let root = Root {block_header; info; parents; block_data} in
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding root in
    set_mbytes buf bytes

  let set_node buf contents =
    let bytes =
      Data_encoding.Binary.to_bytes_exn command_encoding (Node contents)
    in
    set_mbytes buf bytes

  let set_blob buf data =
    let bytes =
      Data_encoding.Binary.to_bytes_exn command_encoding (Blob data)
    in
    set_mbytes buf bytes

  let set_proot buf pruned_block =
    let proot = Proot pruned_block in
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding proot in
    set_mbytes buf bytes

  let set_loot buf protocol_data =
    let loot = Loot protocol_data in
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding loot in
    set_mbytes buf bytes

  let set_end buf =
    let bytes = Data_encoding.Binary.to_bytes_exn command_encoding End in
    set_mbytes buf bytes

  (* Snapshot metadata *)

  (* TODO add more info (e.g. nb context item, nb blocks, etc.) *)
  type snapshot_metadata = {
    version : string;
    mode : Tezos_shell_services.History_mode.t;
  }

  let snapshot_metadata_encoding =
    let open Data_encoding in
    conv
      (fun {version; mode} -> (version, mode))
      (fun (version, mode) -> {version; mode})
      (obj2
         (req "version" string)
         (req "mode" Tezos_shell_services.History_mode.encoding))

  let write_snapshot_metadata ~mode buf =
    let version = {version = current_version; mode} in
    let bytes =
      Data_encoding.(Binary.to_bytes_exn snapshot_metadata_encoding version)
    in
    set_mbytes buf bytes

  let read_snapshot_metadata rbuf =
    get_mbytes rbuf
    >>|? fun bytes ->
    Data_encoding.(Binary.of_bytes_exn snapshot_metadata_encoding) bytes

  let check_version v =
    fail_when
      (v.version <> current_version)
      (Invalid_snapshot_version (v.version, current_version))

  let dump_contexts_fd idx data ~fd =
    (* Dumping *)
    let buf = Buffer.create 1_000_000 in
    let written = ref 0 in
    let flush () =
      let contents = Buffer.contents buf in
      Buffer.clear buf ;
      written := !written + String.length contents ;
      Lwt_utils_unix.write_string fd contents
    in
    let maybe_flush () =
      if Buffer.length buf > 1_000_000 then flush () else Lwt.return_unit
    in
    (* Noting the visited hashes *)
    let visited_hash = Hashtbl.create 1000 in
    let visited h = Hashtbl.mem visited_hash h in
    let set_visit h = Hashtbl.add visited_hash h () in
    (* Folding through a node *)
    let fold_tree_path ctxt tree =
      let cpt = ref 0 in
      let rec fold_tree_path ctxt tree =
        I.tree_list tree
        >>= fun keys ->
        let keys = List.sort (fun (a, _) (b, _) -> String.compare a b) keys in
        Lwt_list.map_s
          (fun (name, kind) ->
            I.sub_tree tree [name]
            >>= function
            | None ->
                assert false
            | Some sub_tree ->
                let hash = I.tree_hash sub_tree in
                ( if visited hash then Lwt.return_unit
                else (
                  Tezos_stdlib_unix.Utils.display_progress
                    ~refresh_rate:(!cpt, 1_000)
                    "Context: %dK elements, %dMiB written%!"
                    (!cpt / 1_000)
                    (!written / 1_048_576) ;
                  incr cpt ;
                  set_visit hash ;
                  (* There cannot be a cycle *)
                  match kind with
                  | `Node ->
                      fold_tree_path ctxt sub_tree
                  | `Contents -> (
                      I.tree_content sub_tree
                      >>= function
                      | None ->
                          assert false
                      | Some data ->
                          set_blob buf data ; maybe_flush () ) ) )
                >|= fun () -> (name, hash))
          keys
        >>= fun sub_keys -> set_node buf sub_keys ; maybe_flush ()
      in
      fold_tree_path ctxt tree
    in
    Lwt.catch
      (fun () ->
        let (bh, block_data, mode, pruned_iterator) = data in
        write_snapshot_metadata ~mode buf ;
        I.get_context idx bh
        >>= function
        | None ->
            fail @@ Context_not_found (I.Block_header.to_bytes bh)
        | Some ctxt ->
            let tree = I.context_tree ctxt in
            fold_tree_path ctxt tree
            >>= fun () ->
            Tezos_stdlib_unix.Utils.display_progress_end () ;
            let parents = I.context_parents ctxt in
            set_root buf bh (I.context_info ctxt) parents block_data ;
            (* Dump pruned blocks *)
            let dump_pruned cpt pruned =
              Tezos_stdlib_unix.Utils.display_progress
                ~refresh_rate:(cpt, 1_000)
                "History: %dK block, %dMiB written"
                (cpt / 1_000)
                (!written / 1_048_576) ;
              set_proot buf pruned ;
              maybe_flush ()
            in
            let rec aux cpt acc header =
              pruned_iterator header
              >>=? function
              | (None, None) ->
                  return acc (* assert false *)
              | (None, Some protocol_data) ->
                  return (protocol_data :: acc)
              | (Some pred_pruned, Some protocol_data) ->
                  dump_pruned cpt pred_pruned
                  >>= fun () ->
                  aux
                    (succ cpt)
                    (protocol_data :: acc)
                    (I.Pruned_block.header pred_pruned)
              | (Some pred_pruned, None) ->
                  dump_pruned cpt pred_pruned
                  >>= fun () ->
                  aux (succ cpt) acc (I.Pruned_block.header pred_pruned)
            in
            let starting_block_header = I.Block_data.header block_data in
            aux 0 [] starting_block_header
            >>=? fun protocol_datas ->
            (* Dump protocol data *)
            Lwt_list.iter_s
              (fun proto -> set_loot buf proto ; maybe_flush ())
              protocol_datas
            >>= fun () ->
            Tezos_stdlib_unix.Utils.display_progress_end () ;
            return_unit
            >>=? fun () ->
            set_end buf ;
            flush () >>= fun () -> return_unit)
      (function
        | Unix.Unix_error (e, _, _) ->
            fail @@ System_write_error (Unix.error_message e)
        | err ->
            Lwt.fail err)

  (* Restoring *)

  let restore_contexts_fd index ~fd k_store_pruned_blocks block_validation =
    let read = ref 0 in
    let rbuf = ref (fd, Bytes.empty, 0, read) in
    (* Editing the repository *)
    let add_blob t blob = I.add_string t blob >>= fun tree -> return tree in
    let add_dir t keys =
      I.add_dir t keys
      >>= function
      | None -> fail Restore_context_failure | Some tree -> return tree
    in
    let restore history_mode =
      let rec first_pass batch ctxt cpt =
        Tezos_stdlib_unix.Utils.display_progress
          ~refresh_rate:(cpt, 1_000)
          "Context: %dK elements, %dMiB read"
          (cpt / 1_000)
          (!read / 1_048_576) ;
        get_command rbuf
        >>=? function
        | Root {block_header; info; parents; block_data} -> (
            I.set_context ~info ~parents ctxt block_header
            >>= function
            | None ->
                fail Inconsistent_snapshot_data
            | Some block_header ->
                return (block_header, block_data) )
        | Node contents ->
            add_dir batch contents
            >>=? fun tree ->
            first_pass batch (I.update_context ctxt tree) (cpt + 1)
        | Blob data ->
            add_blob batch data
            >>=? fun tree ->
            first_pass batch (I.update_context ctxt tree) (cpt + 1)
        | _ ->
            fail Inconsistent_snapshot_data
      in
      let rec second_pass pred_header (rev_block_hashes, protocol_datas) todo
          cpt =
        Tezos_stdlib_unix.Utils.display_progress
          ~refresh_rate:(cpt, 1_000)
          "Store: %dK elements, %dMiB read"
          (cpt / 1_000)
          (!read / 1_048_576) ;
        get_command rbuf
        >>=? function
        | Proot pruned_block ->
            let header = I.Pruned_block.header pruned_block in
            let hash = Block_header.hash header in
            block_validation pred_header hash pruned_block
            >>=? fun () ->
            if (cpt + 1) mod 5_000 = 0 then
              k_store_pruned_blocks ((hash, pruned_block) :: todo)
              >>=? fun () ->
              second_pass
                (Some header)
                (hash :: rev_block_hashes, protocol_datas)
                []
                (cpt + 1)
            else
              second_pass
                (Some header)
                (hash :: rev_block_hashes, protocol_datas)
                ((hash, pruned_block) :: todo)
                (cpt + 1)
        | Loot protocol_data ->
            k_store_pruned_blocks todo
            >>=? fun () ->
            second_pass
              pred_header
              (rev_block_hashes, protocol_data :: protocol_datas)
              todo
              (cpt + 1)
        | End ->
            return (pred_header, rev_block_hashes, List.rev protocol_datas)
        | _ ->
            fail Inconsistent_snapshot_data
      in
      I.batch index (fun batch -> first_pass batch (I.make_context index) 0)
      >>=? fun (block_header, block_data) ->
      Tezos_stdlib_unix.Utils.display_progress_end () ;
      second_pass None ([], []) [] 0
      >>=? fun (oldest_header_opt, rev_block_hashes, protocol_datas) ->
      Tezos_stdlib_unix.Utils.display_progress_end () ;
      return
        ( block_header,
          block_data,
          history_mode,
          oldest_header_opt,
          rev_block_hashes,
          protocol_datas )
    in
    (* Check snapshot version *)
    read_snapshot_metadata rbuf
    >>=? fun version ->
    check_version version
    >>=? fun () ->
    Lwt.catch
      (fun () -> restore version.mode)
      (function
        | Unix.Unix_error (e, _, _) ->
            fail @@ System_read_error (Unix.error_message e)
        | err ->
            Lwt.fail err)
end
src/lib_storage/context_dump.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition current_version : string := "tezos-snapshot-1.0.0" % string.

Module Dump_interface.
  Record signature {index context tree hash commit_info batch Pruned_block_t
    Block_data_t Protocol_data_t Commit_hash_t : Type} := {
    index := index;
    context := context;
    tree := tree;
    hash := hash;
    step := string;
    key := list step;
    commit_info := commit_info;
    batch := batch;
    batch : forall {a : Type}, index -> (batch -> Lwt.t a) -> Lwt.t a;
    commit_info_encoding : Tezos_base__TzPervasives.Data_encoding.t commit_info;
    hash_encoding : Tezos_base__TzPervasives.Data_encoding.t hash;
    Block_header : signature;
    Pruned_block : signature;
    Block_data : signature;
    Protocol_data : signature;
    Commit_hash : signature;
    context_parents : context -> list Commit_hash.t;
    context_info : context -> commit_info;
    get_context : index -> Block_header.t -> Lwt.t (option context);
    set_context : commit_info ->
      (list Commit_hash.t) ->
        context -> Block_header.t -> Lwt.t (option Block_header.t);
    context_tree : context -> tree;
    tree_hash : tree -> hash;
    sub_tree : tree -> key -> Lwt.t (option tree);
    tree_list : forall {variant : Type}, tree -> Lwt.t (list (step * variant));
    tree_content : tree -> Lwt.t (option string);
    make_context : index -> context;
    update_context : context -> tree -> context;
    add_string : batch -> string -> Lwt.t tree;
    add_dir : batch -> (list (step * hash)) -> Lwt.t (option tree);
  }.
  Arguments signature : clear implicits.
End Dump_interface.

Module S.
  Record signature {index context block_header block_data pruned_block
    protocol_data : Type} := {
    index := index;
    context := context;
    block_header := block_header;
    block_data := block_data;
    pruned_block := pruned_block;
    protocol_data := protocol_data;
    dump_contexts_fd : index ->
      (block_header * block_data * Tezos_shell_services.History_mode.t *
        (block_header ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              ((option pruned_block) * (option protocol_data))))) ->
        Lwt_unix.file_descr -> Lwt.t (Tezos_base__TzPervasives.tzresult unit);
    restore_contexts_fd : index ->
      Lwt_unix.file_descr ->
        ((list (Tezos_base__TzPervasives.Block_hash.t * pruned_block)) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
          ((option block_header) ->
            Tezos_base__TzPervasives.Block_hash.t ->
              pruned_block -> Lwt.t (Tezos_base__TzPervasives.tzresult unit)) ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                (block_header * block_data * Tezos_shell_services.History_mode.t
                  * (option Tezos_base__TzPervasives.Block_header.t) *
                  (list Tezos_base__TzPervasives.Block_hash.t) *
                  (list protocol_data)));
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



(* ❌ Functors are not handled. *)
functor

src/lib_storage/raw_store.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Rresult

type t = {
  dir : Lmdb.t;
  parent : (Lmdb.rw Lmdb.txn * Lmdb.db * Lmdb.rw Lmdb.cursor) Lwt.key;
}

type key = string list

type value = Bytes.t

type error += Unknown of string list

let () =
  Error_monad.register_error_kind
    `Permanent
    ~id:"raw_store.unknown"
    ~title:"Missing key in store"
    ~description:"Missing key in store"
    ~pp:(fun ppf keys ->
      Format.fprintf ppf "Missing key in store: %s" (String.concat "/" keys))
    Data_encoding.(obj1 (req "key" (list string)))
    (function Unknown keys -> Some keys | _ -> None)
    (fun keys -> Unknown keys)

let concat = String.concat "/"

let split = String.split_on_char '/'

let lwt_fail_error err = Lwt.fail_with (Lmdb.string_of_error err)

let of_result = function
  | Ok res ->
      Lwt.return res
  | Error err ->
      lwt_fail_error err

let ( >>=? ) v f = match v with Error err -> lwt_fail_error err | Ok v -> f v

let init ?(readonly = false) ?mapsize path =
  if not (Sys.file_exists path) then Unix.mkdir path 0o755 ;
  let sync_flag =
    match Sys.getenv_opt "TEZOS_STORE_SYNC" with
    | None ->
        []
    | Some s -> (
      match String.lowercase_ascii s with
      | "nosync" ->
          [Lmdb.NoSync]
      | "nometasync" ->
          [Lmdb.NoMetaSync]
      | _ ->
          Printf.eprintf
            "Unrecognized TEZOS_STORE_SYNC option : %s\n\
             allowed: nosync nometasync"
            s ;
          [] )
  in
  let readonly_flag = if readonly then [Lmdb.RdOnly] else [] in
  let file_flags = if readonly then 0o444 else 0o644 in
  match
    Lmdb.opendir
      ?mapsize
      ~flags:(sync_flag @ readonly_flag @ [NoTLS; NoMetaSync])
      path
      file_flags
  with
  | Ok dir ->
      return {dir; parent = Lwt.new_key ()}
  | Error err ->
      failwith "%a" Lmdb.pp_error err

let close {dir; _} = Lmdb.closedir dir

let known {dir; parent} key =
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.mem txn db (concat key)
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db -> Lmdb.mem txn db (concat key)) )
  |> of_result

let read_opt {dir; parent} key =
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.get txn db (concat key) >>| Bigstring.to_bytes
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db ->
          Lmdb.get txn db (concat key) >>| Bigstring.to_bytes) )
  |> function
  | Ok v ->
      Lwt.return_some v
  | Error KeyNotFound ->
      Lwt.return_none
  | Error err ->
      lwt_fail_error err

let read {dir; parent} key =
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.get txn db (concat key) >>| Bigstring.to_bytes
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db ->
          Lmdb.get txn db (concat key) >>| Bigstring.to_bytes) )
  |> function Ok v -> return v | Error _err -> fail (Unknown key)

let store {dir; parent} k v =
  let v = Bigstring.of_bytes v in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.put txn db (concat k) v
  | None ->
      Lmdb.with_rw_db dir ~f:(fun txn db -> Lmdb.put txn db (concat k) v) )
  |> of_result

let remove {dir; parent} k =
  let remove txn db =
    match Lmdb.del txn db (concat k) with
    | Ok () ->
        Ok ()
    | Error KeyNotFound ->
        Ok ()
    | Error err ->
        Error err
  in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      remove txn db
  | None ->
      Lmdb.with_rw_db dir ~f:remove )
  |> of_result

let is_prefix s s' =
  String.(length s <= length s' && compare s (sub s' 0 (length s)) = 0)

let known_dir {dir; parent} k =
  let k = concat k in
  let cursor_fun cursor =
    Lmdb.cursor_at cursor k
    >>= fun () ->
    Lmdb.cursor_get cursor
    >>| fun (first_k, _v) -> is_prefix k (Bigstring.to_string first_k)
  in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.with_cursor txn db ~f:cursor_fun
  | None ->
      Lmdb.with_ro_db dir ~f:(fun txn db ->
          Lmdb.with_cursor txn db ~f:cursor_fun) )
  |> of_result

let remove_dir {dir; parent} k =
  let k = concat k in
  let cursor_fun cursor =
    Lmdb.cursor_at cursor k
    >>= fun () ->
    Lmdb.cursor_iter cursor ~f:(fun (kk, _v) ->
        let kk_string = Bigstring.to_string kk in
        if is_prefix k kk_string then Lmdb.cursor_del cursor
        else Error KeyNotFound)
  in
  ( match Lwt.get parent with
  | Some (txn, db, _cursor) ->
      Lmdb.with_cursor txn db ~f:cursor_fun
  | None ->
      Lmdb.with_rw_db dir ~f:(fun txn db ->
          Lmdb.with_cursor txn db ~f:cursor_fun) )
  |> function
  | Error KeyNotFound | Ok () ->
      Lwt.return_unit
  | Error err ->
      lwt_fail_error err

let list_equal l1 l2 len =
  if len < 0 || len > List.length l1 || len > List.length l2 then
    invalid_arg "list_compare: invalid len" ;
  let rec inner l1 l2 len =
    match (len, l1, l2) with
    | (0, _, _) ->
        true
    | (_, [], _) | (_, _, []) ->
        false
    | (_, h1 :: t1, h2 :: t2) ->
        if h1 <> h2 then false else inner t1 t2 (pred len)
  in
  inner l1 l2 len

let is_child ~parent ~child =
  let plen = List.length parent in
  let clen = List.length child in
  clen > plen && list_equal parent child plen

let list_sub l pos len =
  if len < 0 || pos < 0 || pos + len > List.length l then
    invalid_arg "list_sub" ;
  let rec inner (acc, n) = function
    | [] ->
        List.rev acc
    | h :: t ->
        if n = 0 then List.rev acc else inner (h :: acc, pred n) t
  in
  inner ([], len) l

let with_rw_cursor_lwt ?nosync ?nometasync ?flags ?name {dir; parent} ~f =
  let local_parent =
    match Lwt.get parent with
    | None ->
        None
    | Some (txn, _db, _cursor) ->
        Some txn
  in
  Lmdb.create_rw_txn ?nosync ?nometasync ?parent:local_parent dir
  >>=? fun txn ->
  Lmdb.opendb ?flags ?name txn
  >>=? fun db ->
  Lmdb.opencursor txn db
  >>=? fun cursor ->
  Lwt.with_value
    parent
    (Some (txn, db, cursor))
    (fun () ->
      Lwt.try_bind
        (fun () -> f cursor)
        (fun res ->
          Lmdb.cursor_close cursor ;
          Lmdb.commit_txn txn >>=? fun () -> Lwt.return res)
        (fun exn ->
          Lmdb.cursor_close cursor ; Lmdb.abort_txn txn ; Lwt.fail exn))

let cursor_next_lwt cursor acc f =
  match Lmdb.cursor_next cursor with
  | Error KeyNotFound ->
      acc
  | Error err ->
      lwt_fail_error err
  | Ok () ->
      Lwt.bind acc f

let cursor_at_lwt cursor k acc f =
  match Lmdb.cursor_at cursor (concat k) with
  | Error KeyNotFound ->
      acc
  | Error err ->
      lwt_fail_error err
  | Ok () ->
      Lwt.bind acc f

(* assumption: store path segments have only characters different than
   the separator '/', which immediately precedes '0' *)
let zero_char_str = String.make 1 (Char.chr (Char.code '/' + 1))

let next_key_after_subdirs = function
  | [] ->
      [zero_char_str]
  | _ :: _ as path ->
      List.sub path (List.length path - 1)
      @ [List.last_exn path ^ zero_char_str]

let fold t k ~init ~f =
  let base_len = List.length k in
  let rec inner ht cursor acc =
    Lmdb.cursor_get cursor
    >>=? fun (kk, _v) ->
    let kk = Bigstring.to_string kk in
    let kk_split = split kk in
    match is_child ~child:kk_split ~parent:k with
    | false ->
        Lwt.return acc
    | true ->
        let cur_len = List.length kk_split in
        if cur_len = succ base_len then
          cursor_next_lwt cursor (f (`Key kk_split) acc) (inner ht cursor)
        else
          let dir = list_sub kk_split 0 (succ base_len) in
          if Hashtbl.mem ht dir then
            cursor_at_lwt
              cursor
              (next_key_after_subdirs dir)
              (Lwt.return acc)
              (inner ht cursor)
          else (
            Hashtbl.add ht dir () ;
            cursor_next_lwt cursor (f (`Dir dir) acc) (inner ht cursor) )
  in
  with_rw_cursor_lwt t ~f:(fun cursor ->
      cursor_at_lwt cursor k (Lwt.return init) (fun acc ->
          let ht = Hashtbl.create 31 in
          inner ht cursor acc))

let fold_keys t k ~init ~f =
  with_rw_cursor_lwt t ~f:(fun cursor ->
      cursor_at_lwt
        cursor
        k
        (Lwt.return init)
        (let rec inner acc =
           Lmdb.cursor_get cursor
           >>=? fun (kk, _v) ->
           let kk = Bigstring.to_string kk in
           let kk_split = split kk in
           match is_child ~child:kk_split ~parent:k with
           | false ->
               Lwt.return acc
           | true ->
               cursor_next_lwt cursor (f kk_split acc) inner
         in
         inner))

let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

let open_with_atomic_rw ?mapsize path f =
  let open Error_monad in
  init ?mapsize path
  >>=? fun state ->
  with_rw_cursor_lwt state ~f:(fun _c -> f state)
  >>=? fun res -> close state ; return res

let with_atomic_rw state f = with_rw_cursor_lwt state ~f:(fun _c -> f ())
src/lib_storage/raw_store.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Rresult.

Record t := {
  dir : Lmdb.t;
  parent : Lwt.key ((Lmdb.txn Lmdb.rw) * Lmdb.db * (Lmdb.cursor Lmdb.rw)) }.

Definition key := list string.

Definition value := Stdlib.Bytes.t.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition concat : (list string) -> string := String.concat "/" % string.

Definition split : string -> list string := String.split_on_char "/" % char.

Definition lwt_fail_error {A : Type} (err : Lmdb.error) : Lwt.t A :=
  Lwt.fail_with (Lmdb.string_of_error err).

Definition of_result {A : Type}
  (function_parameter : Rresult.result A Lmdb.error) : Lwt.t A :=
  match function_parameter with
  | Rresult.Ok res => Lwt._return res
  | Rresult.Error err => lwt_fail_error err
  end.

Definition op_gtgteqquestion {A B : Type}
  (v : Rresult.result A Lmdb.error) (f : A -> Lwt.t B) : Lwt.t B :=
  match v with
  | Rresult.Error err => lwt_fail_error err
  | Rresult.Ok v => f v
  end.

Definition init (op_staroptstar : option bool)
  : (option int64) -> string -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let readonly :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun mapsize =>
    fun path =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if negb (Sys.file_exists path) then
          Unix.mkdir path 493
        else
          tt in
      let sync_flag :=
        match Sys.getenv_opt "TEZOS_STORE_SYNC" % string with
        | None => []
        | Some s =>
          match String.lowercase_ascii s with
          | "nosync" % string => cons Lmdb.NoSync []
          | "nometasync" % string => cons Lmdb.NoMetaSync []
          | _ =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              Printf.eprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Unrecognized TEZOS_STORE_SYNC option : " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        "
allowed: nosync nometasync" % string
                        CamlinternalFormatBasics.End_of_format)))
                  "Unrecognized TEZOS_STORE_SYNC option : %s
allowed: nosync nometasync"
                    % string) s in
            []
          end
        end in
      let readonly_flag :=
        if readonly then
          cons Lmdb.RdOnly []
        else
          [] in
      let file_flags :=
        if readonly then
          292
        else
          420 in
      match
        Lmdb.opendir None None mapsize
          (Some
            (OCaml.Stdlib.app sync_flag
              (OCaml.Stdlib.app readonly_flag
                (cons Lmdb.NoTLS (cons Lmdb.NoMetaSync []))))) path file_flags
        with
      | Rresult.Ok dir => _return {| dir := dir; parent := Lwt.new_key tt |}
      | Rresult.Error err =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Lmdb.pp_error err
      end.

Definition close (function_parameter : t) : unit :=
  let '{| dir := dir |} := function_parameter in
  Lmdb.closedir dir.

Definition known (function_parameter : t) : (list string) -> Lwt.t bool :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun key =>
    OCaml.Stdlib.reverse_apply
      match Lwt.get parent with
      | Some (txn, db, _cursor) => Lmdb.mem txn db (concat key)
      | None =>
        Lmdb.with_ro_db None None None None None dir
          (fun txn => fun db => Lmdb.mem txn db (concat key))
      end of_result.

Definition read_opt (function_parameter : t)
  : (list string) -> Lwt.t (option Stdlib.Bytes.t) :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun key =>
    OCaml.Stdlib.reverse_apply
      match Lwt.get parent with
      | Some (txn, db, _cursor) =>
        op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes
      | None =>
        Lmdb.with_ro_db None None None None None dir
          (fun txn =>
            fun db =>
              op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes)
      end
      (fun function_parameter =>
        match function_parameter with
        | Rresult.Ok v => Lwt.return_some v
        | Rresult.Error Lmdb.KeyNotFound => Lwt.return_none
        | Rresult.Error err => lwt_fail_error err
        end).

Definition read (function_parameter : t)
  : (list string) -> Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun key =>
    OCaml.Stdlib.reverse_apply
      match Lwt.get parent with
      | Some (txn, db, _cursor) =>
        op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes
      | None =>
        Lmdb.with_ro_db None None None None None dir
          (fun txn =>
            fun db =>
              op_gtgtpipe (Lmdb.get txn db (concat key)) Bigstring.to_bytes)
      end
      (fun function_parameter =>
        match function_parameter with
        | Rresult.Ok v => _return v
        | Rresult.Error _err => fail (Tezos_base__TzPervasives.Unknown key)
        end).

Definition store (function_parameter : t)
  : (list string) -> Stdlib.Bytes.t -> Lwt.t unit :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun k =>
    fun v =>
      let v := Bigstring.of_bytes v in
      OCaml.Stdlib.reverse_apply
        match Lwt.get parent with
        | Some (txn, db, _cursor) => Lmdb.put None txn db (concat k) v
        | None =>
          Lmdb.with_rw_db None None None None None dir
            (fun txn => fun db => Lmdb.put None txn db (concat k) v)
        end of_result.

Definition remove (function_parameter : t) : (list string) -> Lwt.t unit :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun k =>
    let remove (txn : Lmdb.txn Lmdb.rw) (db : Lmdb.db)
      : Rresult.result unit Lmdb.error :=
      match Lmdb.del None txn db (concat k) with
      | Rresult.Ok tt => Rresult.Ok tt
      | Rresult.Error Lmdb.KeyNotFound => Rresult.Ok tt
      | Rresult.Error err => Rresult.Error err
      end in
    OCaml.Stdlib.reverse_apply
      match Lwt.get parent with
      | Some (txn, db, _cursor) => remove txn db
      | None => Lmdb.with_rw_db None None None None None dir remove
      end of_result.

Definition is_prefix (s : Tezos_base__TzPervasives.String.t) (s' : string)
  : bool :=
  andb (OCaml.Stdlib.le (length s) (length s'))
    (equiv_decb (compare s (sub s' 0 (length s))) 0).

Definition known_dir (function_parameter : t) : (list string) -> Lwt.t bool :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun k =>
    let k := concat k in
    let cursor_fun {A : Type} (cursor : Lmdb.cursor A)
      : Result.result bool Lmdb.error :=
      op_gtgteq (Lmdb.cursor_at cursor k)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtpipe (Lmdb.cursor_get cursor)
            (fun function_parameter =>
              let '(first_k, _v) := function_parameter in
              is_prefix k (Bigstring.to_string first_k))) in
    OCaml.Stdlib.reverse_apply
      match Lwt.get parent with
      | Some (txn, db, _cursor) => Lmdb.with_cursor txn db cursor_fun
      | None =>
        Lmdb.with_ro_db None None None None None dir
          (fun txn => fun db => Lmdb.with_cursor txn db cursor_fun)
      end of_result.

Definition remove_dir (function_parameter : t) : (list string) -> Lwt.t unit :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun k =>
    let k := concat k in
    let cursor_fun (cursor : Lmdb.cursor Lmdb.rw)
      : Result.result unit Lmdb.error :=
      op_gtgteq (Lmdb.cursor_at cursor k)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lmdb.cursor_iter
            (fun function_parameter =>
              let '(kk, _v) := function_parameter in
              let kk_string := Bigstring.to_string kk in
              if is_prefix k kk_string then
                Lmdb.cursor_del None cursor
              else
                Rresult.Error Lmdb.KeyNotFound) cursor) in
    OCaml.Stdlib.reverse_apply
      match Lwt.get parent with
      | Some (txn, db, _cursor) => Lmdb.with_cursor txn db cursor_fun
      | None =>
        Lmdb.with_rw_db None None None None None dir
          (fun txn => fun db => Lmdb.with_cursor txn db cursor_fun)
      end
      (fun function_parameter =>
        match function_parameter with
        | Rresult.Error Lmdb.KeyNotFound | Rresult.Ok tt => Lwt.return_unit
        | Rresult.Error err => lwt_fail_error err
        end).

Definition list_equal {A : Type} (l1 : list A) (l2 : list A) (len : Z) : bool :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      orb (OCaml.Stdlib.lt len 0)
        (orb (OCaml.Stdlib.gt len (List.length l1))
          (OCaml.Stdlib.gt len (List.length l2))) then
      OCaml.Stdlib.invalid_arg "list_compare: invalid len" % string
    else
      tt in
  let fix inner {B : Type} (l1 : list B) (l2 : list B) (len : Z) : bool :=
    match (len, l1, l2) with
    | (0, _, _) => true
    | (_, [], _) | (_, _, []) => false
    | (_, cons h1 t1, cons h2 t2) =>
      if nequiv_decb h1 h2 then
        false
      else
        inner t1 t2 (Z.pred len)
    end in
  inner l1 l2 len.

Definition is_child {A : Type} (parent : list A) (child : list A) : bool :=
  let plen := List.length parent in
  let clen := List.length child in
  andb (OCaml.Stdlib.gt clen plen) (list_equal parent child plen).

Definition list_sub {A : Type} (l : list A) (pos : Z) (len : Z) : list A :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      orb (OCaml.Stdlib.lt len 0)
        (orb (OCaml.Stdlib.lt pos 0)
          (OCaml.Stdlib.gt (Z.add pos len) (List.length l))) then
      OCaml.Stdlib.invalid_arg "list_sub" % string
    else
      tt in
  let fix inner {B : Type} (function_parameter : (list B) * Z)
    : (list B) -> list B :=
    let '(acc, n) := function_parameter in
    fun function_parameter =>
      match function_parameter with
      | [] => List.rev acc
      | cons h t =>
        if equiv_decb n 0 then
          List.rev acc
        else
          inner ((cons h acc), (Z.pred n)) t
      end in
  inner ([], len) l.

Definition with_rw_cursor_lwt {A : Type}
  (nosync : option bool) (nometasync : option bool)
  (flags : option (list Lmdb.flag_open)) (name : option string)
  (function_parameter : t) : ((Lmdb.cursor Lmdb.rw) -> Lwt.t A) -> Lwt.t A :=
  let '{| dir := dir; parent := parent |} := function_parameter in
  fun f =>
    let local_parent :=
      match Lwt.get parent with
      | None => None
      | Some (txn, _db, _cursor) => Some txn
      end in
    op_gtgteqquestion (Lmdb.create_rw_txn nosync nometasync local_parent dir)
      (fun txn =>
        op_gtgteqquestion (Lmdb.opendb flags name txn)
          (fun db =>
            op_gtgteqquestion (Lmdb.opencursor txn db)
              (fun cursor =>
                Lwt.with_value parent (Some (txn, db, cursor))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt.try_bind
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        f cursor)
                      (fun res =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ := Lmdb.cursor_close cursor in
                        op_gtgteqquestion (Lmdb.commit_txn txn)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            Lwt._return res))
                      (fun exn =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ := Lmdb.cursor_close cursor in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ := Lmdb.abort_txn txn in
                        Lwt.fail exn))))).

Definition cursor_next_lwt {A B : Type}
  (cursor : Lmdb.cursor A) (acc : Lwt.t B) (f : B -> Lwt.t B) : Lwt.t B :=
  match Lmdb.cursor_next cursor with
  | Rresult.Error Lmdb.KeyNotFound => acc
  | Rresult.Error err => lwt_fail_error err
  | Rresult.Ok tt => Lwt.bind acc f
  end.

Definition cursor_at_lwt {A B : Type}
  (cursor : Lmdb.cursor A) (k : list string) (acc : Lwt.t B) (f : B -> Lwt.t B)
  : Lwt.t B :=
  match Lmdb.cursor_at cursor (concat k) with
  | Rresult.Error Lmdb.KeyNotFound => acc
  | Rresult.Error err => lwt_fail_error err
  | Rresult.Ok tt => Lwt.bind acc f
  end.

Definition zero_char_str : string :=
  String.make 1 (Char.chr (Z.add (Char.code "/" % char) 1)).

Definition next_key_after_subdirs (function_parameter : list string)
  : list string :=
  match function_parameter with
  | [] => cons zero_char_str []
  | (cons _ _) as path =>
    OCaml.Stdlib.app (List.sub path (Z.sub (List.length path) 1))
      (cons (String.append (List.last_exn path) zero_char_str) [])
  end.

Definition fold {A : Type}
  (t : t) (k : list string) (init : A) (f : variant -> A -> Lwt.t A)
  : Lwt.t A :=
  let base_len := List.length k in
  let fix inner {B : Type}
    (ht : Stdlib.Hashtbl.t (list string) unit) (cursor : Lmdb.cursor B) (acc :
    A) : Lwt.t A :=
    op_gtgteqquestion (Lmdb.cursor_get cursor)
      (fun function_parameter =>
        let '(kk, _v) := function_parameter in
        let kk := Bigstring.to_string kk in
        let kk_split := split kk in
        match is_child k kk_split with
        | false => Lwt._return acc
        | true =>
          let cur_len := List.length kk_split in
          if equiv_decb cur_len (Z.succ base_len) then
            cursor_next_lwt cursor
              (f
                (* ❌ Variants not supported *)
                variant acc) (inner ht cursor)
          else
            let dir := list_sub kk_split 0 (Z.succ base_len) in
            if Hashtbl.mem ht dir then
              cursor_at_lwt cursor (next_key_after_subdirs dir)
                (Lwt._return acc) (inner ht cursor)
            else
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Hashtbl.add ht dir tt in
              cursor_next_lwt cursor
                (f
                  (* ❌ Variants not supported *)
                  variant acc) (inner ht cursor)
        end) in
  with_rw_cursor_lwt None None None None t
    (fun cursor =>
      cursor_at_lwt cursor k (Lwt._return init)
        (fun acc =>
          let ht := Hashtbl.create None 31 in
          inner ht cursor acc)).

Definition fold_keys {A : Type}
  (t : t) (k : list string) (init : A) (f : (list string) -> A -> Lwt.t A)
  : Lwt.t A :=
  with_rw_cursor_lwt None None None None t
    (fun cursor =>
      cursor_at_lwt cursor k (Lwt._return init)
        (let fix inner (acc : A) : Lwt.t A :=
          op_gtgteqquestion (Lmdb.cursor_get cursor)
            (fun function_parameter =>
              let '(kk, _v) := function_parameter in
              let kk := Bigstring.to_string kk in
              let kk_split := split kk in
              match is_child k kk_split with
              | false => Lwt._return acc
              | true => cursor_next_lwt cursor (f kk_split acc) inner
              end) in
        inner)).

Definition keys (t : t) : (list string) -> Lwt.t (list (list string)) :=
  fold_keys t
    (* ❌ expected an argument *)
    expected_argument [] (fun k => fun acc => Lwt._return (cons k acc)).

Definition open_with_atomic_rw {A : Type}
  (mapsize : option int64) (path : string)
  (f : t -> Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A))
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
  op_gtgteqquestion (init None mapsize path)
    (fun state =>
      op_gtgteqquestion
        (with_rw_cursor_lwt None None None None state (fun _c => f state))
        (fun res =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := close state in
          _return res)).

Definition with_atomic_rw {A : Type} (state : t) (f : unit -> Lwt.t A)
  : Lwt.t A := with_rw_cursor_lwt None None None None state (fun _c => f tt).

src/lib_storage/store_helpers.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Store_sigs

module Make_value (V : ENCODED_VALUE) = struct
  type t = V.t

  let of_bytes b =
    match Data_encoding.Binary.of_bytes V.encoding b with
    | None ->
        generic_error "Cannot parse data" (* TODO personalize *)
    | Some v ->
        ok v

  let to_bytes v =
    try Data_encoding.Binary.to_bytes_exn V.encoding v
    with Data_encoding.Binary.Write_error error ->
      Store_logging.log_error
        "Exception while serializing value %a"
        Data_encoding.Binary.pp_write_error
        error ;
      Bytes.create 0
end

module Raw_value = struct
  type t = Bytes.t

  let of_bytes b = ok b

  let to_bytes b = b
end

module Make_single_store (S : STORE) (N : NAME) (V : VALUE) = struct
  type t = S.t

  type value = V.t

  let known t = S.known t N.name

  let read t = S.read t N.name >>=? fun b -> Lwt.return (V.of_bytes b)

  let read_opt t = read t >|= function Error _ -> None | Ok v -> Some v

  let store t v = S.store t N.name (V.to_bytes v)

  let remove t = S.remove t N.name
end

let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)

module Make_substore (S : STORE) (N : NAME) : STORE with type t = S.t = struct
  type t = S.t

  type key = string list

  type value = Bytes.t

  let name_length = List.length N.name

  let to_key k = N.name @ k

  let of_key k = List.remove name_length k

  let known t k = S.known t (to_key k)

  let known_dir t k = S.known_dir t (to_key k)

  let read t k = S.read t (to_key k)

  let read_opt t k = S.read_opt t (to_key k)

  let store t k v = S.store t (to_key k) v

  let remove t k = S.remove t (to_key k)

  let fold t k ~init ~f =
    S.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

  let keys t k = S.keys t (to_key k) >|= fun keys -> List.map of_key keys

  let fold_keys t k ~init ~f =
    S.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)

  let remove_dir t k = S.remove_dir t (to_key k)
end

module Make_indexed_substore (S : STORE) (I : INDEX) = struct
  type t = S.t

  type key = I.t

  module Store = struct
    type t = S.t * I.t

    type key = string list

    type value = Bytes.t

    let to_key i k =
      assert (List.length (I.to_path i []) = I.path_length) ;
      I.to_path i k

    let of_key k = List.remove I.path_length k

    let known (t, i) k = S.known t (to_key i k)

    let known_dir (t, i) k = S.known_dir t (to_key i k)

    let read (t, i) k = S.read t (to_key i k)

    let read_opt (t, i) k = S.read_opt t (to_key i k)

    let store (t, i) k v = S.store t (to_key i k) v

    let remove (t, i) k = S.remove t (to_key i k)

    let fold (t, i) k ~init ~f =
      S.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

    let keys (t, i) k =
      S.keys t (to_key i k) >|= fun keys -> List.map of_key keys

    let fold_keys (t, i) k ~init ~f =
      S.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)

    let remove_dir (t, i) k = S.remove_dir t (to_key i k)
  end

  let remove_all t i = Store.remove_dir (t, i) []

  let fold_indexes t ~init ~f =
    let rec dig i path acc =
      if i <= 0 then
        match I.of_path path with
        | None ->
            assert false
        | Some path ->
            f path acc
      else
        S.fold t path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let indexes t =
    fold_indexes t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))

  let list t k = S.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

  let resolve_index t prefix =
    let rec loop i prefix = function
      | [] when i = I.path_length -> (
        match I.of_path prefix with
        | None ->
            assert false
        | Some path ->
            Lwt.return [path] )
      | [] ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_p
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
            prefixes
          >|= List.flatten
      | [d] when i = I.path_length - 1 ->
          if i >= I.path_length then invalid_arg "IO.resolve" ;
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_p
            (function
              | `Key prefix | `Dir prefix -> (
                match
                  String.remove_prefix ~prefix:d (List.hd (List.rev prefix))
                with
                | None ->
                    Lwt.return_nil
                | Some _ ->
                    loop (i + 1) prefix [] ))
            prefixes
          >|= List.flatten
      | "" :: ds ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_p
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
            prefixes
          >|= List.flatten
      | d :: ds -> (
          if i >= I.path_length then invalid_arg "IO.resolve" ;
          S.known_dir t (prefix @ [d])
          >>= function
          | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
    in
    loop 0 [] prefix

  module Make_set (N : NAME) = struct
    type t = S.t

    type elt = I.t

    let inited = Bytes.of_string "inited"

    let known s i = Store.known (s, i) N.name

    let store s i = Store.store (s, i) N.name inited

    let remove s i = Store.remove (s, i) N.name

    let remove_all s = fold_indexes s ~init:() ~f:(fun i () -> remove s i)

    let fold s ~init ~f =
      fold_indexes s ~init ~f:(fun i acc ->
          known s i >>= function true -> f i acc | false -> Lwt.return acc)

    let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let iter s ~f = fold s ~init:() ~f:(fun p () -> f p)
  end

  module Make_buffered_set (N : NAME) (Set : Set.S with type elt = I.t) =
  struct
    include Make_set (N)
    module Set = Set

    let read_all s =
      fold s ~init:Set.empty ~f:(fun i set -> Lwt.return (Set.add i set))

    let store_all s new_set =
      read_all s
      >>= fun old_set ->
      Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set))
      >>= fun () ->
      Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set))
  end

  module Make_map (N : NAME) (V : VALUE) = struct
    type t = S.t

    type key = I.t

    type value = V.t

    let known s i = Store.known (s, i) N.name

    let read s i =
      Store.read (s, i) N.name >>=? fun b -> Lwt.return (V.of_bytes b)

    let read_opt s i =
      read s i
      >>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v

    let store s i v = Store.store (s, i) N.name (V.to_bytes v)

    let remove s i = Store.remove (s, i) N.name

    let remove_all s = fold_indexes s ~init:() ~f:(fun i () -> remove s i)

    let fold s ~init ~f =
      fold_indexes s ~init ~f:(fun i acc ->
          read_opt s i
          >>= function None -> Lwt.return acc | Some v -> f i v acc)

    let bindings s =
      fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

    let iter s ~f = fold s ~init:() ~f:(fun p v () -> f p v)

    let fold_keys s ~init ~f =
      fold_indexes s ~init ~f:(fun i acc ->
          known s i >>= function false -> Lwt.return acc | true -> f i acc)

    let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let iter_keys s ~f = fold_keys s ~init:() ~f:(fun p () -> f p)
  end

  module Make_buffered_map
      (N : NAME)
      (V : VALUE)
      (Map : Map.S with type key = I.t) =
  struct
    include Make_map (N) (V)
    module Map = Map

    let read_all s =
      fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set))

    let store_all s map =
      remove_all s
      >>= fun () ->
      Map.fold
        (fun k v acc ->
          let res = store s k v in
          acc >>= fun () -> res)
        map
        Lwt.return_unit
  end
end

module Make_set (S : STORE) (I : INDEX) = struct
  type t = S.t

  type elt = I.t

  let inited = Bytes.of_string "inited"

  let known s i = S.known s (I.to_path i [])

  let store s i = S.store s (I.to_path i []) inited

  let remove s i = S.remove s (I.to_path i [])

  let remove_all s = S.remove_dir s []

  let fold s ~init ~f =
    let rec dig i path acc =
      if i <= 1 then
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some p ->
                  f p acc ))
      else
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let iter s ~f = fold s ~init:() ~f:(fun p () -> f p)
end

module Make_buffered_set
    (S : STORE)
    (I : INDEX)
    (Set : Set.S with type elt = I.t) =
struct
  include Make_set (S) (I)
  module Set = Set

  let read_all s =
    fold s ~init:Set.empty ~f:(fun i set -> Lwt.return (Set.add i set))

  let store_all s new_set =
    read_all s
    >>= fun old_set ->
    Lwt_list.iter_p (remove s) Set.(elements (diff old_set new_set))
    >>= fun () ->
    Lwt_list.iter_p (store s) Set.(elements (diff new_set old_set))
end

module Make_map (S : STORE) (I : INDEX) (V : VALUE) = struct
  type t = S.t

  type key = I.t

  type value = V.t

  let known s i = S.known s (I.to_path i [])

  let read s i =
    S.read s (I.to_path i []) >>=? fun b -> Lwt.return (V.of_bytes b)

  let read_opt s i =
    read s i
    >>= function Error _ -> Lwt.return_none | Ok v -> Lwt.return_some v

  let store s i v = S.store s (I.to_path i []) (V.to_bytes v)

  let remove s i = S.remove s (I.to_path i [])

  let remove_all s = S.remove_dir s []

  let fold s ~init ~f =
    let rec dig i path acc =
      if i <= 1 then
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
                S.read_opt s file
                >>= function
                | None ->
                    Lwt.return acc
                | Some b -> (
                  match V.of_bytes b with
                  | Error _ ->
                      (* Silently ignore unparsable data *)
                      Lwt.return acc
                  | Ok v -> (
                    match I.of_path file with
                    | None ->
                        assert false
                    | Some path ->
                        f path v acc ) ) ))
      else
        S.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let iter s ~f = fold s ~init:() ~f:(fun p v () -> f p v)

  let fold_keys s ~init ~f =
    S.fold s [] ~init ~f:(fun p acc ->
        match p with
        | `Dir _ ->
            Lwt.return acc
        | `Key p -> (
          match I.of_path p with
          | None ->
              assert false
          | Some path ->
              f path acc ))

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let iter_keys s ~f = fold_keys s ~init:() ~f:(fun p () -> f p)
end

module Make_buffered_map
    (S : STORE)
    (I : INDEX)
    (V : VALUE)
    (Map : Map.S with type key = I.t) =
struct
  include Make_map (S) (I) (V)
  module Map = Map

  let read_all s =
    fold s ~init:Map.empty ~f:(fun i v set -> Lwt.return (Map.add i v set))

  let store_all s map =
    remove_all s
    >>= fun () ->
    Map.fold
      (fun k v acc ->
        let res = store s k v in
        acc >>= fun () -> res)
      map
      Lwt.return_unit
end

module Integer_index = struct
  type t = int

  let path_length = 1

  let to_path x l = string_of_int x :: l

  let of_path = function
    | [x] -> (
      try Some (int_of_string x) with _ -> None )
    | _ ->
        None
end
src/lib_storage/store_helpers.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Store_sigs.

(* ❌ Functors are not handled. *)
functor

Module Raw_value.
  Definition t := Stdlib.Bytes.t.
  
  Definition of_bytes {A : Type} (b : A)
    : Tezos_base__TzPervasives.tzresult A := ok b.
  
  Definition to_bytes {A : Type} (b : A) : A := b.
End Raw_value.

(* ❌ Functors are not handled. *)
functor

Definition map_key {A B : Type} (f : A -> B) (function_parameter : variant)
  : variant :=
  match function_parameter with
  | Key k =>
    (* ❌ Variants not supported *)
    variant
  | Dir k =>
    (* ❌ Variants not supported *)
    variant
  end.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

Module Integer_index.
  Definition t := Z.
  
  Definition path_length : Z := 1.
  
  Definition to_path (x : Z) (l : list string) : list string :=
    cons (OCaml.Stdlib.string_of_int x) l.
  
  Definition of_path (function_parameter : list string) : option Z :=
    match function_parameter with
    | cons x [] =>
      (* ❌ Try-with are not handled *)
      try (Some (OCaml.Stdlib.int_of_string x))
    | _ => None
    end.
End Integer_index.

src/lib_storage/store_logging.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make (struct
  let name = "db"
end)
src/lib_storage/store_logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

src/lib_storage/store_sigs.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type NAME = sig
  val name : string list
end

module type VALUE = sig
  type t

  val of_bytes : Bytes.t -> t tzresult

  val to_bytes : t -> Bytes.t
end

module type ENCODED_VALUE = sig
  type t

  val encoding : t Data_encoding.t
end

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option
end

module type SINGLE_STORE = sig
  type t

  type value

  val known : t -> bool Lwt.t

  val read : t -> value tzresult Lwt.t

  val read_opt : t -> value option Lwt.t

  val store : t -> value -> unit Lwt.t

  val remove : t -> unit Lwt.t
end

module type STORE = sig
  type t

  type key = string list

  type value = Bytes.t

  val known : t -> key -> bool Lwt.t

  val read : t -> key -> value tzresult Lwt.t

  val read_opt : t -> key -> value option Lwt.t

  val store : t -> key -> value -> unit Lwt.t

  val remove : t -> key -> unit Lwt.t

  val known_dir : t -> key -> bool Lwt.t

  val remove_dir : t -> key -> unit Lwt.t

  val fold :
    t ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val keys : t -> key -> key list Lwt.t

  val fold_keys : t -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type SET_STORE = sig
  type t

  type elt

  val known : t -> elt -> bool Lwt.t

  val store : t -> elt -> unit Lwt.t

  val remove : t -> elt -> unit Lwt.t

  val elements : t -> elt list Lwt.t

  val remove_all : t -> unit Lwt.t

  val iter : t -> f:(elt -> unit Lwt.t) -> unit Lwt.t

  val fold : t -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type BUFFERED_SET_STORE = sig
  include SET_STORE

  module Set : Set.S with type elt = elt

  val read_all : t -> Set.t Lwt.t

  val store_all : t -> Set.t -> unit Lwt.t
end

module type MAP_STORE = sig
  type t

  type key

  type value

  val known : t -> key -> bool Lwt.t

  val read : t -> key -> value tzresult Lwt.t

  val read_opt : t -> key -> value option Lwt.t

  val store : t -> key -> value -> unit Lwt.t

  val remove : t -> key -> unit Lwt.t

  val keys : t -> key list Lwt.t

  val bindings : t -> (key * value) list Lwt.t

  val remove_all : t -> unit Lwt.t

  val iter : t -> f:(key -> value -> unit Lwt.t) -> unit Lwt.t

  val iter_keys : t -> f:(key -> unit Lwt.t) -> unit Lwt.t

  val fold : t -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val fold_keys : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type BUFFERED_MAP_STORE = sig
  include MAP_STORE

  module Map : Map.S with type key = key

  val read_all : t -> value Map.t Lwt.t

  val store_all : t -> value Map.t -> unit Lwt.t
end

module type INDEXED_STORE = sig
  type t

  type key

  module Store : STORE with type t = t * key

  val remove_all : t -> key -> unit Lwt.t

  val fold_indexes : t -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val indexes : t -> key list Lwt.t

  val resolve_index : t -> string list -> key list Lwt.t

  module Make_set (N : NAME) : SET_STORE with type t = t and type elt = key

  module Make_buffered_set (N : NAME) (Set : Set.S with type elt = key) :
    BUFFERED_SET_STORE with type t = t and type elt = key and module Set = Set

  module Make_map (N : NAME) (V : VALUE) :
    MAP_STORE with type t = t and type key = key and type value = V.t

  module Make_buffered_map
      (N : NAME)
      (V : VALUE)
      (Map : Map.S with type key = key) :
    BUFFERED_MAP_STORE
      with type t = t
       and type key = key
       and type value = V.t
       and module Map = Map
end
src/lib_storage/store_sigs.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module NAME.
  Record signature := {
    name : list string;
  }.
End NAME.

Module VALUE.
  Record signature {t : Type} := {
    t := t;
    of_bytes : Stdlib.Bytes.t -> Tezos_base__TzPervasives.tzresult t;
    to_bytes : t -> Stdlib.Bytes.t;
  }.
  Arguments signature : clear implicits.
End VALUE.

Module ENCODED_VALUE.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_base__TzPervasives.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End ENCODED_VALUE.

Module INDEX.
  Record signature {t : Type} := {
    t := t;
    path_length : Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
  }.
  Arguments signature : clear implicits.
End INDEX.

Module SINGLE_STORE.
  Record signature {t value : Type} := {
    t := t;
    value := value;
    known : t -> Lwt.t bool;
    read : t -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> Lwt.t (option value);
    store : t -> value -> Lwt.t unit;
    remove : t -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End SINGLE_STORE.

Module STORE.
  Record signature {t : Type} := {
    t := t;
    key := list string;
    value := Stdlib.Bytes.t;
    known : t -> key -> Lwt.t bool;
    read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> key -> Lwt.t (option value);
    store : t -> key -> value -> Lwt.t unit;
    remove : t -> key -> Lwt.t unit;
    known_dir : t -> key -> Lwt.t bool;
    remove_dir : t -> key -> Lwt.t unit;
    fold : forall {a variant : Type}, t ->
      key -> a -> (variant -> a -> Lwt.t a) -> Lwt.t a;
    keys : t -> key -> Lwt.t (list key);
    fold_keys : forall {a : Type}, t ->
      key -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End STORE.

Module SET_STORE.
  Record signature {t elt : Type} := {
    t := t;
    elt := elt;
    known : t -> elt -> Lwt.t bool;
    store : t -> elt -> Lwt.t unit;
    remove : t -> elt -> Lwt.t unit;
    elements : t -> Lwt.t (list elt);
    remove_all : t -> Lwt.t unit;
    iter : t -> (elt -> Lwt.t unit) -> Lwt.t unit;
    fold : forall {a : Type}, t -> a -> (elt -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End SET_STORE.

Module BUFFERED_SET_STORE.
  Record signature {t elt Set_t : Type} := {
    include;
    Set : Set.S.signature elt Set_t;
    read_all : t -> Lwt.t Set.t;
    store_all : t -> Set.t -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End BUFFERED_SET_STORE.

Module MAP_STORE.
  Record signature {t key value : Type} := {
    t := t;
    key := key;
    value := value;
    known : t -> key -> Lwt.t bool;
    read : t -> key -> Lwt.t (Tezos_base__TzPervasives.tzresult value);
    read_opt : t -> key -> Lwt.t (option value);
    store : t -> key -> value -> Lwt.t unit;
    remove : t -> key -> Lwt.t unit;
    keys : t -> Lwt.t (list key);
    bindings : t -> Lwt.t (list (key * value));
    remove_all : t -> Lwt.t unit;
    iter : t -> (key -> value -> Lwt.t unit) -> Lwt.t unit;
    iter_keys : t -> (key -> Lwt.t unit) -> Lwt.t unit;
    fold : forall {a : Type}, t ->
      a -> (key -> value -> a -> Lwt.t a) -> Lwt.t a;
    fold_keys : forall {a : Type}, t -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
  }.
  Arguments signature : clear implicits.
End MAP_STORE.

Module BUFFERED_MAP_STORE.
  Record signature {t key value Map_t : Type} := {
    include;
    Map : Map.S.signature key Map_t;
    read_all : t -> Lwt.t (Map.t value);
    store_all : t -> (Map.t value) -> Lwt.t unit;
  }.
  Arguments signature : clear implicits.
End BUFFERED_MAP_STORE.

Module INDEXED_STORE.
  Record signature {t key : Type} := {
    t := t;
    key := key;
    Store : STORE.signature (t * key);
    remove_all : t -> key -> Lwt.t unit;
    fold_indexes : forall {a : Type}, t -> a -> (key -> a -> Lwt.t a) -> Lwt.t a;
    indexes : t -> Lwt.t (list key);
    resolve_index : t -> (list string) -> Lwt.t (list key);
    Make_set : functor;
    Make_buffered_set : functor;
    Make_map : functor;
    Make_buffered_map : functor;
  }.
  Arguments signature : clear implicits.
End INDEXED_STORE.

src/lib_storage/test/assert.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let equal_string ?msg s1 s2 = equal ?msg ~prn:(fun s -> s) s1 s2

let equal_string_option ?msg o1 o2 =
  let prn = function None -> "None" | Some s -> s in
  equal ?msg ~prn o1 o2

let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg

let make_equal_list eq prn ?(msg = "") x y =
  let rec iter i x y =
    match (x, y) with
    | (hd_x :: tl_x, hd_y :: tl_y) ->
        if eq hd_x hd_y then iter (succ i) tl_x tl_y
        else
          let fm = Printf.sprintf "%s (at index %d)" msg i in
          fail (prn hd_x) (prn hd_y) fm
    | (_ :: _, []) | ([], _ :: _) ->
        let fm = Printf.sprintf "%s (lists of different sizes)" msg in
        fail_msg "%s" fm
    | ([], []) ->
        ()
  in
  iter 0 x y

let equal_string_list ?msg l1 l2 =
  make_equal_list ?msg ( = ) (fun x -> x) l1 l2

let equal_string_list_list ?msg l1 l2 =
  let pr_persist l =
    let res =
      String.concat ";" (List.map (fun s -> Printf.sprintf "%S" s) l)
    in
    Printf.sprintf "[%s]" res
  in
  make_equal_list ?msg ( = ) pr_persist l1 l2

let equal_key_dir_list ?msg l1 l2 =
  make_equal_list
    ?msg
    ( = )
    (function
      | `Key k ->
          "Key " ^ String.concat "/" k
      | `Dir k ->
          "Dir " ^ String.concat "/" k)
    l1
    l2

let equal_context_hash_list ?msg l1 l2 =
  let pr_persist hash = Printf.sprintf "[%s]" @@ Context_hash.to_string hash in
  make_equal_list ?msg Context_hash.( = ) pr_persist l1 l2
src/lib_storage/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt : Stdlib.format4 A Stdlib.Format.formatter unit B) : A :=
  Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let prn :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition equal_string (msg : option string) (s1 : string) (s2 : string)
  : unit := equal None (Some (fun s => s)) msg s1 s2.

Definition equal_string_option
  (msg : option string) (o1 : option string) (o2 : option string) : unit :=
  let prn (function_parameter : option string) : string :=
    match function_parameter with
    | None => "None" % string
    | Some s => s
    end in
  equal None (Some prn) msg o1 o2.

Definition is_none {A : Type} (op_staroptstar : option string)
  : (option A) -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    if nequiv_decb x None then
      fail "None" % string "Some _" % string msg
    else
      tt.

Definition make_equal_list {A : Type}
  (eq : A -> A -> bool) (prn : A -> string) (op_staroptstar : option string)
  : (list A) -> (list A) -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    fun y =>
      let fix iter (i : Z) (x : list A) (y : list A) : unit :=
        match (x, y) with
        | (cons hd_x tl_x, cons hd_y tl_y) =>
          if eq hd_x hd_y then
            iter (Z.succ i) tl_x tl_y
          else
            let fm :=
              Printf.sprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " (at index " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          CamlinternalFormatBasics.End_of_format))))
                  "%s (at index %d)" % string) msg i in
            fail (prn hd_x) (prn hd_y) fm
        | (cons _ _, []) | ([], cons _ _) =>
          let fm :=
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal
                    " (lists of different sizes)" % string
                    CamlinternalFormatBasics.End_of_format))
                "%s (lists of different sizes)" % string) msg in
          fail_msg
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format) "%s" % string) fm
        | ([], []) => tt
        end in
      iter 0 x y.

Definition equal_string_list
  (msg : option string) (l1 : list string) (l2 : list string) : unit :=
  make_equal_list equiv_decb (fun x => x) msg l1 l2.

Definition equal_string_list_list
  (msg : option string) (l1 : list (list string)) (l2 : list (list string))
  : unit :=
  let pr_persist (l : list string) : string :=
    let res :=
      String.concat ";" % string
        (List.map
          (fun s =>
            Printf.sprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Caml_string
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.End_of_format) "%S" % string) s) l)
      in
    Printf.sprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "[" % char
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal "]" % char
              CamlinternalFormatBasics.End_of_format))) "[%s]" % string) res in
  make_equal_list equiv_decb pr_persist msg l1 l2.

Definition equal_key_dir_list
  (msg : option string) (l1 : list variant) (l2 : list variant) : unit :=
  make_equal_list equiv_decb
    (fun function_parameter =>
      match function_parameter with
      | Key k => String.append "Key " % string (String.concat "/" % string k)
      | Dir k => String.append "Dir " % string (String.concat "/" % string k)
      end) msg l1 l2.

Definition equal_context_hash_list
  (msg : option string) (l1 : list Tezos_base__TzPervasives.Context_hash.t)
  (l2 : list Tezos_base__TzPervasives.Context_hash.t) : unit :=
  let pr_persist (hash : Tezos_base__TzPervasives.Context_hash.t) : string :=
    apply
      (Printf.sprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "[" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "]" % char
                CamlinternalFormatBasics.End_of_format))) "[%s]" % string))
      (Context_hash.to_string hash) in
  make_equal_list Context_hash.op_eq pr_persist msg l1 l2.

src/lib_storage/test/test.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run
    "tezos-storage"
    [("context", Test_context.tests); ("raw_store", Test_raw_store.tests)]
src/lib_storage/test/test.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/lib_storage/test/test_context.ml 67 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Context

let ( >>= ) = Lwt.bind

let ( >|= ) = Lwt.( >|= )

let ( // ) = Filename.concat

(** Basic blocks *)

let genesis_block =
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z"

let genesis_protocol =
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp"

let genesis_time = Time.Protocol.of_seconds 0L

let chain_id = Chain_id.of_block_hash genesis_block

(** Context creation *)

let commit = commit ~time:Time.Protocol.epoch ~message:""

let block2 =
  Block_hash.of_hex_exn
    (`Hex "2222222222222222222222222222222222222222222222222222222222222222")

let create_block2 idx genesis_commit =
  checkout idx genesis_commit
  >>= function
  | None ->
      Assert.fail_msg "checkout genesis_block"
  | Some ctxt ->
      set ctxt ["a"; "b"] (Bytes.of_string "Novembre")
      >>= fun ctxt ->
      set ctxt ["a"; "c"] (Bytes.of_string "Juin")
      >>= fun ctxt ->
      set ctxt ["version"] (Bytes.of_string "0.0") >>= fun ctxt -> commit ctxt

let block3a =
  Block_hash.of_hex_exn
    (`Hex "3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a3a")

let create_block3a idx block2_commit =
  checkout idx block2_commit
  >>= function
  | None ->
      Assert.fail_msg "checkout block2"
  | Some ctxt ->
      del ctxt ["a"; "b"]
      >>= fun ctxt ->
      set ctxt ["a"; "d"] (Bytes.of_string "Mars") >>= fun ctxt -> commit ctxt

let block3b =
  Block_hash.of_hex_exn
    (`Hex "3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b3b")

let block3c =
  Block_hash.of_hex_exn
    (`Hex "3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c3c")

let create_block3b idx block2_commit =
  checkout idx block2_commit
  >>= function
  | None ->
      Assert.fail_msg "checkout block3b"
  | Some ctxt ->
      del ctxt ["a"; "c"]
      >>= fun ctxt ->
      set ctxt ["a"; "d"] (Bytes.of_string "Février")
      >>= fun ctxt -> commit ctxt

type t = {
  idx : Context.index;
  genesis : Context_hash.t;
  block2 : Context_hash.t;
  block3a : Context_hash.t;
  block3b : Context_hash.t;
}

let wrap_context_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "context" in
      Context.init ~mapsize:4_096_000L root
      >>= fun idx ->
      Context.commit_genesis
        idx
        ~chain_id
        ~time:genesis_time
        ~protocol:genesis_protocol
      >>= fun genesis ->
      create_block2 idx genesis
      >>= fun block2 ->
      create_block3a idx block2
      >>= fun block3a ->
      create_block3b idx block2
      >>= fun block3b ->
      f {idx; genesis; block2; block3a; block3b}
      >>= fun result -> Lwt.return result)

(** Simple test *)

let c = function None -> None | Some s -> Some (Bytes.to_string s)

let test_simple {idx; block2; _} =
  checkout idx block2
  >>= function
  | None ->
      Assert.fail_msg "checkout block2"
  | Some ctxt ->
      get ctxt ["version"]
      >>= fun version ->
      Assert.equal_string_option ~msg:__LOC__ (c version) (Some "0.0") ;
      get ctxt ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option (Some "Novembre") (c novembre) ;
      get ctxt ["a"; "c"]
      >>= fun juin ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
      Lwt.return_unit

let test_continuation {idx; block3a; _} =
  checkout idx block3a
  >>= function
  | None ->
      Assert.fail_msg "checkout block3a"
  | Some ctxt ->
      get ctxt ["version"]
      >>= fun version ->
      Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
      get ctxt ["a"; "b"]
      >>= fun novembre ->
      Assert.is_none ~msg:__LOC__ (c novembre) ;
      get ctxt ["a"; "c"]
      >>= fun juin ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Juin") (c juin) ;
      get ctxt ["a"; "d"]
      >>= fun mars ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Mars") (c mars) ;
      Lwt.return_unit

let test_fork {idx; block3b; _} =
  checkout idx block3b
  >>= function
  | None ->
      Assert.fail_msg "checkout block3b"
  | Some ctxt ->
      get ctxt ["version"]
      >>= fun version ->
      Assert.equal_string_option ~msg:__LOC__ (Some "0.0") (c version) ;
      get ctxt ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
      get ctxt ["a"; "c"]
      >>= fun juin ->
      Assert.is_none ~msg:__LOC__ (c juin) ;
      get ctxt ["a"; "d"]
      >>= fun mars ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Février") (c mars) ;
      Lwt.return_unit

let test_replay {idx; genesis; _} =
  checkout idx genesis
  >>= function
  | None ->
      Assert.fail_msg "checkout genesis_block"
  | Some ctxt0 ->
      set ctxt0 ["version"] (Bytes.of_string "0.0")
      >>= fun ctxt1 ->
      set ctxt1 ["a"; "b"] (Bytes.of_string "Novembre")
      >>= fun ctxt2 ->
      set ctxt2 ["a"; "c"] (Bytes.of_string "Juin")
      >>= fun ctxt3 ->
      set ctxt3 ["a"; "d"] (Bytes.of_string "July")
      >>= fun ctxt4a ->
      set ctxt3 ["a"; "d"] (Bytes.of_string "Juillet")
      >>= fun ctxt4b ->
      set ctxt4a ["a"; "b"] (Bytes.of_string "November")
      >>= fun ctxt5a ->
      get ctxt4a ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
      get ctxt5a ["a"; "b"]
      >>= fun november ->
      Assert.equal_string_option ~msg:__LOC__ (Some "November") (c november) ;
      get ctxt5a ["a"; "d"]
      >>= fun july ->
      Assert.equal_string_option ~msg:__LOC__ (Some "July") (c july) ;
      get ctxt4b ["a"; "b"]
      >>= fun novembre ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Novembre") (c novembre) ;
      get ctxt4b ["a"; "d"]
      >>= fun juillet ->
      Assert.equal_string_option ~msg:__LOC__ (Some "Juillet") (c juillet) ;
      Lwt.return_unit

let fold_keys s k ~init ~f =
  let rec loop k acc =
    fold s k ~init:acc ~f:(fun file acc ->
        match file with `Key k -> f k acc | `Dir k -> loop k acc)
  in
  loop k init

let keys t = fold_keys t ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

let test_fold {idx; genesis; _} =
  checkout idx genesis
  >>= function
  | None ->
      Assert.fail_msg "checkout genesis_block"
  | Some ctxt ->
      set ctxt ["a"; "b"] (Bytes.of_string "Novembre")
      >>= fun ctxt ->
      set ctxt ["a"; "c"] (Bytes.of_string "Juin")
      >>= fun ctxt ->
      set ctxt ["a"; "d"; "e"] (Bytes.of_string "Septembre")
      >>= fun ctxt ->
      set ctxt ["f"] (Bytes.of_string "Avril")
      >>= fun ctxt ->
      set ctxt ["g"; "h"] (Bytes.of_string "Avril")
      >>= fun ctxt ->
      keys ctxt []
      >>= fun l ->
      Assert.equal_string_list_list
        ~msg:__LOC__
        [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]; ["f"]; ["g"; "h"]]
        (List.sort compare l) ;
      keys ctxt ["a"]
      >>= fun l ->
      Assert.equal_string_list_list
        ~msg:__LOC__
        [["a"; "b"]; ["a"; "c"]; ["a"; "d"; "e"]]
        (List.sort compare l) ;
      keys ctxt ["f"]
      >>= fun l ->
      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
      keys ctxt ["g"]
      >>= fun l ->
      Assert.equal_string_list_list ~msg:__LOC__ [["g"; "h"]] l ;
      keys ctxt ["i"]
      >>= fun l ->
      Assert.equal_string_list_list ~msg:__LOC__ [] l ;
      Lwt.return_unit

let test_dump {idx; block3b; _} =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir2 ->
      let dumpfile = base_dir2 // "dump" in
      let ctxt_hash = block3b in
      let history_mode = Tezos_shell_services.History_mode.Full in
      let empty_block_header context =
        Block_header.
          {
            protocol_data = Bytes.empty;
            shell =
              {
                level = 0l;
                proto_level = 0;
                predecessor = Block_hash.zero;
                timestamp = Time.Protocol.epoch;
                validation_passes = 0;
                operations_hash = Operation_list_list_hash.zero;
                fitness = [];
                context;
              };
          }
      in
      let _empty_pruned_block =
        ( {
            block_header = empty_block_header Context_hash.zero;
            operations = [];
            operation_hashes = [];
          }
          : Context.Pruned_block.t )
      in
      let empty =
        {
          Context.Block_data.block_header = empty_block_header Context_hash.zero;
          operations = [[]];
        }
      in
      let bhs =
        (fun context ->
          ( empty_block_header context,
            empty,
            history_mode,
            fun _ -> return (None, None) ))
          ctxt_hash
      in
      Context.dump_contexts idx bhs ~filename:dumpfile
      >>=? fun () ->
      let root = base_dir2 // "context" in
      Context.init ?patch_context:None root
      >>= fun idx2 ->
      Context.restore_contexts
        idx2
        ~filename:dumpfile
        (fun _ -> return_unit)
        (fun _ _ _ -> return_unit)
      >>=? fun imported ->
      let (bh, _, _, _, _, _) = imported in
      let expected_ctxt_hash = bh.Block_header.shell.context in
      assert (Context_hash.equal ctxt_hash expected_ctxt_hash) ;
      return ())
  >>= function
  | Error err ->
      Error_monad.pp_print_error Format.err_formatter err ;
      assert false
  | Ok () ->
      Lwt.return_unit

(******************************************************************************)

let tests : (string * (t -> unit Lwt.t)) list =
  [ ("simple", test_simple);
    ("continuation", test_continuation);
    ("fork", test_fork);
    ("replay", test_replay);
    ("fold", test_fold);
    ("dump", test_dump) ]

let tests =
  List.map
    (fun (s, f) -> Alcotest_lwt.test_case s `Quick (wrap_context_init f))
    tests
src/lib_storage/test/test_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Context.

Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition op_gtpipeeq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
  Lwt.op_gtpipeeq.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition genesis_block : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_b58check_exn
    "BLockGenesisGenesisGenesisGenesisGenesisGeneskvg68z" % string.

Definition genesis_protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Protocol_hash.of_b58check_exn
    "ProtoDemoNoopsDemoNoopsDemoNoopsDemoNoopsDemo6XBoYp" % string.

Definition genesis_time : Tezos_base__TzPervasives.Time.Protocol.t :=
  Time.Protocol.of_seconds
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition chain_id : Tezos_base__TzPervasives.Chain_id.t :=
  Chain_id.of_block_hash genesis_block.

Definition commit
  : Tezos_storage.Context.context ->
    Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  commit Time.Protocol.epoch (Some "" % string).

Definition block2 : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_hex_exn
    (* ❌ Variants not supported *)
    variant.

Definition create_block2
  (idx : Tezos_storage.Context.index)
  (genesis_commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  op_gtgteq (checkout idx genesis_commit)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout genesis_block" % string
      | Some ctxt =>
        op_gtgteq
          (set ctxt (cons "a" % string (cons "b" % string []))
            (Stdlib.Bytes.of_string "Novembre" % string))
          (fun ctxt =>
            op_gtgteq
              (set ctxt (cons "a" % string (cons "c" % string []))
                (Stdlib.Bytes.of_string "Juin" % string))
              (fun ctxt =>
                op_gtgteq
                  (set ctxt (cons "version" % string [])
                    (Stdlib.Bytes.of_string "0.0" % string))
                  (fun ctxt => commit ctxt)))
      end).

Definition block3a : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_hex_exn
    (* ❌ Variants not supported *)
    variant.

Definition create_block3a
  (idx : Tezos_storage.Context.index)
  (block2_commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  op_gtgteq (checkout idx block2_commit)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout block2" % string
      | Some ctxt =>
        op_gtgteq (del ctxt (cons "a" % string (cons "b" % string [])))
          (fun ctxt =>
            op_gtgteq
              (set ctxt (cons "a" % string (cons "d" % string []))
                (Stdlib.Bytes.of_string "Mars" % string))
              (fun ctxt => commit ctxt))
      end).

Definition block3b : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_hex_exn
    (* ❌ Variants not supported *)
    variant.

Definition block3c : Tezos_base__TzPervasives.Block_hash.t :=
  Block_hash.of_hex_exn
    (* ❌ Variants not supported *)
    variant.

Definition create_block3b
  (idx : Tezos_storage.Context.index)
  (block2_commit : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t Tezos_base__TzPervasives.Context_hash.t :=
  op_gtgteq (checkout idx block2_commit)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout block3b" % string
      | Some ctxt =>
        op_gtgteq (del ctxt (cons "a" % string (cons "c" % string [])))
          (fun ctxt =>
            op_gtgteq
              (set ctxt (cons "a" % string (cons "d" % string []))
                (Stdlib.Bytes.of_string "Février" % string))
              (fun ctxt => commit ctxt))
      end).

Record t := {
  idx : Tezos_storage.Context.index;
  genesis : Tezos_base__TzPervasives.Context_hash.t;
  block2 : Tezos_base__TzPervasives.Context_hash.t;
  block3a : Tezos_base__TzPervasives.Context_hash.t;
  block3b : Tezos_base__TzPervasives.Context_hash.t }.

Definition wrap_context_init {A B : Type}
  (f : t -> Lwt.t A) (function_parameter : B) : unit -> Lwt.t A :=
  let '_ := function_parameter in
  fun function_parameter =>
    let 'tt := function_parameter in
    Lwt_utils_unix.with_tempdir "tezos_test_" % string
      (fun base_dir =>
        let root := op_divdiv base_dir "context" % string in
        op_gtgteq
          (Context.init None
            (Some
              (* ❌ Constant of type int64 is converted to int *)
              4096000) None root)
          (fun idx =>
            op_gtgteq
              (Context.commit_genesis idx chain_id genesis_time genesis_protocol)
              (fun genesis =>
                op_gtgteq (create_block2 idx genesis)
                  (fun block2 =>
                    op_gtgteq (create_block3a idx block2)
                      (fun block3a =>
                        op_gtgteq (create_block3b idx block2)
                          (fun block3b =>
                            op_gtgteq
                              (f
                                {| idx := idx; genesis := genesis;
                                  block2 := block2; block3a := block3a;
                                  block3b := block3b |})
                              (fun result => Lwt._return result))))))).

Definition c (function_parameter : option string) : option string :=
  match function_parameter with
  | None => None
  | Some s => Some (Stdlib.Bytes.to_string s)
  end.

Definition test_simple (function_parameter : t) : Lwt.t unit :=
  let '{| idx := idx; block2 := block2 |} := function_parameter in
  op_gtgteq (checkout idx block2)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout block2" % string
      | Some ctxt =>
        op_gtgteq (get ctxt (cons "version" % string []))
          (fun version =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              op_startypeminuserrorstar Stdlib.__LOC__ (c version)
                (Some "0.0" % string) in
            op_gtgteq (get ctxt (cons "a" % string (cons "b" % string [])))
              (fun novembre =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  op_startypeminuserrorstar (Some "Novembre" % string)
                    (c novembre) in
                op_gtgteq (get ctxt (cons "a" % string (cons "c" % string [])))
                  (fun juin =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar Stdlib.__LOC__
                        (Some "Juin" % string) (c juin) in
                    Lwt.return_unit)))
      end).

Definition test_continuation (function_parameter : t) : Lwt.t unit :=
  let '{| idx := idx; block3a := block3a |} := function_parameter in
  op_gtgteq (checkout idx block3a)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout block3a" % string
      | Some ctxt =>
        op_gtgteq (get ctxt (cons "version" % string []))
          (fun version =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
                (c version) in
            op_gtgteq (get ctxt (cons "a" % string (cons "b" % string [])))
              (fun novembre =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c novembre)
                  in
                op_gtgteq (get ctxt (cons "a" % string (cons "c" % string [])))
                  (fun juin =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      op_startypeminuserrorstar Stdlib.__LOC__
                        (Some "Juin" % string) (c juin) in
                    op_gtgteq
                      (get ctxt (cons "a" % string (cons "d" % string [])))
                      (fun mars =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          op_startypeminuserrorstar Stdlib.__LOC__
                            (Some "Mars" % string) (c mars) in
                        Lwt.return_unit))))
      end).

Definition test_fork (function_parameter : t) : Lwt.t unit :=
  let '{| idx := idx; block3b := block3b |} := function_parameter in
  op_gtgteq (checkout idx block3b)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout block3b" % string
      | Some ctxt =>
        op_gtgteq (get ctxt (cons "version" % string []))
          (fun version =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              op_startypeminuserrorstar Stdlib.__LOC__ (Some "0.0" % string)
                (c version) in
            op_gtgteq (get ctxt (cons "a" % string (cons "b" % string [])))
              (fun novembre =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  op_startypeminuserrorstar Stdlib.__LOC__
                    (Some "Novembre" % string) (c novembre) in
                op_gtgteq (get ctxt (cons "a" % string (cons "c" % string [])))
                  (fun juin =>
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := op_startypeminuserrorstar Stdlib.__LOC__ (c juin)
                      in
                    op_gtgteq
                      (get ctxt (cons "a" % string (cons "d" % string [])))
                      (fun mars =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          op_startypeminuserrorstar Stdlib.__LOC__
                            (Some "Février" % string) (c mars) in
                        Lwt.return_unit))))
      end).

Definition test_replay (function_parameter : t) : Lwt.t unit :=
  let '{| idx := idx; genesis := genesis |} := function_parameter in
  op_gtgteq (checkout idx genesis)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout genesis_block" % string
      | Some ctxt0 =>
        op_gtgteq
          (set ctxt0 (cons "version" % string [])
            (Stdlib.Bytes.of_string "0.0" % string))
          (fun ctxt1 =>
            op_gtgteq
              (set ctxt1 (cons "a" % string (cons "b" % string []))
                (Stdlib.Bytes.of_string "Novembre" % string))
              (fun ctxt2 =>
                op_gtgteq
                  (set ctxt2 (cons "a" % string (cons "c" % string []))
                    (Stdlib.Bytes.of_string "Juin" % string))
                  (fun ctxt3 =>
                    op_gtgteq
                      (set ctxt3 (cons "a" % string (cons "d" % string []))
                        (Stdlib.Bytes.of_string "July" % string))
                      (fun ctxt4a =>
                        op_gtgteq
                          (set ctxt3 (cons "a" % string (cons "d" % string []))
                            (Stdlib.Bytes.of_string "Juillet" % string))
                          (fun ctxt4b =>
                            op_gtgteq
                              (set ctxt4a
                                (cons "a" % string (cons "b" % string []))
                                (Stdlib.Bytes.of_string "November" % string))
                              (fun ctxt5a =>
                                op_gtgteq
                                  (get ctxt4a
                                    (cons "a" % string (cons "b" % string [])))
                                  (fun novembre =>
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      op_startypeminuserrorstar Stdlib.__LOC__
                                        (Some "Novembre" % string) (c novembre)
                                      in
                                    op_gtgteq
                                      (get ctxt5a
                                        (cons "a" % string
                                          (cons "b" % string [])))
                                      (fun november =>
                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                        let _ :=
                                          op_startypeminuserrorstar
                                            Stdlib.__LOC__
                                            (Some "November" % string)
                                            (c november) in
                                        op_gtgteq
                                          (get ctxt5a
                                            (cons "a" % string
                                              (cons "d" % string [])))
                                          (fun july =>
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            let _ :=
                                              op_startypeminuserrorstar
                                                Stdlib.__LOC__
                                                (Some "July" % string) (c july)
                                              in
                                            op_gtgteq
                                              (get ctxt4b
                                                (cons "a" % string
                                                  (cons "b" % string [])))
                                              (fun novembre =>
                                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                let _ :=
                                                  op_startypeminuserrorstar
                                                    Stdlib.__LOC__
                                                    (Some "Novembre" % string)
                                                    (c novembre) in
                                                op_gtgteq
                                                  (get ctxt4b
                                                    (cons "a" % string
                                                      (cons "d" % string [])))
                                                  (fun juillet =>
                                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                    let _ :=
                                                      op_startypeminuserrorstar
                                                        Stdlib.__LOC__
                                                        (Some "Juillet" % string)
                                                        (c juillet) in
                                                    Lwt.return_unit)))))))))))
      end).

Definition fold_keys {A : Type}
  (s : Tezos_storage.Context.context) (k : Tezos_storage.Context.key) (init : A)
  (f : Tezos_storage.Context.key -> A -> Lwt.t A) : Lwt.t A :=
  let fix loop (k : Tezos_storage.Context.key) (acc : A) : Lwt.t A :=
    fold s k acc
      (fun file =>
        fun acc =>
          match file with
          | Key k => f k acc
          | Dir k => loop k acc
          end) in
  loop k init.

Definition keys (t : Tezos_storage.Context.context)
  : Tezos_storage.Context.key -> Lwt.t (list Tezos_storage.Context.key) :=
  fold_keys t
    (* ❌ expected an argument *)
    expected_argument [] (fun k => fun acc => Lwt._return (cons k acc)).

Definition test_fold (function_parameter : t) : Lwt.t unit :=
  let '{| idx := idx; genesis := genesis |} := function_parameter in
  op_gtgteq (checkout idx genesis)
    (fun function_parameter =>
      match function_parameter with
      | None => op_startypeminuserrorstar "checkout genesis_block" % string
      | Some ctxt =>
        op_gtgteq
          (set ctxt (cons "a" % string (cons "b" % string []))
            (Stdlib.Bytes.of_string "Novembre" % string))
          (fun ctxt =>
            op_gtgteq
              (set ctxt (cons "a" % string (cons "c" % string []))
                (Stdlib.Bytes.of_string "Juin" % string))
              (fun ctxt =>
                op_gtgteq
                  (set ctxt
                    (cons "a" % string
                      (cons "d" % string (cons "e" % string [])))
                    (Stdlib.Bytes.of_string "Septembre" % string))
                  (fun ctxt =>
                    op_gtgteq
                      (set ctxt (cons "f" % string [])
                        (Stdlib.Bytes.of_string "Avril" % string))
                      (fun ctxt =>
                        op_gtgteq
                          (set ctxt (cons "g" % string (cons "h" % string []))
                            (Stdlib.Bytes.of_string "Avril" % string))
                          (fun ctxt =>
                            op_gtgteq (keys ctxt [])
                              (fun l =>
                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                let _ :=
                                  op_startypeminuserrorstar Stdlib.__LOC__
                                    (cons
                                      (cons "a" % string (cons "b" % string []))
                                      (cons
                                        (cons "a" % string
                                          (cons "c" % string []))
                                        (cons
                                          (cons "a" % string
                                            (cons "d" % string
                                              (cons "e" % string [])))
                                          (cons (cons "f" % string [])
                                            (cons
                                              (cons "g" % string
                                                (cons "h" % string [])) [])))))
                                    (List.sort OCaml.Stdlib.compare l) in
                                op_gtgteq (keys ctxt (cons "a" % string []))
                                  (fun l =>
                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                    let _ :=
                                      op_startypeminuserrorstar Stdlib.__LOC__
                                        (cons
                                          (cons "a" % string
                                            (cons "b" % string []))
                                          (cons
                                            (cons "a" % string
                                              (cons "c" % string []))
                                            (cons
                                              (cons "a" % string
                                                (cons "d" % string
                                                  (cons "e" % string []))) [])))
                                        (List.sort OCaml.Stdlib.compare l) in
                                    op_gtgteq (keys ctxt (cons "f" % string []))
                                      (fun l =>
                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                        let _ :=
                                          op_startypeminuserrorstar
                                            Stdlib.__LOC__ [] l in
                                        op_gtgteq
                                          (keys ctxt (cons "g" % string []))
                                          (fun l =>
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            let _ :=
                                              op_startypeminuserrorstar
                                                Stdlib.__LOC__
                                                (cons
                                                  (cons "g" % string
                                                    (cons "h" % string [])) [])
                                                l in
                                            op_gtgteq
                                              (keys ctxt (cons "i" % string []))
                                              (fun l =>
                                                (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                let _ :=
                                                  op_startypeminuserrorstar
                                                    Stdlib.__LOC__ [] l in
                                                Lwt.return_unit))))))))))
      end).

Definition test_dump (function_parameter : t) : Lwt.t unit :=
  let '{| idx := idx; block3b := block3b |} := function_parameter in
  op_gtgteq
    (Lwt_utils_unix.with_tempdir "tezos_test_" % string
      (fun base_dir2 =>
        let dumpfile := op_divdiv base_dir2 "dump" % string in
        let ctxt_hash := block3b in
        let history_mode := Tezos_shell_services.History_mode.Full in
        let empty_block_header (context : Tezos_crypto.Context_hash.t)
          : Tezos_base__TzPervasives.Block_header.t :=
          {|
            shell :=
              {|
                level :=
                  (* ❌ Constant of type int32 is converted to int *)
                  0; proto_level := 0; predecessor := Block_hash.zero;
                timestamp := Time.Protocol.epoch; validation_passes := 0;
                operations_hash := Operation_list_list_hash.zero; fitness := [];
                context := context |}; protocol_data := Stdlib.Bytes.empty |} in
        let _empty_pruned_block :=
          {| block_header := empty_block_header Context_hash.zero;
            operations := []; operation_hashes := [] |} in
        let empty :=
          {|
            Context.Block_data.block_header :=
              empty_block_header Context_hash.zero;
            Context.Block_data.operations := cons [] [] |} in
        let bhs :=
          (fun context =>
            ((empty_block_header context), empty, history_mode,
              (fun function_parameter =>
                let '_ := function_parameter in
                _return (None, None)))) ctxt_hash in
        op_gtgteqquestion (Context.dump_contexts idx bhs dumpfile)
          (fun function_parameter =>
            let 'tt := function_parameter in
            let root := op_divdiv base_dir2 "context" % string in
            op_gtgteq (Context.init None None None root)
              (fun idx2 =>
                op_gtgteqquestion
                  (Context.restore_contexts idx2 dumpfile
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      return_unit)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      fun function_parameter =>
                        let '_ := function_parameter in
                        fun function_parameter =>
                          let '_ := function_parameter in
                          return_unit))
                  (fun imported =>
                    let '(bh, _, _, _, _, _) := imported in
                    let expected_ctxt_hash := context (Block_header.shell bh) in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ :=
                      (* ❌ Assert instruction is not handled. *)
                      assert (Context_hash.equal ctxt_hash expected_ctxt_hash)
                      in
                    _return tt)))))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error err =>
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Error_monad.pp_print_error Format.err_formatter err in
        (* ❌ Assert instruction is not handled. *)
        assert false
      | Stdlib.Ok tt => Lwt.return_unit
      end).

Definition tests : list (string * (t -> Lwt.t unit)) :=
  cons ("simple" % string, test_simple)
    (cons ("continuation" % string, test_continuation)
      (cons ("fork" % string, test_fork)
        (cons ("replay" % string, test_replay)
          (cons ("fold" % string, test_fold)
            (cons ("dump" % string, test_dump) []))))).

Definition tests {A : Type} : list A :=
  List.map
    (fun function_parameter =>
      let '(s, f) := function_parameter in
      op_startypeminuserrorstar s
        (* ❌ Variants not supported *)
        variant (wrap_context_init f)) tests.

src/lib_storage/test/test_raw_store.ml 35 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Raw_store

let ( >>= ) = Lwt.bind

let ( >|= ) = Lwt.( >|= )

let ( // ) = Filename.concat

let wrap_store_init f _ () =
  Lwt_utils_unix.with_tempdir "tezos_test_" (fun base_dir ->
      let root = base_dir // "store" in
      init ~mapsize:4_096_000L root
      >>= function
      | Error _ -> Assert.fail_msg "wrap_store_init" | Ok store -> f store)

let entries s k =
  fold s k ~init:[] ~f:(fun e acc -> Lwt.return (e :: acc)) >|= List.rev

let test_fold st =
  store st ["a"; "b"] (Bytes.of_string "Novembre")
  >>= fun _ ->
  store st ["a"; "c"] (Bytes.of_string "Juin")
  >>= fun _ ->
  store st ["a"; "d"; "e"] (Bytes.of_string "Septembre")
  >>= fun _ ->
  store st ["f"] (Bytes.of_string "Avril")
  >>= fun _ ->
  (* The code of '.' is just below the one of '/' ! *)
  store st ["g"; ".12"; "a"] (Bytes.of_string "Mai")
  >>= fun _ ->
  store st ["g"; ".12"; "b"] (Bytes.of_string "Février")
  >>= fun _ ->
  store st ["g"; "123"; "456"] (Bytes.of_string "Mars")
  >>= fun _ ->
  store st ["g"; "1230"] (Bytes.of_string "Janvier")
  >>= fun _ ->
  entries st []
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [`Dir ["a"]; `Key ["f"]; `Dir ["g"]] l ;
  entries st ["0"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["0"; "1"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["a"]
  >>= fun l ->
  Assert.equal_key_dir_list
    ~msg:__LOC__
    [`Key ["a"; "b"]; `Key ["a"; "c"]; `Dir ["a"; "d"]]
    l ;
  entries st ["a"; "d"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [`Key ["a"; "d"; "e"]] l ;
  entries st ["f"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["f"; "z"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  entries st ["g"]
  >>= fun l ->
  Assert.equal_key_dir_list
    ~msg:__LOC__
    [`Dir ["g"; ".12"]; `Dir ["g"; "123"]; `Key ["g"; "1230"]]
    l ;
  entries st ["g"; "123"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [`Key ["g"; "123"; "456"]] l ;
  entries st ["z"]
  >>= fun l ->
  Assert.equal_key_dir_list ~msg:__LOC__ [] l ;
  Lwt.return_unit

let tests = [Alcotest_lwt.test_case "fold" `Quick (wrap_store_init test_fold)]
src/lib_storage/test/test_raw_store.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Raw_store.

Definition op_gtgteq {A B : Type} : (Lwt.t A) -> (A -> Lwt.t B) -> Lwt.t B :=
  Lwt.bind.

Definition op_gtpipeeq {A B : Type} : (Lwt.t A) -> (A -> B) -> Lwt.t B :=
  Lwt.op_gtpipeeq.

Definition op_divdiv : string -> string -> string := Filename.concat.

Definition wrap_store_init {A B : Type}
  (f : Tezos_storage.Raw_store.t -> Lwt.t A) (function_parameter : B)
  : unit -> Lwt.t A :=
  let '_ := function_parameter in
  fun function_parameter =>
    let 'tt := function_parameter in
    Lwt_utils_unix.with_tempdir "tezos_test_" % string
      (fun base_dir =>
        let root := op_divdiv base_dir "store" % string in
        op_gtgteq
          (init None
            (Some
              (* ❌ Constant of type int64 is converted to int *)
              4096000) root)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Error _ =>
              op_startypeminuserrorstar "wrap_store_init" % string
            | Stdlib.Ok store => f store
            end)).

Definition entries
  (s : Tezos_storage.Raw_store.t) (k : Tezos_storage.Raw_store.key)
  : Lwt.t (list variant) :=
  op_gtpipeeq (fold s k [] (fun e => fun acc => Lwt._return (cons e acc)))
    List.rev.

Definition test_fold (st : Tezos_storage.Raw_store.t) : Lwt.t unit :=
  op_gtgteq
    (store st (cons "a" % string (cons "b" % string []))
      (Stdlib.Bytes.of_string "Novembre" % string))
    (fun function_parameter =>
      let '_ := function_parameter in
      op_gtgteq
        (store st (cons "a" % string (cons "c" % string []))
          (Stdlib.Bytes.of_string "Juin" % string))
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteq
            (store st
              (cons "a" % string (cons "d" % string (cons "e" % string [])))
              (Stdlib.Bytes.of_string "Septembre" % string))
            (fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteq
                (store st (cons "f" % string [])
                  (Stdlib.Bytes.of_string "Avril" % string))
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_gtgteq
                    (store st
                      (cons "g" % string
                        (cons ".12" % string (cons "a" % string [])))
                      (Stdlib.Bytes.of_string "Mai" % string))
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteq
                        (store st
                          (cons "g" % string
                            (cons ".12" % string (cons "b" % string [])))
                          (Stdlib.Bytes.of_string "Février" % string))
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          op_gtgteq
                            (store st
                              (cons "g" % string
                                (cons "123" % string (cons "456" % string [])))
                              (Stdlib.Bytes.of_string "Mars" % string))
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              op_gtgteq
                                (store st
                                  (cons "g" % string (cons "1230" % string []))
                                  (Stdlib.Bytes.of_string "Janvier" % string))
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  op_gtgteq (entries st [])
                                    (fun l =>
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        op_startypeminuserrorstar Stdlib.__LOC__
                                          (cons
                                            (* ❌ Variants not supported *)
                                            variant
                                            (cons
                                              (* ❌ Variants not supported *)
                                              variant
                                              (cons
                                                (* ❌ Variants not supported *)
                                                variant []))) l in
                                      op_gtgteq
                                        (entries st (cons "0" % string []))
                                        (fun l =>
                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                          let _ :=
                                            op_startypeminuserrorstar
                                              Stdlib.__LOC__ [] l in
                                          op_gtgteq
                                            (entries st
                                              (cons "0" % string
                                                (cons "1" % string [])))
                                            (fun l =>
                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                              let _ :=
                                                op_startypeminuserrorstar
                                                  Stdlib.__LOC__ [] l in
                                              op_gtgteq
                                                (entries st
                                                  (cons "a" % string []))
                                                (fun l =>
                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                  let _ :=
                                                    op_startypeminuserrorstar
                                                      Stdlib.__LOC__
                                                      (cons
                                                        (* ❌ Variants not supported *)
                                                        variant
                                                        (cons
                                                          (* ❌ Variants not supported *)
                                                          variant
                                                          (cons
                                                            (* ❌ Variants not supported *)
                                                            variant []))) l in
                                                  op_gtgteq
                                                    (entries st
                                                      (cons "a" % string
                                                        (cons "d" % string [])))
                                                    (fun l =>
                                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                      let _ :=
                                                        op_startypeminuserrorstar
                                                          Stdlib.__LOC__
                                                          (cons
                                                            (* ❌ Variants not supported *)
                                                            variant []) l in
                                                      op_gtgteq
                                                        (entries st
                                                          (cons "f" % string []))
                                                        (fun l =>
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            op_startypeminuserrorstar
                                                              Stdlib.__LOC__ []
                                                              l in
                                                          op_gtgteq
                                                            (entries st
                                                              (cons "f" % string
                                                                (cons
                                                                  "z" % string
                                                                  [])))
                                                            (fun l =>
                                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                              let _ :=
                                                                op_startypeminuserrorstar
                                                                  Stdlib.__LOC__
                                                                  [] l in
                                                              op_gtgteq
                                                                (entries st
                                                                  (cons
                                                                    "g" % string
                                                                    []))
                                                                (fun l =>
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    op_startypeminuserrorstar
                                                                      Stdlib.__LOC__
                                                                      (cons
                                                                        (* ❌ Variants not supported *)
                                                                        variant
                                                                        (cons
                                                                          (* ❌ Variants not supported *)
                                                                          variant
                                                                          (cons
                                                                            (* ❌ Variants not supported *)
                                                                            variant
                                                                            [])))
                                                                      l in
                                                                  op_gtgteq
                                                                    (entries st
                                                                      (cons
                                                                        "g" %
                                                                          string
                                                                        (cons
                                                                          "123"
                                                                            %
                                                                            string
                                                                          [])))
                                                                    (fun l =>
                                                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                      let _ :=
                                                                        op_startypeminuserrorstar
                                                                          Stdlib.__LOC__
                                                                          (cons
                                                                            (* ❌ Variants not supported *)
                                                                            variant
                                                                            [])
                                                                          l in
                                                                      op_gtgteq
                                                                        (entries
                                                                          st
                                                                          (cons
                                                                            "z"
                                                                              %
                                                                              string
                                                                            []))
                                                                        (fun l
                                                                          =>
                                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                          let _
                                                                            :=
                                                                            op_startypeminuserrorstar
                                                                              Stdlib.__LOC__
                                                                              []
                                                                              l
                                                                            in
                                                                          Lwt.return_unit)))))))))))))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "fold" % string
      (* ❌ Variants not supported *)
      variant (wrap_store_init test_fold)) [].

src/lib_validation/block_validation.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs. <nomadic@tezcore.com>                    *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Block_validator_errors

type validation_store = {
  context_hash : Context_hash.t;
  message : string option;
  max_operations_ttl : int;
  last_allowed_fork_level : Int32.t;
}

let validation_store_encoding =
  let open Data_encoding in
  conv
    (fun {context_hash; message; max_operations_ttl; last_allowed_fork_level} ->
      (context_hash, message, max_operations_ttl, last_allowed_fork_level))
    (fun (context_hash, message, max_operations_ttl, last_allowed_fork_level) ->
      {context_hash; message; max_operations_ttl; last_allowed_fork_level})
    (obj4
       (req "context_hash" Context_hash.encoding)
       (req "message" (option string))
       (req "max_operations_ttl" int31)
       (req "last_allowed_fork_level" int32))

type result = {
  validation_store : validation_store;
  block_metadata : Bytes.t;
  ops_metadata : Bytes.t list list;
  forking_testchain : bool;
}

let update_testchain_status ctxt predecessor_header timestamp =
  Context.get_test_chain ctxt
  >>= function
  | Not_running ->
      return ctxt
  | Running {expiration; _} ->
      if Time.Protocol.(expiration <= timestamp) then
        Context.set_test_chain ctxt Not_running >>= fun ctxt -> return ctxt
      else return ctxt
  | Forking {protocol; expiration} ->
      let predecessor_hash = Block_header.hash predecessor_header in
      let genesis = Context.compute_testchain_genesis predecessor_hash in
      let chain_id = Chain_id.of_block_hash genesis in
      (* legacy semantics *)
      Context.set_test_chain
        ctxt
        (Running {chain_id; genesis; protocol; expiration})
      >>= fun ctxt -> return ctxt

let is_testchain_forking ctxt =
  Context.get_test_chain ctxt
  >>= function
  | Not_running | Running _ -> Lwt.return_false | Forking _ -> Lwt.return_true

let init_test_chain ctxt forked_header =
  Context.get_test_chain ctxt
  >>= function
  | Not_running | Running _ ->
      assert false
  | Forking {protocol; _} ->
      ( match Registered_protocol.get protocol with
      | Some proto ->
          return proto
      | None ->
          fail (Missing_test_protocol protocol) )
      >>=? fun (module Proto_test) ->
      let test_ctxt = Shell_context.wrap_disk_context ctxt in
      Proto_test.init test_ctxt forked_header.Block_header.shell
      >>=? fun {context = test_ctxt; _} ->
      let test_ctxt = Shell_context.unwrap_disk_context test_ctxt in
      Context.set_test_chain test_ctxt Not_running
      >>= fun test_ctxt ->
      Context.set_protocol test_ctxt protocol
      >>= fun test_ctxt ->
      Context.commit_test_chain_genesis test_ctxt forked_header
      >>= fun genesis_header -> return genesis_header

let result_encoding =
  let open Data_encoding in
  conv
    (fun {validation_store; block_metadata; ops_metadata; forking_testchain} ->
      (validation_store, block_metadata, ops_metadata, forking_testchain))
    (fun (validation_store, block_metadata, ops_metadata, forking_testchain) ->
      {validation_store; block_metadata; ops_metadata; forking_testchain})
    (obj4
       (req "validation_store" validation_store_encoding)
       (req "block_metadata" bytes)
       (req "ops_metadata" (list @@ list @@ bytes))
       (req "forking_testchain" bool))

let may_force_protocol_upgrade ~level
    (validation_result : Tezos_protocol_environment.validation_result) =
  match Block_header.get_forced_protocol_upgrade ~level with
  | None ->
      Lwt.return validation_result
  | Some hash ->
      let context =
        Shell_context.unwrap_disk_context validation_result.context
      in
      Context.set_protocol context hash
      >>= fun context ->
      let context = Shell_context.wrap_disk_context context in
      Lwt.return {validation_result with context}

(** Applies user activated updates based either on block level or on
    voted protocols *)
let may_patch_protocol ~level
    (validation_result : Tezos_protocol_environment.validation_result) =
  let context = Shell_context.unwrap_disk_context validation_result.context in
  Context.get_protocol context
  >>= fun protocol ->
  match Block_header.get_voted_protocol_overrides protocol with
  | None ->
      may_force_protocol_upgrade ~level validation_result
  | Some replacement_protocol ->
      Context.set_protocol context replacement_protocol
      >>= fun context ->
      let context = Shell_context.wrap_disk_context context in
      Lwt.return {validation_result with context}

module Make (Proto : Registered_protocol.T) = struct
  let check_block_header ~(predecessor_block_header : Block_header.t) hash
      (block_header : Block_header.t) =
    let validation_passes = List.length Proto.validation_passes in
    fail_unless
      ( Int32.succ predecessor_block_header.shell.level
      = block_header.shell.level )
      ( invalid_block hash
      @@ Invalid_level
           {
             expected = Int32.succ predecessor_block_header.shell.level;
             found = block_header.shell.level;
           } )
    >>=? fun () ->
    fail_unless
      Time.Protocol.(
        predecessor_block_header.shell.timestamp < block_header.shell.timestamp)
      (invalid_block hash Non_increasing_timestamp)
    >>=? fun () ->
    fail_unless
      Fitness.(
        predecessor_block_header.shell.fitness < block_header.shell.fitness)
      (invalid_block hash Non_increasing_fitness)
    >>=? fun () ->
    fail_unless
      (block_header.shell.validation_passes = validation_passes)
      (invalid_block
         hash
         (Unexpected_number_of_validation_passes
            block_header.shell.validation_passes))
    >>=? fun () -> return_unit

  let parse_block_header block_hash (block_header : Block_header.t) =
    match
      Data_encoding.Binary.of_bytes
        Proto.block_header_data_encoding
        block_header.protocol_data
    with
    | None ->
        fail (invalid_block block_hash Cannot_parse_block_header)
    | Some protocol_data ->
        return
          ({shell = block_header.shell; protocol_data} : Proto.block_header)

  let check_operation_quota block_hash operations =
    let invalid_block = invalid_block block_hash in
    iteri2_p
      (fun i ops quota ->
        fail_unless
          (Option.unopt_map
             ~default:true
             ~f:(fun max -> List.length ops <= max)
             quota.Tezos_protocol_environment.max_op)
          (let max = Option.unopt ~default:~-1 quota.max_op in
           invalid_block
             (Too_many_operations {pass = i + 1; found = List.length ops; max}))
        >>=? fun () ->
        iter_p
          (fun op ->
            let size = Data_encoding.Binary.length Operation.encoding op in
            fail_unless
              (size <= Proto.max_operation_data_length)
              (invalid_block
                 (Oversized_operation
                    {
                      operation = Operation.hash op;
                      size;
                      max = Proto.max_operation_data_length;
                    })))
          ops
        >>=? fun () -> return_unit)
      operations
      Proto.validation_passes

  let parse_operations block_hash operations =
    let invalid_block = invalid_block block_hash in
    mapi_s
      (fun pass ->
        map_s (fun op ->
            let op_hash = Operation.hash op in
            match
              Data_encoding.Binary.of_bytes
                Proto.operation_data_encoding
                op.Operation.proto
            with
            | None ->
                fail (invalid_block (Cannot_parse_operation op_hash))
            | Some protocol_data ->
                let op = {Proto.shell = op.shell; protocol_data} in
                let allowed_pass = Proto.acceptable_passes op in
                fail_unless
                  (List.mem pass allowed_pass)
                  (invalid_block
                     (Unallowed_pass {operation = op_hash; pass; allowed_pass}))
                >>=? fun () -> return op))
      operations

  let apply chain_id ~max_operations_ttl
      ~(predecessor_block_header : Block_header.t) ~predecessor_context
      ~(block_header : Block_header.t) operations =
    let block_hash = Block_header.hash block_header in
    let invalid_block = invalid_block block_hash in
    check_block_header ~predecessor_block_header block_hash block_header
    >>=? fun () ->
    parse_block_header block_hash block_header
    >>=? fun block_header ->
    check_operation_quota block_hash operations
    >>=? fun () ->
    update_testchain_status
      predecessor_context
      predecessor_block_header
      block_header.shell.timestamp
    >>=? fun context ->
    parse_operations block_hash operations
    >>=? fun operations ->
    let context = Shell_context.wrap_disk_context context in
    Proto.begin_application
      ~chain_id
      ~predecessor_context:context
      ~predecessor_timestamp:predecessor_block_header.shell.timestamp
      ~predecessor_fitness:predecessor_block_header.shell.fitness
      block_header
    >>=? (fun state ->
           fold_left_s
             (fun (state, acc) ops ->
               fold_left_s
                 (fun (state, acc) op ->
                   Proto.apply_operation state op
                   >>=? fun (state, op_metadata) ->
                   return (state, op_metadata :: acc))
                 (state, [])
                 ops
               >>=? fun (state, ops_metadata) ->
               return (state, List.rev ops_metadata :: acc))
             (state, [])
             operations
           >>=? fun (state, ops_metadata) ->
           let ops_metadata = List.rev ops_metadata in
           Proto.finalize_block state
           >>=? fun (validation_result, block_data) ->
           return (validation_result, block_data, ops_metadata))
    >>= (function
          | Error err ->
              fail (invalid_block (Economic_protocol_error err))
          | Ok o ->
              return o)
    >>=? fun (validation_result, block_data, ops_metadata) ->
    (* reset_test_chain
     *   validation_result.context
     *   current_block_header
     *   ~start_testchain >>=? fun forked_genesis_header -> *)
    let context =
      Shell_context.unwrap_disk_context validation_result.context
    in
    is_testchain_forking context
    >>= fun forking_testchain ->
    may_patch_protocol ~level:block_header.shell.level validation_result
    >>= fun validation_result ->
    let context =
      Shell_context.unwrap_disk_context validation_result.context
    in
    Context.get_protocol context
    >>= fun new_protocol ->
    let expected_proto_level =
      if Protocol_hash.equal new_protocol Proto.hash then
        predecessor_block_header.shell.proto_level
      else (predecessor_block_header.shell.proto_level + 1) mod 256
    in
    fail_when
      (block_header.shell.proto_level <> expected_proto_level)
      (invalid_block
         (Invalid_proto_level
            {
              found = block_header.shell.proto_level;
              expected = expected_proto_level;
            }))
    >>=? fun () ->
    fail_when
      Fitness.(validation_result.fitness <> block_header.shell.fitness)
      (invalid_block
         (Invalid_fitness
            {
              expected = block_header.shell.fitness;
              found = validation_result.fitness;
            }))
    >>=? fun () ->
    ( if Protocol_hash.equal new_protocol Proto.hash then
      return validation_result
    else
      match Registered_protocol.get new_protocol with
      | None ->
          fail
            (Unavailable_protocol {block = block_hash; protocol = new_protocol})
      | Some (module NewProto) ->
          NewProto.init validation_result.context block_header.shell )
    >>=? fun validation_result ->
    let max_operations_ttl =
      max 0 (min (max_operations_ttl + 1) validation_result.max_operations_ttl)
    in
    let validation_result = {validation_result with max_operations_ttl} in
    let block_metadata =
      Data_encoding.Binary.to_bytes_exn
        Proto.block_header_metadata_encoding
        block_data
    in
    let ops_metadata =
      List.map
        (List.map
           (Data_encoding.Binary.to_bytes_exn Proto.operation_receipt_encoding))
        ops_metadata
    in
    let context =
      Shell_context.unwrap_disk_context validation_result.context
    in
    Context.commit
      ~time:block_header.shell.timestamp
      ?message:validation_result.message
      context
    >>= fun context_hash ->
    let validation_store =
      {
        context_hash;
        message = validation_result.message;
        max_operations_ttl = validation_result.max_operations_ttl;
        last_allowed_fork_level = validation_result.last_allowed_fork_level;
      }
    in
    return {validation_store; block_metadata; ops_metadata; forking_testchain}
end

let assert_no_duplicate_operations block_hash live_operations operations =
  fold_left_s
    (fold_left_s (fun live_operations op ->
         let oph = Operation.hash op in
         fail_when
           (Operation_hash.Set.mem oph live_operations)
           (invalid_block block_hash @@ Replayed_operation oph)
         >>=? fun () -> return (Operation_hash.Set.add oph live_operations)))
    live_operations
    operations
  >>=? fun _ -> return_unit

let assert_operation_liveness block_hash live_blocks operations =
  iter_s
    (iter_s (fun op ->
         fail_unless
           (Block_hash.Set.mem op.Operation.shell.branch live_blocks)
           ( invalid_block block_hash
           @@ Outdated_operation
                {
                  operation = Operation.hash op;
                  originating_block = op.shell.branch;
                } )))
    operations

let check_liveness ~live_blocks ~live_operations block_hash operations =
  assert_no_duplicate_operations block_hash live_operations operations
  >>=? fun () ->
  assert_operation_liveness block_hash live_blocks operations
  >>=? fun () -> return_unit

let apply chain_id ~max_operations_ttl
    ~(predecessor_block_header : Block_header.t) ~predecessor_context
    ~(block_header : Block_header.t) operations =
  let block_hash = Block_header.hash block_header in
  Context.get_protocol predecessor_context
  >>= fun pred_protocol_hash ->
  ( match Registered_protocol.get pred_protocol_hash with
  | None ->
      fail
        (Unavailable_protocol
           {block = block_hash; protocol = pred_protocol_hash})
  | Some p ->
      return p )
  >>=? fun (module Proto) ->
  let module Block_validation = Make (Proto) in
  Block_validation.apply
    chain_id
    ~max_operations_ttl
    ~predecessor_block_header
    ~predecessor_context
    ~block_header
    operations
  >>= function
  | Error (Exn (Unix.Unix_error (errno, fn, msg)) :: _) ->
      fail (System_error {errno = Unix.error_message errno; fn; msg})
  | (Ok _ | Error _) as res ->
      Lwt.return res
src/lib_validation/block_validation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Block_validator_errors.

Record validation_store := {
  context_hash : Tezos_base__TzPervasives.Context_hash.t;
  message : option string;
  max_operations_ttl : Z;
  last_allowed_fork_level : Stdlib.Int32.t }.

Definition validation_store_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding validation_store :=
  conv
    (fun function_parameter =>
      let '{|
        context_hash := context_hash;
          message := message;
          max_operations_ttl := max_operations_ttl;
          last_allowed_fork_level := last_allowed_fork_level
          |} := function_parameter in
      (context_hash, message, max_operations_ttl, last_allowed_fork_level))
    (fun function_parameter =>
      let
        '(context_hash, message, max_operations_ttl, last_allowed_fork_level) :=
        function_parameter in
      {| context_hash := context_hash; message := message;
        max_operations_ttl := max_operations_ttl;
        last_allowed_fork_level := last_allowed_fork_level |}) None
    (obj4 (req None None "context_hash" % string Context_hash.encoding)
      (req None None "message" % string (option string))
      (req None None "max_operations_ttl" % string int31)
      (req None None "last_allowed_fork_level" % string int32)).

Record result := {
  validation_store : validation_store;
  block_metadata : Stdlib.Bytes.t;
  ops_metadata : list (list Stdlib.Bytes.t);
  forking_testchain : bool }.

Definition update_testchain_status
  (ctxt : Tezos_storage.Context.context)
  (predecessor_header : Tezos_base__TzPervasives.Block_header.t)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_storage.Context.context) :=
  op_gtgteq (Context.get_test_chain ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Tezos_base__TzPervasives.Test_chain_status.Not_running => _return ctxt
      |
        Tezos_base__TzPervasives.Test_chain_status.Running {|
          expiration := expiration |} =>
        if op_lteq expiration timestamp then
          op_gtgteq
            (Context.set_test_chain ctxt
              Tezos_base__TzPervasives.Test_chain_status.Not_running)
            (fun ctxt => _return ctxt)
        else
          _return ctxt
      |
        Tezos_base__TzPervasives.Test_chain_status.Forking {|
          protocol := protocol; expiration := expiration |} =>
        let predecessor_hash := Block_header.hash predecessor_header in
        let genesis := Context.compute_testchain_genesis predecessor_hash in
        let chain_id := Chain_id.of_block_hash genesis in
        op_gtgteq
          (Context.set_test_chain ctxt
            (Tezos_base__TzPervasives.Test_chain_status.Running
              {| chain_id := chain_id; genesis := genesis; protocol := protocol;
                expiration := expiration |})) (fun ctxt => _return ctxt)
      end).

Definition is_testchain_forking (ctxt : Tezos_storage.Context.context)
  : Lwt.t bool :=
  op_gtgteq (Context.get_test_chain ctxt)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_base__TzPervasives.Test_chain_status.Not_running |
          Tezos_base__TzPervasives.Test_chain_status.Running _ =>
        Lwt.return_false
      | Tezos_base__TzPervasives.Test_chain_status.Forking _ => Lwt.return_true
      end).

Definition init_test_chain
  (ctxt : Tezos_storage.Context.context)
  (forked_header : Tezos_base__TzPervasives.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_header.t) :=
  op_gtgteq (Context.get_test_chain ctxt)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_base__TzPervasives.Test_chain_status.Not_running |
          Tezos_base__TzPervasives.Test_chain_status.Running _ =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      |
        Tezos_base__TzPervasives.Test_chain_status.Forking {|
          protocol := protocol |} =>
        op_gtgteqquestion
          match Registered_protocol.get protocol with
          | Some proto => _return proto
          | None =>
            fail (Tezos_base__TzPervasives.Missing_test_protocol protocol)
          end
          (fun Proto_test =>
            let Proto_test := projT2 Proto_test in
            let test_ctxt := Shell_context.wrap_disk_context ctxt in
            op_gtgteqquestion
              (Proto_test.(Tezos_protocol_updater__Registered_protocol.T.init)
                test_ctxt (Block_header.shell forked_header))
              (fun function_parameter =>
                let '{| context := test_ctxt |} := function_parameter in
                let test_ctxt := Shell_context.unwrap_disk_context test_ctxt in
                op_gtgteq
                  (Context.set_test_chain test_ctxt
                    Tezos_base__TzPervasives.Test_chain_status.Not_running)
                  (fun test_ctxt =>
                    op_gtgteq (Context.set_protocol test_ctxt protocol)
                      (fun test_ctxt =>
                        op_gtgteq
                          (Context.commit_test_chain_genesis test_ctxt
                            forked_header)
                          (fun genesis_header => _return genesis_header)))))
      end).

Definition result_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding result :=
  conv
    (fun function_parameter =>
      let '{|
        validation_store := validation_store;
          block_metadata := block_metadata;
          ops_metadata := ops_metadata;
          forking_testchain := forking_testchain
          |} := function_parameter in
      (validation_store, block_metadata, ops_metadata, forking_testchain))
    (fun function_parameter =>
      let
        '(validation_store, block_metadata, ops_metadata, forking_testchain) :=
        function_parameter in
      {| validation_store := validation_store; block_metadata := block_metadata;
        ops_metadata := ops_metadata; forking_testchain := forking_testchain |})
    None
    (obj4 (req None None "validation_store" % string validation_store_encoding)
      (req None None "block_metadata" % string bytes)
      (req None None "ops_metadata" % string
        (apply
          (let arg := list in
          fun eta => arg None eta)
          (apply
            (let arg := list in
            fun eta => arg None eta) bytes)))
      (req None None "forking_testchain" % string bool)).

Definition may_force_protocol_upgrade
  (level : Stdlib.Int32.t)
  (validation_result : Tezos_protocol_environment.validation_result)
  : Lwt.t Tezos_protocol_environment.validation_result :=
  match Block_header.get_forced_protocol_upgrade level with
  | None => Lwt._return validation_result
  | Some hash =>
    let context := Shell_context.unwrap_disk_context (context validation_result)
      in
    op_gtgteq (Context.set_protocol context hash)
      (fun context =>
        let context := Shell_context.wrap_disk_context context in
        Lwt._return
          (* ❌ Record substitution not handled *)
          record_substitution)
  end.

Definition may_patch_protocol
  (level : Stdlib.Int32.t)
  (validation_result : Tezos_protocol_environment.validation_result)
  : Lwt.t Tezos_protocol_environment.validation_result :=
  let context := Shell_context.unwrap_disk_context (context validation_result)
    in
  op_gtgteq (Context.get_protocol context)
    (fun protocol =>
      match Block_header.get_voted_protocol_overrides protocol with
      | None => may_force_protocol_upgrade level validation_result
      | Some replacement_protocol =>
        op_gtgteq (Context.set_protocol context replacement_protocol)
          (fun context =>
            let context := Shell_context.wrap_disk_context context in
            Lwt._return
              (* ❌ Record substitution not handled *)
              record_substitution)
      end).

(* ❌ Functors are not handled. *)
functor

Definition assert_no_duplicate_operations
  (block_hash : Tezos_base__TzPervasives.Block_hash.t)
  (live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (fold_left_s
      (fold_left_s
        (fun live_operations =>
          fun op =>
            let oph := Operation.hash op in
            op_gtgteqquestion
              (fail_when (Operation_hash.Set.mem oph live_operations)
                (apply (invalid_block block_hash)
                  (Tezos_shell_services.Block_validator_errors.Replayed_operation
                    oph)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                _return (Operation_hash.Set.add oph live_operations))))
      live_operations operations)
    (fun function_parameter =>
      let '_ := function_parameter in
      return_unit).

Definition assert_operation_liveness
  (block_hash : Tezos_base__TzPervasives.Block_hash.t)
  (live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  iter_s
    (iter_s
      (fun op =>
        fail_unless
          (Block_hash.Set.mem (branch (Operation.shell op)) live_blocks)
          (apply (invalid_block block_hash)
            (Tezos_shell_services.Block_validator_errors.Outdated_operation
              {| operation := Operation.hash op;
                originating_block := branch (shell op) |})))) operations.

Definition check_liveness
  (live_blocks : Tezos_base__TzPervasives.Block_hash.Set.t)
  (live_operations : Tezos_base__TzPervasives.Operation_hash.Set.t)
  (block_hash : Tezos_base__TzPervasives.Block_hash.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (assert_no_duplicate_operations block_hash live_operations operations)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (assert_operation_liveness block_hash live_blocks operations)
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition apply
  (chain_id : Tezos_base__TzPervasives.Chain_id.t) (max_operations_ttl : Z)
  (predecessor_block_header : Tezos_base__TzPervasives.Block_header.t)
  (predecessor_context : Tezos_storage.Context.context)
  (block_header : Tezos_base__TzPervasives.Block_header.t)
  (operations : list (list Tezos_base__TzPervasives.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult result) :=
  let block_hash := Block_header.hash block_header in
  op_gtgteq (Context.get_protocol predecessor_context)
    (fun pred_protocol_hash =>
      op_gtgteqquestion
        match Registered_protocol.get pred_protocol_hash with
        | None =>
          fail
            (Tezos_base__TzPervasives.Unavailable_protocol
              {| block := block_hash; protocol := pred_protocol_hash |})
        | Some p => _return p
        end
        (fun Proto =>
          let Proto := projT2 Proto in
          let Block_validation :=
            (* ❌ Applications of functors are not supported for first-class module values *)
            unsupported_functor_application in
          op_gtgteq
            (Block_validation.apply chain_id max_operations_ttl
              predecessor_block_header predecessor_context block_header
              operations)
            (fun function_parameter =>
              match function_parameter with
              |
                Stdlib.Error
                  (cons (Tezos_base__TzPervasives.Exn (Unix_error errno fn msg))
                    _) =>
                fail
                  (Tezos_base__TzPervasives.System_error
                    {| errno := Unix.error_message errno; fn := fn; msg := msg
                      |})
              | (Stdlib.Ok _ | Stdlib.Error _) as res => Lwt._return res
              end))).

src/lib_validation/external_validation.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Labs. <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type parameters = {
  context_root : string;
  protocol_root : string;
  sandbox_parameters : Data_encoding.json option;
}

type request =
  | Init
  | Validate of {
      chain_id : Chain_id.t;
      block_header : Block_header.t;
      predecessor_block_header : Block_header.t;
      operations : Operation.t list list;
      max_operations_ttl : int;
    }
  | Commit_genesis of {
      chain_id : Chain_id.t;
      genesis_hash : Block_hash.t;
      time : Time.Protocol.t;
      protocol : Protocol_hash.t;
    }
  | Fork_test_chain of {
      context_hash : Context_hash.t;
      forked_header : Block_header.t;
    }
  | Terminate

let magic = Bytes.of_string "TEZOS_FORK_VALIDATOR_MAGIC_0"

let parameters_encoding =
  let open Data_encoding in
  conv
    (fun {context_root; protocol_root; sandbox_parameters} ->
      (context_root, protocol_root, sandbox_parameters))
    (fun (context_root, protocol_root, sandbox_parameters) ->
      {context_root; protocol_root; sandbox_parameters})
    (obj3
       (req "context_root" string)
       (req "protocol_root" string)
       (opt "sandbox_parameters" json))

let request_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"init"
        empty
        (function
          | Init ->
              Some ()
          | Commit_genesis _ | Validate _ | Fork_test_chain _ | Terminate ->
              None)
        (fun () -> Init);
      case
        (Tag 1)
        ~title:"validate"
        (obj5
           (req "chain_id" Chain_id.encoding)
           (req "block_header" (dynamic_size Block_header.encoding))
           (req "pred_header" (dynamic_size Block_header.encoding))
           (req "max_operations_ttl" int31)
           (req "operations" (list (list (dynamic_size Operation.encoding)))))
        (function
          | Validate
              { chain_id;
                block_header;
                predecessor_block_header;
                max_operations_ttl;
                operations } ->
              Some
                ( chain_id,
                  block_header,
                  predecessor_block_header,
                  max_operations_ttl,
                  operations )
          | Init | Commit_genesis _ | Fork_test_chain _ | Terminate ->
              None)
        (fun ( chain_id,
               block_header,
               predecessor_block_header,
               max_operations_ttl,
               operations ) ->
          Validate
            {
              chain_id;
              block_header;
              predecessor_block_header;
              max_operations_ttl;
              operations;
            });
      case
        (Tag 2)
        ~title:"commit_genesis"
        (obj4
           (req "chain_id" Chain_id.encoding)
           (req "time" Time.Protocol.encoding)
           (req "genesis_hash" Block_hash.encoding)
           (req "protocol" Protocol_hash.encoding))
        (function
          | Commit_genesis {chain_id; time; genesis_hash; protocol} ->
              Some (chain_id, time, genesis_hash, protocol)
          | Init | Validate _ | Fork_test_chain _ | Terminate ->
              None)
        (fun (chain_id, time, genesis_hash, protocol) ->
          Commit_genesis {chain_id; time; genesis_hash; protocol});
      case
        (Tag 3)
        ~title:"fork_test_chain"
        (obj2
           (req "context_hash" Context_hash.encoding)
           (req "forked_header" Block_header.encoding))
        (function
          | Fork_test_chain {context_hash; forked_header} ->
              Some (context_hash, forked_header)
          | Init | Validate _ | Commit_genesis _ | Terminate ->
              None)
        (fun (context_hash, forked_header) ->
          Fork_test_chain {context_hash; forked_header});
      case
        (Tag 4)
        ~title:"terminate"
        unit
        (function
          | Terminate ->
              Some ()
          | Init | Validate _ | Commit_genesis _ | Fork_test_chain _ ->
              None)
        (fun () -> Terminate) ]

let send pin encoding data =
  let msg = Data_encoding.Binary.to_bytes_exn encoding data in
  Lwt_io.write_int pin (Bytes.length msg)
  >>= fun () ->
  Lwt_io.write pin (Bytes.to_string msg) >>= fun () -> Lwt_io.flush pin

let recv_result pout encoding =
  Lwt_io.read_int pout
  >>= fun count ->
  let buf = Bytes.create count in
  Lwt_io.read_into_exactly pout buf 0 count
  >>= fun () ->
  Lwt.return
    (Data_encoding.Binary.of_bytes_exn
       (Error_monad.result_encoding encoding)
       buf)

let recv pout encoding =
  Lwt_io.read_int pout
  >>= fun count ->
  let buf = Bytes.create count in
  Lwt_io.read_into_exactly pout buf 0 count
  >>= fun () -> Lwt.return (Data_encoding.Binary.of_bytes_exn encoding buf)
src/lib_validation/external_validation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record parameters := {
  context_root : string;
  protocol_root : string;
  sandbox_parameters : option Tezos_base__TzPervasives.Data_encoding.json }.

Inductive request : Type :=
| Init : request
| Validate : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_header.t ->
  Tezos_base__TzPervasives.Block_header.t ->
  (list (list Tezos_base__TzPervasives.Operation.t)) -> Z -> request
| Commit_genesis : Tezos_base__TzPervasives.Chain_id.t ->
  Tezos_base__TzPervasives.Block_hash.t ->
  Tezos_base__TzPervasives.Time.Protocol.t ->
  Tezos_base__TzPervasives.Protocol_hash.t -> request
| Fork_test_chain : Tezos_base__TzPervasives.Context_hash.t ->
  Tezos_base__TzPervasives.Block_header.t -> request
| Terminate : request.

Definition magic : string :=
  Stdlib.Bytes.of_string "TEZOS_FORK_VALIDATOR_MAGIC_0" % string.

Definition parameters_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding parameters :=
  conv
    (fun function_parameter =>
      let '{|
        context_root := context_root;
          protocol_root := protocol_root;
          sandbox_parameters := sandbox_parameters
          |} := function_parameter in
      (context_root, protocol_root, sandbox_parameters))
    (fun function_parameter =>
      let '(context_root, protocol_root, sandbox_parameters) :=
        function_parameter in
      {| context_root := context_root; protocol_root := protocol_root;
        sandbox_parameters := sandbox_parameters |}) None
    (obj3 (req None None "context_root" % string string)
      (req None None "protocol_root" % string string)
      (opt None None "sandbox_parameters" % string json)).

Definition request_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding request :=
  union None
    (cons
      (case "init" % string None (Tezos_base__TzPervasives.Data_encoding.Tag 0)
        empty
        (fun function_parameter =>
          match function_parameter with
          | Init => Some tt
          | Commit_genesis _ | Validate _ | Fork_test_chain _ | Terminate =>
            None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Init))
      (cons
        (case "validate" % string None
          (Tezos_base__TzPervasives.Data_encoding.Tag 1)
          (obj5 (req None None "chain_id" % string Chain_id.encoding)
            (req None None "block_header" % string
              (dynamic_size None Block_header.encoding))
            (req None None "pred_header" % string
              (dynamic_size None Block_header.encoding))
            (req None None "max_operations_ttl" % string int31)
            (req None None "operations" % string
              (list None (list None (dynamic_size None Operation.encoding)))))
          (fun function_parameter =>
            match function_parameter with
            |
              Validate {|
                chain_id := chain_id;
                  block_header := block_header;
                  predecessor_block_header := predecessor_block_header;
                  operations := operations;
                  max_operations_ttl := max_operations_ttl
                  |} =>
              Some
                (chain_id, block_header, predecessor_block_header,
                  max_operations_ttl, operations)
            | Init | Commit_genesis _ | Fork_test_chain _ | Terminate => None
            end)
          (fun function_parameter =>
            let
              '(chain_id, block_header, predecessor_block_header,
                max_operations_ttl, operations) := function_parameter in
            Validate
              {| chain_id := chain_id; block_header := block_header;
                predecessor_block_header := predecessor_block_header;
                operations := operations;
                max_operations_ttl := max_operations_ttl |}))
        (cons
          (case "commit_genesis" % string None
            (Tezos_base__TzPervasives.Data_encoding.Tag 2)
            (obj4 (req None None "chain_id" % string Chain_id.encoding)
              (req None None "time" % string Time.Protocol.encoding)
              (req None None "genesis_hash" % string Block_hash.encoding)
              (req None None "protocol" % string Protocol_hash.encoding))
            (fun function_parameter =>
              match function_parameter with
              |
                Commit_genesis {|
                  chain_id := chain_id;
                    genesis_hash := genesis_hash;
                    time := time;
                    protocol := protocol
                    |} => Some (chain_id, time, genesis_hash, protocol)
              | Init | Validate _ | Fork_test_chain _ | Terminate => None
              end)
            (fun function_parameter =>
              let '(chain_id, time, genesis_hash, protocol) :=
                function_parameter in
              Commit_genesis
                {| chain_id := chain_id; genesis_hash := genesis_hash;
                  time := time; protocol := protocol |}))
          (cons
            (case "fork_test_chain" % string None
              (Tezos_base__TzPervasives.Data_encoding.Tag 3)
              (obj2
                (req None None "context_hash" % string Context_hash.encoding)
                (req None None "forked_header" % string Block_header.encoding))
              (fun function_parameter =>
                match function_parameter with
                |
                  Fork_test_chain {|
                    context_hash := context_hash;
                      forked_header := forked_header
                      |} => Some (context_hash, forked_header)
                | Init | Validate _ | Commit_genesis _ | Terminate => None
                end)
              (fun function_parameter =>
                let '(context_hash, forked_header) := function_parameter in
                Fork_test_chain
                  {| context_hash := context_hash;
                    forked_header := forked_header |}))
            (cons
              (case "terminate" % string None
                (Tezos_base__TzPervasives.Data_encoding.Tag 4) unit
                (fun function_parameter =>
                  match function_parameter with
                  | Terminate => Some tt
                  | Init | Validate _ | Commit_genesis _ | Fork_test_chain _ =>
                    None
                  end)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Terminate)) []))))).

Definition send {A : Type}
  (pin : Lwt_io.output_channel)
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) (data : A)
  : Lwt.t unit :=
  let msg := Data_encoding.Binary.to_bytes_exn encoding data in
  op_gtgteq (Lwt_io.write_int pin (String.length msg))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (Lwt_io.write pin (Stdlib.Bytes.to_string msg))
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt_io.flush pin)).

Definition recv_result {A : Type}
  (pout : Lwt_io.input_channel)
  (encoding : Tezos_data_encoding.Data_encoding.t A)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
  op_gtgteq (Lwt_io.read_int pout)
    (fun count =>
      let buf := Stdlib.Bytes.create count in
      op_gtgteq (Lwt_io.read_into_exactly pout buf 0 count)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt._return
            (Data_encoding.Binary.of_bytes_exn
              (Error_monad.result_encoding encoding) buf))).

Definition recv {A : Type}
  (pout : Lwt_io.input_channel)
  (encoding : Tezos_data_encoding__Data_encoding.Encoding.t A) : Lwt.t A :=
  op_gtgteq (Lwt_io.read_int pout)
    (fun count =>
      let buf := Stdlib.Bytes.create count in
      op_gtgteq (Lwt_io.read_into_exactly pout buf 0 count)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Lwt._return (Data_encoding.Binary.of_bytes_exn encoding buf))).

src/lib_version/current_git_info.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* When we (or the CI) run "git archive", git substitutes the dollar-format part
   because this file is marked as "export-subst" in ".gitattributes".

   To know whether we are in a Git repository or in an archive, we check whether
   the string was substituted. Thanks to this, we know whether we should get the
   hash from Generated_git_info (not available in archives) or not. *)

let raw_commit_hash = "$Format:%H$"

let commit_hash =
  if String.equal raw_commit_hash ("$Format" ^ ":%H$") then
    Generated_git_info.commit_hash
  else raw_commit_hash

let abbreviated_commit_hash =
  if String.length commit_hash >= 8 then String.sub commit_hash 0 8
  else commit_hash

let raw_committer_date = "$Format:%ci$"

let committer_date =
  if String.equal raw_committer_date ("$Format" ^ ":%ci$") then
    Generated_git_info.committer_date
  else raw_committer_date
src/lib_version/current_git_info.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition raw_commit_hash : string := "$Format:%H$" % string.

Definition commit_hash : string :=
  if
    Stdlib.String.equal raw_commit_hash
      (String.append "$Format" % string ":%H$" % string) then
    Generated_git_info.commit_hash
  else
    raw_commit_hash.

Definition abbreviated_commit_hash : string :=
  if OCaml.Stdlib.ge (OCaml.String.length commit_hash) 8 then
    Stdlib.String.sub commit_hash 0 8
  else
    commit_hash.

Definition raw_committer_date : string := "$Format:%ci$" % string.

Definition committer_date : string :=
  if
    Stdlib.String.equal raw_committer_date
      (String.append "$Format" % string ":%ci$" % string) then
    Generated_git_info.committer_date
  else
    raw_committer_date.

src/proto_alpha/bin_accuser/main_accuser_alpha.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "accuser.main"
end)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.accuser_commands ()

let select_commands _ _ =
  return
    (List.map
       (Clic.map_command (new Protocol_client_context.wrap_full))
       (Delegate_commands.accuser_commands ()))

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/proto_alpha/bin_accuser/main_accuser_alpha.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application



Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    _return
      (List.map
        (Clic.map_command
          (* ❌ Creation of new objects is not handled *)
          new) (Delegate_commands.accuser_commands tt)).



src/proto_alpha/bin_baker/main_baker_alpha.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "baker.main"
end)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.delegate_commands ()

let select_commands _ _ =
  return
    (List.map
       (Clic.map_command (new Protocol_client_context.wrap_full))
       (Delegate_commands.baker_commands ()))

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/proto_alpha/bin_baker/main_baker_alpha.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application



Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    _return
      (List.map
        (Clic.map_command
          (* ❌ Creation of new objects is not handled *)
          new) (Delegate_commands.baker_commands tt)).



src/proto_alpha/bin_endorser/main_endorser_alpha.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Log = Internal_event.Legacy_logging.Make (struct
  let name = "endorser.main"
end)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.delegate_commands ()

let select_commands _ _ =
  return
    (List.map
       (Clic.map_command (new Protocol_client_context.wrap_full))
       (Delegate_commands.endorser_commands ()))

let () =
  Client_main_run.run
    ~log:(Log.fatal_error "%s")
    (module Client_config)
    ~select_commands
src/proto_alpha/bin_endorser/main_endorser_alpha.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application



Definition select_commands {A B : Type} (function_parameter : A)
  : B ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (list
          (Tezos_base__TzPervasives.Clic.command
            Tezos_client_base.Client_context.full))) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    _return
      (List.map
        (Clic.map_command
          (* ❌ Creation of new objects is not handled *)
          new) (Delegate_commands.endorser_commands tt)).



src/proto_alpha/lib_client/client_proto_args.ml 53 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context
open Clic

type error += Bad_tez_arg of string * string (* Arg_name * value *)

type error += Bad_max_priority of string

type error += Bad_minimal_fees of string

type error += Bad_max_waiting_time of string

type error += Bad_endorsement_delay of string

type error += Bad_preserved_levels of string

let () =
  register_error_kind
    `Permanent
    ~id:"badTezArg"
    ~title:"Bad Tez Arg"
    ~description:"Invalid \xEA\x9C\xA9 notation in parameter."
    ~pp:(fun ppf (arg_name, literal) ->
      Format.fprintf
        ppf
        "Invalid \xEA\x9C\xA9 notation in parameter %s: '%s'"
        arg_name
        literal)
    Data_encoding.(obj2 (req "parameter" string) (req "literal" string))
    (function
      | Bad_tez_arg (parameter, literal) ->
          Some (parameter, literal)
      | _ ->
          None)
    (fun (parameter, literal) -> Bad_tez_arg (parameter, literal)) ;
  register_error_kind
    `Permanent
    ~id:"badMaxPriorityArg"
    ~title:"Bad -max-priority arg"
    ~description:"invalid priority in -max-priority"
    ~pp:(fun ppf literal ->
      Format.fprintf ppf "invalid priority '%s' in -max-priority" literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_max_priority parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_max_priority parameter) ;
  register_error_kind
    `Permanent
    ~id:"badMinimalFeesArg"
    ~title:"Bad -minimal-fees arg"
    ~description:"invalid fee threshold in -fee-threshold"
    ~pp:(fun ppf literal ->
      Format.fprintf ppf "invalid minimal fees '%s'" literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_minimal_fees parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_minimal_fees parameter) ;
  register_error_kind
    `Permanent
    ~id:"badMaxWaitingTimeArg"
    ~title:"Bad -max-waiting-time arg"
    ~description:"invalid duration in -max-waiting-time"
    ~pp:(fun ppf literal ->
      Format.fprintf
        ppf
        "Bad argument value for -max-waiting-time. Expected an integer, but \
         given '%s'"
        literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_max_waiting_time parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_max_waiting_time parameter) ;
  register_error_kind
    `Permanent
    ~id:"badEndorsementDelayArg"
    ~title:"Bad -endorsement-delay arg"
    ~description:"invalid duration in -endorsement-delay"
    ~pp:(fun ppf literal ->
      Format.fprintf
        ppf
        "Bad argument value for -endorsement-delay. Expected an integer, but \
         given '%s'"
        literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_endorsement_delay parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_endorsement_delay parameter) ;
  register_error_kind
    `Permanent
    ~id:"badPreservedLevelsArg"
    ~title:"Bad -preserved-levels arg"
    ~description:"invalid number of levels in -preserved-levels"
    ~pp:(fun ppf literal ->
      Format.fprintf
        ppf
        "Bad argument value for -preserved_levels. Expected a positive \
         integer, but given '%s'"
        literal)
    Data_encoding.(obj1 (req "parameter" string))
    (function Bad_preserved_levels parameter -> Some parameter | _ -> None)
    (fun parameter -> Bad_preserved_levels parameter)

let tez_sym = "\xEA\x9C\xA9"

let string_parameter = parameter (fun _ x -> return x)

let int_parameter =
  parameter (fun _ p ->
      try return (int_of_string p) with _ -> failwith "Cannot read int")

let bytes_parameter =
  parameter (fun _ s ->
      try
        if String.length s < 2 || s.[0] <> '0' || s.[1] <> 'x' then raise Exit
        else
          return (Hex.to_bytes (`Hex (String.sub s 2 (String.length s - 2))))
      with _ ->
        failwith
          "Invalid bytes, expecting hexadecimal notation (e.g. 0x1234abcd)")

let init_arg =
  default_arg
    ~long:"init"
    ~placeholder:"data"
    ~doc:"initial value of the contract's storage"
    ~default:"Unit"
    string_parameter

let arg_arg =
  arg
    ~long:"arg"
    ~placeholder:"data"
    ~doc:"argument passed to the contract's script, if needed"
    string_parameter

let delegate_arg =
  Client_keys.Public_key_hash.source_arg
    ~long:"delegate"
    ~placeholder:"address"
    ~doc:"delegate of the contract\nMust be a known address."
    ()

let source_arg =
  arg
    ~long:"source"
    ~placeholder:"address"
    ~doc:"source of the deposits to be paid\nMust be a known address."
    string_parameter

let entrypoint_arg =
  arg
    ~long:"entrypoint"
    ~placeholder:"name"
    ~doc:"entrypoint of the smart contract"
    string_parameter

let force_switch =
  switch
    ~long:"force"
    ~short:'f'
    ~doc:
      "disables the node's injection checks\n\
       Force the injection of branch-invalid operation or force  the \
       injection of block without a fitness greater than the  current head."
    ()

let minimal_timestamp_switch =
  switch
    ~long:"minimal-timestamp"
    ~doc:
      "Use the minimal timestamp instead of the current date as timestamp of \
       the baked block."
    ()

let tez_format =
  "Text format: `DDDDDDD.DDDDDD`.\n\
   Tez and mutez and separated by a period sign. Trailing and pending zeroes \
   are allowed."

let tez_parameter param =
  parameter (fun _ s ->
      match Tez.of_string s with
      | Some tez ->
          return tez
      | None ->
          fail (Bad_tez_arg (param, s)))

let tez_arg ~default ~parameter ~doc =
  default_arg
    ~long:parameter
    ~placeholder:"amount"
    ~doc
    ~default
    (tez_parameter ("--" ^ parameter))

let tez_param ~name ~desc next =
  Clic.param
    ~name
    ~desc:(desc ^ " in \xEA\x9C\xA9\n" ^ tez_format)
    (tez_parameter name)
    next

let fee_arg =
  arg
    ~long:"fee"
    ~placeholder:"amount"
    ~doc:"fee in \xEA\x9C\xA9 to pay to the baker"
    (tez_parameter "--fee")

let gas_limit_arg =
  arg
    ~long:"gas-limit"
    ~short:'G'
    ~placeholder:"amount"
    ~doc:
      "Set the gas limit of the transaction instead of letting the client \
       decide based on a simulation"
    (parameter (fun _ s ->
         try
           let v = Z.of_string s in
           assert (Compare.Z.(v >= Z.zero)) ;
           return v
         with _ -> failwith "invalid gas limit (must be a positive number)"))

let storage_limit_arg =
  arg
    ~long:"storage-limit"
    ~short:'S'
    ~placeholder:"amount"
    ~doc:
      "Set the storage limit of the transaction instead of letting the client \
       decide based on a simulation"
    (parameter (fun _ s ->
         try
           let v = Z.of_string s in
           assert (Compare.Z.(v >= Z.zero)) ;
           return v
         with _ ->
           failwith
             "invalid storage limit (must be a positive number of bytes)"))

let counter_arg =
  arg
    ~long:"counter"
    ~short:'C'
    ~placeholder:"counter"
    ~doc:"Set the counter to be used by the transaction"
    (parameter (fun _ s ->
         try
           let v = Z.of_string s in
           assert (Compare.Z.(v >= Z.zero)) ;
           return v
         with _ ->
           failwith "invalid counter (must be a positive number of bytes)"))

let max_priority_arg =
  arg
    ~long:"max-priority"
    ~placeholder:"slot"
    ~doc:"maximum allowed baking slot"
    (parameter (fun _ s ->
         try return (int_of_string s) with _ -> fail (Bad_max_priority s)))

let default_minimal_fees =
  match Tez.of_mutez 100L with None -> assert false | Some t -> t

let default_minimal_nanotez_per_gas_unit = Z.of_int 100

let default_minimal_nanotez_per_byte = Z.of_int 1000

let minimal_fees_arg =
  default_arg
    ~long:"minimal-fees"
    ~placeholder:"amount"
    ~doc:"exclude operations with fees lower than this threshold (in tez)"
    ~default:(Tez.to_string default_minimal_fees)
    (parameter (fun _ s ->
         match Tez.of_string s with
         | Some t ->
             return t
         | None ->
             fail (Bad_minimal_fees s)))

let minimal_nanotez_per_gas_unit_arg =
  default_arg
    ~long:"minimal-nanotez-per-gas-unit"
    ~placeholder:"amount"
    ~doc:
      "exclude operations with fees per gas lower than this threshold (in \
       nanotez)"
    ~default:(Z.to_string default_minimal_nanotez_per_gas_unit)
    (parameter (fun _ s ->
         try return (Z.of_string s) with _ -> fail (Bad_minimal_fees s)))

let minimal_nanotez_per_byte_arg =
  default_arg
    ~long:"minimal-nanotez-per-byte"
    ~placeholder:"amount"
    ~default:(Z.to_string default_minimal_nanotez_per_byte)
    ~doc:
      "exclude operations with fees per byte lower than this threshold (in \
       nanotez)"
    (parameter (fun _ s ->
         try return (Z.of_string s) with _ -> fail (Bad_minimal_fees s)))

let force_low_fee_arg =
  switch
    ~long:"force-low-fee"
    ~doc:"Don't check that the fee is lower than the estimated default value"
    ()

let fee_cap_arg =
  default_arg
    ~long:"fee-cap"
    ~placeholder:"amount"
    ~default:"1.0"
    ~doc:"Set the fee cap"
    (parameter (fun _ s ->
         match Tez.of_string s with
         | Some t ->
             return t
         | None ->
             failwith "Bad fee cap"))

let burn_cap_arg =
  default_arg
    ~long:"burn-cap"
    ~placeholder:"amount"
    ~default:"0"
    ~doc:"Set the burn cap"
    (parameter (fun _ s ->
         match Tez.of_string s with
         | Some t ->
             return t
         | None ->
             failwith "Bad burn cap"))

let no_waiting_for_endorsements_arg =
  switch
    ~long:"no-waiting-for-late-endorsements"
    ~doc:"Disable waiting for late endorsements"
    ()

let await_endorsements_arg =
  switch
    ~long:"await-late-endorsements"
    ~doc:"Await late endorsements when baking a block"
    ()

let endorsement_delay_arg =
  default_arg
    ~long:"endorsement-delay"
    ~placeholder:"seconds"
    ~doc:
      "delay before endorsing blocks\n\
       Delay between notifications of new blocks from the node and production \
       of endorsements for these blocks."
    ~default:"5"
    (parameter (fun _ s ->
         try
           let i = int_of_string s in
           fail_when (i < 0) (Bad_endorsement_delay s)
           >>=? fun () -> return (int_of_string s)
         with _ -> fail (Bad_endorsement_delay s)))

let preserved_levels_arg =
  default_arg
    ~long:"preserved-levels"
    ~placeholder:"threshold"
    ~doc:"Number of effective levels kept in the accuser's memory"
    ~default:"4096"
    (parameter (fun _ s ->
         try
           let preserved_cycles = int_of_string s in
           if preserved_cycles < 0 then fail (Bad_preserved_levels s)
           else return preserved_cycles
         with _ -> fail (Bad_preserved_levels s)))

let no_print_source_flag =
  switch
    ~long:"no-print-source"
    ~short:'q'
    ~doc:
      "don't print the source code\n\
       If an error is encountered, the client will print the contract's \
       source code by default.\n\
       This option disables this behaviour."
    ()

let no_confirmation =
  switch
    ~long:"no-confirmation"
    ~doc:"don't print wait for the operation to be confirmed."
    ()

let signature_parameter =
  parameter (fun _cctxt s ->
      match Signature.of_b58check_opt s with
      | Some s ->
          return s
      | None ->
          failwith "Not given a valid signature")

module Daemon = struct
  let baking_switch =
    switch ~long:"baking" ~short:'B' ~doc:"run the baking daemon" ()

  let endorsement_switch =
    switch ~long:"endorsement" ~short:'E' ~doc:"run the endorsement daemon" ()

  let denunciation_switch =
    switch
      ~long:"denunciation"
      ~short:'D'
      ~doc:"run the denunciation daemon"
      ()
end
src/proto_alpha/lib_client/client_proto_args.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol_client_context.

Import Protocol.

Import Alpha_context.

Import Clic.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition tez_sym : string := "ꜩ" % string.

Definition string_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter string A :=
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun x => _return x).

Definition int_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter Z A :=
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun p =>
        (* ❌ Try-with are not handled *)
        try (_return (OCaml.Stdlib.int_of_string p))).

Definition bytes_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter string A :=
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        (* ❌ Try-with are not handled *)
        try
          (if
            orb (OCaml.Stdlib.lt (String.length s) 2)
              (orb (nequiv_decb (String.get s 0) "0" % char)
                (nequiv_decb (String.get s 1) "x" % char)) then
            Stdlib.raise Exit
          else
            _return
              (Hex.to_bytes
                (* ❌ Variants not supported *)
                variant))).

Definition init_arg {A : Type} : Tezos_base__TzPervasives.Clic.arg string A :=
  default_arg "initial value of the contract's storage" % string None
    "init" % string "data" % string "Unit" % string string_parameter.

Definition arg_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  arg "argument passed to the contract's script, if needed" % string None
    "arg" % string "data" % string string_parameter.

Definition delegate_arg {B a : Type}
  : Tezos_base__TzPervasives.Clic.arg
    (option Tezos_client_base.Client_keys.Public_key_hash.t)
    (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) :=
  Client_keys.Public_key_hash.source_arg (Some "delegate" % string)
    (Some "address" % string)
    (Some "delegate of the contract
Must be a known address." % string) tt.

Definition source_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  arg "source of the deposits to be paid
Must be a known address." % string None
    "source" % string "address" % string string_parameter.

Definition entrypoint_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option string) A :=
  arg "entrypoint of the smart contract" % string None "entrypoint" % string
    "name" % string string_parameter.

Definition force_switch {A : Type} : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch
    "disables the node's injection checks
Force the injection of branch-invalid operation or force  the injection of block without a fitness greater than the  current head."
      % string (Some "f" % char) "force" % string tt.

Definition minimal_timestamp_switch {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch
    "Use the minimal timestamp instead of the current date as timestamp of the baked block."
      % string None "minimal-timestamp" % string tt.

Definition tez_format : string :=
  "Text format: `DDDDDDD.DDDDDD`.
Tez and mutez and separated by a period sign. Trailing and pending zeroes are allowed."
    % string.

Definition tez_parameter {A : Type} (param : string)
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        match Tez.of_string s with
        | Some tez => _return tez
        | None => fail (Tezos_base__TzPervasives.Bad_tez_arg param s)
        end).

Definition tez_arg {A : Type}
  (default : string) (parameter : string) (doc : string)
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  default_arg doc None parameter "amount" % string default
    (tez_parameter (String.append "--" % string parameter)).

Definition tez_param {A B : Type}
  (name : string) (desc : string)
  (next : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez -> A) B :=
  Clic.param name
    (String.append desc (String.append " in ꜩ
" % string tez_format))
    (tez_parameter name) next.

Definition fee_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) A :=
  arg "fee in ꜩ to pay to the baker" % string None "fee" % string
    "amount" % string (tez_parameter "--fee" % string).

Definition gas_limit_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
  arg
    "Set the gas limit of the transaction instead of letting the client decide based on a simulation"
      % string (Some "G" % char) "gas-limit" % string "amount" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try
            (let v := Z.of_string s in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Assert instruction is not handled. *)
              assert (op_gteq v Z.zero) in
            _return v))).

Definition storage_limit_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
  arg
    "Set the storage limit of the transaction instead of letting the client decide based on a simulation"
      % string (Some "S" % char) "storage-limit" % string "amount" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try
            (let v := Z.of_string s in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Assert instruction is not handled. *)
              assert (op_gteq v Z.zero) in
            _return v))).

Definition counter_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z.t) A :=
  arg "Set the counter to be used by the transaction" % string (Some "C" % char)
    "counter" % string "counter" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try
            (let v := Z.of_string s in
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Assert instruction is not handled. *)
              assert (op_gteq v Z.zero) in
            _return v))).

Definition max_priority_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg (option Z) A :=
  arg "maximum allowed baking slot" % string None "max-priority" % string
    "slot" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try (_return (OCaml.Stdlib.int_of_string s)))).

Definition default_minimal_fees
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  match
    Tez.of_mutez
      (* ❌ Constant of type int64 is converted to int *)
      100 with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some t => t
  end.

Definition default_minimal_nanotez_per_gas_unit : Z.t := Z.of_int 100.

Definition default_minimal_nanotez_per_byte : Z.t := Z.of_int 1000.

Definition minimal_fees_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  default_arg
    "exclude operations with fees lower than this threshold (in tez)" % string
    None "minimal-fees" % string "amount" % string
    (Tez.to_string default_minimal_fees)
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          match Tez.of_string s with
          | Some t => _return t
          | None => fail (Tezos_base__TzPervasives.Bad_minimal_fees s)
          end)).

Definition minimal_nanotez_per_gas_unit_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z.t A :=
  default_arg
    "exclude operations with fees per gas lower than this threshold (in nanotez)"
      % string None "minimal-nanotez-per-gas-unit" % string "amount" % string
    (Z.to_string default_minimal_nanotez_per_gas_unit)
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try (_return (Z.of_string s)))).

Definition minimal_nanotez_per_byte_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z.t A :=
  default_arg
    "exclude operations with fees per byte lower than this threshold (in nanotez)"
      % string None "minimal-nanotez-per-byte" % string "amount" % string
    (Z.to_string default_minimal_nanotez_per_byte)
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try (_return (Z.of_string s)))).

Definition force_low_fee_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch
    "Don't check that the fee is lower than the estimated default value" %
      string None "force-low-fee" % string tt.

Definition fee_cap_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  default_arg "Set the fee cap" % string None "fee-cap" % string
    "amount" % string "1.0" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          match Tez.of_string s with
          | Some t => _return t
          | None =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Bad fee cap" % string
                  CamlinternalFormatBasics.End_of_format) "Bad fee cap" % string)
          end)).

Definition burn_cap_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez A :=
  default_arg "Set the burn cap" % string None "burn-cap" % string
    "amount" % string "0" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          match Tez.of_string s with
          | Some t => _return t
          | None =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Bad burn cap" % string
                  CamlinternalFormatBasics.End_of_format)
                "Bad burn cap" % string)
          end)).

Definition no_waiting_for_endorsements_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch "Disable waiting for late endorsements" % string None
    "no-waiting-for-late-endorsements" % string tt.

Definition await_endorsements_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch "Await late endorsements when baking a block" % string None
    "await-late-endorsements" % string tt.

Definition endorsement_delay_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z A :=
  default_arg
    "delay before endorsing blocks
Delay between notifications of new blocks from the node and production of endorsements for these blocks."
      % string None "endorsement-delay" % string "seconds" % string "5" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try
            (let i := OCaml.Stdlib.int_of_string s in
            op_gtgteqquestion
              (fail_when (OCaml.Stdlib.lt i 0)
                (Tezos_base__TzPervasives.Bad_endorsement_delay s))
              (fun function_parameter =>
                let 'tt := function_parameter in
                _return (OCaml.Stdlib.int_of_string s))))).

Definition preserved_levels_arg {A : Type}
  : Tezos_base__TzPervasives.Clic.arg Z A :=
  default_arg "Number of effective levels kept in the accuser's memory" % string
    None "preserved-levels" % string "threshold" % string "4096" % string
    (parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s =>
          (* ❌ Try-with are not handled *)
          try
            (let preserved_cycles := OCaml.Stdlib.int_of_string s in
            if OCaml.Stdlib.lt preserved_cycles 0 then
              fail (Tezos_base__TzPervasives.Bad_preserved_levels s)
            else
              _return preserved_cycles))).

Definition no_print_source_flag {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch
    "don't print the source code
If an error is encountered, the client will print the contract's source code by default.
This option disables this behaviour."
      % string (Some "q" % char) "no-print-source" % string tt.

Definition no_confirmation {A : Type}
  : Tezos_base__TzPervasives.Clic.arg bool A :=
  switch "don't print wait for the operation to be confirmed." % string None
    "no-confirmation" % string tt.

Definition signature_parameter {A : Type}
  : Tezos_base__TzPervasives.Clic.parameter Tezos_base__TzPervasives.Signature.t
    A :=
  parameter None
    (fun _cctxt =>
      fun s =>
        match Signature.of_b58check_opt s with
        | Some s => _return s
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Not given a valid signature" % string
                CamlinternalFormatBasics.End_of_format)
              "Not given a valid signature" % string)
        end).

Module Daemon.
  Definition baking_switch {A : Type}
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    switch "run the baking daemon" % string (Some "B" % char) "baking" % string
      tt.
  
  Definition endorsement_switch {A : Type}
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    switch "run the endorsement daemon" % string (Some "E" % char)
      "endorsement" % string tt.
  
  Definition denunciation_switch {A : Type}
    : Tezos_base__TzPervasives.Clic.arg bool A :=
    switch "run the denunciation daemon" % string (Some "D" % char)
      "denunciation" % string tt.
End Daemon.

src/proto_alpha/lib_client/client_proto_context.ml 1572 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Protocol_client_context
open Tezos_micheline
open Client_proto_contracts
open Client_keys

let get_balance (rpc : #rpc_context) ~chain ~block contract =
  Alpha_services.Contract.balance rpc (chain, block) contract

let get_storage (rpc : #rpc_context) ~chain ~block contract =
  Alpha_services.Contract.storage_opt rpc (chain, block) contract

let get_big_map_value (rpc : #rpc_context) ~chain ~block id key =
  Alpha_services.Contract.big_map_get rpc (chain, block) id key

let get_contract_big_map_value (rpc : #rpc_context) ~chain ~block contract key
    =
  Alpha_services.Contract.contract_big_map_get_opt
    rpc
    (chain, block)
    contract
    key

let get_script (rpc : #rpc_context) ~chain ~block contract =
  Alpha_services.Contract.script_opt rpc (chain, block) contract

let parse_expression arg =
  Lwt.return
    (Micheline_parser.no_parsing_error
       (Michelson_v1_parser.parse_expression arg))

let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ~source ~src_pk ~src_sk ~destination
    ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit
    ?counter ~fee_parameter () =
  ( match arg with
  | Some arg ->
      parse_expression arg >>=? fun {expanded = arg; _} -> return_some arg
  | None ->
      return_none )
  >>=? fun parameters ->
  let parameters =
    Option.unopt_map
      ~f:Script.lazy_expr
      ~default:Script.unit_parameter
      parameters
  in
  let contents = Transaction {amount; parameters; destination; entrypoint} in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~src_pk
    ~src_sk
    ~fee_parameter
    contents
  >>=? fun ((_oph, _op, result) as res) ->
  Lwt.return (Injection.originated_contracts (Single_result result))
  >>=? fun contracts -> return (res, contracts)

let reveal cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing ?branch
    ~source ~src_pk ~src_sk ?fee ~fee_parameter () =
  let (compute_fee, fee) =
    match fee with None -> (true, Tez.zero) | Some fee -> (false, fee)
  in
  Alpha_services.Contract.counter cctxt (chain, block) source
  >>=? fun pcounter ->
  let counter = Z.succ pcounter in
  Alpha_services.Contract.manager_key cctxt (chain, block) source
  >>=? fun key ->
  match key with
  | Some _ ->
      failwith "The manager key was previously revealed."
  | None -> (
      let contents =
        Single
          (Manager_operation
             {
               source;
               fee;
               counter;
               gas_limit = Z.of_int ~-1;
               storage_limit = Z.zero;
               operation = Reveal src_pk;
             })
      in
      Injection.inject_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ?verbose_signing
        ?branch
        ~src_sk
        ~compute_fee
        ~fee_parameter
        contents
      >>=? fun (oph, op, result) ->
      match Apply_results.pack_contents_list op result with
      | Apply_results.Single_and_result ((Manager_operation _ as op), result)
        ->
          return (oph, op, result) )

let delegate_contract cctxt ~chain ~block ?branch ?confirmations ?dry_run
    ?verbose_signing ~source ~src_pk ~src_sk ?fee ~fee_parameter delegate_opt =
  let operation = Delegation delegate_opt in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ~storage_limit:Z.zero
    ~src_pk
    ~src_sk
    ~fee_parameter
    operation
  >>=? fun res -> return res

let list_contract_labels cctxt ~chain ~block =
  Alpha_services.Contract.list cctxt (chain, block)
  >>=? fun contracts ->
  rev_map_s
    (fun h ->
      ( match Contract.is_implicit h with
      | Some m -> (
          Public_key_hash.rev_find cctxt m
          >>=? function
          | None ->
              return ""
          | Some nm -> (
              RawContractAlias.find_opt cctxt nm
              >>=? function
              | None ->
                  return (" (known as " ^ nm ^ ")")
              | Some _ ->
                  return (" (known as key:" ^ nm ^ ")") ) )
      | None -> (
          RawContractAlias.rev_find cctxt h
          >>=? function
          | None -> return "" | Some nm -> return (" (known as " ^ nm ^ ")") )
      )
      >>=? fun nm ->
      let kind =
        match Contract.is_implicit h with
        | Some _ ->
            " (implicit)"
        | None ->
            ""
      in
      let h_b58 = Contract.to_b58check h in
      return (nm, h_b58, kind))
    contracts
  >>|? List.rev

let message_added_contract (cctxt : #full) name =
  cctxt#message "Contract memorized as %s." name

let set_delegate cctxt ~chain ~block ?confirmations ?dry_run ?verbose_signing
    ?fee contract ~src_pk ~manager_sk ~fee_parameter opt_delegate =
  delegate_contract
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ~source:contract
    ~src_pk
    ~src_sk:manager_sk
    ?fee
    ~fee_parameter
    opt_delegate

let register_as_delegate cctxt ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?fee ~manager_sk ~fee_parameter src_pk =
  let source = Signature.Public_key.hash src_pk in
  delegate_contract
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ~source
    ~src_pk
    ~src_sk:manager_sk
    ?fee
    ~fee_parameter
    (Some source)

let save_contract ~force cctxt alias_name contract =
  RawContractAlias.add ~force cctxt alias_name contract
  >>=? fun () ->
  message_added_contract cctxt alias_name >>= fun () -> return_unit

let originate_contract (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ?fee ?gas_limit ?storage_limit ~delegate
    ~initial_storage ~balance ~source ~src_pk ~src_sk ~code ~fee_parameter () =
  (* With the change of making implicit accounts delegatable, the following
     3 arguments are being defaulted before they can be safely removed. *)
  Lwt.return (Michelson_v1_parser.parse_expression initial_storage)
  >>= fun result ->
  Lwt.return (Micheline_parser.no_parsing_error result)
  >>=? fun {Michelson_v1_parser.expanded = storage; _} ->
  let code = Script.lazy_expr code and storage = Script.lazy_expr storage in
  let origination =
    Origination
      {
        delegate;
        script = {code; storage};
        credit = balance;
        preorigination = None;
      }
  in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ?gas_limit
    ?storage_limit
    ~src_pk
    ~src_sk
    ~fee_parameter
    origination
  >>=? fun ((_oph, _op, result) as res) ->
  Lwt.return (Injection.originated_contracts (Single_result result))
  >>=? function
  | [contract] ->
      return (res, contract)
  | contracts ->
      failwith
        "The origination introduced %d contracts instead of one."
        (List.length contracts)

type activation_key = {
  pkh : Ed25519.Public_key_hash.t;
  amount : Tez.t;
  activation_code : Blinded_public_key_hash.activation_code;
  mnemonic : string list;
  password : string;
  email : string;
}

let raw_activation_key_encoding =
  let open Data_encoding in
  obj6
    (req "pkh" Ed25519.Public_key_hash.encoding)
    (req "amount" Tez.encoding)
    (req "activation_code" Blinded_public_key_hash.activation_code_encoding)
    (req "mnemonic" (list string))
    (req "password" string)
    (req "email" string)

let activation_key_encoding =
  (* Hack: allow compatibility with older encoding *)
  let open Data_encoding in
  conv
    (fun {pkh; amount; activation_code; mnemonic; password; email} ->
      (pkh, amount, activation_code, mnemonic, password, email))
    (fun (pkh, amount, activation_code, mnemonic, password, email) ->
      {pkh; amount; activation_code; mnemonic; password; email})
  @@ splitted
       ~binary:raw_activation_key_encoding
       ~json:
         (union
            [ case
                ~title:"Activation"
                Json_only
                raw_activation_key_encoding
                (fun x -> Some x)
                (fun x -> x);
              case
                ~title:"Deprecated_activation"
                Json_only
                (obj6
                   (req "pkh" Ed25519.Public_key_hash.encoding)
                   (req "amount" Tez.encoding)
                   (req
                      "secret"
                      Blinded_public_key_hash.activation_code_encoding)
                   (req "mnemonic" (list string))
                   (req "password" string)
                   (req "email" string))
                (fun _ -> None)
                (fun x -> x) ])

let read_key key =
  match Bip39.of_words key.mnemonic with
  | None ->
      failwith ""
  | Some t ->
      (* TODO: unicode normalization (NFKD)... *)
      let passphrase =
        Bigstring.(concat "" [of_string key.email; of_string key.password])
      in
      let sk = Bip39.to_seed ~passphrase t in
      let sk = Bigstring.sub_bytes sk 0 32 in
      let sk : Signature.Secret_key.t =
        Ed25519
          (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
      in
      let pk = Signature.Secret_key.to_public_key sk in
      let pkh = Signature.Public_key.hash pk in
      return (pkh, pk, sk)

let inject_activate_operation cctxt ~chain ~block ?confirmations ?dry_run alias
    pkh activation_code =
  let contents = Single (Activate_account {id = pkh; activation_code}) in
  Injection.inject_operation
    cctxt
    ?confirmations
    ?dry_run
    ~chain
    ~block
    ~fee_parameter:Injection.dummy_fee_parameter
    contents
  >>=? fun (oph, op, result) ->
  ( match confirmations with
  | None ->
      return_unit
  | Some _confirmations ->
      Alpha_services.Contract.balance
        cctxt
        (chain, block)
        (Contract.implicit_contract (Ed25519 pkh))
      >>=? fun balance ->
      cctxt#message
        "Account %s (%a) activated with %s%a."
        alias
        Ed25519.Public_key_hash.pp
        pkh
        Client_proto_args.tez_sym
        Tez.pp
        balance
      >>= fun () -> return_unit )
  >>=? fun () ->
  match Apply_results.pack_contents_list op result with
  | Apply_results.Single_and_result ((Activate_account _ as op), result) ->
      return (oph, op, result)

let activate_account (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?(encrypted = false) ?force key name =
  read_key key
  >>=? fun (pkh, pk, sk) ->
  fail_unless
    (Signature.Public_key_hash.equal pkh (Ed25519 key.pkh))
    (failure
       "@[<v 2>Inconsistent activation key:@ Computed pkh: %a@ Embedded pkh: \
        %a @]"
       Signature.Public_key_hash.pp
       pkh
       Ed25519.Public_key_hash.pp
       key.pkh)
  >>=? fun () ->
  let pk_uri = Tezos_signer_backends.Unencrypted.make_pk pk in
  ( if encrypted then Tezos_signer_backends.Encrypted.encrypt cctxt sk
  else return (Tezos_signer_backends.Unencrypted.make_sk sk) )
  >>=? fun sk_uri ->
  Client_keys.register_key cctxt ?force (pkh, pk_uri, sk_uri) name
  >>=? fun () ->
  inject_activate_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    name
    key.pkh
    key.activation_code

let activate_existing_account (cctxt : #full) ~chain ~block ?confirmations
    ?dry_run alias activation_code =
  Client_keys.alias_keys cctxt alias
  >>=? function
  | Some (Ed25519 pkh, _, _) ->
      inject_activate_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        alias
        pkh
        activation_code
  | Some _ ->
      failwith "Only Ed25519 accounts can be activated"
  | None ->
      failwith "Unknown account"

type period_info = {
  current_period_kind : Voting_period.kind;
  position : Int32.t;
  remaining : Int32.t;
  current_proposal : Protocol_hash.t option;
}

type ballots_info = {
  current_quorum : Int32.t;
  participation : Int32.t;
  supermajority : Int32.t;
  ballots : Vote.ballots;
}

let get_ballots_info (cctxt : #full) ~chain ~block =
  (* Get the next level, not the current *)
  let cb = (chain, block) in
  Alpha_services.Voting.ballots cctxt cb
  >>=? fun ballots ->
  Alpha_services.Voting.current_quorum cctxt cb
  >>=? fun current_quorum ->
  Alpha_services.Voting.listings cctxt cb
  >>=? fun listings ->
  let max_participation =
    List.fold_left (fun acc (_, w) -> Int32.add w acc) 0l listings
  in
  let all_votes = Int32.(add (add ballots.yay ballots.nay) ballots.pass) in
  let participation = Int32.(div (mul all_votes 100_00l) max_participation) in
  let supermajority = Int32.(div (mul 8l (add ballots.yay ballots.nay)) 10l) in
  return {current_quorum; participation; supermajority; ballots}

let get_period_info (cctxt : #full) ~chain ~block =
  (* Get the next level, not the current *)
  let cb = (chain, block) in
  Alpha_services.Helpers.current_level cctxt ~offset:1l cb
  >>=? fun level ->
  Alpha_services.Constants.all cctxt cb
  >>=? fun constants ->
  Alpha_services.Voting.current_proposal cctxt cb
  >>=? fun current_proposal ->
  let position = level.voting_period_position in
  let remaining =
    Int32.(sub constants.parametric.blocks_per_voting_period position)
  in
  Alpha_services.Voting.current_period_kind cctxt cb
  >>=? fun current_period_kind ->
  return {current_period_kind; position; remaining; current_proposal}

let get_proposals (cctxt : #full) ~chain ~block =
  let cb = (chain, block) in
  Alpha_services.Voting.proposals cctxt cb

let submit_proposals ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block
    ?confirmations ~src_sk source proposals =
  (* We need the next level, not the current *)
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
  >>=? fun (level : Level.t) ->
  let period = level.voting_period in
  let contents = Single (Proposals {source; period; proposals}) in
  Injection.inject_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ~fee_parameter:Injection.dummy_fee_parameter
    ?dry_run
    ~src_sk
    contents
    ?verbose_signing

let submit_ballot ?dry_run ?verbose_signing (cctxt : #full) ~chain ~block
    ?confirmations ~src_sk source proposal ballot =
  (* The user must provide the proposal explicitly to make himself sure
     for what he is voting. *)
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
  >>=? fun (level : Level.t) ->
  let period = level.voting_period in
  let contents = Single (Ballot {source; period; proposal; ballot}) in
  Injection.inject_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ~fee_parameter:Injection.dummy_fee_parameter
    ?dry_run
    ~src_sk
    contents
    ?verbose_signing

let pp_operation formatter (a : Alpha_block_services.operation) =
  match (a.receipt, a.protocol_data) with
  | (Apply_results.Operation_metadata omd, Operation_data od) -> (
    match Apply_results.kind_equal_list od.contents omd.contents with
    | Some Apply_results.Eq ->
        Operation_result.pp_operation_result
          formatter
          (od.contents, omd.contents)
    | None ->
        Pervasives.failwith "Unexpected result." )
  | _ ->
      Pervasives.failwith "Unexpected result."

let get_operation_from_block (cctxt : #full) ~chain predecessors operation_hash
    =
  Client_confirmations.lookup_operation_in_previous_blocks
    cctxt
    ~chain
    ~predecessors
    operation_hash
  >>=? function
  | None ->
      return_none
  | Some (block, i, j) ->
      cctxt#message
        "Operation found in block: %a (pass: %d, offset: %d)"
        Block_hash.pp
        block
        i
        j
      >>= fun () ->
      Protocol_client_context.Alpha_block_services.Operations.operation
        cctxt
        ~chain
        ~block:(`Hash (block, 0))
        i
        j
      >>=? fun op' -> return_some op'

let display_receipt_for_operation (cctxt : #full) ~chain ?(predecessors = 10)
    operation_hash =
  get_operation_from_block cctxt ~chain predecessors operation_hash
  >>=? function
  | None ->
      failwith "Couldn't find operation"
  | Some op ->
      cctxt#message "%a" pp_operation op >>= fun () -> return_unit
src/proto_alpha/lib_client/client_proto_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Protocol_client_context.

Import Tezos_micheline.

Import Client_proto_contracts.

Import Client_keys.

Definition get_balance {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  Alpha_services.Contract.balance rpc (chain, block) contract.

Definition get_storage {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Alpha_services.Contract.storage_opt rpc (chain, block) contract.

Definition get_big_map_value {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (id : Tezos_protocol_environment_alpha__Environment.Z.t)
  (key : Tezos_raw_protocol_alpha.Script_expr_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  Alpha_services.Contract.big_map_get rpc (chain, block) id key.

Definition get_contract_big_map_value {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (key :
    Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  Alpha_services.Contract.contract_big_map_get_opt rpc (chain, block) contract
    key.

Definition get_script {D F H J L M N a b c i o p q : Type}
  (rpc :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.t)) :=
  Alpha_services.Contract.script_opt rpc (chain, block) contract.

Definition parse_expression (arg : string)
  : Lwt.t
    (Tezos_error_monad.Error_monad.tzresult
      Tezos_client_alpha.Michelson_v1_parser.parsed) :=
  Lwt._return
    (Micheline_parser.no_parsing_error
      (Michelson_v1_parser.parse_expression None arg)).

Definition transfer {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
  (op_staroptstar : option string)
  : (option string) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
        (option Z.t) ->
          (option Z.t) ->
            (option Z.t) ->
              Tezos_client_alpha.Injection.fee_parameter ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      ((Tezos_base__TzPervasives.Operation_hash.t *
                        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                        *
                        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)))
                        *
                        (list
                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  let entrypoint :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "default" % string
    end in
  fun arg =>
    fun amount =>
      fun fee =>
        fun gas_limit =>
          fun storage_limit =>
            fun counter =>
              fun fee_parameter =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    match arg with
                    | Some arg =>
                      op_gtgteqquestion (parse_expression arg)
                        (fun function_parameter =>
                          let '{| expanded := arg |} := function_parameter in
                          return_some arg)
                    | None => return_none
                    end
                    (fun parameters =>
                      let parameters :=
                        Option.unopt_map Script.lazy_expr Script.unit_parameter
                          parameters in
                      let contents :=
                        Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
                          {| amount := amount; parameters := parameters;
                            entrypoint := entrypoint; destination := destination
                            |} in
                      op_gtgteqquestion
                        (Injection.inject_manager_operation cctxt chain block
                          branch confirmations dry_run verbose_signing source
                          src_pk src_sk fee gas_limit storage_limit counter
                          fee_parameter contents)
                        (fun function_parameter =>
                          let '(_oph, _op, result) as res := function_parameter
                            in
                          op_gtgteqquestion
                            (Lwt._return
                              (Injection.originated_contracts
                                (Tezos_protocol_alpha.Protocol.Apply_results.Single_result
                                  result)))
                            (fun contracts => _return (res, contracts)))).

Definition reveal {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (L * p * q * i * o)) *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                (o -> unit) ->
                  (unit -> unit) ->
                    p ->
                      q ->
                        i ->
                          Lwt.t
                            (Tezos_error_monad.Error_monad.tzresult
                              (unit -> unit))) * (M * p * q * i * o)) *
                (Tezos_shell_services.Shell_services.chain *
                  ((option Z) *
                    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                      (a * b)) *
                      ((Tezos_rpc.RPC_service.meth ->
                        (option Tezos_data_encoding.Data_encoding.json) ->
                          Uri.t ->
                            Lwt.t
                              (Tezos_rpc.RPC_context.rest_result
                                Tezos_data_encoding.Data_encoding.json
                                (option Tezos_data_encoding.Data_encoding.json)))
                        *
                        (((string ->
                          a ->
                            (Tezos_base__TzPervasives.Data_encoding.encoding a)
                              -> Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                          (a)) *
                          ((option (Lwt_stream.t string)) *
                            (((string ->
                              (Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                                ((unit -> Ptime.t) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((Z -> Lwt.t unit) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * N)))))))))))))))))))))
      *
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block))
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal)) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.reveal)))) :=
  let 'tt := function_parameter in
  let '(compute_fee, fee) :=
    match fee with
    | None => (true, Tez.zero)
    | Some fee => (false, fee)
    end in
  op_gtgteqquestion
    (Alpha_services.Contract.counter cctxt (chain, block) source)
    (fun pcounter =>
      let counter := Z.succ pcounter in
      op_gtgteqquestion
        (Alpha_services.Contract.manager_key cctxt (chain, block) source)
        (fun key =>
          match key with
          | Some _ =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "The manager key was previously revealed." % string
                  CamlinternalFormatBasics.End_of_format)
                "The manager key was previously revealed." % string)
          | None =>
            let contents :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Single
                (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                  {| source := source; fee := fee; counter := counter;
                    operation :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Reveal src_pk;
                    gas_limit := Z.of_int (Z.opp 1); storage_limit := Z.zero |})
              in
            op_gtgteqquestion
              (Injection.inject_operation cctxt chain block confirmations
                dry_run branch (Some src_sk) verbose_signing fee_parameter
                (Some compute_fee) contents)
              (fun function_parameter =>
                let '(oph, op, result) := function_parameter in
                let
                  'Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
                    ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                      _) as op) result :=
                  Apply_results.pack_contents_list op result in
                _return (oph, op, result))
          end)).

Definition delegate_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (branch : option Z)
  (confirmations : option Z) (dry_run : option bool)
  (verbose_signing : option bool)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (delegate_opt :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
  let operation :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Delegation delegate_opt in
  op_gtgteqquestion
    (Injection.inject_manager_operation cctxt chain block branch confirmations
      dry_run verbose_signing source src_pk src_sk fee None (Some Z.zero) None
      fee_parameter operation) (fun res => _return res).

Definition list_contract_labels {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              ((option (Lwt_stream.t string)) *
                ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
                  ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                    (((string ->
                      a ->
                        (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                          Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a))
                      * M))))))))) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * M)))))
      * (D * E)) (chain : D) (block : E)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (list (string * string * string))) :=
  op_gtgteqquestion (Alpha_services.Contract.list cctxt (chain, block))
    (fun contracts =>
      op_gtgtpipequestion
        (rev_map_s
          (fun h =>
            op_gtgteqquestion
              match Contract.is_implicit h with
              | Some m =>
                op_gtgteqquestion (Public_key_hash.rev_find cctxt m)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => _return "" % string
                    | Some nm =>
                      op_gtgteqquestion (RawContractAlias.find_opt cctxt nm)
                        (fun function_parameter =>
                          match function_parameter with
                          | None =>
                            _return
                              (String.append " (known as " % string
                                (String.append nm ")" % string))
                          | Some _ =>
                            _return
                              (String.append " (known as key:" % string
                                (String.append nm ")" % string))
                          end)
                    end)
              | None =>
                op_gtgteqquestion (RawContractAlias.rev_find cctxt h)
                  (fun function_parameter =>
                    match function_parameter with
                    | None => _return "" % string
                    | Some nm =>
                      _return
                        (String.append " (known as " % string
                          (String.append nm ")" % string))
                    end)
              end
              (fun nm =>
                let kind :=
                  match Contract.is_implicit h with
                  | Some _ => " (implicit)" % string
                  | None => "" % string
                  end in
                let h_b58 := Contract.to_b58check h in
                _return (nm, h_b58, kind))) contracts) List.rev).

Definition message_added_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (name : string) : Lwt.t unit :=
  (* ❌ Sending method message is not handled *)
  send
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal "Contract memorized as " % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal "." % char
            CamlinternalFormatBasics.End_of_format)))
      "Contract memorized as %s." % string) name.

Definition set_delegate {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (contract : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (manager_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (opt_delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
  delegate_contract cctxt chain block None confirmations dry_run verbose_signing
    contract src_pk manager_sk fee fee_parameter opt_delegate.

Definition register_as_delegate {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (manager_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (src_pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.delegation))) :=
  let source := Signature.Public_key.hash src_pk in
  delegate_contract cctxt chain block None confirmations dry_run verbose_signing
    source src_pk manager_sk fee fee_parameter (Some source).

Definition save_contract {E F H J L M N a b c i o p q : Type}
  (force : bool)
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q
                      i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (E * q * i * o)) *
                      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                        variant
                        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          * a) q i o) ->
                        (Tezos_shell_services.Shell_services.chain *
                          Tezos_shell_services.Shell_services.block) ->
                          a ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (F * a * q * i * o)) *
                        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                          variant
                          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            * a) * b) q i o) ->
                          (Tezos_shell_services.Shell_services.chain *
                            Tezos_shell_services.Shell_services.block) ->
                            a ->
                              b ->
                                q ->
                                  i ->
                                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                        o)) * (H * a * b * q * i * o)) *
                          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                            variant
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                              * a) * b) * c) q i o) ->
                            (Tezos_shell_services.Shell_services.chain *
                              Tezos_shell_services.Shell_services.block) ->
                              a ->
                                b ->
                                  c ->
                                    q ->
                                      i ->
                                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                            o)) * (J * a * b * c * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((Z -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (E * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
                i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (F * a * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (H * a * b * q * i * o)) *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                      a) * b) * c) q i o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      a ->
                        b ->
                          c ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (J * a * b * c * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((Z -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) * N)))))))))))))))))))))
  (alias_name : string)
  (contract : Tezos_client_alpha.Client_proto_contracts.RawContractAlias.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (RawContractAlias.add force cctxt alias_name contract)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (message_added_contract cctxt alias_name)
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition originate_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t)
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (initial_storage : string)
  (balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (code : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination)) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
            Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination))) *
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)) :=
  let 'tt := function_parameter in
  op_gtgteq
    (Lwt._return (Michelson_v1_parser.parse_expression None initial_storage))
    (fun result =>
      op_gtgteqquestion (Lwt._return (Micheline_parser.no_parsing_error result))
        (fun function_parameter =>
          let '{| Michelson_v1_parser.expanded := storage |} :=
            function_parameter in
          let code
            : Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr :=
            Script.lazy_expr code
          with storage
            : Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr :=
            Script.lazy_expr storage in
          let origination :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Origination
              {| delegate := delegate;
                script := {| code := code; storage := storage |};
                credit := balance; preorigination := None |} in
          op_gtgteqquestion
            (Injection.inject_manager_operation cctxt chain block branch
              confirmations dry_run verbose_signing source src_pk src_sk fee
              gas_limit storage_limit None fee_parameter origination)
            (fun function_parameter =>
              let '(_oph, _op, result) as res := function_parameter in
              op_gtgteqquestion
                (Lwt._return
                  (Injection.originated_contracts
                    (Tezos_protocol_alpha.Protocol.Apply_results.Single_result
                      result)))
                (fun function_parameter =>
                  match function_parameter with
                  | cons contract [] => _return (res, contract)
                  | contracts =>
                    failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "The origination introduced " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.String_literal
                              " contracts instead of one." % string
                              CamlinternalFormatBasics.End_of_format)))
                        "The origination introduced %d contracts instead of one."
                          % string) (List.length contracts)
                  end)))).

Record activation_key := {
  pkh : Tezos_base__TzPervasives.Ed25519.Public_key_hash.t;
  amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  activation_code :
    Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
  mnemonic : list string;
  password : string;
  email : string }.

Definition raw_activation_key_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (Tezos_base__TzPervasives.Ed25519.Public_key_hash.t *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t *
      Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code *
      (list string) * string * string) :=
  obj6 (req None None "pkh" % string Ed25519.Public_key_hash.encoding)
    (req None None "amount" % string Tez.encoding)
    (req None None "activation_code" % string
      Blinded_public_key_hash.activation_code_encoding)
    (req None None "mnemonic" % string (list None string))
    (req None None "password" % string string)
    (req None None "email" % string string).

Definition activation_key_encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding activation_key :=
  apply
    (let arg :=
      conv
        (fun function_parameter =>
          let '{|
            pkh := pkh;
              amount := amount;
              activation_code := activation_code;
              mnemonic := mnemonic;
              password := password;
              email := email
              |} := function_parameter in
          (pkh, amount, activation_code, mnemonic, password, email))
        (fun function_parameter =>
          let '(pkh, amount, activation_code, mnemonic, password, email) :=
            function_parameter in
          {| pkh := pkh; amount := amount; activation_code := activation_code;
            mnemonic := mnemonic; password := password; email := email |}) in
    fun eta => arg None eta)
    (splitted
      (union None
        (cons
          (case "Activation" % string None
            Tezos_base__TzPervasives.Data_encoding.Json_only
            raw_activation_key_encoding (fun x => Some x) (fun x => x))
          (cons
            (case "Deprecated_activation" % string None
              Tezos_base__TzPervasives.Data_encoding.Json_only
              (obj6
                (req None None "pkh" % string Ed25519.Public_key_hash.encoding)
                (req None None "amount" % string Tez.encoding)
                (req None None "secret" % string
                  Blinded_public_key_hash.activation_code_encoding)
                (req None None "mnemonic" % string (list None string))
                (req None None "password" % string string)
                (req None None "email" % string string))
              (fun function_parameter =>
                let '_ := function_parameter in
                None) (fun x => x)) []))) raw_activation_key_encoding).

Definition read_key (key : activation_key)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_crypto__Signature.Public_key_hash.t *
        Tezos_crypto__Signature.Public_key.t *
        Tezos_base__TzPervasives.Signature.Secret_key.t)) :=
  match Bip39.of_words (mnemonic key) with
  | None =>
    failwith
      (CamlinternalFormatBasics.Format CamlinternalFormatBasics.End_of_format
        "" % string)
  | Some t =>
    let passphrase :=
      concat "" % string
        (cons (of_string (email key)) (cons (of_string (password key)) [])) in
    let sk := Bip39.to_seed (Some passphrase) t in
    let sk := Bigstring.sub_bytes sk 0 32 in
    let sk :=
      Tezos_crypto__Signature.Ed25519
        (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk) in
    let pk := Signature.Secret_key.to_public_key sk in
    let pkh := Signature.Public_key.hash pk in
    _return (pkh, pk, sk)
  end.

Definition inject_activate_operation {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (alias : string)
  (pkh : Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t)
  (activation_code :
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
  let contents :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Single
      (Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account
        {| id := pkh; activation_code := activation_code |}) in
  op_gtgteqquestion
    (Injection.inject_operation cctxt chain block confirmations dry_run None
      None None Injection.dummy_fee_parameter None contents)
    (fun function_parameter =>
      let '(oph, op, result) := function_parameter in
      op_gtgteqquestion
        match confirmations with
        | None => return_unit
        | Some _confirmations =>
          op_gtgteqquestion
            (Alpha_services.Contract.balance cctxt (chain, block)
              (Contract.implicit_contract
                (Tezos_protocol_environment_alpha__Environment.Signature.Ed25519
                  pkh)))
            (fun balance =>
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "Account " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal " (" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              ") activated with " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    "." % char
                                    CamlinternalFormatBasics.End_of_format))))))))
                    "Account %s (%a) activated with %s%a." % string) alias
                  Ed25519.Public_key_hash.pp pkh Client_proto_args.tez_sym
                  Tez.pp balance)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit))
        end
        (fun function_parameter =>
          let 'tt := function_parameter in
          let
            'Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
              ((Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account _)
                as op) result := Apply_results.pack_contents_list op result in
          _return (oph, op, result))).

Definition activate_account {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (op_staroptstar : option bool)
  : (option bool) ->
    activation_key ->
      string ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_base__TzPervasives.Operation_hash.t *
              (Tezos_protocol_alpha.Protocol.Alpha_context.contents
                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account)
              *
              (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
                Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
  let encrypted :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun force =>
    fun key =>
      fun name =>
        op_gtgteqquestion (read_key key)
          (fun function_parameter =>
            let '(pkh, pk, sk) := function_parameter in
            op_gtgteqquestion
              (fail_unless
                (Signature.Public_key_hash.equal pkh
                  (Tezos_crypto__Signature.Ed25519 (pkh key)))
                (failure
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Inconsistent activation key:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.String_literal
                            "Computed pkh: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@ " % string 1
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "Embedded pkh: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      " " % char
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))
                    "@[<v 2>Inconsistent activation key:@ Computed pkh: %a@ Embedded pkh: %a @]"
                      % string) Signature.Public_key_hash.pp pkh
                  Ed25519.Public_key_hash.pp (pkh key)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                let pk_uri := Tezos_signer_backends.Unencrypted.make_pk pk in
                op_gtgteqquestion
                  (if encrypted then
                    Tezos_signer_backends.Encrypted.encrypt cctxt sk
                  else
                    _return (Tezos_signer_backends.Unencrypted.make_sk sk))
                  (fun sk_uri =>
                    op_gtgteqquestion
                      (Client_keys.register_key cctxt force
                        (pkh, pk_uri, sk_uri) None name)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        inject_activate_operation cctxt chain block
                          confirmations dry_run name (pkh key)
                          (activation_code key))))).

Definition activate_existing_account {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (alias : string)
  (activation_code :
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Operation_hash.t *
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account) *
        (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.activate_account))) :=
  op_gtgteqquestion (Client_keys.alias_keys cctxt alias)
    (fun function_parameter =>
      match function_parameter with
      | Some (Tezos_crypto__Signature.Ed25519 pkh, _, _) =>
        inject_activate_operation cctxt chain block confirmations dry_run alias
          pkh activation_code
      | Some _ =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Only Ed25519 accounts can be activated" % string
              CamlinternalFormatBasics.End_of_format)
            "Only Ed25519 accounts can be activated" % string)
      | None =>
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "Unknown account" % string
              CamlinternalFormatBasics.End_of_format) "Unknown account" % string)
      end).

Record period_info := {
  current_period_kind :
    Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.kind;
  position : Stdlib.Int32.t;
  remaining : Stdlib.Int32.t;
  current_proposal : option Tezos_base__TzPervasives.Protocol_hash.t }.

Record ballots_info := {
  current_quorum : Stdlib.Int32.t;
  participation : Stdlib.Int32.t;
  supermajority : Stdlib.Int32.t;
  ballots : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots }.

Definition get_ballots_info {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  : Lwt.t (Tezos_base__TzPervasives.tzresult ballots_info) :=
  let cb := (chain, block) in
  op_gtgteqquestion (Alpha_services.Voting.ballots cctxt cb)
    (fun ballots =>
      op_gtgteqquestion (Alpha_services.Voting.current_quorum cctxt cb)
        (fun current_quorum =>
          op_gtgteqquestion (Alpha_services.Voting.listings cctxt cb)
            (fun listings =>
              let max_participation :=
                List.fold_left
                  (fun acc =>
                    fun function_parameter =>
                      let '(_, w) := function_parameter in
                      Int32.add w acc)
                  (* ❌ Constant of type int32 is converted to int *)
                  0 listings in
              let all_votes :=
                add (add (yay ballots) (nay ballots)) (pass ballots) in
              let participation :=
                div
                  (mul all_votes
                    (* ❌ Constant of type int32 is converted to int *)
                    10000) max_participation in
              let supermajority :=
                div
                  (mul
                    (* ❌ Constant of type int32 is converted to int *)
                    8 (add (yay ballots) (nay ballots)))
                  (* ❌ Constant of type int32 is converted to int *)
                  10 in
              _return
                {| current_quorum := current_quorum;
                  participation := participation;
                  supermajority := supermajority; ballots := ballots |}))).

Definition get_period_info {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  : Lwt.t (Tezos_base__TzPervasives.tzresult period_info) :=
  let cb := (chain, block) in
  op_gtgteqquestion
    (Alpha_services.Helpers.current_level cctxt
      (Some
        (* ❌ Constant of type int32 is converted to int *)
        1) cb)
    (fun level =>
      op_gtgteqquestion (Alpha_services.Constants.all cctxt cb)
        (fun constants =>
          op_gtgteqquestion (Alpha_services.Voting.current_proposal cctxt cb)
            (fun current_proposal =>
              let position := voting_period_position level in
              let remaining :=
                sub (blocks_per_voting_period (parametric constants)) position
                in
              op_gtgteqquestion
                (Alpha_services.Voting.current_period_kind cctxt cb)
                (fun current_period_kind =>
                  _return
                    {| current_period_kind := current_period_kind;
                      position := position; remaining := remaining;
                      current_proposal := current_proposal |})))).

Definition get_proposals {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
        Tezos_protocol_environment_alpha__Environment.Int32.t)) :=
  let cb := (chain, block) in
  Alpha_services.Voting.proposals cctxt cb.

Definition submit_proposals {D F H J L M N a b c i o p q : Type}
  (dry_run : option bool) (verbose_signing : option bool)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (source :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (proposals :
    list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result_list
        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.proposals)) :=
  op_gtgteqquestion
    (Alpha_services.Helpers.current_level cctxt
      (Some
        (* ❌ Constant of type int32 is converted to int *)
        1) (chain, block))
    (fun level =>
      let period := voting_period level in
      let contents :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Single
          (Tezos_protocol_alpha.Protocol.Alpha_context.Proposals
            {| source := source; period := period; proposals := proposals |}) in
      Injection.inject_operation cctxt chain block confirmations dry_run None
        (Some src_sk) verbose_signing Injection.dummy_fee_parameter None
        contents).

Definition submit_ballot {D F H J L M N a b c i o p q : Type}
  (dry_run : option bool) (verbose_signing : option bool)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (source :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ballot : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result_list
        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.ballot)) :=
  op_gtgteqquestion
    (Alpha_services.Helpers.current_level cctxt
      (Some
        (* ❌ Constant of type int32 is converted to int *)
        1) (chain, block))
    (fun level =>
      let period := voting_period level in
      let contents :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Single
          (Tezos_protocol_alpha.Protocol.Alpha_context.Ballot
            {| source := source; period := period; proposal := proposal;
              ballot := ballot |}) in
      Injection.inject_operation cctxt chain block confirmations dry_run None
        (Some src_sk) verbose_signing Injection.dummy_fee_parameter None
        contents).

Definition pp_operation
  (formatter : Stdlib.Format.formatter)
  (a : Tezos_client_alpha.Protocol_client_context.Alpha_block_services.operation)
  : unit :=
  match ((receipt a), (protocol_data a)) with
  |
    (Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata omd,
      Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data od) =>
    match Apply_results.kind_equal_list (contents od) (contents omd) with
    | Some Tezos_protocol_alpha.Protocol.Apply_results.Eq =>
      Operation_result.pp_operation_result formatter
        ((contents od), (contents omd))
    | None => Pervasives.failwith "Unexpected result." % string
    end
  | _ => Pervasives.failwith "Unexpected result." % string
  end.

Definition get_operation_from_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Block_services.chain)
  (predecessors : Z)
  (operation_hash : Tezos_base__TzPervasives.Operation_list_hash.elt)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        Tezos_client_alpha__Protocol_client_context.Alpha_block_services.operation)) :=
  op_gtgteqquestion
    (Client_confirmations.lookup_operation_in_previous_blocks cctxt chain
      predecessors operation_hash)
    (fun function_parameter =>
      match function_parameter with
      | None => return_none
      | Some (block, i, j) =>
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Operation found in block: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " (pass: " % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        ", offset: " % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))))
              "Operation found in block: %a (pass: %d, offset: %d)" % string)
            Block_hash.pp block i j)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Protocol_client_context.Alpha_block_services.Operations.operation
                cctxt (Some chain)
                (Some
                  (* ❌ Variants not supported *)
                  variant) i j) (fun op' => return_some op'))
      end).

Definition display_receipt_for_operation {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Block_services.chain)
  (op_staroptstar : option Z)
  : Tezos_base__TzPervasives.Operation_list_hash.elt ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let predecessors :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 10
    end in
  fun operation_hash =>
    op_gtgteqquestion
      (get_operation_from_block cctxt chain predecessors operation_hash)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Couldn't find operation" % string
                CamlinternalFormatBasics.End_of_format)
              "Couldn't find operation" % string)
        | Some op =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              pp_operation op)
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        end).

src/proto_alpha/lib_client/client_proto_contracts.ml 157 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

module ContractEntity = struct
  type t = Contract.t

  let encoding = Contract.encoding

  let of_source s =
    match Contract.of_b58check s with
    | Error _ as err ->
        Lwt.return (Environment.wrap_error err)
        |> trace (failure "bad contract notation")
    | Ok s ->
        return s

  let to_source s = return (Contract.to_b58check s)

  let name = "contract"
end

module RawContractAlias = Client_aliases.Alias (ContractEntity)

module ContractAlias = struct
  let find cctxt s =
    RawContractAlias.find_opt cctxt s
    >>=? function
    | Some v ->
        return (s, v)
    | None -> (
        Client_keys.Public_key_hash.find_opt cctxt s
        >>=? function
        | Some v ->
            return (s, Contract.implicit_contract v)
        | None ->
            failwith "no contract or key named %s" s )

  let find_key cctxt name =
    Client_keys.Public_key_hash.find cctxt name
    >>=? fun v -> return (name, Contract.implicit_contract v)

  let rev_find cctxt c =
    match Contract.is_implicit c with
    | Some hash -> (
        Client_keys.Public_key_hash.rev_find cctxt hash
        >>=? function
        | Some name -> return_some ("key:" ^ name) | None -> return_none )
    | None ->
        RawContractAlias.rev_find cctxt c

  let get_contract cctxt s =
    match String.split ~limit:1 ':' s with
    | ["key"; key] ->
        find_key cctxt key
    | _ ->
        find cctxt s

  let autocomplete cctxt =
    Client_keys.Public_key_hash.autocomplete cctxt
    >>=? fun keys ->
    RawContractAlias.autocomplete cctxt
    >>=? fun contracts -> return (List.map (( ^ ) "key:") keys @ contracts)

  let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
    let desc =
      desc ^ "\n"
      ^ "Can be a contract alias or a key alias (autodetected in order).\n\
         Use 'key:name' to force the later."
    in
    Clic.(
      param
        ~name
        ~desc
        (parameter ~autocomplete (fun cctxt p -> get_contract cctxt p))
        next)

  let destination_parameter () =
    Clic.parameter
      ~autocomplete:(fun cctxt ->
        autocomplete cctxt
        >>=? fun list1 ->
        Client_keys.Public_key_hash.autocomplete cctxt
        >>=? fun list2 -> return (list1 @ list2))
      (fun cctxt s ->
        match String.split ~limit:1 ':' s with
        | ["alias"; alias] ->
            find cctxt alias
        | ["key"; text] ->
            Client_keys.Public_key_hash.find cctxt text
            >>=? fun v -> return (s, Contract.implicit_contract v)
        | _ -> (
            find cctxt s
            >>= function
            | Ok v ->
                return v
            | Error k_errs -> (
                ContractEntity.of_source s
                >>= function
                | Ok v ->
                    return (s, v)
                | Error c_errs ->
                    Lwt.return_error (k_errs @ c_errs) ) ))

  let destination_param ?(name = "dst") ?(desc = "destination contract") next =
    let desc =
      String.concat
        "\n"
        [ desc;
          "Can be an alias, a key, or a literal (autodetected in order).\n\
           Use 'text:literal', 'alias:name', 'key:name' to force." ]
    in
    Clic.param ~name ~desc (destination_parameter ()) next

  let destination_arg ?(name = "dst") ?(doc = "destination contract") () =
    let doc =
      String.concat
        "\n"
        [ doc;
          "Can be an alias, a key, or a literal (autodetected in order).\n\
           Use 'text:literal', 'alias:name', 'key:name' to force." ]
    in
    Clic.arg ~long:name ~doc ~placeholder:name (destination_parameter ())

  let name cctxt contract =
    rev_find cctxt contract
    >>=? function
    | None -> return (Contract.to_b58check contract) | Some name -> return name
end

let list_contracts cctxt =
  RawContractAlias.load cctxt
  >>=? fun raw_contracts ->
  Lwt_list.map_s (fun (n, v) -> Lwt.return ("", n, v)) raw_contracts
  >>= fun contracts ->
  Client_keys.Public_key_hash.load cctxt
  >>=? fun keys ->
  (* List accounts (implicit contracts of identities) *)
  map_s
    (fun (n, v) ->
      RawContractAlias.mem cctxt n
      >>=? fun mem ->
      let p = if mem then "key:" else "" in
      let v' = Contract.implicit_contract v in
      return (p, n, v'))
    keys
  >>=? fun accounts -> return (contracts @ accounts)

let get_delegate cctxt ~chain ~block source =
  Alpha_services.Contract.delegate_opt cctxt (chain, block) source
src/proto_alpha/lib_client/client_proto_contracts.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Module ContractEntity.
  Definition t := Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t :=
    Contract.encoding.
  
  Definition of_source (s : string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) :=
    match Contract.of_b58check s with
    | (Stdlib.Error _) as err =>
      OCaml.Stdlib.reverse_apply (Lwt._return (Environment.wrap_error err))
        (trace
          (failure
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "bad contract notation" % string
                CamlinternalFormatBasics.End_of_format)
              "bad contract notation" % string)))
    | Stdlib.Ok s => _return s
    end.
  
  Definition to_source
    (s : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    _return (Contract.to_b58check s).
  
  Definition name : string := "contract" % string.
End ContractEntity.

(* ❌ Applications of functors are not handled. *)
functor_application

Module ContractAlias.
  Definition find {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (s : string)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (string * RawContractAlias.t)) :=
    op_gtgteqquestion (RawContractAlias.find_opt cctxt s)
      (fun function_parameter =>
        match function_parameter with
        | Some v => _return (s, v)
        | None =>
          op_gtgteqquestion (Client_keys.Public_key_hash.find_opt cctxt s)
            (fun function_parameter =>
              match function_parameter with
              | Some v => _return (s, (Contract.implicit_contract v))
              | None =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "no contract or key named " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format))
                    "no contract or key named %s" % string) s
              end)
        end).
  
  Definition find_key {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (name : string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
    op_gtgteqquestion (Client_keys.Public_key_hash.find cctxt name)
      (fun v => _return (name, (Contract.implicit_contract v))).
  
  Definition rev_find {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (c : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult (option string)) :=
    match Contract.is_implicit c with
    | Some hash =>
      op_gtgteqquestion (Client_keys.Public_key_hash.rev_find cctxt hash)
        (fun function_parameter =>
          match function_parameter with
          | Some name => return_some (String.append "key:" % string name)
          | None => return_none
          end)
    | None => RawContractAlias.rev_find cctxt c
    end.
  
  Definition get_contract {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) (s : string)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (string * Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
    match String.split ":" % char None (Some 1) s with
    | cons "key" % string (cons key []) => find_key cctxt key
    | _ => find cctxt s
    end.
  
  Definition autocomplete {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) : Lwt.t (Tezos_base__TzPervasives.tzresult (list string)) :=
    op_gtgteqquestion (Client_keys.Public_key_hash.autocomplete cctxt)
      (fun keys =>
        op_gtgteqquestion (RawContractAlias.autocomplete cctxt)
          (fun contracts =>
            _return
              (OCaml.Stdlib.app (List.map (String.append "key:" % string) keys)
                contracts))).
  
  Definition alias_param {A C a : Type} (op_staroptstar : option string)
    : (option string) ->
      (Tezos_base__TzPervasives.Clic.params A
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
          * C)) ->
        Tezos_base__TzPervasives.Clic.params
          ((string *
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) -> A)
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    C))))) * C) :=
    let name :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => "name" % string
      end in
    fun op_staroptstar =>
      let desc :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "existing contract alias" % string
        end in
      fun next =>
        let desc :=
          String.append desc
            (String.append "
" % string
              "Can be a contract alias or a key alias (autodetected in order).
Use 'key:name' to force the later."
                % string) in
        param name desc
          (parameter (Some autocomplete)
            (fun cctxt => fun p => get_contract cctxt p)) next.
  
  Definition destination_parameter {B a : Type} (function_parameter : unit)
    : Tezos_base__TzPervasives.Clic.parameter (string * RawContractAlias.t)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B) :=
    let 'tt := function_parameter in
    Clic.parameter
      (Some
        (fun cctxt =>
          op_gtgteqquestion (autocomplete cctxt)
            (fun list1 =>
              op_gtgteqquestion (Client_keys.Public_key_hash.autocomplete cctxt)
                (fun list2 => _return (OCaml.Stdlib.app list1 list2)))))
      (fun cctxt =>
        fun s =>
          match String.split ":" % char None (Some 1) s with
          | cons "alias" % string (cons alias []) => find cctxt alias
          | cons "key" % string (cons text []) =>
            op_gtgteqquestion (Client_keys.Public_key_hash.find cctxt text)
              (fun v => _return (s, (Contract.implicit_contract v)))
          | _ =>
            op_gtgteq (find cctxt s)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok v => _return v
                | Stdlib.Error k_errs =>
                  op_gtgteq (ContractEntity.of_source s)
                    (fun function_parameter =>
                      match function_parameter with
                      | Stdlib.Ok v => _return (s, v)
                      | Stdlib.Error c_errs =>
                        Lwt.return_error (OCaml.Stdlib.app k_errs c_errs)
                      end)
                end)
          end).
  
  Definition destination_param {A C a : Type} (op_staroptstar : option string)
    : (option string) ->
      (Tezos_base__TzPervasives.Clic.params A
        (((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
          * C)) ->
        Tezos_base__TzPervasives.Clic.params
          ((string * RawContractAlias.t) -> A)
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    C))))) * C) :=
    let name :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => "dst" % string
      end in
    fun op_staroptstar =>
      let desc :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "destination contract" % string
        end in
      fun next =>
        let desc :=
          String.concat "
" % string
            (cons desc
              (cons
                "Can be an alias, a key, or a literal (autodetected in order).
Use 'text:literal', 'alias:name', 'key:name' to force."
                  % string [])) in
        Clic.param name desc (destination_parameter tt) next.
  
  Definition destination_arg {B a : Type} (op_staroptstar : option string)
    : (option string) ->
      unit ->
        Tezos_base__TzPervasives.Clic.arg (option (string * RawContractAlias.t))
          (((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    B))))) * B) :=
    let name :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => "dst" % string
      end in
    fun op_staroptstar =>
      let doc :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "destination contract" % string
        end in
      fun function_parameter =>
        let 'tt := function_parameter in
        let doc :=
          String.concat "
" % string
            (cons doc
              (cons
                "Can be an alias, a key, or a literal (autodetected in order).
Use 'text:literal', 'alias:name', 'key:name' to force."
                  % string [])) in
        Clic.arg doc None name name (destination_parameter tt).
  
  Definition name {B a : Type}
    (cctxt :
      ((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
        * B)
    (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    op_gtgteqquestion (rev_find cctxt contract)
      (fun function_parameter =>
        match function_parameter with
        | None => _return (Contract.to_b58check contract)
        | Some name => _return name
        end).
End ContractAlias.

Definition list_contracts {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * string * RawContractAlias.t))) :=
  op_gtgteqquestion (RawContractAlias.load cctxt)
    (fun raw_contracts =>
      op_gtgteq
        (Lwt_list.map_s
          (fun function_parameter =>
            let '(n, v) := function_parameter in
            Lwt._return ("" % string, n, v)) raw_contracts)
        (fun contracts =>
          op_gtgteqquestion (Client_keys.Public_key_hash.load cctxt)
            (fun keys =>
              op_gtgteqquestion
                (map_s
                  (fun function_parameter =>
                    let '(n, v) := function_parameter in
                    op_gtgteqquestion (RawContractAlias.mem cctxt n)
                      (fun mem =>
                        let p :=
                          if mem then
                            "key:" % string
                          else
                            "" % string in
                        let v' := Contract.implicit_contract v in
                        _return (p, n, v'))) keys)
                (fun accounts => _return (OCaml.Stdlib.app contracts accounts))))).

Definition get_delegate {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)) :=
  Alpha_services.Contract.delegate_opt cctxt (chain, block) source.

src/proto_alpha/lib_client/client_proto_multisig.ml 508 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context

type error += Contract_has_no_script of Contract.t

type error +=
  | Not_a_supported_multisig_contract of (Script_expr_hash.t * Script.expr)

type error += Contract_has_no_storage of Contract.t

type error += Contract_has_unexpected_storage of Contract.t

type error += Invalid_signature of signature

type error += Not_enough_signatures of int * int

type error += Action_deserialisation_error of Script.expr

type error += Bytes_deserialisation_error of Bytes.t

type error += Bad_deserialized_contract of (Contract.t * Contract.t)

type error += Bad_deserialized_counter of (counter * counter)

type error += Non_positive_threshold of int

type error += Threshold_too_high of int * int

let () =
  register_error_kind
    `Permanent
    ~id:"contractHasNoScript"
    ~title:
      "The given contract is not a multisig contract because it has no script"
    ~description:
      "A multisig command has referenced a scriptless smart contract instead \
       of a multisig smart contract."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no script %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_no_script c -> Some c | _ -> None)
    (fun c -> Contract_has_no_script c) ;
  register_error_kind
    `Permanent
    ~id:"notASupportedMultisigContract"
    ~title:"The given contract is not one of the supported contracts"
    ~description:
      "A multisig command has referenced a smart contract whose script is not \
       one of the known multisig contract scripts."
    ~pp:(fun ppf (hash, script) ->
      Format.fprintf
        ppf
        "Not a supported multisig contract %a.@\n\
         The hash of this script is 0x%a, it was not found among in the list \
         of known multisig script hashes."
        Michelson_v1_printer.print_expr
        script
        Hex.pp
        (Script_expr_hash.to_bytes hash |> Hex.of_bytes))
    Data_encoding.(
      obj2
        (req "hash" Script_expr_hash.encoding)
        (req "script" Script.expr_encoding))
    (function
      | Not_a_supported_multisig_contract (h, c) -> Some (h, c) | _ -> None)
    (fun (h, c) -> Not_a_supported_multisig_contract (h, c)) ;
  register_error_kind
    `Permanent
    ~id:"contractHasNoStorage"
    ~title:
      "The given contract is not a multisig contract because it has no storage"
    ~description:
      "A multisig command has referenced a smart contract without storage \
       instead of a multisig smart contract."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no storage %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_no_storage c -> Some c | _ -> None)
    (fun c -> Contract_has_no_storage c) ;
  register_error_kind
    `Permanent
    ~id:"contractHasUnexpectedStorage"
    ~title:
      "The storage of the given contract is not of the shape expected for a \
       multisig contract"
    ~description:
      "A multisig command has referenced a smart contract whose storage is of \
       a different shape than the expected one."
    ~pp:(fun ppf contract ->
      Format.fprintf
        ppf
        "Contract has unexpected storage %a."
        Contract.pp
        contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_has_unexpected_storage c -> Some c | _ -> None)
    (fun c -> Contract_has_unexpected_storage c) ;
  register_error_kind
    `Permanent
    ~id:"invalidSignature"
    ~title:
      "The following signature did not match a public key in the given \
       multisig contract"
    ~description:
      "A signature was given for a multisig contract that matched none of the \
       public keys of the contract signers"
    ~pp:(fun ppf s ->
      Format.fprintf ppf "Invalid signature %s." (Signature.to_b58check s))
    Data_encoding.(obj1 (req "invalid_signature" Signature.encoding))
    (function Invalid_signature s -> Some s | _ -> None)
    (fun s -> Invalid_signature s) ;
  register_error_kind
    `Permanent
    ~id:"notEnoughSignatures"
    ~title:"Not enough signatures were provided for this multisig action"
    ~description:
      "To run an action on a multisig contract, you should provide at least \
       as many signatures as indicated by the threshold stored in the \
       multisig contract."
    ~pp:(fun ppf (threshold, nsigs) ->
      Format.fprintf
        ppf
        "Not enough signatures: only %d signatures were given but the \
         threshold is currently %d"
        nsigs
        threshold)
    Data_encoding.(obj1 (req "threshold_nsigs" (tup2 int31 int31)))
    (function
      | Not_enough_signatures (threshold, nsigs) ->
          Some (threshold, nsigs)
      | _ ->
          None)
    (fun (threshold, nsigs) -> Not_enough_signatures (threshold, nsigs)) ;
  register_error_kind
    `Permanent
    ~id:"actionDeserialisation"
    ~title:"The expression is not a valid multisig action"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an expression that does not correspond to a known multisig action"
    ~pp:(fun ppf e ->
      Format.fprintf
        ppf
        "Action deserialisation error %a."
        Michelson_v1_printer.print_expr
        e)
    Data_encoding.(obj1 (req "expr" Script.expr_encoding))
    (function Action_deserialisation_error e -> Some e | _ -> None)
    (fun e -> Action_deserialisation_error e) ;
  register_error_kind
    `Permanent
    ~id:"bytesDeserialisation"
    ~title:"The byte sequence is not a valid multisig action"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an error"
    ~pp:(fun ppf b ->
      Format.fprintf ppf "Bytes deserialisation error %s." (Bytes.to_string b))
    Data_encoding.(obj1 (req "expr" bytes))
    (function Bytes_deserialisation_error b -> Some b | _ -> None)
    (fun b -> Bytes_deserialisation_error b) ;
  register_error_kind
    `Permanent
    ~id:"badDeserializedContract"
    ~title:"The byte sequence is not for the given multisig contract"
    ~description:
      "When trying to deserialise an action from a sequence of bytes, we got \
       an action for another multisig contract"
    ~pp:(fun ppf (recieved, expected) ->
      Format.fprintf
        ppf
        "Bad deserialized contract, recieved %a expected %a."
        Contract.pp
        recieved
        Contract.pp
        expected)
    Data_encoding.(
      obj1 (req "recieved_expected" (tup2 Contract.encoding Contract.encoding)))
    (function Bad_deserialized_contract b -> Some b | _ -> None)
    (fun b -> Bad_deserialized_contract b) ;
  register_error_kind
    `Permanent
    ~id:"Bad deserialized counter"
    ~title:"Deserialized counter does not match the stored one"
    ~description:
      "The byte sequence references a multisig counter that does not match \
       the one currently stored in the given multisig contract"
    ~pp:(fun ppf (recieved, expected) ->
      Format.fprintf
        ppf
        "Bad deserialized counter, recieved %d expected %d."
        recieved
        expected)
    Data_encoding.(obj1 (req "recieved_expected" (tup2 int31 int31)))
    (function
      | Bad_deserialized_counter (c1, c2) ->
          Some (Z.to_int c1, Z.to_int c2)
      | _ ->
          None)
    (fun (c1, c2) -> Bad_deserialized_counter (Z.of_int c1, Z.of_int c2)) ;
  register_error_kind
    `Permanent
    ~id:"thresholdTooHigh"
    ~title:"Given threshold is too high"
    ~description:
      "The given threshold is higher than the number of keys, this would lead \
       to a frozen multisig contract"
    ~pp:(fun ppf (threshold, nkeys) ->
      Format.fprintf
        ppf
        "Threshold too high: %d expected at most %d."
        threshold
        nkeys)
    Data_encoding.(obj1 (req "recieved_expected" (tup2 int31 int31)))
    (function Threshold_too_high (c1, c2) -> Some (c1, c2) | _ -> None)
    (fun (c1, c2) -> Threshold_too_high (c1, c2)) ;
  register_error_kind
    `Permanent
    ~id:"nonPositiveThreshold"
    ~title:"Given threshold is not positive"
    ~description:"A multisig threshold should be a positive number"
    ~pp:(fun ppf threshold ->
      Format.fprintf ppf "Multisig threshold %d should be positive." threshold)
    Data_encoding.(obj1 (req "threshold" int31))
    (function Non_positive_threshold t -> Some t | _ -> None)
    (fun t -> Non_positive_threshold t)

(* The multisig contract script written by Arthur Breitman
     https://github.com/murbard/smart-contracts/blob/master/multisig/michelson/multisig.tz *)
(* Updated to take the chain id into account *)
let multisig_script_string =
  "parameter (pair\n\
  \             (pair :payload\n\
  \                (nat %counter) # counter, used to prevent replay attacks\n\
  \                (or :action    # payload to sign, represents the requested \
   action\n\
  \                   (pair :transfer    # transfer tokens\n\
  \                      (mutez %amount) # amount to transfer\n\
  \                      (contract %dest unit)) # destination to transfer to\n\
  \                   (or\n\
  \                      (option %delegate key_hash) # change the delegate to \
   this address\n\
  \                      (pair %change_keys          # change the keys \
   controlling the multisig\n\
  \                         (nat %threshold)         # new threshold\n\
  \                         (list %keys key)))))     # new list of keys\n\
  \             (list %sigs (option signature)));    # signatures\n\n\
   storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys \
   key))) ;\n\n\
   code\n\
  \  {\n\
  \    UNPAIR ; SWAP ; DUP ; DIP { SWAP } ;\n\
  \    DIP\n\
  \      {\n\
  \        UNPAIR ;\n\
  \        # pair the payload with the current contract address, to ensure \
   signatures\n\
  \        # can't be replayed accross different contracts if a key is reused.\n\
  \        DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;\n\
  \        PACK ; # form the binary payload that we expect to be signed\n\
  \        DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP\n\
  \      } ;\n\n\
  \    # Check that the counters match\n\
  \    UNPAIR @stored_counter; DIP { SWAP };\n\
  \    ASSERT_CMPEQ ;\n\n\
  \    # Compute the number of valid signatures\n\
  \    DIP { SWAP } ; UNPAIR @threshold @keys;\n\
  \    DIP\n\
  \      {\n\
  \        # Running count of valid signatures\n\
  \        PUSH @valid nat 0; SWAP ;\n\
  \        ITER\n\
  \          {\n\
  \            DIP { SWAP } ; SWAP ;\n\
  \            IF_CONS\n\
  \              {\n\
  \                IF_SOME\n\
  \                  { SWAP ;\n\
  \                    DIP\n\
  \                      {\n\
  \                        SWAP ; DIIP { DUUP } ;\n\
  \                        # Checks signatures, fails if invalid\n\
  \                        { DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} \
   {FAILWITH} };\n\
  \                        PUSH nat 1 ; ADD @valid } }\n\
  \                  { SWAP ; DROP }\n\
  \              }\n\
  \              {\n\
  \                # There were fewer signatures in the list\n\
  \                # than keys. Not all signatures must be present, but\n\
  \                # they should be marked as absent using the option type.\n\
  \                FAIL\n\
  \              } ;\n\
  \            SWAP\n\
  \          }\n\
  \      } ;\n\
  \    # Assert that the threshold is less than or equal to the\n\
  \    # number of valid signatures.\n\
  \    ASSERT_CMPLE ;\n\
  \    DROP ; DROP ;\n\n\
  \    # Increment counter and place in storage\n\
  \    DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;\n\n\
  \    # We have now handled the signature verification part,\n\
  \    # produce the operation requested by the signers.\n\
  \    NIL operation ; SWAP ;\n\
  \    IF_LEFT\n\
  \      { # Transfer tokens\n\
  \        UNPAIR ; UNIT ; TRANSFER_TOKENS ; CONS }\n\
  \      { IF_LEFT {\n\
  \                  # Change delegate\n\
  \                  SET_DELEGATE ; CONS }\n\
  \                {\n\
  \                  # Change set of signatures\n\
  \                  DIP { SWAP ; CAR } ; SWAP ; PAIR ; SWAP }} ;\n\
  \    PAIR }\n"

(* Client_proto_context.originate expects the contract script as a Script.expr *)
let multisig_script : Script.expr tzresult =
  Tezos_micheline.Micheline_parser.no_parsing_error
  @@ Michelson_v1_parser.parse_toplevel
       ?check:(Some true)
       multisig_script_string
  >>? fun parsing_result -> ok parsing_result.Michelson_v1_parser.expanded

let multisig_script_hash =
  multisig_script
  >>? fun mcontract ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn Script.expr_encoding mcontract
  in
  let hash = Script_expr_hash.hash_bytes [bytes] in
  ok hash

(* The previous multisig script is the only one that the client can
   originate but the client knows how to interact with several
   versions of the multisig contract. For each version, the description
   indicates which features are available and how to interact with
   the contract. *)

type multisig_contract_description = {
  hash : Script_expr_hash.t;
  (* The hash of the contract script *)
  requires_chain_id : bool;
  (* The signatures should contain the chain identifier *)
  generic : bool;
      (* False means that the contract uses a custom action type, true
                       means that the contract expects the action as a (lambda unit
                       (list operation)). *)
}

let script_hash_of_hex_string s =
  Script_expr_hash.of_bytes_exn @@ MBytes.of_hex @@ `Hex s

(* List of known multisig contracts hashes with their kinds *)
let known_multisig_contracts : multisig_contract_description list tzresult =
  multisig_script_hash
  >>? fun hash ->
  ok
    [ {hash; requires_chain_id = true; generic = false};
      {
        hash =
          script_hash_of_hex_string
            "36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94";
        requires_chain_id = true;
        generic = false;
      };
      {
        hash =
          script_hash_of_hex_string
            "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31";
        requires_chain_id = false;
        generic = false;
      } ]

let known_multisig_hashes =
  known_multisig_contracts
  >>? fun l -> ok (List.map (fun descr -> descr.hash) l)

let check_multisig_script script : multisig_contract_description tzresult Lwt.t
    =
  let bytes = Data_encoding.force_bytes script in
  let hash = Script_expr_hash.hash_bytes [bytes] in
  Lwt.return known_multisig_contracts
  >>=? fun l ->
  fold_left_s
    (fun descr_opt d ->
      return
      @@
      match descr_opt with
      | Some descr ->
          Some descr
      | None ->
          if Script_expr_hash.(d.hash = hash) then Some d else None)
    None
    l
  >>=? function
  | None ->
      fail
        (Not_a_supported_multisig_contract
           ( hash,
             match Data_encoding.force_decode script with
             | Some s ->
                 s
             | None ->
                 assert false ))
  | Some d ->
      return d

(* Returns [Ok ()] if [~contract] is an originated contract whose code
   is [multisig_script] *)
let check_multisig_contract (cctxt : #Protocol_client_context.full) ~chain
    ~block contract =
  Client_proto_context.get_script cctxt ~chain ~block contract
  >>=? fun script_opt ->
  ( match script_opt with
  | Some script ->
      return script.code
  | None ->
      fail (Contract_has_no_script contract) )
  >>=? check_multisig_script

let seq ~loc l = Tezos_micheline.Micheline.Seq (loc, l)

let pair ~loc a b =
  Tezos_micheline.Micheline.Prim (loc, Script.D_Pair, [a; b], [])

let none ~loc () = Tezos_micheline.Micheline.Prim (loc, Script.D_None, [], [])

let some ~loc a = Tezos_micheline.Micheline.Prim (loc, Script.D_Some, [a], [])

let left ~loc a = Tezos_micheline.Micheline.Prim (loc, Script.D_Left, [a], [])

let right ~loc b = Tezos_micheline.Micheline.Prim (loc, Script.D_Right, [b], [])

let int ~loc i = Tezos_micheline.Micheline.Int (loc, i)

let bytes ~loc s = Tezos_micheline.Micheline.Bytes (loc, s)

(** * Actions *)

type multisig_action =
  | Transfer of Tez.t * Contract.t
  | Change_delegate of public_key_hash option
  | Change_keys of Z.t * public_key list

let action_to_expr ~loc = function
  | Transfer (amount, destination) ->
      left
        ~loc
        (pair
           ~loc
           (int ~loc (Z.of_int64 (Tez.to_mutez amount)))
           (bytes
              ~loc
              (Data_encoding.Binary.to_bytes_exn Contract.encoding destination)))
  | Change_delegate delegate_opt ->
      right
        ~loc
        (left
           ~loc
           ( match delegate_opt with
           | None ->
               none ~loc ()
           | Some delegate ->
               some
                 ~loc
                 (bytes
                    ~loc
                    (Data_encoding.Binary.to_bytes_exn
                       Signature.Public_key_hash.encoding
                       delegate)) ))
  | Change_keys (threshold, keys) ->
      right
        ~loc
        (right
           ~loc
           (pair
              ~loc
              (int ~loc threshold)
              (seq
                 ~loc
                 (List.map
                    (fun k ->
                      bytes
                        ~loc
                        (Data_encoding.Binary.to_bytes_exn
                           Signature.Public_key.encoding
                           k))
                    keys))))

let action_of_expr e =
  let fail () =
    Error_monad.fail
      (Action_deserialisation_error
         (Tezos_micheline.Micheline.strip_locations e))
  in
  match e with
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Left,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Pair,
              [ Tezos_micheline.Micheline.Int (_, i);
                Tezos_micheline.Micheline.Bytes (_, s) ],
              [] ) ],
        [] ) -> (
    match Tez.of_mutez (Z.to_int64 i) with
    | None ->
        fail ()
    | Some amount ->
        return
        @@ Transfer
             (amount, Data_encoding.Binary.of_bytes_exn Contract.encoding s) )
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Left,
              [Tezos_micheline.Micheline.Prim (_, Script.D_None, [], [])],
              [] ) ],
        [] ) ->
      return @@ Change_delegate None
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Left,
              [ Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Some,
                    [Tezos_micheline.Micheline.Bytes (_, s)],
                    [] ) ],
              [] ) ],
        [] ) ->
      return
      @@ Change_delegate
           (Some
              (Data_encoding.Binary.of_bytes_exn
                 Signature.Public_key_hash.encoding
                 s))
  | Tezos_micheline.Micheline.Prim
      ( _,
        Script.D_Right,
        [ Tezos_micheline.Micheline.Prim
            ( _,
              Script.D_Right,
              [ Tezos_micheline.Micheline.Prim
                  ( _,
                    Script.D_Pair,
                    [ Tezos_micheline.Micheline.Int (_, threshold);
                      Tezos_micheline.Micheline.Seq (_, key_bytes) ],
                    [] ) ],
              [] ) ],
        [] ) ->
      map_s
        (function
          | Tezos_micheline.Micheline.Bytes (_, s) ->
              return
              @@ Data_encoding.Binary.of_bytes_exn
                   Signature.Public_key.encoding
                   s
          | _ ->
              fail ())
        key_bytes
      >>=? fun keys -> return @@ Change_keys (threshold, keys)
  | _ ->
      fail ()

type key_list = Signature.Public_key.t list

(* The relevant information that we can get about a multisig smart contract *)
type multisig_contract_information = {
  counter : Z.t;
  threshold : Z.t;
  keys : key_list;
}

let multisig_get_information (cctxt : #Protocol_client_context.full) ~chain
    ~block contract =
  let open Client_proto_context in
  let open Tezos_micheline.Micheline in
  get_storage cctxt ~chain ~block contract
  >>=? fun storage_opt ->
  match storage_opt with
  | None ->
      fail (Contract_has_no_storage contract)
  | Some storage -> (
    match root storage with
    | Prim
        ( _,
          D_Pair,
          [ Int (_, counter);
            Prim (_, D_Pair, [Int (_, threshold); Seq (_, key_nodes)], _) ],
          _ ) ->
        map_s
          (function
            | String (_, key_str) ->
                return @@ Signature.Public_key.of_b58check_exn key_str
            | _ ->
                fail (Contract_has_unexpected_storage contract))
          key_nodes
        >>=? fun keys -> return {counter; threshold; keys}
    | _ ->
        fail (Contract_has_unexpected_storage contract) )

let multisig_create_storage ~counter ~threshold ~keys () :
    Script.expr tzresult Lwt.t =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let open Tezos_micheline.Micheline in
  map_s
    (fun key ->
      let key_str = Signature.Public_key.to_b58check key in
      return (String (loc, key_str)))
    keys
  >>=? fun l ->
  return @@ strip_locations
  @@ pair ~loc (int ~loc counter) (pair ~loc (int ~loc threshold) (seq ~loc l))

(* Client_proto_context.originate expects the initial storage as a string *)
let multisig_storage_string ~counter ~threshold ~keys () =
  multisig_create_storage ~counter ~threshold ~keys ()
  >>=? fun expr ->
  return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr

let multisig_create_param ~counter ~action ~optional_signatures () :
    Script.expr tzresult Lwt.t =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let open Tezos_micheline.Micheline in
  map_s
    (fun sig_opt ->
      match sig_opt with
      | None ->
          return @@ none ~loc ()
      | Some signature ->
          return @@ some ~loc (String (loc, Signature.to_b58check signature)))
    optional_signatures
  >>=? fun l ->
  return @@ strip_locations
  @@ pair
       ~loc
       (pair ~loc (int ~loc counter) (action_to_expr ~loc action))
       (Seq (loc, l))

let mutlisig_param_string ~counter ~action ~optional_signatures () =
  multisig_create_param ~counter ~action ~optional_signatures ()
  >>=? fun expr ->
  return @@ Format.asprintf "%a" Michelson_v1_printer.print_expr expr

let get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract =
  let address =
    bytes ~loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract)
  in
  if descr.requires_chain_id then
    let chain_id_bytes =
      bytes ~loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id)
    in
    pair ~loc chain_id_bytes address
  else address

let multisig_bytes ~counter ~action ~contract ~chain_id ~descr () =
  let loc = Tezos_micheline.Micheline_parser.location_zero in
  let triple =
    pair
      ~loc
      (get_contract_address_maybe_chain_id ~descr ~loc ~chain_id contract)
      (pair ~loc (int ~loc counter) (action_to_expr ~loc action))
  in
  let bytes =
    Data_encoding.Binary.to_bytes_exn Script.expr_encoding
    @@ Tezos_micheline.Micheline.strip_locations @@ triple
  in
  return @@ Bytes.concat (Bytes.of_string "") [Bytes.of_string "\005"; bytes]

let check_threshold ~threshold ~keys () =
  let nkeys = List.length keys in
  let threshold = Z.to_int threshold in
  if Compare.Int.(List.length keys < threshold) then
    fail (Threshold_too_high (threshold, nkeys))
  else if Compare.Int.(threshold <= 0) then
    fail (Non_positive_threshold threshold)
  else return_unit

let originate_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?branch ?fee ?gas_limit ?storage_limit ~delegate
    ~threshold ~keys ~balance ~source ~src_pk ~src_sk ~fee_parameter () =
  Lwt.return multisig_script
  >>=? fun code ->
  multisig_storage_string ~counter:Z.zero ~threshold ~keys ()
  >>=? fun initial_storage ->
  check_threshold ~threshold ~keys ()
  >>=? fun () ->
  Client_proto_context.originate_contract
    cctxt
    ~chain
    ~block
    ?branch
    ?confirmations
    ?dry_run
    ?fee
    ?gas_limit
    ?storage_limit
    ~delegate
    ~initial_storage
    ~balance
    ~source
    ~src_pk
    ~src_sk
    ~code
    ~fee_parameter
    ()

type multisig_prepared_action = {
  bytes : Bytes.t;
  threshold : Z.t;
  keys : public_key list;
  counter : Z.t;
}

let check_action ~action () =
  match action with
  | Change_keys (threshold, keys) ->
      check_threshold ~threshold ~keys ()
  | _ ->
      return_unit

let prepare_multisig_transaction (cctxt : #Protocol_client_context.full) ~chain
    ~block ~multisig_contract ~action () =
  let contract = multisig_contract in
  check_multisig_contract cctxt ~chain ~block contract
  >>=? fun descr ->
  check_action ~action ()
  >>=? fun () ->
  multisig_get_information cctxt ~chain ~block contract
  >>=? fun {counter; threshold; keys} ->
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  multisig_bytes ~counter ~action ~contract ~descr ~chain_id ()
  >>=? fun bytes -> return {bytes; threshold; keys; counter}

let check_multisig_signatures ~bytes ~threshold ~keys signatures =
  let key_array = Array.of_list keys in
  let nkeys = Array.length key_array in
  let opt_sigs_arr = Array.make nkeys None in
  let matching_key_found = ref false in
  let check_signature_against_key_number signature i key =
    _when (Signature.check key signature bytes) (fun () ->
        return
        @@
        ( matching_key_found := true ;
          opt_sigs_arr.(i) <- Some signature ))
  in
  iter_p
    (fun signature ->
      return @@ (matching_key_found := false)
      >>=? fun () ->
      iteri_p (check_signature_against_key_number signature) keys
      >>=? fun () ->
      fail_unless !matching_key_found (Invalid_signature signature))
    signatures
  >>=? fun () ->
  let opt_sigs = Array.to_list opt_sigs_arr in
  let signature_count =
    List.fold_left
      (fun n sig_opt -> match sig_opt with Some _ -> n + 1 | None -> n)
      0
      opt_sigs
  in
  let threshold_int = Z.to_int threshold in
  if signature_count >= threshold_int then return opt_sigs
  else fail (Not_enough_signatures (threshold_int, signature_count))

let call_multisig (cctxt : #Protocol_client_context.full) ~chain ~block
    ?confirmations ?dry_run ?branch ~source ~src_pk ~src_sk ~multisig_contract
    ~action ~signatures ~amount ?fee ?gas_limit ?storage_limit ?counter
    ~fee_parameter () =
  prepare_multisig_transaction
    cctxt
    ~chain
    ~block
    ~multisig_contract
    ~action
    ()
  >>=? fun {bytes; threshold; keys; counter = stored_counter} ->
  check_multisig_signatures ~bytes ~threshold ~keys signatures
  >>=? fun optional_signatures ->
  mutlisig_param_string ~counter:stored_counter ~action ~optional_signatures ()
  >>=? fun arg ->
  Client_proto_context.transfer
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?branch
    ~source
    ~src_pk
    ~src_sk
    ~destination:multisig_contract
    ~arg
    ~amount
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~fee_parameter
    ()

let action_of_bytes ~multisig_contract ~stored_counter ~descr ~chain_id bytes =
  if
    Compare.Int.(Bytes.length bytes >= 1)
    && Compare.Int.(TzEndian.get_uint8 bytes 0 = 0x05)
  then
    let nbytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
    match Data_encoding.Binary.of_bytes Script.expr_encoding nbytes with
    | None ->
        fail (Bytes_deserialisation_error bytes)
    | Some e -> (
      match Tezos_micheline.Micheline.root e with
      | Tezos_micheline.Micheline.Prim
          ( _,
            Script.D_Pair,
            [ Tezos_micheline.Micheline.Bytes (_, contract_bytes);
              Tezos_micheline.Micheline.Prim
                ( _,
                  Script.D_Pair,
                  [Tezos_micheline.Micheline.Int (_, counter); e],
                  [] ) ],
            [] )
        when not descr.requires_chain_id ->
          let contract =
            Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
          in
          if counter = stored_counter then
            if multisig_contract = contract then action_of_expr e
            else fail (Bad_deserialized_contract (contract, multisig_contract))
          else fail (Bad_deserialized_counter (counter, stored_counter))
      | Tezos_micheline.Micheline.Prim
          ( _,
            Script.D_Pair,
            [ Tezos_micheline.Micheline.Prim
                ( _,
                  Script.D_Pair,
                  [ Tezos_micheline.Micheline.Bytes (_, chain_id_bytes);
                    Tezos_micheline.Micheline.Bytes (_, contract_bytes) ],
                  [] );
              Tezos_micheline.Micheline.Prim
                ( _,
                  Script.D_Pair,
                  [Tezos_micheline.Micheline.Int (_, counter); e],
                  [] ) ],
            [] )
        when descr.requires_chain_id ->
          let contract =
            Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes
          in
          let cid =
            Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes
          in
          if counter = stored_counter then
            if multisig_contract = contract && chain_id = cid then
              action_of_expr e
            else fail (Bad_deserialized_contract (contract, multisig_contract))
          else fail (Bad_deserialized_counter (counter, stored_counter))
      | _ ->
          fail (Bytes_deserialisation_error bytes) )
  else fail (Bytes_deserialisation_error bytes)

let call_multisig_on_bytes (cctxt : #Protocol_client_context.full) ~chain
    ~block ?confirmations ?dry_run ?branch ~source ~src_pk ~src_sk
    ~multisig_contract ~bytes ~signatures ~amount ?fee ?gas_limit
    ?storage_limit ?counter ~fee_parameter () =
  multisig_get_information cctxt ~chain ~block multisig_contract
  >>=? fun info ->
  check_multisig_contract cctxt ~chain ~block multisig_contract
  >>=? fun descr ->
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  action_of_bytes
    ~multisig_contract
    ~stored_counter:info.counter
    ~chain_id
    ~descr
    bytes
  >>=? fun action ->
  call_multisig
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?branch
    ~source
    ~src_pk
    ~src_sk
    ~multisig_contract
    ~action
    ~signatures
    ~amount
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~fee_parameter
    ()
src/proto_alpha/lib_client/client_proto_multisig.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol_client_context.

Import Protocol.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition multisig_script_string : string :=
  "parameter (pair
             (pair :payload
                (nat %counter) # counter, used to prevent replay attacks
                (or :action    # payload to sign, represents the requested action
                   (pair :transfer    # transfer tokens
                      (mutez %amount) # amount to transfer
                      (contract %dest unit)) # destination to transfer to
                   (or
                      (option %delegate key_hash) # change the delegate to this address
                      (pair %change_keys          # change the keys controlling the multisig
                         (nat %threshold)         # new threshold
                         (list %keys key)))))     # new list of keys
             (list %sigs (option signature)));    # signatures

storage (pair (nat %stored_counter) (pair (nat %threshold) (list %keys key))) ;

code
  {
    UNPAIR ; SWAP ; DUP ; DIP { SWAP } ;
    DIP
      {
        UNPAIR ;
        # pair the payload with the current contract address, to ensure signatures
        # can't be replayed accross different contracts if a key is reused.
        DUP ; SELF ; ADDRESS ; CHAIN_ID ; PAIR ; PAIR ;
        PACK ; # form the binary payload that we expect to be signed
        DIP { UNPAIR @counter ; DIP { SWAP } } ; SWAP
      } ;

    # Check that the counters match
    UNPAIR @stored_counter; DIP { SWAP };
    ASSERT_CMPEQ ;

    # Compute the number of valid signatures
    DIP { SWAP } ; UNPAIR @threshold @keys;
    DIP
      {
        # Running count of valid signatures
        PUSH @valid nat 0; SWAP ;
        ITER
          {
            DIP { SWAP } ; SWAP ;
            IF_CONS
              {
                IF_SOME
                  { SWAP ;
                    DIP
                      {
                        SWAP ; DIIP { DUUP } ;
                        # Checks signatures, fails if invalid
                        { DUUUP; DIP {CHECK_SIGNATURE}; SWAP; IF {DROP} {FAILWITH} };
                        PUSH nat 1 ; ADD @valid } }
                  { SWAP ; DROP }
              }
              {
                # There were fewer signatures in the list
                # than keys. Not all signatures must be present, but
                # they should be marked as absent using the option type.
                FAIL
              } ;
            SWAP
          }
      } ;
    # Assert that the threshold is less than or equal to the
    # number of valid signatures.
    ASSERT_CMPLE ;
    DROP ; DROP ;

    # Increment counter and place in storage
    DIP { UNPAIR ; PUSH nat 1 ; ADD @new_counter ; PAIR} ;

    # We have now handled the signature verification part,
    # produce the operation requested by the signers.
    NIL operation ; SWAP ;
    IF_LEFT
      { # Transfer tokens
        UNPAIR ; UNIT ; TRANSFER_TOKENS ; CONS }
      { IF_LEFT {
                  # Change delegate
                  SET_DELEGATE ; CONS }
                {
                  # Change set of signatures
                  DIP { SWAP ; CAR } ; SWAP ; PAIR ; SWAP }} ;
    PAIR }
"
    % string.

Definition multisig_script
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
  op_gtgtquestion
    (apply Tezos_micheline.Micheline_parser.no_parsing_error
      (Michelson_v1_parser.parse_toplevel (Some true) multisig_script_string))
    (fun parsing_result => ok (Michelson_v1_parser.expanded parsing_result)).

Definition multisig_script_hash
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_alpha.Protocol.Script_expr_hash.t :=
  op_gtgtquestion multisig_script
    (fun mcontract =>
      let bytes :=
        Data_encoding.Binary.to_bytes_exn Script.expr_encoding mcontract in
      let hash := Script_expr_hash.hash_bytes None (cons string []) in
      ok hash).

Record multisig_contract_description := {
  hash : Tezos_protocol_alpha.Protocol.Script_expr_hash.t;
  requires_chain_id : bool;
  generic : bool }.

Definition script_hash_of_hex_string (s : string)
  : Tezos_protocol_alpha.Protocol.Script_expr_hash.t :=
  apply Script_expr_hash.of_bytes_exn
    (apply MBytes.of_hex
      (* ❌ Variants not supported *)
      variant).

Definition known_multisig_contracts
  : Tezos_base__TzPervasives.tzresult (list multisig_contract_description) :=
  op_gtgtquestion multisig_script_hash
    (fun hash =>
      ok
        (cons {| hash := hash; requires_chain_id := true; generic := false |}
          (cons
            {|
              hash :=
                script_hash_of_hex_string
                  "36cf0b376c2d0e21f0ed42b2974fedaafdcafb9b7f8eb9254ef811b37cb46d94"
                    % string; requires_chain_id := true; generic := false |}
            (cons
              {|
                hash :=
                  script_hash_of_hex_string
                    "475e37a6386d0b85890eb446db1faad67f85fc814724ad07473cac8c0a124b31"
                      % string; requires_chain_id := false; generic := false |}
              [])))).

Definition known_multisig_hashes
  : Tezos_base__TzPervasives.tzresult
    (list Tezos_protocol_alpha.Protocol.Script_expr_hash.t) :=
  op_gtgtquestion known_multisig_contracts
    (fun l => ok (List.map (fun descr => hash descr) l)).

Definition check_multisig_script
  (script :
    Tezos_base__TzPervasives.Data_encoding.lazy_t
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_description) :=
  let bytes := Data_encoding.force_bytes script in
  let hash := Script_expr_hash.hash_bytes None (cons string []) in
  op_gtgteqquestion (Lwt._return known_multisig_contracts)
    (fun l =>
      op_gtgteqquestion
        (fold_left_s
          (fun descr_opt =>
            fun d =>
              apply _return
                match descr_opt with
                | Some descr => Some descr
                | None =>
                  if op_eq (hash d) hash then
                    Some d
                  else
                    None
                end) None l)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            fail
              (Tezos_base__TzPervasives.Not_a_supported_multisig_contract
                (hash,
                  match Data_encoding.force_decode script with
                  | Some s => s
                  | None =>
                    (* ❌ Assert instruction is not handled. *)
                    assert false
                  end))
          | Some d => _return d
          end)).

Definition check_multisig_contract {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_description) :=
  op_gtgteqquestion (Client_proto_context.get_script cctxt chain block contract)
    (fun script_opt =>
      op_gtgteqquestion
        match script_opt with
        | Some script => _return (code script)
        | None =>
          fail (Tezos_base__TzPervasives.Contract_has_no_script contract)
        end check_multisig_script).

Definition seq {A B : Type}
  (loc : A) (l : list (Tezos_micheline.Micheline.node A B))
  : Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Seq loc l.

Definition pair {A : Type}
  (loc : A)
  (a :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  (b :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
    (cons a (cons b [])) [].

Definition none {A : Type} (loc : A) (function_parameter : unit)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  let 'tt := function_parameter in
  Tezos_micheline.Micheline.Prim loc
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_None [] [].

Definition some {A : Type}
  (loc : A)
  (a :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Some (cons a []) [].

Definition left {A : Type}
  (loc : A)
  (a :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left (cons a []) [].

Definition right {A : Type}
  (loc : A)
  (b :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  Tezos_micheline.Micheline.Prim loc
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right (cons b []) [].

Definition int {A B : Type} (loc : A) (i : Z.t)
  : Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Int loc i.

Definition bytes {A B : Type} (loc : A) (s : Stdlib.Bytes.t)
  : Tezos_micheline.Micheline.node A B := Tezos_micheline.Micheline.Bytes loc s.

Inductive multisig_action : Type :=
| Transfer : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
  Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> multisig_action
| Change_delegate :
  (option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
  multisig_action
| Change_keys : Z.t ->
  (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key) ->
  multisig_action.

Definition action_to_expr {A : Type}
  (loc : A) (function_parameter : multisig_action)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  match function_parameter with
  | Transfer amount destination =>
    left loc
      (pair loc (Z loc (Z.of_int64 (Tez.to_mutez amount)))
        (string loc
          (Data_encoding.Binary.to_bytes_exn Contract.encoding destination)))
  | Change_delegate delegate_opt =>
    right loc
      (left loc
        match delegate_opt with
        | None => none loc tt
        | Some delegate =>
          some loc
            (string loc
              (Data_encoding.Binary.to_bytes_exn
                Signature.Public_key_hash.encoding delegate))
        end)
  | Change_keys threshold keys =>
    right loc
      (right loc
        (pair loc (Z loc threshold)
          (seq loc
            (List.map
              (fun k =>
                string loc
                  (Data_encoding.Binary.to_bytes_exn
                    Signature.Public_key.encoding k)) keys))))
  end.

Definition action_of_expr {A : Type}
  (e :
    Tezos_micheline.Micheline.node A
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult multisig_action) :=
  let fail {B : Type} (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult B) :=
    let 'tt := function_parameter in
    Error_monad.fail
      (Tezos_base__TzPervasives.Action_deserialisation_error
        (Tezos_micheline.Micheline.strip_locations e)) in
  match e with
  |
    Tezos_micheline.Micheline.Prim _
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left
      (cons
        (Tezos_micheline.Micheline.Prim _
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
          (cons (Tezos_micheline.Micheline.Int _ i)
            (cons (Tezos_micheline.Micheline.Bytes _ s) [])) []) []) [] =>
    match Tez.of_mutez (Z.to_int64 i) with
    | None => fail tt
    | Some amount =>
      apply _return
        (Transfer amount (Data_encoding.Binary.of_bytes_exn Contract.encoding s))
    end
  |
    Tezos_micheline.Micheline.Prim _
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
      (cons
        (Tezos_micheline.Micheline.Prim _
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left
          (cons
            (Tezos_micheline.Micheline.Prim _
              Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_None [] [])
            []) []) []) [] => apply _return (Change_delegate None)
  |
    Tezos_micheline.Micheline.Prim _
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
      (cons
        (Tezos_micheline.Micheline.Prim _
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Left
          (cons
            (Tezos_micheline.Micheline.Prim _
              Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Some
              (cons (Tezos_micheline.Micheline.Bytes _ s) []) []) []) []) []) []
    =>
    apply _return
      (Change_delegate
        (Some
          (Data_encoding.Binary.of_bytes_exn Signature.Public_key_hash.encoding
            s)))
  |
    Tezos_micheline.Micheline.Prim _
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
      (cons
        (Tezos_micheline.Micheline.Prim _
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Right
          (cons
            (Tezos_micheline.Micheline.Prim _
              Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
              (cons (Tezos_micheline.Micheline.Int _ threshold)
                (cons (Tezos_micheline.Micheline.Seq _ key_bytes) [])) []) [])
          []) []) [] =>
    op_gtgteqquestion
      (map_s
        (fun function_parameter =>
          match function_parameter with
          | Tezos_micheline.Micheline.Bytes _ s =>
            apply _return
              (Data_encoding.Binary.of_bytes_exn Signature.Public_key.encoding s)
          | _ => fail tt
          end) key_bytes)
      (fun keys => apply _return (Change_keys threshold keys))
  | _ => fail tt
  end.

Definition key_list := list Tezos_base__TzPervasives.Signature.Public_key.t.

Record multisig_contract_information := {
  counter : Z.t;
  threshold : Z.t;
  keys : key_list }.

Definition multisig_get_information {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_contract_information) :=
  op_gtgteqquestion (get_storage cctxt chain block contract)
    (fun storage_opt =>
      match storage_opt with
      | None => fail (Tezos_base__TzPervasives.Contract_has_no_storage contract)
      | Some storage =>
        match root storage with
        |
          Tezos_micheline.Micheline.Prim _
            Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
            (cons (Tezos_micheline.Micheline.Int _ counter)
              (cons
                (Tezos_micheline.Micheline.Prim _
                  Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
                  (cons (Tezos_micheline.Micheline.Int _ threshold)
                    (cons (Tezos_micheline.Micheline.Seq _ key_nodes) [])) _) []))
            _ =>
          op_gtgteqquestion
            (map_s
              (fun function_parameter =>
                match function_parameter with
                | Tezos_micheline.Micheline.String _ key_str =>
                  apply _return (Signature.Public_key.of_b58check_exn key_str)
                | _ =>
                  fail
                    (Tezos_base__TzPervasives.Contract_has_unexpected_storage
                      contract)
                end) key_nodes)
            (fun keys =>
              _return
                {| counter := counter; threshold := threshold; keys := keys |})
        | _ =>
          fail
            (Tezos_base__TzPervasives.Contract_has_unexpected_storage contract)
        end
      end).

Definition multisig_create_storage
  (counter : Z.t) (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) :=
  let 'tt := function_parameter in
  let loc := Tezos_micheline.Micheline_parser.location_zero in
  op_gtgteqquestion
    (map_s
      (fun key =>
        let key_str := Signature.Public_key.to_b58check key in
        _return (Tezos_micheline.Micheline.String loc key_str)) keys)
    (fun l =>
      apply _return
        (apply strip_locations
          (pair loc (Z loc counter) (pair loc (Z loc threshold) (seq loc l))))).

Definition multisig_storage_string
  (counter : Z.t) (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (multisig_create_storage counter threshold keys tt)
    (fun expr =>
      apply _return
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Michelson_v1_printer.print_expr expr)).

Definition multisig_create_param
  (counter : Z.t) (action : multisig_action)
  (optional_signatures : list (option Tezos_base__TzPervasives.Signature.t))
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr) :=
  let 'tt := function_parameter in
  let loc := Tezos_micheline.Micheline_parser.location_zero in
  op_gtgteqquestion
    (map_s
      (fun sig_opt =>
        match sig_opt with
        | None => apply _return (none loc tt)
        | Some signature =>
          apply _return
            (some loc
              (Tezos_micheline.Micheline.String loc
                (Signature.to_b58check signature)))
        end) optional_signatures)
    (fun l =>
      apply _return
        (apply strip_locations
          (pair loc (pair loc (Z loc counter) (action_to_expr loc action))
            (Tezos_micheline.Micheline.Seq loc l)))).

Definition mutlisig_param_string
  (counter : Z.t) (action : multisig_action)
  (optional_signatures : list (option Tezos_base__TzPervasives.Signature.t))
  (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    (multisig_create_param counter action optional_signatures tt)
    (fun expr =>
      apply _return
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Michelson_v1_printer.print_expr expr)).

Definition get_contract_address_maybe_chain_id {A : Type}
  (descr : multisig_contract_description) (loc : A)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Tezos_micheline.Micheline.node A
    Tezos_protocol_alpha.Protocol.Alpha_context.Script.prim :=
  let address :=
    string loc (Data_encoding.Binary.to_bytes_exn Contract.encoding contract) in
  if requires_chain_id descr then
    let chain_id_bytes :=
      string loc (Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id)
      in
    pair loc chain_id_bytes address
  else
    address.

Definition multisig_bytes
  (counter : Z.t) (action : multisig_action)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t)
  (descr : multisig_contract_description) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
  let 'tt := function_parameter in
  let loc := Tezos_micheline.Micheline_parser.location_zero in
  let triple :=
    pair loc (get_contract_address_maybe_chain_id descr loc chain_id contract)
      (pair loc (Z loc counter) (action_to_expr loc action)) in
  let bytes :=
    apply (Data_encoding.Binary.to_bytes_exn Script.expr_encoding)
      (apply Tezos_micheline.Micheline.strip_locations triple) in
  apply _return
    (String.concat (Stdlib.Bytes.of_string "" % string)
      (cons (Stdlib.Bytes.of_string "" % string) (cons string []))).

Definition check_threshold {A : Type}
  (threshold : Z.t) (keys : list A) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let 'tt := function_parameter in
  let nkeys := List.length keys in
  let threshold := Z.to_int threshold in
  if op_lt (List.length keys) threshold then
    fail (Tezos_base__TzPervasives.Threshold_too_high threshold nkeys)
  else
    if op_lteq threshold 0 then
      fail (Tezos_base__TzPervasives.Non_positive_threshold threshold)
    else
      return_unit.

Definition originate_multisig {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (branch : option Z)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t)
  (delegate : option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.origination)) *
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (Lwt._return multisig_script)
    (fun code =>
      op_gtgteqquestion (multisig_storage_string Z.zero threshold keys tt)
        (fun initial_storage =>
          op_gtgteqquestion (check_threshold threshold keys tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Client_proto_context.originate_contract cctxt chain block
                confirmations dry_run None branch fee gas_limit storage_limit
                delegate initial_storage balance source src_pk src_sk code
                fee_parameter tt))).

Record multisig_prepared_action := {
  bytes : Stdlib.Bytes.t;
  threshold : Z.t;
  keys : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key;
  counter : Z.t }.

Definition check_action (action : multisig_action) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let 'tt := function_parameter in
  match action with
  | Change_keys threshold keys => check_threshold threshold keys tt
  | _ => return_unit
  end.

Definition prepare_multisig_transaction {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (action : multisig_action) (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_prepared_action) :=
  let 'tt := function_parameter in
  let contract := multisig_contract in
  op_gtgteqquestion (check_multisig_contract cctxt chain block contract)
    (fun descr =>
      op_gtgteqquestion (check_action action tt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (multisig_get_information cctxt chain block contract)
            (fun function_parameter =>
              let '{|
                counter := counter; threshold := threshold; keys := keys |} :=
                function_parameter in
              op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
                (fun chain_id =>
                  op_gtgteqquestion
                    (multisig_bytes counter action contract chain_id descr tt)
                    (fun bytes =>
                      _return
                        {| bytes := string; threshold := threshold;
                          keys := keys; counter := counter |}))))).

Definition check_multisig_signatures
  (bytes : Stdlib.Bytes.t) (threshold : Z.t)
  (keys : list Tezos_base__TzPervasives.Signature.Public_key.t)
  (signatures : list Tezos_base__TzPervasives.Signature.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (option Tezos_base__TzPervasives.Signature.t))) :=
  let key_array := Array.of_list keys in
  let nkeys := Array.length key_array in
  let opt_sigs_arr := Array.make nkeys None in
  let matching_key_found := Stdlib.ref false in
  let check_signature_against_key_number
    (signature : Tezos_base__TzPervasives.Signature.t) (i : Z) (key :
    Tezos_base__TzPervasives.Signature.Public_key.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    _when (Signature.check None key signature string)
      (fun function_parameter =>
        let 'tt := function_parameter in
        apply _return
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          (let _ := Stdlib.op_coloneq matching_key_found true in
          Array.set opt_sigs_arr i (Some signature))) in
  op_gtgteqquestion
    (iter_p
      (fun signature =>
        op_gtgteqquestion
          (apply _return (Stdlib.op_coloneq matching_key_found false))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (iteri_p (check_signature_against_key_number signature) keys)
              (fun function_parameter =>
                let 'tt := function_parameter in
                fail_unless (Stdlib.op_exclamation matching_key_found)
                  (Tezos_base__TzPervasives.Invalid_signature signature))))
      signatures)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let opt_sigs := Array.to_list opt_sigs_arr in
      let signature_count :=
        List.fold_left
          (fun n =>
            fun sig_opt =>
              match sig_opt with
              | Some _ => Z.add n 1
              | None => n
              end) 0 opt_sigs in
      let threshold_int := Z.to_int threshold in
      if OCaml.Stdlib.ge signature_count threshold_int then
        _return opt_sigs
      else
        fail
          (Tezos_base__TzPervasives.Not_enough_signatures threshold_int
            signature_count)).

Definition call_multisig {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (branch : option Z)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (action : multisig_action)
  (signatures : list Tezos_base__TzPervasives.Signature.t)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t) (counter : option Z.t)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)) *
        (list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    (prepare_multisig_transaction cctxt chain block multisig_contract action tt)
    (fun function_parameter =>
      let '{|
        bytes := bytes;
          threshold := threshold;
          keys := keys;
          counter := stored_counter
          |} := function_parameter in
      op_gtgteqquestion
        (check_multisig_signatures string threshold keys signatures)
        (fun optional_signatures =>
          op_gtgteqquestion
            (mutlisig_param_string stored_counter action optional_signatures tt)
            (fun arg =>
              Client_proto_context.transfer cctxt chain block confirmations
                dry_run None branch source src_pk src_sk multisig_contract None
                (Some arg) amount fee gas_limit storage_limit counter
                fee_parameter tt))).

Definition action_of_bytes
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (stored_counter : Tezos_protocol_alpha.Protocol.Alpha_context.counter)
  (descr : multisig_contract_description)
  (chain_id : Tezos_base__TzPervasives.Chain_id.t) (bytes : Stdlib.Bytes.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult multisig_action) :=
  if
    andb (op_gteq (String.length string) 1)
      (op_eq (TzEndian.get_uint8 string 0) 5) then
    let nbytes := String.sub string 1 (Z.sub (String.length string) 1) in
    match Data_encoding.Binary.of_bytes Script.expr_encoding nbytes with
    | None => fail (Tezos_base__TzPervasives.Bytes_deserialisation_error string)
    | Some e =>
      match Tezos_micheline.Micheline.root e with
      |
        Tezos_micheline.Micheline.Prim _
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
          (cons (Tezos_micheline.Micheline.Bytes _ contract_bytes)
            (cons
              (Tezos_micheline.Micheline.Prim _
                Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
                (cons (Tezos_micheline.Micheline.Int _ counter) (cons e [])) [])
              [])) [] =>
        let contract :=
          Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes in
        if equiv_decb counter stored_counter then
          if equiv_decb multisig_contract contract then
            action_of_expr e
          else
            fail
              (Tezos_base__TzPervasives.Bad_deserialized_contract
                (contract, multisig_contract))
        else
          fail
            (Tezos_base__TzPervasives.Bad_deserialized_counter
              (counter, stored_counter))
      |
        Tezos_micheline.Micheline.Prim _
          Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
          (cons
            (Tezos_micheline.Micheline.Prim _
              Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
              (cons (Tezos_micheline.Micheline.Bytes _ chain_id_bytes)
                (cons (Tezos_micheline.Micheline.Bytes _ contract_bytes) [])) [])
            (cons
              (Tezos_micheline.Micheline.Prim _
                Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Pair
                (cons (Tezos_micheline.Micheline.Int _ counter) (cons e [])) [])
              [])) [] =>
        let contract :=
          Data_encoding.Binary.of_bytes_exn Contract.encoding contract_bytes in
        let cid :=
          Data_encoding.Binary.of_bytes_exn Chain_id.encoding chain_id_bytes in
        if equiv_decb counter stored_counter then
          if
            andb (equiv_decb multisig_contract contract)
              (equiv_decb chain_id cid) then
            action_of_expr e
          else
            fail
              (Tezos_base__TzPervasives.Bad_deserialized_contract
                (contract, multisig_contract))
        else
          fail
            (Tezos_base__TzPervasives.Bad_deserialized_counter
              (counter, stored_counter))
      | _ => fail (Tezos_base__TzPervasives.Bytes_deserialisation_error string)
      end
    end
  else
    fail (Tezos_base__TzPervasives.Bytes_deserialisation_error string).

Definition call_multisig_on_bytes {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (dry_run : option bool) (branch : option Z)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_alpha.Protocol.Alpha_context.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (multisig_contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (bytes : Stdlib.Bytes.t)
  (signatures : list Tezos_base__TzPervasives.Signature.t)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (gas_limit : option Z.t) (storage_limit : option Z.t) (counter : option Z.t)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction)) *
        (list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    (multisig_get_information cctxt chain block multisig_contract)
    (fun info =>
      op_gtgteqquestion
        (check_multisig_contract cctxt chain block multisig_contract)
        (fun descr =>
          op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
            (fun chain_id =>
              op_gtgteqquestion
                (action_of_bytes multisig_contract (counter info) descr chain_id
                  string)
                (fun action =>
                  call_multisig cctxt chain block confirmations dry_run branch
                    source src_pk src_sk multisig_contract action signatures
                    amount fee gas_limit storage_limit counter fee_parameter tt)))).

src/proto_alpha/lib_client/client_proto_programs.ml 290 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Michelson_v1_printer

module Program = Client_aliases.Alias (struct
  type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result

  let encoding =
    Data_encoding.conv
      (fun ({Michelson_v1_parser.source; _}, _) -> source)
      (fun source -> Michelson_v1_parser.parse_toplevel source)
      Data_encoding.string

  let of_source source = return (Michelson_v1_parser.parse_toplevel source)

  let to_source ({Michelson_v1_parser.source; _}, _) = return source

  let name = "script"
end)

let print_errors (cctxt : #Client_context.printer) errs ~show_source ~parsed =
  cctxt#warning
    "%a"
    (Michelson_v1_error_reporter.report_errors
       ~details:false
       ~show_source
       ~parsed)
    errs
  >>= fun () -> cctxt#error "error running script" >>= fun () -> return_unit

let print_run_result (cctxt : #Client_context.printer) ~show_source ~parsed =
  function
  | Ok (storage, operations, maybe_diff) ->
      cctxt#message
        "@[<v 0>@[<v 2>storage@,\
         %a@]@,\
         @[<v 2>emitted operations@,\
         %a@]@,\
         @[<v 2>big_map diff@,\
         %a@]@]@."
        print_expr
        storage
        (Format.pp_print_list Operation_result.pp_internal_operation)
        operations
        (fun ppf -> function None -> () | Some diff ->
              print_big_map_diff ppf diff)
        maybe_diff
      >>= fun () -> return_unit
  | Error errs ->
      print_errors cctxt errs ~show_source ~parsed

let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
  function
  | Ok (storage, operations, trace, maybe_big_map_diff) ->
      cctxt#message
        "@[<v 0>@[<v 2>storage@,\
         %a@]@,\
         @[<v 2>emitted operations@,\
         %a@]@,\
         @[<v 2>big_map diff@,\
         %a@]@,\
         @[<v 2>trace@,\
         %a@]@]@."
        print_expr
        storage
        (Format.pp_print_list Operation_result.pp_internal_operation)
        operations
        (fun ppf -> function None -> () | Some diff ->
              print_big_map_diff ppf diff)
        maybe_big_map_diff
        print_execution_trace
        trace
      >>= fun () -> return_unit
  | Error errs ->
      print_errors cctxt errs ~show_source ~parsed

let run (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents)
    ~(program : Michelson_v1_parser.parsed)
    ~(storage : Michelson_v1_parser.parsed)
    ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas
    ?(entrypoint = "default") () =
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.run_code
    cctxt
    (chain, block)
    program.expanded
    ( storage.expanded,
      input.expanded,
      amount,
      chain_id,
      source,
      payer,
      gas,
      entrypoint )

let trace (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block ?(amount = Tez.fifty_cents)
    ~(program : Michelson_v1_parser.parsed)
    ~(storage : Michelson_v1_parser.parsed)
    ~(input : Michelson_v1_parser.parsed) ?source ?payer ?gas
    ?(entrypoint = "default") () =
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.trace_code
    cctxt
    (chain, block)
    program.expanded
    ( storage.expanded,
      input.expanded,
      amount,
      chain_id,
      source,
      payer,
      gas,
      entrypoint )

let typecheck_data cctxt ~(chain : Chain_services.chain) ~block ?gas
    ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) ()
    =
  Alpha_services.Helpers.Scripts.typecheck_data
    cctxt
    (chain, block)
    (data.expanded, ty.expanded, gas)

let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ?gas
    (program : Michelson_v1_parser.parsed) =
  Alpha_services.Helpers.Scripts.typecheck_code
    cctxt
    (chain, block)
    (program.expanded, gas)

let print_typecheck_result ~emacs ~show_types ~print_source_on_error program
    res (cctxt : #Client_context.printer) =
  if emacs then
    let (type_map, errs, _gas) =
      match res with
      | Ok (type_map, gas) ->
          (type_map, [], Some gas)
      | Error
          ( Environment.Ecoproto_error
              (Script_tc_errors.Ill_typed_contract (_, type_map))
            :: _ as errs ) ->
          (type_map, errs, None)
      | Error errs ->
          ([], errs, None)
    in
    cctxt#message
      "(@[<v 0>(types . %a)@ (errors . %a)@])"
      Michelson_v1_emacs.print_type_map
      (program, type_map)
      Michelson_v1_emacs.report_errors
      (program, errs)
    >>= fun () -> return_unit
  else
    match res with
    | Ok (type_map, gas) ->
        let program = Michelson_v1_printer.inject_types type_map program in
        cctxt#message "@[<v 0>Well typed@,Gas remaining: %a@]" Gas.pp gas
        >>= fun () ->
        if show_types then
          cctxt#message "%a" Micheline_printer.print_expr program
          >>= fun () -> return_unit
        else return_unit
    | Error errs ->
        cctxt#warning
          "%a"
          (Michelson_v1_error_reporter.report_errors
             ~details:show_types
             ~show_source:print_source_on_error
             ~parsed:program)
          errs
        >>= fun () -> cctxt#error "ill-typed script"

let entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) ~entrypoint =
  Michelson_v1_entrypoints.script_entrypoint_type
    cctxt
    ~chain
    ~block
    program.expanded
    ~entrypoint

let print_entrypoint_type (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ~entrypoint ty =
  Michelson_v1_entrypoints.print_entrypoint_type
    cctxt
    ~entrypoint
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty

let list_entrypoints cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) =
  Michelson_v1_entrypoints.list_entrypoints
    cctxt
    ~chain
    ~block
    program.expanded

let print_entrypoints_list (cctxt : #Client_context.printer) ~emacs
    ?script_name ~show_source ~parsed ty =
  Michelson_v1_entrypoints.print_entrypoints_list
    cctxt
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty

let list_unreachables cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) =
  Michelson_v1_entrypoints.list_unreachables
    cctxt
    ~chain
    ~block
    program.expanded

let print_unreachables (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ty =
  Michelson_v1_entrypoints.print_unreachables
    cctxt
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty
src/proto_alpha/lib_client/client_proto_programs.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Tezos_micheline.

Import Michelson_v1_printer.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition print_errors {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (errs : list Tezos_base__TzPervasives.Error_monad.error) (show_source : bool)
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    ((* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string)
      (Michelson_v1_error_reporter.report_errors false show_source (Some parsed))
      errs)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq
        ((* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "error running script" % string
              CamlinternalFormatBasics.End_of_format)
            "error running script" % string))
        (fun function_parameter =>
          let 'tt := function_parameter in
          return_unit)).

Definition print_run_result {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (show_source : bool)
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (function_parameter :
    sum
      (Tezos_protocol_alpha.Protocol.Script_repr.expr *
        (list
          Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
        *
        (option
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))
      (list Tezos_base__TzPervasives.Error_monad.error))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | Stdlib.Ok (storage, operations, maybe_diff) =>
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal "storage" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "emitted operations" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "big_map diff" % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Flush_newline
                                                  CamlinternalFormatBasics.End_of_format))))))))))))))))))))
          "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>emitted operations@,%a@]@,@[<v 2>big_map diff@,%a@]@]@."
            % string) print_expr storage
        (Format.pp_print_list None Operation_result.pp_internal_operation)
        operations
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | None => tt
            | Some diff => print_big_map_diff ppf diff
            end) maybe_diff)
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  | Stdlib.Error errs => print_errors cctxt errs show_source parsed
  end.

Definition print_trace_result {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (show_source : bool)
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (function_parameter :
    sum
      (Tezos_protocol_alpha.Protocol.Script_repr.expr *
        (list
          Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
        *
        (list
          (Tezos_protocol_alpha.Protocol.Alpha_context.Script.location *
            Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
            (list
              (Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr *
                (option string))))) *
        (option
          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff))
      (list Tezos_base__TzPervasives.Error_monad.error))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | Stdlib.Ok (storage, operations, trace, maybe_big_map_diff) =>
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal "storage" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "emitted operations" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "big_map diff" % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                (CamlinternalFormatBasics.Break
                                                  "@," % string 0 0)
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<v 2>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<v 2>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "trace" % string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@," % string 0 0)
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Formatting_lit
                                                          CamlinternalFormatBasics.Close_box
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Flush_newline
                                                              CamlinternalFormatBasics.End_of_format))))))))))))))))))))))))))
          "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>emitted operations@,%a@]@,@[<v 2>big_map diff@,%a@]@,@[<v 2>trace@,%a@]@]@."
            % string) print_expr storage
        (Format.pp_print_list None Operation_result.pp_internal_operation)
        operations
        (fun ppf =>
          fun function_parameter =>
            match function_parameter with
            | None => tt
            | Some diff => print_big_map_diff ppf diff
            end) maybe_big_map_diff print_execution_trace trace)
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  | Stdlib.Error errs => print_errors cctxt errs show_source parsed
  end.

Definition run {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_client_alpha.Michelson_v1_parser.parsed ->
    Tezos_client_alpha.Michelson_v1_parser.parsed ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
            (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
              (option string) ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                        (list
                          Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
                        *
                        (option
                          Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  let amount :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tez.fifty_cents
    end in
  fun program =>
    fun storage =>
      fun input =>
        fun source =>
          fun payer =>
            fun gas =>
              fun op_staroptstar =>
                let entrypoint :=
                  match op_staroptstar with
                  | Some op_starsthstar => op_starsthstar
                  | None => "default" % string
                  end in
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (Chain_services.chain_id cctxt (Some chain) tt)
                    (fun chain_id =>
                      Alpha_services.Helpers.Scripts.run_code cctxt
                        (chain, block) (expanded program)
                        ((expanded storage), (expanded input), amount, chain_id,
                          source, payer, gas, entrypoint)).

Definition trace {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_client_alpha.Michelson_v1_parser.parsed ->
    Tezos_client_alpha.Michelson_v1_parser.parsed ->
      Tezos_client_alpha.Michelson_v1_parser.parsed ->
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
            (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
              (option string) ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                        (list
                          Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
                        *
                        Tezos_raw_protocol_alpha.Script_interpreter.execution_trace
                        *
                        (option
                          Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  let amount :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tez.fifty_cents
    end in
  fun program =>
    fun storage =>
      fun input =>
        fun source =>
          fun payer =>
            fun gas =>
              fun op_staroptstar =>
                let entrypoint :=
                  match op_staroptstar with
                  | Some op_starsthstar => op_starsthstar
                  | None => "default" % string
                  end in
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (Chain_services.chain_id cctxt (Some chain) tt)
                    (fun chain_id =>
                      Alpha_services.Helpers.Scripts.trace_code cctxt
                        (chain, block) (expanded program)
                        ((expanded storage), (expanded input), amount, chain_id,
                          source, payer, gas, entrypoint)).

Definition typecheck_data {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (gas : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (data : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ty : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
  let 'tt := function_parameter in
  Alpha_services.Helpers.Scripts.typecheck_data cctxt (chain, block)
    ((expanded data), (expanded ty), gas).

Definition typecheck_program {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (gas : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
        Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
  Alpha_services.Helpers.Scripts.typecheck_code cctxt (chain, block)
    ((expanded program), gas).

Definition print_typecheck_result {C a b : Type}
  (emacs : bool) (show_types : bool) (print_source_on_error : bool)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (res :
    sum
      (Tezos_protocol_alpha.Protocol.Script_tc_errors.type_map *
        Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t)
      (list Tezos_base__TzPervasives.Error_monad.error))
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if emacs then
    let '(type_map, errs, _gas) :=
      match res with
      | Stdlib.Ok (type_map, gas) => (type_map, [], (Some gas))
      |
        Stdlib.Error
          ((cons
            (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
                _ type_map)) _) as errs) => (type_map, errs, None)
      | Stdlib.Error errs => ([], errs, None)
      end in
    op_gtgteq
      ((* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal "(types . " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.String_literal
                        "(errors . " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                CamlinternalFormatBasics.End_of_format)))))))))))
          "(@[<v 0>(types . %a)@ (errors . %a)@])" % string)
        Michelson_v1_emacs.print_type_map (program, type_map)
        Michelson_v1_emacs.report_errors (program, errs))
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  else
    match res with
    | Stdlib.Ok (type_map, gas) =>
      let program := Michelson_v1_printer.inject_types type_map program in
      op_gtgteq
        ((* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal "Well typed" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "Gas remaining: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@[<v 0>Well typed@,Gas remaining: %a@]" % string) Gas.pp gas)
        (fun function_parameter =>
          let 'tt := function_parameter in
          if show_types then
            op_gtgteq
              ((* ❌ Sending method message is not handled *)
              send
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                Micheline_printer.print_expr program)
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)
          else
            return_unit)
    | Stdlib.Error errs =>
      op_gtgteq
        ((* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          (Michelson_v1_error_reporter.report_errors show_types
            print_source_on_error (Some program)) errs)
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "ill-typed script" % string
                CamlinternalFormatBasics.End_of_format)
              "ill-typed script" % string))
    end.

Definition entrypoint_type {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (entrypoint : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)) :=
  Michelson_v1_entrypoints.script_entrypoint_type cctxt chain block
    (expanded program) entrypoint.

Definition print_entrypoint_type {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (emacs : bool) (script_name : option string)
  (show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (entrypoint : string)
  (ty :
    Tezos_base__TzPervasives.tzresult
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Michelson_v1_entrypoints.print_entrypoint_type cctxt
    (Some
      (print_errors cctxt
        (* ❌ expected an argument *)
        expected_argument show_source parsed)) emacs None script_name entrypoint
    ty.

Definition list_entrypoints {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr))) :=
  Michelson_v1_entrypoints.list_entrypoints cctxt chain block (expanded program).

Definition print_entrypoints_list {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (emacs : bool) (script_name : option string)
  (show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ty :
    Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Michelson_v1_entrypoints.print_entrypoints_list cctxt
    (Some
      (print_errors cctxt
        (* ❌ expected an argument *)
        expected_argument show_source parsed)) emacs None script_name ty.

Definition list_unreachables {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (program : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))) :=
  Michelson_v1_entrypoints.list_unreachables cctxt chain block
    (expanded program).

Definition print_unreachables {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (emacs : bool) (script_name : option string)
  (show_source : bool) (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ty :
    Tezos_base__TzPervasives.tzresult
      (list (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  Michelson_v1_entrypoints.print_unreachables cctxt
    (Some
      (print_errors cctxt
        (* ❌ expected an argument *)
        expected_argument show_source parsed)) emacs None script_name ty.

src/proto_alpha/lib_client/injection.ml 651 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2018 Nomadic Labs, <contact@nomadic-labs.com>               *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Apply_results
open Protocol_client_context

let get_branch (rpc_config : #Protocol_client_context.full) ~chain
    ~(block : Block_services.block) branch =
  let branch = Option.unopt ~default:0 branch in
  (* TODO export parameter *)
  ( match block with
  | `Head n ->
      return (`Head (n + branch))
  | `Hash (h, n) ->
      return (`Hash (h, n + branch))
  | `Alias (a, n) ->
      return (`Alias (a, n))
  | `Genesis ->
      return `Genesis
  | `Level i ->
      return (`Level i) )
  >>=? fun block ->
  Shell_services.Blocks.hash rpc_config ~chain ~block ()
  >>=? fun hash ->
  Shell_services.Chain.chain_id rpc_config ~chain ()
  >>=? fun chain_id -> return (chain_id, hash)

type 'kind preapply_result =
  Operation_hash.t * 'kind operation * 'kind operation_metadata

type 'kind result_list =
  Operation_hash.t * 'kind contents_list * 'kind contents_result_list

type 'kind result = Operation_hash.t * 'kind contents * 'kind contents_result

let get_manager_operation_gas_and_fee contents =
  let open Operation in
  let l = to_list (Contents_list contents) in
  List.fold_left
    (fun acc -> function
      | Contents (Manager_operation {fee; gas_limit; _}) -> (
        match acc with
        | Error _ as e ->
            e
        | Ok (total_fee, total_gas) -> (
          match Tez.(total_fee +? fee) with
          | Ok total_fee ->
              Ok (total_fee, Z.add total_gas gas_limit)
          | Error _ as e ->
              e ) ) | _ -> acc)
    (Ok (Tez.zero, Z.zero))
    l

type fee_parameter = {
  minimal_fees : Tez.t;
  minimal_nanotez_per_byte : Z.t;
  minimal_nanotez_per_gas_unit : Z.t;
  force_low_fee : bool;
  fee_cap : Tez.t;
  burn_cap : Tez.t;
}

let dummy_fee_parameter =
  {
    minimal_fees = Tez.zero;
    minimal_nanotez_per_byte = Z.zero;
    minimal_nanotez_per_gas_unit = Z.zero;
    force_low_fee = false;
    fee_cap = Tez.one;
    burn_cap = Tez.zero;
  }

let check_fees :
    type t.
    #Protocol_client_context.full ->
    fee_parameter ->
    t contents_list ->
    int ->
    unit Lwt.t =
 fun cctxt config op size ->
  match get_manager_operation_gas_and_fee op with
  | Error _ ->
      assert false (* FIXME *)
  | Ok (fee, gas) ->
      if Tez.compare fee config.fee_cap > 0 then
        cctxt#error
          "The proposed fee (%s%a) are higher than the configured fee cap \
           (%s%a).@\n\
          \ Use `--fee-cap %a` to emit this operation anyway."
          Client_proto_args.tez_sym
          Tez.pp
          fee
          Client_proto_args.tez_sym
          Tez.pp
          config.fee_cap
          Tez.pp
          fee
        >>= fun () -> exit 1
      else
        (* *)
        let fees_in_nanotez =
          Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
        in
        let minimal_fees_in_nanotez =
          Z.mul (Z.of_int64 (Tez.to_mutez config.minimal_fees)) (Z.of_int 1000)
        in
        let minimal_fees_for_gas_in_nanotez =
          Z.mul config.minimal_nanotez_per_gas_unit gas
        in
        let minimal_fees_for_size_in_nanotez =
          Z.mul config.minimal_nanotez_per_byte (Z.of_int size)
        in
        let estimated_fees_in_nanotez =
          Z.add
            minimal_fees_in_nanotez
            (Z.add
               minimal_fees_for_gas_in_nanotez
               minimal_fees_for_size_in_nanotez)
        in
        let estimated_fees =
          match
            Tez.of_mutez
              (Z.to_int64
                 (Z.div
                    (Z.add (Z.of_int 999) estimated_fees_in_nanotez)
                    (Z.of_int 1000)))
          with
          | None ->
              assert false
          | Some fee ->
              fee
        in
        if
          (not config.force_low_fee)
          && Z.compare fees_in_nanotez estimated_fees_in_nanotez < 0
        then
          cctxt#error
            "The proposed fee (%s%a) are lower than the fee that baker expect \
             by default (%s%a).@\n\
            \ Use `--force-low-fee` to emit this operation anyway."
            Client_proto_args.tez_sym
            Tez.pp
            fee
            Client_proto_args.tez_sym
            Tez.pp
            estimated_fees
          >>= fun () -> exit 1
        else Lwt.return_unit

let print_for_verbose_signing ppf ~watermark ~bytes ~branch ~contents =
  let open Format in
  pp_open_vbox ppf 0 ;
  let item f =
    pp_open_hovbox ppf 4 ;
    pp_print_string ppf "  * " ;
    f ppf () ;
    pp_close_box ppf () ;
    pp_print_cut ppf ()
  in
  let hash_pp l =
    fprintf ppf "%s" (Base58.raw_encode Blake2B.(hash_bytes l |> to_string))
  in
  item (fun ppf () ->
      pp_print_text ppf "Branch: " ;
      Block_hash.pp ppf branch) ;
  item (fun ppf () ->
      fprintf
        ppf
        "Watermark: `%a` (0x%s)"
        Signature.pp_watermark
        watermark
        (Hex.of_bytes (Signature.bytes_of_watermark watermark) |> Hex.show)) ;
  item (fun ppf () ->
      pp_print_text ppf "Operation bytes: " ;
      TzString.fold_left (* We split the bytes into lines for display: *)
        (fun n c ->
          pp_print_char ppf c ;
          if
            n < 72
            (* is the email-body standard width, ideal for copy-pasting. *)
          then n + 1
          else (pp_print_space ppf () ; 0))
        0
        (Hex.of_bytes bytes |> Hex.show)
      |> ignore) ;
  item (fun ppf () ->
      pp_print_text ppf "Blake 2B Hash (raw): " ;
      hash_pp [bytes]) ;
  item (fun ppf () ->
      pp_print_text
        ppf
        "Blake 2B Hash (ledger-style, with operation watermark): " ;
      hash_pp [Signature.bytes_of_watermark watermark; bytes]) ;
  let json =
    Data_encoding.Json.construct
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  item (fun ppf () ->
      pp_print_text ppf "JSON encoding: " ;
      Data_encoding.Json.pp ppf json) ;
  pp_close_box ppf ()

let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
    ?(verbose_signing = false) ?fee_parameter ?branch ?src_sk
    (contents : t contents_list) =
  get_branch cctxt ~chain ~block branch
  >>=? fun (chain_id, branch) ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  ( match src_sk with
  | None ->
      return_none
  | Some src_sk ->
      let watermark =
        match contents with
        | Single (Endorsement _) ->
            Signature.(Endorsement chain_id)
        | _ ->
            Signature.Generic_operation
      in
      ( if verbose_signing then
        cctxt#message
          "Pre-signature information (verbose signing):@.%t%!"
          (print_for_verbose_signing ~watermark ~bytes ~branch ~contents)
      else Lwt.return_unit )
      >>= fun () ->
      Client_keys.sign cctxt ~watermark src_sk bytes
      >>=? fun signature -> return_some signature )
  >>=? fun signature ->
  let op : _ Operation.t =
    {shell = {branch}; protocol_data = {contents; signature}}
  in
  let oph = Operation.hash op in
  let size = Bytes.length bytes + Signature.size in
  ( match fee_parameter with
  | Some fee_parameter ->
      check_fees cctxt fee_parameter contents size
  | None ->
      Lwt.return_unit )
  >>= fun () ->
  Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
    cctxt
    ~chain
    ~block
    [Operation.pack op]
  >>=? function
  | [(Operation_data op', Operation_metadata result)] -> (
    match
      ( Operation.equal op {shell = {branch}; protocol_data = op'},
        Apply_results.kind_equal_list contents result.contents )
    with
    | (Some Operation.Eq, Some Apply_results.Eq) ->
        return ((oph, op, result) : t preapply_result)
    | _ ->
        failwith "Unexpected result" )
  | _ ->
      failwith "Unexpected result"

let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
    ?branch (contents : t contents_list) =
  get_branch cctxt ~chain ~block branch
  >>=? fun (_chain_id, branch) ->
  let op : _ Operation.t =
    {shell = {branch}; protocol_data = {contents; signature = None}}
  in
  let oph = Operation.hash op in
  Chain_services.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.run_operation
    cctxt
    (chain, block)
    (Operation.pack op, chain_id)
  >>=? function
  | (Operation_data op', Operation_metadata result) -> (
    match
      ( Operation.equal op {shell = {branch}; protocol_data = op'},
        Apply_results.kind_equal_list contents result.contents )
    with
    | (Some Operation.Eq, Some Apply_results.Eq) ->
        return ((oph, op, result) : t preapply_result)
    | _ ->
        failwith "Unexpected result" )
  | _ ->
      failwith "Unexpected result"

let estimated_gas_single (type kind)
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let consumed_gas (type kind) (result : kind manager_operation_result) =
    match result with
    | Applied (Transaction_result {consumed_gas; _}) ->
        Ok consumed_gas
    | Applied (Origination_result {consumed_gas; _}) ->
        Ok consumed_gas
    | Applied (Reveal_result {consumed_gas}) ->
        Ok consumed_gas
    | Applied (Delegation_result {consumed_gas}) ->
        Ok consumed_gas
    | Skipped _ ->
        assert false
    | Backtracked (_, None) ->
        Ok Z.zero (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) ->
        Environment.wrap_error (Error errs)
    | Failed (_, errs) ->
        Environment.wrap_error (Error errs)
  in
  List.fold_left
    (fun acc (Internal_operation_result (_, r)) ->
      acc >>? fun acc -> consumed_gas r >>? fun gas -> Ok (Z.add acc gas))
    (consumed_gas operation_result)
    internal_operation_results

let estimated_storage_single (type kind) origination_size
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let storage_size_diff (type kind) (result : kind manager_operation_result) =
    match result with
    | Applied
        (Transaction_result
          {paid_storage_size_diff; allocated_destination_contract; _}) ->
        if allocated_destination_contract then
          Ok (Z.add paid_storage_size_diff origination_size)
        else Ok paid_storage_size_diff
    | Applied (Origination_result {paid_storage_size_diff; _}) ->
        Ok (Z.add paid_storage_size_diff origination_size)
    | Applied (Reveal_result _) ->
        Ok Z.zero
    | Applied (Delegation_result _) ->
        Ok Z.zero
    | Skipped _ ->
        assert false
    | Backtracked (_, None) ->
        Ok Z.zero (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) ->
        Environment.wrap_error (Error errs)
    | Failed (_, errs) ->
        Environment.wrap_error (Error errs)
  in
  List.fold_left
    (fun acc (Internal_operation_result (_, r)) ->
      acc
      >>? fun acc ->
      storage_size_diff r >>? fun storage -> Ok (Z.add acc storage))
    (storage_size_diff operation_result)
    internal_operation_results

let estimated_storage origination_size res =
  let rec estimated_storage : type kind. kind contents_result_list -> _ =
    function
    | Single_result (Manager_operation_result _ as res) ->
        estimated_storage_single origination_size res
    | Single_result _ ->
        Ok Z.zero
    | Cons_result (res, rest) ->
        estimated_storage_single origination_size res
        >>? fun storage1 ->
        estimated_storage rest >>? fun storage2 -> Ok (Z.add storage1 storage2)
  in
  estimated_storage res >>? fun diff -> Ok (Z.max Z.zero diff)

let originated_contracts_single (type kind)
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let originated_contracts (type kind) (result : kind manager_operation_result)
      =
    match result with
    | Applied (Transaction_result {originated_contracts; _}) ->
        Ok originated_contracts
    | Applied (Origination_result {originated_contracts; _}) ->
        Ok originated_contracts
    | Applied (Reveal_result _) ->
        Ok []
    | Applied (Delegation_result _) ->
        Ok []
    | Skipped _ ->
        assert false
    | Backtracked (_, None) ->
        Ok [] (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) ->
        Environment.wrap_error (Error errs)
    | Failed (_, errs) ->
        Environment.wrap_error (Error errs)
  in
  List.fold_left
    (fun acc (Internal_operation_result (_, r)) ->
      acc
      >>? fun acc ->
      originated_contracts r
      >>? fun contracts -> Ok (List.rev_append contracts acc))
    (originated_contracts operation_result >|? List.rev)
    internal_operation_results

let rec originated_contracts : type kind. kind contents_result_list -> _ =
  function
  | Single_result (Manager_operation_result _ as res) ->
      originated_contracts_single res >|? List.rev
  | Single_result _ ->
      Ok []
  | Cons_result (res, rest) ->
      originated_contracts_single res
      >>? fun contracts1 ->
      originated_contracts rest
      >>? fun contracts2 -> Ok (List.rev_append contracts1 contracts2)

let detect_script_failure : type kind. kind operation_metadata -> _ =
  let rec detect_script_failure : type kind. kind contents_result_list -> _ =
    let detect_script_failure_single (type kind)
        (Manager_operation_result
           {operation_result; internal_operation_results; _} :
          kind Kind.manager contents_result) =
      let detect_script_failure (type kind)
          (result : kind manager_operation_result) =
        match result with
        | Applied _ ->
            Ok ()
        | Skipped _ ->
            assert false
        | Backtracked (_, None) ->
            (* there must be another error for this to happen *)
            Ok ()
        | Backtracked (_, Some errs) ->
            record_trace
              (failure "The transfer simulation failed.")
              (Environment.wrap_error (Error errs))
        | Failed (_, errs) ->
            record_trace
              (failure "The transfer simulation failed.")
              (Environment.wrap_error (Error errs))
      in
      List.fold_left
        (fun acc (Internal_operation_result (_, r)) ->
          acc >>? fun () -> detect_script_failure r)
        (detect_script_failure operation_result)
        internal_operation_results
    in
    function
    | Single_result (Manager_operation_result _ as res) ->
        detect_script_failure_single res
    | Single_result _ ->
        Ok ()
    | Cons_result (res, rest) ->
        detect_script_failure_single res
        >>? fun () -> detect_script_failure rest
  in
  fun {contents} -> detect_script_failure contents

let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full)
    ~fee_parameter ~chain ~block ?branch ?(compute_fee = false)
    (contents : kind contents_list) : kind contents_list tzresult Lwt.t =
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun { parametric =
               { hard_gas_limit_per_operation = gas_limit;
                 hard_storage_limit_per_operation = storage_limit;
                 origination_size;
                 cost_per_byte;
                 _ };
             _ } ->
  let may_need_patching_single :
      type kind. kind contents -> kind contents option = function
    | Manager_operation c
      when compute_fee || c.gas_limit < Z.zero || gas_limit <= c.gas_limit
           || c.storage_limit < Z.zero
           || storage_limit <= c.storage_limit ->
        let gas_limit =
          if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then gas_limit
          else c.gas_limit
        in
        let storage_limit =
          if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then
            storage_limit
          else c.storage_limit
        in
        Some (Manager_operation {c with gas_limit; storage_limit})
    | _ ->
        None
  in
  let rec may_need_patching :
      type kind. kind contents_list -> kind contents_list option = function
    | Single (Manager_operation _ as c) -> (
      match may_need_patching_single c with
      | None ->
          None
      | Some op ->
          Some (Single op) )
    | Single _ ->
        None
    | Cons ((Manager_operation _ as c), rest) -> (
      match (may_need_patching_single c, may_need_patching rest) with
      | (None, None) ->
          None
      | (Some c, None) ->
          Some (Cons (c, rest))
      | (None, Some rest) ->
          Some (Cons (c, rest))
      | (Some c, Some rest) ->
          Some (Cons (c, rest)) )
  in
  let rec patch_fee : type kind. bool -> kind contents -> kind contents =
   fun first -> function
    | Manager_operation c as op -> (
        let gas_limit = c.gas_limit in
        let size =
          if first then
            Data_encoding.Binary.fixed_length_exn
              Tezos_base.Operation.shell_header_encoding
            + Data_encoding.Binary.length
                Operation.contents_encoding
                (Contents op)
            + Signature.size
          else
            Data_encoding.Binary.length
              Operation.contents_encoding
              (Contents op)
        in
        let minimal_fees_in_nanotez =
          Z.mul
            (Z.of_int64 (Tez.to_mutez fee_parameter.minimal_fees))
            (Z.of_int 1000)
        in
        let minimal_fees_for_gas_in_nanotez =
          Z.mul fee_parameter.minimal_nanotez_per_gas_unit gas_limit
        in
        let minimal_fees_for_size_in_nanotez =
          Z.mul fee_parameter.minimal_nanotez_per_byte (Z.of_int size)
        in
        let fees_in_nanotez =
          Z.add minimal_fees_in_nanotez
          @@ Z.add
               minimal_fees_for_gas_in_nanotez
               minimal_fees_for_size_in_nanotez
        in
        match
          Tez.of_mutez
            (Z.to_int64
               (Z.div (Z.add (Z.of_int 999) fees_in_nanotez) (Z.of_int 1000)))
        with
        | None ->
            assert false
        | Some fee ->
            if fee <= c.fee then op
            else patch_fee first (Manager_operation {c with fee}) )
    | c ->
        c
  in
  let patch :
      type kind.
      bool ->
      kind contents * kind contents_result ->
      kind contents tzresult Lwt.t =
   fun first -> function
    | (Manager_operation c, (Manager_operation_result _ as result)) ->
        ( if c.gas_limit < Z.zero || gas_limit <= c.gas_limit then
          Lwt.return (estimated_gas_single result)
          >>=? fun gas ->
          if Z.equal gas Z.zero then
            cctxt#message "Estimated gas: none" >>= fun () -> return Z.zero
          else
            cctxt#message
              "Estimated gas: %s units (will add 100 for safety)"
              (Z.to_string gas)
            >>= fun () -> return (Z.min (Z.add gas (Z.of_int 100)) gas_limit)
        else return c.gas_limit )
        >>=? fun gas_limit ->
        ( if c.storage_limit < Z.zero || storage_limit <= c.storage_limit then
          Lwt.return
            (estimated_storage_single (Z.of_int origination_size) result)
          >>=? fun storage ->
          if Z.equal storage Z.zero then
            cctxt#message "Estimated storage: no bytes added"
            >>= fun () -> return Z.zero
          else
            cctxt#message
              "Estimated storage: %s bytes added (will add 20 for safety)"
              (Z.to_string storage)
            >>= fun () ->
            return (Z.min (Z.add storage (Z.of_int 20)) storage_limit)
        else return c.storage_limit )
        >>=? fun storage_limit ->
        let c = Manager_operation {c with gas_limit; storage_limit} in
        if compute_fee then return (patch_fee first c) else return c
    | (c, _) ->
        return c
  in
  let rec patch_list :
      type kind.
      bool ->
      kind contents_and_result_list ->
      kind contents_list tzresult Lwt.t =
   fun first -> function
    | Single_and_result
        ((Manager_operation _ as op), (Manager_operation_result _ as res)) ->
        patch first (op, res) >>=? fun op -> return (Single op)
    | Single_and_result (op, _) ->
        return (Single op)
    | Cons_and_result
        ((Manager_operation _ as op), (Manager_operation_result _ as res), rest)
      ->
        patch first (op, res)
        >>=? fun op ->
        patch_list false rest >>=? fun rest -> return (Cons (op, rest))
  in
  match may_need_patching contents with
  | Some contents ->
      simulate cctxt ~chain ~block ?branch contents
      >>=? fun (_, _, result) ->
      ( match detect_script_failure result with
      | Ok () ->
          return_unit
      | Error _ ->
          cctxt#message
            "@[<v 2>This simulation failed:@,%a@]"
            Operation_result.pp_operation_result
            (contents, result.contents)
          >>= fun () -> return_unit )
      >>=? fun () ->
      Lwt.return
        (estimated_storage (Z.of_int origination_size) result.contents)
      >>=? (fun storage ->
             Lwt.return
               (Environment.wrap_error
                  Tez.(cost_per_byte *? Z.to_int64 storage))
             >>=? fun burn ->
             if Tez.(burn > fee_parameter.burn_cap) then
               cctxt#error
                 "The operation will burn %s%a which is higher than the \
                  configured burn cap (%s%a).@\n\
                 \ Use `--burn-cap %a` to emit this operation."
                 Client_proto_args.tez_sym
                 Tez.pp
                 burn
                 Client_proto_args.tez_sym
                 Tez.pp
                 fee_parameter.burn_cap
                 Tez.pp
                 burn
               >>= fun () -> exit 1
             else return_unit)
      >>=? fun () ->
      let res = pack_contents_list contents result.contents in
      patch_list true res
  | None ->
      return contents

let inject_operation (type kind) cctxt ~chain ~block ?confirmations
    ?(dry_run = false) ?branch ?src_sk ?verbose_signing ~fee_parameter
    ?compute_fee (contents : kind contents_list) =
  Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt
  >>=? fun () ->
  may_patch_limits
    cctxt
    ~chain
    ~block
    ?branch
    ~fee_parameter
    ?compute_fee
    contents
  >>=? fun contents ->
  preapply
    cctxt
    ~chain
    ~block
    ~fee_parameter
    ?verbose_signing
    ?branch
    ?src_sk
    contents
  >>=? fun (_oph, op, result) ->
  ( match detect_script_failure result with
  | Ok () ->
      return_unit
  | Error _ as res ->
      cctxt#message
        "@[<v 2>This simulation failed:@,%a@]"
        Operation_result.pp_operation_result
        (op.protocol_data.contents, result.contents)
      >>= fun () -> Lwt.return res )
  >>=? fun () ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn Operation.encoding (Operation.pack op)
  in
  if dry_run then
    let oph = Operation_hash.hash_bytes [bytes] in
    cctxt#message
      "@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
      Hex.pp
      (Hex.of_bytes bytes)
      Operation_hash.pp
      oph
    >>= fun () ->
    cctxt#message
      "@[<v 2>Simulation result:@,%a@]"
      Operation_result.pp_operation_result
      (op.protocol_data.contents, result.contents)
    >>= fun () -> return (oph, op.protocol_data.contents, result.contents)
  else
    Shell_services.Injection.operation cctxt ~chain bytes
    >>=? fun oph ->
    cctxt#message "Operation successfully injected in the node."
    >>= fun () ->
    cctxt#message "Operation hash is '%a'" Operation_hash.pp oph
    >>= fun () ->
    ( match confirmations with
    | None ->
        cctxt#message
          "@[<v 0>NOT waiting for the operation to be included.@,\
           Use command@,\
          \  tezos-client wait for %a to be included --confirmations 30 \
           --branch %a@,\
           and/or an external block explorer to make sure that it has been \
           included.@]"
          Operation_hash.pp
          oph
          Block_hash.pp
          op.shell.branch
        >>= fun () -> return result
    | Some confirmations -> (
        cctxt#message "Waiting for the operation to be included..."
        >>= fun () ->
        Client_confirmations.wait_for_operation_inclusion
          ~branch:op.shell.branch
          ~confirmations
          cctxt
          ~chain
          oph
        >>=? fun (h, i, j) ->
        Alpha_block_services.Operations.operation
          cctxt
          ~chain
          ~block:(`Hash (h, 0))
          i
          j
        >>=? fun op' ->
        match op'.receipt with
        | No_operation_metadata ->
            failwith "Internal error: unexpected receipt."
        | Operation_metadata receipt -> (
          match Apply_results.kind_equal_list contents receipt.contents with
          | Some Apply_results.Eq ->
              return (receipt : kind operation_metadata)
          | None ->
              failwith "Internal error: unexpected receipt." ) ) )
    >>=? fun result ->
    cctxt#message
      "@[<v 2>This sequence of operations was run:@,%a@]"
      Operation_result.pp_operation_result
      (op.protocol_data.contents, result.contents)
    >>= fun () ->
    Lwt.return (originated_contracts result.contents)
    >>=? fun contracts ->
    Lwt_list.iter_s
      (fun c -> cctxt#message "New contract %a originated." Contract.pp c)
      contracts
    >>= fun () ->
    ( match confirmations with
    | None ->
        Lwt.return_unit
    | Some number ->
        if number >= 30 then
          cctxt#message
            "The operation was included in a block %d blocks ago."
            number
        else
          cctxt#message
            "@[<v 0>The operation has only been included %d blocks ago.@,\
             We recommend to wait more.@,\
             Use command@,\
            \  tezos-client wait for %a to be included --confirmations 30 \
             --branch %a@,\
             and/or an external block explorer.@]"
            number
            Operation_hash.pp
            oph
            Block_hash.pp
            op.shell.branch )
    >>= fun () -> return (oph, op.protocol_data.contents, result.contents)

let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations
    ?dry_run ?verbose_signing ~source ~src_pk ~src_sk ?fee
    ?(gas_limit = Z.minus_one) ?(storage_limit = Z.of_int (-1)) ?counter
    ~fee_parameter (type kind) (operation : kind manager_operation) :
    ( Operation_hash.t
    * kind Kind.manager contents
    * kind Kind.manager contents_result )
    tzresult
    Lwt.t =
  ( match counter with
  | None ->
      Alpha_services.Contract.counter cctxt (chain, block) source
      >>=? fun pcounter ->
      let counter = Z.succ pcounter in
      return counter
  | Some counter ->
      return counter )
  >>=? fun counter ->
  Alpha_services.Contract.manager_key cctxt (chain, block) source
  >>=? fun key ->
  let is_reveal : type kind. kind manager_operation -> bool = function
    | Reveal _ ->
        true
    | _ ->
        false
  in
  let (compute_fee, fee) =
    match fee with None -> (true, Tez.zero) | Some fee -> (false, fee)
  in
  match key with
  | None when not (is_reveal operation) -> (
      let contents =
        Cons
          ( Manager_operation
              {
                source;
                fee = Tez.zero;
                counter;
                gas_limit = Z.of_int 10_000;
                storage_limit = Z.zero;
                operation = Reveal src_pk;
              },
            Single
              (Manager_operation
                 {
                   source;
                   fee;
                   counter = Z.succ counter;
                   gas_limit;
                   storage_limit;
                   operation;
                 }) )
      in
      inject_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ~fee_parameter
        ~compute_fee
        ?verbose_signing
        ?branch
        ~src_sk
        contents
      >>=? fun (oph, op, result) ->
      match pack_contents_list op result with
      | Cons_and_result (_, _, Single_and_result (op, result)) ->
          return (oph, op, result)
      | Single_and_result (Manager_operation _, _) ->
          .
      | _ ->
          assert false
      (* Grrr... *) )
  | _ -> (
      let contents =
        Single
          (Manager_operation
             {source; fee; counter; gas_limit; storage_limit; operation})
      in
      inject_operation
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ?verbose_signing
        ~compute_fee
        ~fee_parameter
        ?branch
        ~src_sk
        contents
      >>=? fun (oph, op, result) ->
      match pack_contents_list op result with
      | Single_and_result ((Manager_operation _ as op), result) ->
          return (oph, op, result)
      | _ ->
          assert false )

(* Grrr... *)
src/proto_alpha/lib_client/injection.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Apply_results.

Import Protocol_client_context.

Definition get_branch {D F H J L M N a b c i o p q : Type}
  (rpc_config :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services.Block_services.block) (branch : option Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Chain_id.t *
        Tezos_base__TzPervasives.Block_hash.t)) :=
  let branch := Option.unopt 0 branch in
  op_gtgteqquestion
    match block with
    | Head n =>
      _return
        (* ❌ Variants not supported *)
        variant
    | Hash (h, n) =>
      _return
        (* ❌ Variants not supported *)
        variant
    | Alias (a, n) =>
      _return
        (* ❌ Variants not supported *)
        variant
    | Genesis =>
      _return
        (* ❌ Variants not supported *)
        variant
    | Level i =>
      _return
        (* ❌ Variants not supported *)
        variant
    end
    (fun block =>
      op_gtgteqquestion
        (Shell_services.Blocks.hash rpc_config (Some chain) (Some block) tt)
        (fun hash =>
          op_gtgteqquestion
            (Shell_services.Chain.chain_id rpc_config (Some chain) tt)
            (fun chain_id => _return (chain_id, hash)))).

Definition preapply_result (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.operation kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind).

Definition result_list (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind).

Definition result (kind : Type) :=
  Tezos_base__TzPervasives.Operation_hash.t *
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind).

Definition get_manager_operation_gas_and_fee {A : Type}
  (contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A)
  : sum (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)
    (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
  let l :=
    to_list (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents)
    in
  List.fold_left
    (fun acc =>
      fun function_parameter =>
        match function_parameter with
        |
          Tezos_protocol_alpha.Protocol.Alpha_context.Contents
            (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
              fee := fee; gas_limit := gas_limit |}) =>
          match acc with
          | (Stdlib.Error _) as e => e
          | Stdlib.Ok (total_fee, total_gas) =>
            match op_plusquestion total_fee fee with
            | Stdlib.Ok total_fee =>
              Stdlib.Ok (total_fee, (Z.add total_gas gas_limit))
            | (Stdlib.Error _) as e => e
            end
          end
        | _ => acc
        end) (Stdlib.Ok (Tez.zero, Z.zero)) l.

Record fee_parameter := {
  minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  minimal_nanotez_per_byte : Z.t;
  minimal_nanotez_per_gas_unit : Z.t;
  force_low_fee : bool;
  fee_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  burn_cap : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.

Definition dummy_fee_parameter : fee_parameter :=
  {| minimal_fees := Tez.zero; minimal_nanotez_per_byte := Z.zero;
    minimal_nanotez_per_gas_unit := Z.zero; force_low_fee := false;
    fee_cap := Tez.one; burn_cap := Tez.zero |}.

Definition check_fees {D F H J L M N a b c i o p q t : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (config : fee_parameter)
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list t) (size : Z)
  : Lwt.t unit :=
  match get_manager_operation_gas_and_fee op with
  | Stdlib.Error _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Stdlib.Ok (fee, gas) =>
    if OCaml.Stdlib.gt (Tez.compare fee (fee_cap config)) 0 then
      op_gtgteq
        ((* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "The proposed fee (" % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    ") are higher than the configured fee cap (" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal ")." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Force_newline
                            (CamlinternalFormatBasics.String_literal
                              " Use `--fee-cap " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  "` to emit this operation anyway." % string
                                  CamlinternalFormatBasics.End_of_format)))))))))))
            "The proposed fee (%s%a) are higher than the configured fee cap (%s%a).@
 Use `--fee-cap %a` to emit this operation anyway."
              % string) Client_proto_args.tez_sym Tez.pp fee
          Client_proto_args.tez_sym Tez.pp (fee_cap config) Tez.pp fee)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Stdlib.exit 1)
    else
      let fees_in_nanotez :=
        Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000) in
      let minimal_fees_in_nanotez :=
        Z.mul (Z.of_int64 (Tez.to_mutez (minimal_fees config))) (Z.of_int 1000)
        in
      let minimal_fees_for_gas_in_nanotez :=
        Z.mul (minimal_nanotez_per_gas_unit config) gas in
      let minimal_fees_for_size_in_nanotez :=
        Z.mul (minimal_nanotez_per_byte config) (Z.of_int size) in
      let estimated_fees_in_nanotez :=
        Z.add minimal_fees_in_nanotez
          (Z.add minimal_fees_for_gas_in_nanotez
            minimal_fees_for_size_in_nanotez) in
      let estimated_fees :=
        match
          Tez.of_mutez
            (Z.to_int64
              (Z.div (Z.add (Z.of_int 999) estimated_fees_in_nanotez)
                (Z.of_int 1000))) with
        | None =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Some fee => fee
        end in
      if
        andb (negb (force_low_fee config))
          (OCaml.Stdlib.lt (Z.compare fees_in_nanotez estimated_fees_in_nanotez)
            0) then
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "The proposed fee (" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      ") are lower than the fee that baker expect by default ("
                        % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal ")." % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Force_newline
                              (CamlinternalFormatBasics.String_literal
                                " Use `--force-low-fee` to emit this operation anyway."
                                  % string
                                CamlinternalFormatBasics.End_of_format)))))))))
              "The proposed fee (%s%a) are lower than the fee that baker expect by default (%s%a).@
 Use `--force-low-fee` to emit this operation anyway."
                % string) Client_proto_args.tez_sym Tez.pp fee
            Client_proto_args.tez_sym Tez.pp estimated_fees)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Stdlib.exit 1)
      else
        Lwt.return_unit
  end.

Definition print_for_verbose_signing {A : Type}
  (ppf : Stdlib.Format.formatter)
  (watermark : Tezos_base__TzPervasives.Signature.watermark) (bytes : string)
  (branch : Tezos_base__TzPervasives.Block_hash.t)
  (contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A)
  : unit :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := pp_open_vbox ppf 0 in
  let item (f : Stdlib.Format.formatter -> unit -> unit) : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := pp_open_hovbox ppf 4 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := pp_print_string ppf "  * " % string in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := f ppf tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := pp_close_box ppf tt in
    pp_print_cut ppf tt in
  let hash_pp (l : list Stdlib.Bytes.t) : unit :=
    fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          CamlinternalFormatBasics.End_of_format) "%s" % string)
      (Base58.raw_encode None
        (OCaml.Stdlib.reverse_apply (hash_bytes None l) to_string)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    item
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := pp_print_text ppf "Branch: " % string in
          Block_hash.pp ppf branch) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    item
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "Watermark: `" % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal "` (0x" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal ")" % char
                        CamlinternalFormatBasics.End_of_format)))))
              "Watermark: `%a` (0x%s)" % string) Signature.pp_watermark
            watermark
            (OCaml.Stdlib.reverse_apply
              (Hex.of_bytes None (Signature.bytes_of_watermark watermark))
              Hex.show)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    item
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := pp_print_text ppf "Operation bytes: " % string in
          OCaml.Stdlib.reverse_apply
            (TzString.fold_left
              (fun n =>
                fun c =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ := pp_print_char ppf c in
                  if OCaml.Stdlib.lt n 72 then
                    Z.add n 1
                  else
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := pp_print_space ppf tt in
                    0) 0
              (OCaml.Stdlib.reverse_apply (Hex.of_bytes None string) Hex.show))
            OCaml.Stdlib.ignore) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    item
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := pp_print_text ppf "Blake 2B Hash (raw): " % string in
          hash_pp (cons string [])) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    item
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            pp_print_text ppf
              "Blake 2B Hash (ledger-style, with operation watermark): " %
                string in
          hash_pp
            (cons (Signature.bytes_of_watermark watermark) (cons string []))) in
  let json :=
    Data_encoding.Json.construct Operation.unsigned_encoding
      ({| branch := branch |},
        (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    item
      (fun ppf =>
        fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ := pp_print_text ppf "JSON encoding: " % string in
          Data_encoding.Json.pp ppf json) in
  pp_close_box ppf tt.

Definition preapply {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (op_staroptstar : option bool)
  : (option fee_parameter) ->
    (option Z) ->
      (option Tezos_client_base.Client_keys.sk_uri) ->
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result O)) :=
  let verbose_signing :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun fee_parameter =>
    fun branch =>
      fun src_sk =>
        fun contents =>
          op_gtgteqquestion (get_branch cctxt chain block branch)
            (fun function_parameter =>
              let '(chain_id, branch) := function_parameter in
              let bytes :=
                Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding
                  ({| branch := branch |},
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
                      contents)) in
              op_gtgteqquestion
                match src_sk with
                | None => return_none
                | Some src_sk =>
                  let watermark :=
                    match contents with
                    |
                      Tezos_protocol_alpha.Protocol.Alpha_context.Single
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
                          _) =>
                      Tezos_base__TzPervasives.Signature.Endorsement chain_id
                    | _ => Tezos_base__TzPervasives.Signature.Generic_operation
                    end in
                  op_gtgteq
                    (if verbose_signing then
                      (* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Pre-signature information (verbose signing):" %
                              string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              (CamlinternalFormatBasics.Theta
                                (CamlinternalFormatBasics.Flush
                                  CamlinternalFormatBasics.End_of_format))))
                          "Pre-signature information (verbose signing):@.%t%!" %
                            string)
                        (print_for_verbose_signing
                          (* ❌ expected an argument *)
                          expected_argument watermark string branch contents)
                    else
                      Lwt.return_unit)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (Client_keys.sign cctxt (Some watermark) src_sk string)
                        (fun signature => return_some signature))
                end
                (fun signature =>
                  let op :=
                    {| shell := {| branch := branch |};
                      protocol_data :=
                        {| contents := contents; signature := signature |} |} in
                  let oph := Operation.hash op in
                  let size := Z.add (String.length string) Signature.size in
                  op_gtgteq
                    match fee_parameter with
                    | Some fee_parameter =>
                      check_fees cctxt fee_parameter contents size
                    | None => Lwt.return_unit
                    end
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
                          cctxt (Some chain) (Some block)
                          (cons (Operation.pack op) []))
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            cons
                              (Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
                                op',
                                Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                                  result) [] =>
                            match
                              ((Operation.equal op
                                {| shell := {| branch := branch |};
                                  protocol_data := op' |}),
                                (Apply_results.kind_equal_list contents
                                  (contents result))) with
                            |
                              (Some
                                Tezos_protocol_alpha.Protocol.Alpha_context.Operation.Eq,
                                Some
                                  Tezos_protocol_alpha.Protocol.Apply_results.Eq)
                              => _return (oph, op, result)
                            | _ =>
                              failwith
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Unexpected result" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "Unexpected result" % string)
                            end
                          | _ =>
                            failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Unexpected result" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Unexpected result" % string)
                          end)))).

Definition simulate {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services.Block_services.block) (branch : option Z)
  (contents : Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (preapply_result O)) :=
  op_gtgteqquestion (get_branch cctxt chain block branch)
    (fun function_parameter =>
      let '(_chain_id, branch) := function_parameter in
      let op :=
        {| shell := {| branch := branch |};
          protocol_data := {| contents := contents; signature := None |} |} in
      let oph := Operation.hash op in
      op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
        (fun chain_id =>
          op_gtgteqquestion
            (Alpha_services.Helpers.Scripts.run_operation cctxt (chain, block)
              ((Operation.pack op), chain_id))
            (fun function_parameter =>
              match function_parameter with
              |
                (Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data op',
                  Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                    result) =>
                match
                  ((Operation.equal op
                    {| shell := {| branch := branch |}; protocol_data := op' |}),
                    (Apply_results.kind_equal_list contents (contents result)))
                  with
                |
                  (Some Tezos_protocol_alpha.Protocol.Alpha_context.Operation.Eq,
                    Some Tezos_protocol_alpha.Protocol.Apply_results.Eq) =>
                  _return (oph, op, result)
                | _ =>
                  failwith
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Unexpected result" % string
                        CamlinternalFormatBasics.End_of_format)
                      "Unexpected result" % string)
                end
              | _ =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Unexpected result" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Unexpected result" % string)
              end))).

Definition estimated_gas_single {A : Type}
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_environment_alpha__Environment.Z.t :=
  let
    'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
      operation_result := operation_result;
        internal_operation_results := internal_operation_results
        |} := function_parameter in
  let consumed_gas {B : Type}
    (result :
    Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
    : sum Tezos_protocol_environment_alpha__Environment.Z.t
      Tezos_base__TzPervasives.Error_monad.trace :=
    match result with
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
          consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
          consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result {|
          consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result {|
          consumed_gas := consumed_gas |}) => Stdlib.Ok consumed_gas
    | Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
      Stdlib.Ok Z.zero
    | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs) =>
      Environment.wrap_error (Stdlib.Error errs)
    | Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
      Environment.wrap_error (Stdlib.Error errs)
    end in
  List.fold_left
    (fun acc =>
      fun function_parameter =>
        let
          'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
            _ r := function_parameter in
        op_gtgtquestion acc
          (fun acc =>
            op_gtgtquestion (consumed_gas r)
              (fun gas => Stdlib.Ok (Z.add acc gas))))
    (consumed_gas operation_result) internal_operation_results.

Definition estimated_storage_single {A : Type}
  (origination_size : Z.t)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
  : Tezos_base__TzPervasives.tzresult
    Tezos_protocol_environment_alpha__Environment.Z.t :=
  let
    'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
      operation_result := operation_result;
        internal_operation_results := internal_operation_results
        |} := function_parameter in
  let storage_size_diff {B : Type}
    (result :
    Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
    : sum Tezos_protocol_environment_alpha__Environment.Z.t
      Tezos_base__TzPervasives.Error_monad.trace :=
    match result with
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
          paid_storage_size_diff := paid_storage_size_diff;
            allocated_destination_contract := allocated_destination_contract
            |}) =>
      if allocated_destination_contract then
        Stdlib.Ok (Z.add paid_storage_size_diff origination_size)
      else
        Stdlib.Ok paid_storage_size_diff
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
          paid_storage_size_diff := paid_storage_size_diff |}) =>
      Stdlib.Ok (Z.add paid_storage_size_diff origination_size)
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result _) =>
      Stdlib.Ok Z.zero
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result _) =>
      Stdlib.Ok Z.zero
    | Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
      Stdlib.Ok Z.zero
    | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs) =>
      Environment.wrap_error (Stdlib.Error errs)
    | Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
      Environment.wrap_error (Stdlib.Error errs)
    end in
  List.fold_left
    (fun acc =>
      fun function_parameter =>
        let
          'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
            _ r := function_parameter in
        op_gtgtquestion acc
          (fun acc =>
            op_gtgtquestion (storage_size_diff r)
              (fun storage => Stdlib.Ok (Z.add acc storage))))
    (storage_size_diff operation_result) internal_operation_results.

Definition estimated_storage {A : Type}
  (origination_size : Z.t)
  (res : Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list A)
  : Tezos_base__TzPervasives.tzresult Z.t :=
  let fix estimated_storage {kind : Type}
    (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)
    : Tezos_base__TzPervasives.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    match function_parameter with
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Single_result
        ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
          as res) => estimated_storage_single origination_size res
    | Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ =>
      Stdlib.Ok Z.zero
    | Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
      op_gtgtquestion (estimated_storage_single origination_size res)
        (fun storage1 =>
          op_gtgtquestion (estimated_storage rest)
            (fun storage2 => Stdlib.Ok (Z.add storage1 storage2)))
    end in
  op_gtgtquestion (estimated_storage res)
    (fun diff => Stdlib.Ok (Z.max Z.zero diff)).

Definition originated_contracts_single {A : Type}
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A))
  : Tezos_base__TzPervasives.tzresult
    (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
  let
    'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
      operation_result := operation_result;
        internal_operation_results := internal_operation_results
        |} := function_parameter in
  let originated_contracts {B : Type}
    (result :
    Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result B)
    : sum (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
      Tezos_base__TzPervasives.Error_monad.trace :=
    match result with
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
          originated_contracts := originated_contracts |}) =>
      Stdlib.Ok originated_contracts
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
          originated_contracts := originated_contracts |}) =>
      Stdlib.Ok originated_contracts
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result _) =>
      Stdlib.Ok []
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result _) =>
      Stdlib.Ok []
    | Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
      Stdlib.Ok []
    | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs) =>
      Environment.wrap_error (Stdlib.Error errs)
    | Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
      Environment.wrap_error (Stdlib.Error errs)
    end in
  List.fold_left
    (fun acc =>
      fun function_parameter =>
        let
          'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
            _ r := function_parameter in
        op_gtgtquestion acc
          (fun acc =>
            op_gtgtquestion (originated_contracts r)
              (fun contracts => Stdlib.Ok (List.rev_append contracts acc))))
    (op_gtpipequestion (originated_contracts operation_result) List.rev)
    internal_operation_results.

Fixpoint originated_contracts {kind : Type}
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind)
  : Tezos_base__TzPervasives.tzresult
    (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
  match function_parameter with
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_result
      ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
        as res) => op_gtpipequestion (originated_contracts_single res) List.rev
  | Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ => Stdlib.Ok []
  | Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
    op_gtgtquestion (originated_contracts_single res)
      (fun contracts1 =>
        op_gtgtquestion (originated_contracts rest)
          (fun contracts2 => Stdlib.Ok (List.rev_append contracts1 contracts2)))
  end.

Definition detect_script_failure {kind : Type}
  : (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind) ->
    Tezos_base__TzPervasives.tzresult unit :=
  let detect_script_failure :=
    let detect_script_failure_single {B : Type}
      (function_parameter :
      Tezos_protocol_alpha.Protocol.Apply_results.contents_result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager B))
      : Tezos_base__TzPervasives.tzresult unit :=
      let
        'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
          operation_result := operation_result;
            internal_operation_results := internal_operation_results
            |} := function_parameter in
      let detect_script_failure {C : Type}
        (result :
        Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
        : sum unit Tezos_base__TzPervasives.trace :=
        match result with
        | Tezos_protocol_alpha.Protocol.Apply_results.Applied _ => Stdlib.Ok tt
        | Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
          Stdlib.Ok tt
        | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs)
          =>
          record_trace
            (failure
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "The transfer simulation failed." % string
                  CamlinternalFormatBasics.End_of_format)
                "The transfer simulation failed." % string))
            (Environment.wrap_error (Stdlib.Error errs))
        | Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
          record_trace
            (failure
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "The transfer simulation failed." % string
                  CamlinternalFormatBasics.End_of_format)
                "The transfer simulation failed." % string))
            (Environment.wrap_error (Stdlib.Error errs))
        end in
      List.fold_left
        (fun acc =>
          fun function_parameter =>
            let
              'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
                _ r := function_parameter in
            op_gtgtquestion acc
              (fun function_parameter =>
                let 'tt := function_parameter in
                detect_script_failure r))
        (detect_script_failure operation_result) internal_operation_results in
    fun function_parameter =>
      match function_parameter with
      |
        Tezos_protocol_alpha.Protocol.Apply_results.Single_result
          ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
            _) as res) => detect_script_failure_single res
      | Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ =>
        Stdlib.Ok tt
      | Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
        op_gtgtquestion (detect_script_failure_single res)
          (fun function_parameter =>
            let 'tt := function_parameter in
            detect_script_failure rest)
      end in
  fun function_parameter =>
    let '{| contents := contents |} := function_parameter in
    detect_script_failure contents.

Definition may_patch_limits {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (fee_parameter : fee_parameter)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (branch : option Z)
  (op_staroptstar : option bool)
  : (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)) :=
  let compute_fee :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun contents =>
    op_gtgteqquestion (Alpha_services.Constants.all cctxt (chain, block))
      (fun function_parameter =>
        let '{|
          parametric := {|
            hard_gas_limit_per_operation := gas_limit;
              origination_size := origination_size;
              cost_per_byte := cost_per_byte;
              hard_storage_limit_per_operation := storage_limit
              |}
            |} := function_parameter in
        let may_need_patching_single {kind : Type}
          (function_parameter :
          Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)
          : option (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) :=
          match function_parameter with
          | Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation c =>
            let gas_limit :=
              if
                orb (OCaml.Stdlib.lt (gas_limit c) Z.zero)
                  (OCaml.Stdlib.le gas_limit (gas_limit c)) then
                gas_limit
              else
                gas_limit c in
            let storage_limit :=
              if
                orb (OCaml.Stdlib.lt (storage_limit c) Z.zero)
                  (OCaml.Stdlib.le storage_limit (storage_limit c)) then
                storage_limit
              else
                storage_limit c in
            Some
              (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                (* ❌ Record substitution not handled *)
                record_substitution)
          | _ => None
          end in
        let fix may_need_patching {kind : Type}
          (function_parameter :
          Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)
          : option
            (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) :=
          match function_parameter with
          |
            Tezos_protocol_alpha.Protocol.Alpha_context.Single
              ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
                as c) =>
            match may_need_patching_single c with
            | None => None
            | Some op =>
              Some (Tezos_protocol_alpha.Protocol.Alpha_context.Single op)
            end
          | Tezos_protocol_alpha.Protocol.Alpha_context.Single _ => None
          |
            Tezos_protocol_alpha.Protocol.Alpha_context.Cons
              ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
                as c) rest =>
            match ((may_need_patching_single c), (may_need_patching rest)) with
            | (None, None) => None
            | (Some c, None) =>
              Some (Tezos_protocol_alpha.Protocol.Alpha_context.Cons c rest)
            | (None, Some rest) =>
              Some (Tezos_protocol_alpha.Protocol.Alpha_context.Cons c rest)
            | (Some c, Some rest) =>
              Some (Tezos_protocol_alpha.Protocol.Alpha_context.Cons c rest)
            end
          end in
        let fix patch_fee {kind : Type}
          (first : bool) (function_parameter :
          Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)
          : Tezos_protocol_alpha.Protocol.Alpha_context.contents kind :=
          match function_parameter with
          |
            (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation c) as
              op =>
            let gas_limit := gas_limit c in
            let size :=
              if first then
                Z.add
                  (Z.add
                    (Data_encoding.Binary.fixed_length_exn
                      Tezos_base.Operation.shell_header_encoding)
                    (Data_encoding.Binary.length Operation.contents_encoding
                      (Tezos_protocol_alpha.Protocol.Alpha_context.Contents op)))
                  Signature.size
              else
                Data_encoding.Binary.length Operation.contents_encoding
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contents op) in
            let minimal_fees_in_nanotez :=
              Z.mul (Z.of_int64 (Tez.to_mutez (minimal_fees fee_parameter)))
                (Z.of_int 1000) in
            let minimal_fees_for_gas_in_nanotez :=
              Z.mul (minimal_nanotez_per_gas_unit fee_parameter) gas_limit in
            let minimal_fees_for_size_in_nanotez :=
              Z.mul (minimal_nanotez_per_byte fee_parameter) (Z.of_int size) in
            let fees_in_nanotez :=
              apply (Z.add minimal_fees_in_nanotez)
                (Z.add minimal_fees_for_gas_in_nanotez
                  minimal_fees_for_size_in_nanotez) in
            match
              Tez.of_mutez
                (Z.to_int64
                  (Z.div (Z.add (Z.of_int 999) fees_in_nanotez) (Z.of_int 1000)))
              with
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Some fee =>
              if OCaml.Stdlib.le fee (fee c) then
                op
              else
                patch_fee first
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                    (* ❌ Record substitution not handled *)
                    record_substitution)
            end
          | c => c
          end in
        let patch {kind : Type}
          (first : bool) (function_parameter :
          (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind) *
            (Tezos_protocol_alpha.Protocol.Apply_results.contents_result kind))
          : Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_protocol_alpha.Protocol.Alpha_context.contents kind)) :=
          match function_parameter with
          |
            (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation c,
              (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                _) as result) =>
            op_gtgteqquestion
              (if
                orb (OCaml.Stdlib.lt (gas_limit c) Z.zero)
                  (OCaml.Stdlib.le gas_limit (gas_limit c)) then
                op_gtgteqquestion (Lwt._return (estimated_gas_single result))
                  (fun gas =>
                    if Z.equal gas Z.zero then
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Estimated gas: none" % string
                              CamlinternalFormatBasics.End_of_format)
                            "Estimated gas: none" % string))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          _return Z.zero)
                    else
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Estimated gas: " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " units (will add 100 for safety)" % string
                                  CamlinternalFormatBasics.End_of_format)))
                            "Estimated gas: %s units (will add 100 for safety)"
                              % string) (Z.to_string gas))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          _return (Z.min (Z.add gas (Z.of_int 100)) gas_limit)))
              else
                _return (gas_limit c))
              (fun gas_limit =>
                op_gtgteqquestion
                  (if
                    orb (OCaml.Stdlib.lt (storage_limit c) Z.zero)
                      (OCaml.Stdlib.le storage_limit (storage_limit c)) then
                    op_gtgteqquestion
                      (Lwt._return
                        (estimated_storage_single (Z.of_int origination_size)
                          result))
                      (fun storage =>
                        if Z.equal storage Z.zero then
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Estimated storage: no bytes added" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Estimated storage: no bytes added" % string))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              _return Z.zero)
                        else
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Estimated storage: " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      " bytes added (will add 20 for safety)" %
                                        string
                                      CamlinternalFormatBasics.End_of_format)))
                                "Estimated storage: %s bytes added (will add 20 for safety)"
                                  % string) (Z.to_string storage))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              _return
                                (Z.min (Z.add storage (Z.of_int 20))
                                  storage_limit)))
                  else
                    _return (storage_limit c))
                  (fun storage_limit =>
                    let c :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                        (* ❌ Record substitution not handled *)
                        record_substitution in
                    if compute_fee then
                      _return (patch_fee first c)
                    else
                      _return c))
          | (c, _) => _return c
          end in
        let fix patch_list {kind : Type}
          (first : bool) (function_parameter :
          Tezos_protocol_alpha.Protocol.Apply_results.contents_and_result_list
            kind)
          : Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind)) :=
          match function_parameter with
          |
            Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
              ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
                as op)
              ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                _) as res) =>
            op_gtgteqquestion (patch first (op, res))
              (fun op =>
                _return (Tezos_protocol_alpha.Protocol.Alpha_context.Single op))
          | Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result op _
            => _return (Tezos_protocol_alpha.Protocol.Alpha_context.Single op)
          |
            Tezos_protocol_alpha.Protocol.Apply_results.Cons_and_result
              ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _)
                as op)
              ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                _) as res) rest =>
            op_gtgteqquestion (patch first (op, res))
              (fun op =>
                op_gtgteqquestion (patch_list false rest)
                  (fun rest =>
                    _return
                      (Tezos_protocol_alpha.Protocol.Alpha_context.Cons op rest)))
          end in
        match may_need_patching contents with
        | Some contents =>
          op_gtgteqquestion (simulate cctxt chain block branch contents)
            (fun function_parameter =>
              let '(_, _, result) := function_parameter in
              op_gtgteqquestion
                match detect_script_failure result with
                | Stdlib.Ok tt => return_unit
                | Stdlib.Error _ =>
                  op_gtgteq
                    ((* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "This simulation failed:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format)))))
                        "@[<v 2>This simulation failed:@,%a@]" % string)
                      Operation_result.pp_operation_result
                      (contents, (contents result)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit)
                end
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (op_gtgteqquestion
                      (Lwt._return
                        (estimated_storage (Z.of_int origination_size)
                          (contents result)))
                      (fun storage =>
                        op_gtgteqquestion
                          (Lwt._return
                            (Environment.wrap_error
                              (op_starquestion cost_per_byte
                                (Z.to_int64 storage))))
                          (fun burn =>
                            if op_gt burn (burn_cap fee_parameter) then
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "The operation will burn " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " which is higher than the configured burn cap ("
                                              % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  ")." % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Force_newline
                                                    (CamlinternalFormatBasics.String_literal
                                                      " Use `--burn-cap " %
                                                        string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          "` to emit this operation."
                                                            % string
                                                          CamlinternalFormatBasics.End_of_format)))))))))))
                                    "The operation will burn %s%a which is higher than the configured burn cap (%s%a).@
 Use `--burn-cap %a` to emit this operation."
                                      % string) Client_proto_args.tez_sym Tez.pp
                                  burn Client_proto_args.tez_sym Tez.pp
                                  (burn_cap fee_parameter) Tez.pp burn)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  Stdlib.exit 1)
                            else
                              return_unit)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let res := pack_contents_list contents (contents result)
                        in
                      patch_list true res)))
        | None => _return contents
        end).

Definition inject_operation {F G I J K M N O a b c i o p q : Type}
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) *
                                              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                variant
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                q i o) ->
                                                (Tezos_shell_services.Shell_services.chain
                                                  *
                                                  Tezos_shell_services.Shell_services.block)
                                                  ->
                                                  q ->
                                                    i ->
                                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                          o)) * (I * q * i * o))
                                                *
                                                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                  variant
                                                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                  (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    * a) q i o) ->
                                                  (Tezos_shell_services.Shell_services.chain
                                                    *
                                                    Tezos_shell_services.Shell_services.block)
                                                    ->
                                                    a ->
                                                      q ->
                                                        i ->
                                                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                              o)) *
                                                  (J * a * q * i * o)) *
                                                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                    variant
                                                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      * a) * b) q i o) ->
                                                    (Tezos_shell_services.Shell_services.chain
                                                      *
                                                      Tezos_shell_services.Shell_services.block)
                                                      ->
                                                      a ->
                                                        b ->
                                                          q ->
                                                            i ->
                                                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                  o)) *
                                                    (K * a * b * q * i * o)) *
                                                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                      variant
                                                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                        * a) * b) * c) q i o) ->
                                                      (Tezos_shell_services.Shell_services.chain
                                                        *
                                                        Tezos_shell_services.Shell_services.block)
                                                        ->
                                                        a ->
                                                          b ->
                                                            c ->
                                                              q ->
                                                                i ->
                                                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                      o)) *
                                                      (M * a * b * c * q * i * o))
                                                      * N)))))))))))))))))))))))))
      *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (I * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (J * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N)))))
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (confirmations : option Z)
  (op_staroptstar : option bool)
  : (option Z) ->
    (option Tezos_client_base.Client_keys.sk_uri) ->
      (option bool) ->
        fee_parameter ->
          (option bool) ->
            (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O) ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  (Tezos_base__TzPervasives.Operation_hash.t *
                    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list O)
                    *
                    (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list
                      O))) :=
  let dry_run :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun branch =>
    fun src_sk =>
      fun verbose_signing =>
        fun fee_parameter =>
          fun compute_fee =>
            fun contents =>
              op_gtgteqquestion
                (Tezos_client_base.Client_confirmations.wait_for_bootstrapped
                  cctxt)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (may_patch_limits cctxt fee_parameter chain block branch
                      compute_fee contents)
                    (fun contents =>
                      op_gtgteqquestion
                        (preapply cctxt chain block verbose_signing
                          (Some fee_parameter) branch src_sk contents)
                        (fun function_parameter =>
                          let '(_oph, op, result) := function_parameter in
                          op_gtgteqquestion
                            match detect_script_failure result with
                            | Stdlib.Ok tt => return_unit
                            | (Stdlib.Error _) as res =>
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "This simulation failed:" % string
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format)))))
                                    "@[<v 2>This simulation failed:@,%a@]" %
                                      string)
                                  Operation_result.pp_operation_result
                                  ((contents (protocol_data op)),
                                    (contents result)))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  Lwt._return res)
                            end
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              let bytes :=
                                Data_encoding.Binary.to_bytes_exn
                                  Operation.encoding (Operation.pack op) in
                              if dry_run then
                                let oph :=
                                  Operation_hash.hash_bytes None
                                    (cons string []) in
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 0>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 0>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Operation: 0x" % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@," % string 0 0)
                                              (CamlinternalFormatBasics.String_literal
                                                "Operation hash is '" % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "'" % char
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format))))))))
                                      "@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
                                        % string) Hex.pp
                                    (Hex.of_bytes None string) Operation_hash.pp
                                    oph)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Formatting_gen
                                            (CamlinternalFormatBasics.Open_box
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "<v 2>" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "<v 2>" % string))
                                            (CamlinternalFormatBasics.String_literal
                                              "Simulation result:" % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                (CamlinternalFormatBasics.Break
                                                  "@," % string 0 0)
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    CamlinternalFormatBasics.End_of_format)))))
                                          "@[<v 2>Simulation result:@,%a@]" %
                                            string)
                                        Operation_result.pp_operation_result
                                        ((contents (protocol_data op)),
                                          (contents result)))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        _return
                                          (oph, (contents (protocol_data op)),
                                            (contents result))))
                              else
                                op_gtgteqquestion
                                  (Shell_services.Injection.operation cctxt None
                                    (Some chain) string)
                                  (fun oph =>
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Operation successfully injected in the node."
                                              % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "Operation successfully injected in the node."
                                            % string))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Operation hash is '" % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "'" % char
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "Operation hash is '%a'" % string)
                                            Operation_hash.pp oph)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_gtgteqquestion
                                              match confirmations with
                                              | None =>
                                                op_gtgteq
                                                  ((* ❌ Sending method message is not handled *)
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.Formatting_gen
                                                        (CamlinternalFormatBasics.Open_box
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "<v 0>" % string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "<v 0>" % string))
                                                        (CamlinternalFormatBasics.String_literal
                                                          "NOT waiting for the operation to be included."
                                                            % string
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            (CamlinternalFormatBasics.Break
                                                              "@," % string 0 0)
                                                            (CamlinternalFormatBasics.String_literal
                                                              "Use command" %
                                                                string
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                (CamlinternalFormatBasics.Break
                                                                  "@," % string
                                                                  0 0)
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "  tezos-client wait for "
                                                                    % string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      " to be included --confirmations 30 --branch "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          (CamlinternalFormatBasics.Break
                                                                            "@,"
                                                                              %
                                                                              string
                                                                            0 0)
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "and/or an external block explorer to make sure that it has been included."
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                              CamlinternalFormatBasics.Close_box
                                                                              CamlinternalFormatBasics.End_of_format))))))))))))
                                                      "@[<v 0>NOT waiting for the operation to be included.@,Use command@,  tezos-client wait for %a to be included --confirmations 30 --branch %a@,and/or an external block explorer to make sure that it has been included.@]"
                                                        % string)
                                                    Operation_hash.pp oph
                                                    Block_hash.pp
                                                    (branch (shell op)))
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    _return result)
                                              | Some confirmations =>
                                                op_gtgteq
                                                  ((* ❌ Sending method message is not handled *)
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Waiting for the operation to be included..."
                                                          % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "Waiting for the operation to be included..."
                                                        % string))
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (Client_confirmations.wait_for_operation_inclusion
                                                        cctxt chain None
                                                        (Some confirmations)
                                                        (Some
                                                          (branch (shell op)))
                                                        oph)
                                                      (fun function_parameter =>
                                                        let '(h, i, j) :=
                                                          function_parameter in
                                                        op_gtgteqquestion
                                                          (Alpha_block_services.Operations.operation
                                                            cctxt (Some chain)
                                                            (Some
                                                              (* ❌ Variants not supported *)
                                                              variant) i j)
                                                          (fun op' =>
                                                            match receipt op'
                                                              with
                                                            |
                                                              Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
                                                              =>
                                                              failwith
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Internal error: unexpected receipt."
                                                                      % string
                                                                    CamlinternalFormatBasics.End_of_format)
                                                                  "Internal error: unexpected receipt."
                                                                    % string)
                                                            |
                                                              Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                                                                receipt =>
                                                              match
                                                                Apply_results.kind_equal_list
                                                                  contents
                                                                  (contents
                                                                    receipt)
                                                                with
                                                              |
                                                                Some
                                                                  Tezos_protocol_alpha.Protocol.Apply_results.Eq
                                                                =>
                                                                _return receipt
                                                              | None =>
                                                                failwith
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "Internal error: unexpected receipt."
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "Internal error: unexpected receipt."
                                                                      % string)
                                                              end
                                                            end)))
                                              end
                                              (fun result =>
                                                op_gtgteq
                                                  ((* ❌ Sending method message is not handled *)
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.Formatting_gen
                                                        (CamlinternalFormatBasics.Open_box
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "<v 2>" % string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "<v 2>" % string))
                                                        (CamlinternalFormatBasics.String_literal
                                                          "This sequence of operations was run:"
                                                            % string
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            (CamlinternalFormatBasics.Break
                                                              "@," % string 0 0)
                                                            (CamlinternalFormatBasics.Alpha
                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                CamlinternalFormatBasics.Close_box
                                                                CamlinternalFormatBasics.End_of_format)))))
                                                      "@[<v 2>This sequence of operations was run:@,%a@]"
                                                        % string)
                                                    Operation_result.pp_operation_result
                                                    ((contents
                                                      (protocol_data op)),
                                                      (contents result)))
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (Lwt._return
                                                        (originated_contracts
                                                          (contents result)))
                                                      (fun contracts =>
                                                        op_gtgteq
                                                          (Lwt_list.iter_s
                                                            (fun c =>
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "New contract "
                                                                      % string
                                                                    (CamlinternalFormatBasics.Alpha
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        " originated."
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)))
                                                                  "New contract %a originated."
                                                                    % string)
                                                                Contract.pp c)
                                                            contracts)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let 'tt :=
                                                              function_parameter
                                                              in
                                                            op_gtgteq
                                                              match
                                                                confirmations
                                                                with
                                                              | None =>
                                                                Lwt.return_unit
                                                              | Some number =>
                                                                if
                                                                  OCaml.Stdlib.ge
                                                                    number 30
                                                                  then
                                                                  (* ❌ Sending method message is not handled *)
                                                                  send
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "The operation was included in a block "
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Int
                                                                          CamlinternalFormatBasics.Int_d
                                                                          CamlinternalFormatBasics.No_padding
                                                                          CamlinternalFormatBasics.No_precision
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            " blocks ago."
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)))
                                                                      "The operation was included in a block %d blocks ago."
                                                                        % string)
                                                                    number
                                                                else
                                                                  (* ❌ Sending method message is not handled *)
                                                                  send
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                        (CamlinternalFormatBasics.Open_box
                                                                          (CamlinternalFormatBasics.Format
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "<v 0>"
                                                                                %
                                                                                string
                                                                              CamlinternalFormatBasics.End_of_format)
                                                                            "<v 0>"
                                                                              %
                                                                              string))
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          "The operation has only been included "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Int
                                                                            CamlinternalFormatBasics.Int_d
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              " blocks ago."
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                (CamlinternalFormatBasics.Break
                                                                                  "@,"
                                                                                    %
                                                                                    string
                                                                                  0
                                                                                  0)
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "We recommend to wait more."
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                    (CamlinternalFormatBasics.Break
                                                                                      "@,"
                                                                                        %
                                                                                        string
                                                                                      0
                                                                                      0)
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      "Use command"
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                        (CamlinternalFormatBasics.Break
                                                                                          "@,"
                                                                                            %
                                                                                            string
                                                                                          0
                                                                                          0)
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          "  tezos-client wait for "
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Alpha
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              " to be included --confirmations 30 --branch "
                                                                                                %
                                                                                                string
                                                                                              (CamlinternalFormatBasics.Alpha
                                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                                  (CamlinternalFormatBasics.Break
                                                                                                    "@,"
                                                                                                      %
                                                                                                      string
                                                                                                    0
                                                                                                    0)
                                                                                                  (CamlinternalFormatBasics.String_literal
                                                                                                    "and/or an external block explorer."
                                                                                                      %
                                                                                                      string
                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                      CamlinternalFormatBasics.Close_box
                                                                                                      CamlinternalFormatBasics.End_of_format))))))))))))))))
                                                                      "@[<v 0>The operation has only been included %d blocks ago.@,We recommend to wait more.@,Use command@,  tezos-client wait for %a to be included --confirmations 30 --branch %a@,and/or an external block explorer.@]"
                                                                        % string)
                                                                    number
                                                                    Operation_hash.pp
                                                                    oph
                                                                    Block_hash.pp
                                                                    (branch
                                                                      (shell op))
                                                              end
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                _return
                                                                  (oph,
                                                                    (contents
                                                                      (protocol_data
                                                                        op)),
                                                                    (contents
                                                                      result)))))))))))))).

Definition inject_manager_operation {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (L * p * q * i * o)) *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                (o -> unit) ->
                  (unit -> unit) ->
                    p ->
                      q ->
                        i ->
                          Lwt.t
                            (Tezos_error_monad.Error_monad.tzresult
                              (unit -> unit))) * (M * p * q * i * o)) *
                (Tezos_shell_services.Shell_services.chain *
                  ((option Z) *
                    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) *
                      (a * b)) *
                      ((Tezos_rpc.RPC_service.meth ->
                        (option Tezos_data_encoding.Data_encoding.json) ->
                          Uri.t ->
                            Lwt.t
                              (Tezos_rpc.RPC_context.rest_result
                                Tezos_data_encoding.Data_encoding.json
                                (option Tezos_data_encoding.Data_encoding.json)))
                        *
                        (((string ->
                          a ->
                            (Tezos_base__TzPervasives.Data_encoding.encoding a)
                              -> Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                          (a)) *
                          ((option (Lwt_stream.t string)) *
                            (((string ->
                              (Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                unit) -> a) * (a)) *
                                ((unit -> Ptime.t) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((Z -> Lwt.t unit) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((((unit -> Lwt.t a) -> Lwt.t a) *
                                              (a)) *
                                              (((string ->
                                                a ->
                                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                                    a) ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        unit)) * (a)) * N)))))))))))))))))))))
      *
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block))
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block) (branch : option Z)
  (confirmations : option Z) (dry_run : option bool)
  (verbose_signing : option bool)
  (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (src_pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (op_staroptstar : option Z.t)
  : (option Z.t) ->
    (option Z.t) ->
      fee_parameter ->
        (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation O) ->
          Lwt.t
            (Tezos_base__TzPervasives.tzresult
              (Tezos_base__TzPervasives.Operation_hash.t *
                (Tezos_protocol_alpha.Protocol.Alpha_context.contents
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager O))
                *
                (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager O)))) :=
  let gas_limit :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Z.minus_one
    end in
  fun op_staroptstar =>
    let storage_limit :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Z.of_int (-1)
      end in
    fun counter =>
      fun fee_parameter =>
        fun operation =>
          op_gtgteqquestion
            match counter with
            | None =>
              op_gtgteqquestion
                (Alpha_services.Contract.counter cctxt (chain, block) source)
                (fun pcounter =>
                  let counter := Z.succ pcounter in
                  _return counter)
            | Some counter => _return counter
            end
            (fun counter =>
              op_gtgteqquestion
                (Alpha_services.Contract.manager_key cctxt (chain, block) source)
                (fun key =>
                  let is_reveal {kind : Type}
                    (function_parameter :
                    Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation
                      kind) : bool :=
                    match function_parameter with
                    | Tezos_protocol_alpha.Protocol.Alpha_context.Reveal _ =>
                      true
                    | _ => false
                    end in
                  let '(compute_fee, fee) :=
                    match fee with
                    | None => (true, Tez.zero)
                    | Some fee => (false, fee)
                    end in
                  match key with
                  | None =>
                    let contents :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Cons
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                          {| source := source; fee := Tez.zero;
                            counter := counter;
                            operation :=
                              Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
                                src_pk; gas_limit := Z.of_int 10000;
                            storage_limit := Z.zero |})
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Single
                          (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                            {| source := source; fee := fee;
                              counter := Z.succ counter; operation := operation;
                              gas_limit := gas_limit;
                              storage_limit := storage_limit |})) in
                    op_gtgteqquestion
                      (inject_operation cctxt chain block confirmations dry_run
                        branch (Some src_sk) verbose_signing fee_parameter
                        (Some compute_fee) contents)
                      (fun function_parameter =>
                        let '(oph, op, result) := function_parameter in
                        match pack_contents_list op result with
                        |
                          Tezos_protocol_alpha.Protocol.Apply_results.Cons_and_result
                            _ _
                            (Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
                              op result) => _return (oph, op, result)
                        |
                          Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
                            (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                              _) _ =>
                          (* ❌ Unreachable expressions are not supported *)
                          unreachable
                        | _ =>
                          (* ❌ Assert instruction is not handled. *)
                          assert false
                        end)
                  | _ =>
                    let contents :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Single
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                          {| source := source; fee := fee; counter := counter;
                            operation := operation; gas_limit := gas_limit;
                            storage_limit := storage_limit |}) in
                    op_gtgteqquestion
                      (inject_operation cctxt chain block confirmations dry_run
                        branch (Some src_sk) verbose_signing fee_parameter
                        (Some compute_fee) contents)
                      (fun function_parameter =>
                        let '(oph, op, result) := function_parameter in
                        match pack_contents_list op result with
                        |
                          Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
                            ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                              _) as op) result => _return (oph, op, result)
                        | _ =>
                          (* ❌ Assert instruction is not handled. *)
                          assert false
                        end)
                  end)).

src/proto_alpha/lib_client/managed_contract.ml 254 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)
open Protocol
open Alpha_context
open Protocol_client_context
open Tezos_micheline
open Client_proto_context

let get_contract_manager (cctxt : #full) contract =
  let open Micheline in
  let open Michelson_v1_primitives in
  get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract
  >>=? function
  | None ->
      cctxt#error "This is not a smart contract."
  | Some storage -> (
    match root storage with
    | Prim (_, D_Pair, [Bytes (_, bytes); _], _) | Bytes (_, bytes) -> (
      match
        Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
      with
      | Some k ->
          return k
      | None ->
          cctxt#error
            "Cannot find a manager key in contracts storage (decoding bytes \
             failed).\n\
             Transfer from scripted contract are currently only supported for \
             \"manager\" contract." )
    | Prim (_, D_Pair, [String (_, value); _], _) | String (_, value) -> (
      match Signature.Public_key_hash.of_b58check_opt value with
      | Some k ->
          return k
      | None ->
          cctxt#error
            "Cannot find a manager key in contracts storage (\"%s\" is not a \
             valid key).\n\
             Transfer from scripted contract are currently only supported for \
             \"manager\" contract."
            value )
    | _raw_storage ->
        cctxt#error
          "Cannot find a manager key in contracts storage (wrong storage \
           format : @[%a@]).\n\
           Transfer from scripted contract are currently only supported for \
           \"manager\" contract."
          Michelson_v1_printer.print_expr
          storage )

let parse code =
  Lwt.return
    ( Micheline_parser.no_parsing_error
      @@ Michelson_v1_parser.parse_expression code
    >>? fun exp ->
    Error_monad.ok @@ Script.lazy_expr Michelson_v1_parser.(exp.expanded) )

let set_delegate (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ~fee_parameter ?fee ~source ~src_pk ~src_sk
    contract (* the KT1 to delegate *)
    (delegate : Signature.public_key_hash option) =
  let entrypoint = "do" in
  Michelson_v1_entrypoints.contract_entrypoint_type
    cctxt
    ~chain
    ~block
    ~contract
    ~entrypoint
  >>=? (function
         | Some _ ->
             (* their is a "do" entrypoint (we could check its type here)*)
             let lambda =
               match delegate with
               | Some delegate ->
                   let (`Hex delegate) =
                     Signature.Public_key_hash.to_hex delegate
                   in
                   Format.asprintf
                     "{ DROP ; NIL operation ; PUSH key_hash 0x%s ; SOME ; \
                      SET_DELEGATE ; CONS }"
                     delegate
               | None ->
                   "{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; \
                    CONS }"
             in
             parse lambda >>=? fun param -> return (param, entrypoint)
         | None -> (
             (*  their is no "do" entrypoint trying "set/remove_delegate" *)
             let entrypoint =
               match delegate with
               | Some _ ->
                   "set_delegate"
               | None ->
                   "remove_delegate"
             in
             Michelson_v1_entrypoints.contract_entrypoint_type
               cctxt
               ~chain
               ~block
               ~contract
               ~entrypoint
             >>=? function
             | Some _ ->
                 (*  their is a "set/remove_delegate" entrypoint *)
                 let delegate_data =
                   match delegate with
                   | Some delegate ->
                       let (`Hex delegate) =
                         Signature.Public_key_hash.to_hex delegate
                       in
                       "0x" ^ delegate
                   | None ->
                       "Unit"
                 in
                 parse delegate_data
                 >>=? fun param -> return (param, entrypoint)
             | None ->
                 cctxt#error
                   "Cannot find a %%do or %%set_delegate entrypoint in \
                    contract@." ))
  >>=? fun (parameters, entrypoint) ->
  let operation =
    Transaction
      {amount = Tez.zero; parameters; entrypoint; destination = contract}
  in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ~storage_limit:Z.zero
    ~src_pk
    ~src_sk
    ~fee_parameter
    operation
  >>=? fun res -> return res

let d_unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))

let t_unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.T_unit, [], []))

let build_lambda_for_implicit ~delegate ~amount =
  let (`Hex delegate) = Signature.Public_key_hash.to_hex delegate in
  Format.asprintf
    "{ DROP ; NIL operation ;PUSH key_hash 0x%s; IMPLICIT_ACCOUNT;PUSH mutez \
     %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
    delegate
    (Tez.to_mutez amount)

let build_lambda_for_originated ~destination ~entrypoint ~amount
    ~parameter_type ~parameter =
  let destination =
    Data_encoding.Binary.to_bytes_exn Contract.encoding destination
  in
  let amount = Tez.to_mutez amount in
  let (`Hex destination) = MBytes.to_hex destination in
  let entrypoint = match entrypoint with "default" -> "" | s -> "%" ^ s in
  if parameter_type = t_unit then
    Format.asprintf
      "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; \
       ASSERT_SOME;PUSH mutez %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
      destination
      entrypoint
      Michelson_v1_printer.print_expr
      parameter_type
      amount
  else
    Format.asprintf
      "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; \
       ASSERT_SOME;PUSH mutez %Ld ;PUSH %a %a;TRANSFER_TOKENS ; CONS }"
      destination
      entrypoint
      Michelson_v1_printer.print_expr
      parameter_type
      amount
      Michelson_v1_printer.print_expr
      parameter_type
      Michelson_v1_printer.print_expr
      parameter

let transfer (cctxt : #full) ~chain ~block ?confirmations ?dry_run
    ?verbose_signing ?branch ~source ~src_pk ~src_sk ~contract ~destination
    ?(entrypoint = "default") ?arg ~amount ?fee ?gas_limit ?storage_limit
    ?counter ~fee_parameter () :
    (Kind.transaction Kind.manager Injection.result * Contract.t list) tzresult
    Lwt.t =
  ( match Alpha_context.Contract.is_implicit destination with
  | Some delegate when entrypoint = "default" ->
      return @@ build_lambda_for_implicit ~delegate ~amount
  | Some _ ->
      cctxt#error
        "Implicit accounts have no entrypoints. (targeted entrypoint %%%s on \
         contract %a)"
        entrypoint
        Contract.pp
        destination
  | None ->
      Michelson_v1_entrypoints.contract_entrypoint_type
        cctxt
        ~chain
        ~block
        ~contract:destination
        ~entrypoint
      >>=? (function
             | None ->
                 cctxt#error
                   "Contract %a has no entrypoint named %s"
                   Contract.pp
                   destination
                   entrypoint
             | Some parameter_type ->
                 return parameter_type)
      >>=? fun parameter_type ->
      ( match arg with
      | Some arg ->
          Lwt.return @@ Micheline_parser.no_parsing_error
          @@ Michelson_v1_parser.parse_expression arg
          >>=? fun {expanded = arg; _} -> return_some arg
      | None ->
          return_none )
      >>=? fun parameter ->
      let parameter = Option.unopt ~default:d_unit parameter in
      return
      @@ build_lambda_for_originated
           ~destination
           ~entrypoint
           ~amount
           ~parameter_type
           ~parameter )
  >>=? fun lambda ->
  parse lambda
  >>=? fun parameters ->
  let entrypoint = "do" in
  let operation =
    Transaction
      {amount = Tez.zero; parameters; entrypoint; destination = contract}
  in
  Injection.inject_manager_operation
    cctxt
    ~chain
    ~block
    ?confirmations
    ?dry_run
    ?verbose_signing
    ?branch
    ~source
    ?fee
    ?gas_limit
    ?storage_limit
    ?counter
    ~src_pk
    ~src_sk
    ~fee_parameter
    operation
  >>=? fun ((_oph, _op, result) as res) ->
  Lwt.return (Injection.originated_contracts (Single_result result))
  >>=? fun contracts -> return (res, contracts)
src/proto_alpha/lib_client/managed_contract.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Protocol_client_context.

Import Tezos_micheline.

Import Client_proto_context.

Definition get_contract_manager {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_base__TzPervasives.Signature.Public_key_hash.t) :=
  op_gtgteqquestion
    (get_storage cctxt
      (* ❌ Sending method message is not handled *)
      send
      (* ❌ Sending method message is not handled *)
      send contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        (* ❌ Sending method message is not handled *)
        send
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This is not a smart contract." % string
              CamlinternalFormatBasics.End_of_format)
            "This is not a smart contract." % string)
      | Some storage =>
        match root storage with
        |
          Tezos_micheline.Micheline.Prim _
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.D_Pair
            (cons (Tezos_micheline.Micheline.Bytes _ bytes) (cons _ [])) _ |
            Tezos_micheline.Micheline.Bytes _ bytes =>
          match
            Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding
              string with
          | Some k => _return k
          | None =>
            (* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Cannot find a manager key in contracts storage (decoding bytes failed).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                    % string CamlinternalFormatBasics.End_of_format)
                "Cannot find a manager key in contracts storage (decoding bytes failed).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                  % string)
          end
        |
          Tezos_micheline.Micheline.Prim _
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.D_Pair
            (cons (Tezos_micheline.Micheline.String _ value) (cons _ [])) _ |
            Tezos_micheline.Micheline.String _ value =>
          match Signature.Public_key_hash.of_b58check_opt value with
          | Some k => _return k
          | None =>
            (* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Cannot find a manager key in contracts storage (""" % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      """ is not a valid key).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                        % string CamlinternalFormatBasics.End_of_format)))
                "Cannot find a manager key in contracts storage (""%s"" is not a valid key).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                  % string) value
          end
        | _raw_storage =>
          (* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Cannot find a manager key in contracts storage (wrong storage format : "
                  % string
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      CamlinternalFormatBasics.End_of_format "" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      (CamlinternalFormatBasics.String_literal
                        ").
Transfer from scripted contract are currently only supported for ""manager"" contract."
                          % string CamlinternalFormatBasics.End_of_format)))))
              "Cannot find a manager key in contracts storage (wrong storage format : @[%a@]).
Transfer from scripted contract are currently only supported for ""manager"" contract."
                % string) Michelson_v1_printer.print_expr storage
        end
      end).

Definition parse (code : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr) :=
  Lwt._return
    (op_gtgtquestion
      (apply Micheline_parser.no_parsing_error
        (Michelson_v1_parser.parse_expression None code))
      (fun exp => apply Error_monad.ok (Script.lazy_expr (expanded exp)))).

Definition set_delegate {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (fee_parameter : Tezos_client_alpha.Injection.fee_parameter)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (delegate : option Tezos_base__TzPervasives.Signature.public_key_hash)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_client_alpha.Injection.result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))) :=
  let entrypoint := "do" % string in
  op_gtgteqquestion
    (op_gtgteqquestion
      (Michelson_v1_entrypoints.contract_entrypoint_type cctxt chain block
        contract entrypoint)
      (fun function_parameter =>
        match function_parameter with
        | Some _ =>
          let lambda :=
            match delegate with
            | Some delegate =>
              let 'Hex delegate := Signature.Public_key_hash.to_hex delegate in
              Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "{ DROP ; NIL operation ; PUSH key_hash 0x" % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        " ; SOME ; SET_DELEGATE ; CONS }" % string
                        CamlinternalFormatBasics.End_of_format)))
                  "{ DROP ; NIL operation ; PUSH key_hash 0x%s ; SOME ; SET_DELEGATE ; CONS }"
                    % string) delegate
            | None =>
              "{ DROP ; NIL operation ; NONE key_hash ; SET_DELEGATE ; CONS }" %
                string
            end in
          op_gtgteqquestion (parse lambda)
            (fun param => _return (param, entrypoint))
        | None =>
          let entrypoint :=
            match delegate with
            | Some _ => "set_delegate" % string
            | None => "remove_delegate" % string
            end in
          op_gtgteqquestion
            (Michelson_v1_entrypoints.contract_entrypoint_type cctxt chain block
              contract entrypoint)
            (fun function_parameter =>
              match function_parameter with
              | Some _ =>
                let delegate_data :=
                  match delegate with
                  | Some delegate =>
                    let 'Hex delegate :=
                      Signature.Public_key_hash.to_hex delegate in
                    String.append "0x" % string delegate
                  | None => "Unit" % string
                  end in
                op_gtgteqquestion (parse delegate_data)
                  (fun param => _return (param, entrypoint))
              | None =>
                (* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot find a " % string
                      (CamlinternalFormatBasics.Char_literal "%" % char
                        (CamlinternalFormatBasics.String_literal
                          "do or " % string
                          (CamlinternalFormatBasics.Char_literal "%" % char
                            (CamlinternalFormatBasics.String_literal
                              "set_delegate entrypoint in contract" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))))
                    "Cannot find a %%do or %%set_delegate entrypoint in contract@."
                      % string)
              end)
        end))
    (fun function_parameter =>
      let '(parameters, entrypoint) := function_parameter in
      let operation :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
          {| amount := Tez.zero; parameters := parameters;
            entrypoint := entrypoint; destination := contract |} in
      op_gtgteqquestion
        (Injection.inject_manager_operation cctxt chain block branch
          confirmations dry_run verbose_signing source src_pk src_sk fee None
          (Some Z.zero) None fee_parameter operation) (fun res => _return res)).

Definition d_unit
  : Tezos_micheline.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim :=
  Micheline.strip_locations
    (Tezos_micheline.Micheline.Prim 0
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.D_Unit [] []).

Definition t_unit
  : Tezos_micheline.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim :=
  Micheline.strip_locations
    (Tezos_micheline.Micheline.Prim 0
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.T_unit [] []).

Definition build_lambda_for_implicit
  (delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) : string :=
  let 'Hex delegate := Signature.Public_key_hash.to_hex delegate in
  Format.asprintf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.String_literal
        "{ DROP ; NIL operation ;PUSH key_hash 0x" % string
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.String_literal
            "; IMPLICIT_ACCOUNT;PUSH mutez " % string
            (CamlinternalFormatBasics.Int64 CamlinternalFormatBasics.Int_d
              CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.No_precision
              (CamlinternalFormatBasics.String_literal
                " ;UNIT;TRANSFER_TOKENS ; CONS }" % string
                CamlinternalFormatBasics.End_of_format)))))
      "{ DROP ; NIL operation ;PUSH key_hash 0x%s; IMPLICIT_ACCOUNT;PUSH mutez %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
        % string) delegate (Tez.to_mutez amount).

Definition build_lambda_for_originated
  (destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (entrypoint : string)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (parameter_type :
    Tezos_micheline.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim)
  (parameter : Tezos_protocol_alpha.Protocol.Script_repr.expr) : string :=
  let destination :=
    Data_encoding.Binary.to_bytes_exn Contract.encoding destination in
  let amount := Tez.to_mutez amount in
  let 'Hex destination := MBytes.to_hex destination in
  let entrypoint :=
    match entrypoint with
    | "default" % string => "" % string
    | s => String.append "%" % string s
    end in
  if equiv_decb parameter_type t_unit then
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "{ DROP ; NIL operation ;PUSH address 0x" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "; CONTRACT " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "; ASSERT_SOME;PUSH mutez " % string
                      (CamlinternalFormatBasics.Int64
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " ;UNIT;TRANSFER_TOKENS ; CONS }" % string
                          CamlinternalFormatBasics.End_of_format)))))))))
        "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; ASSERT_SOME;PUSH mutez %Ld ;UNIT;TRANSFER_TOKENS ; CONS }"
          % string) destination entrypoint Michelson_v1_printer.print_expr
      parameter_type amount
  else
    Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "{ DROP ; NIL operation ;PUSH address 0x" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.String_literal "; CONTRACT " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "; ASSERT_SOME;PUSH mutez " % string
                      (CamlinternalFormatBasics.Int64
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " ;PUSH " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal " " % char
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  ";TRANSFER_TOKENS ; CONS }" % string
                                  CamlinternalFormatBasics.End_of_format)))))))))))))
        "{ DROP ; NIL operation ;PUSH address 0x%s; CONTRACT %s %a; ASSERT_SOME;PUSH mutez %Ld ;PUSH %a %a;TRANSFER_TOKENS ; CONS }"
          % string) destination entrypoint Michelson_v1_printer.print_expr
      parameter_type amount Michelson_v1_printer.print_expr parameter_type
      Michelson_v1_printer.print_expr parameter.

Definition transfer {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block) (confirmations : option Z)
  (dry_run : option bool) (verbose_signing : option bool) (branch : option Z)
  (source : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (src_pk : Tezos_base__TzPervasives.Signature.public_key)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
  (destination : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
  (op_staroptstar : option string)
  : (option string) ->
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) ->
        (option Z.t) ->
          (option Z.t) ->
            (option Z.t) ->
              Tezos_client_alpha.Injection.fee_parameter ->
                unit ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      ((Tezos_client_alpha.Injection.result
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager
                          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.transaction))
                        *
                        (list
                          Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))) :=
  let entrypoint :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "default" % string
    end in
  fun arg =>
    fun amount =>
      fun fee =>
        fun gas_limit =>
          fun storage_limit =>
            fun counter =>
              fun fee_parameter =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    match Alpha_context.Contract.is_implicit destination with
                    | Some delegate =>
                      apply _return (build_lambda_for_implicit delegate amount)
                    | Some _ =>
                      (* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Implicit accounts have no entrypoints. (targeted entrypoint "
                              % string
                            (CamlinternalFormatBasics.Char_literal "%" % char
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " on contract " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      CamlinternalFormatBasics.End_of_format))))))
                          "Implicit accounts have no entrypoints. (targeted entrypoint %%%s on contract %a)"
                            % string) entrypoint Contract.pp destination
                    | None =>
                      op_gtgteqquestion
                        (op_gtgteqquestion
                          (Michelson_v1_entrypoints.contract_entrypoint_type
                            cctxt chain block destination entrypoint)
                          (fun function_parameter =>
                            match function_parameter with
                            | None =>
                              (* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Contract " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.String_literal
                                        " has no entrypoint named " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.End_of_format))))
                                  "Contract %a has no entrypoint named %s" %
                                    string) Contract.pp destination entrypoint
                            | Some parameter_type => _return parameter_type
                            end))
                        (fun parameter_type =>
                          op_gtgteqquestion
                            match arg with
                            | Some arg =>
                              op_gtgteqquestion
                                (apply Lwt._return
                                  (apply Micheline_parser.no_parsing_error
                                    (Michelson_v1_parser.parse_expression None
                                      arg)))
                                (fun function_parameter =>
                                  let '{| expanded := arg |} :=
                                    function_parameter in
                                  return_some arg)
                            | None => return_none
                            end
                            (fun parameter =>
                              let parameter := Option.unopt d_unit parameter in
                              apply _return
                                (build_lambda_for_originated destination
                                  entrypoint amount parameter_type parameter)))
                    end
                    (fun lambda =>
                      op_gtgteqquestion (parse lambda)
                        (fun parameters =>
                          let entrypoint := "do" % string in
                          let operation :=
                            Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
                              {| amount := Tez.zero; parameters := parameters;
                                entrypoint := entrypoint;
                                destination := contract |} in
                          op_gtgteqquestion
                            (Injection.inject_manager_operation cctxt chain
                              block branch confirmations dry_run verbose_signing
                              source src_pk src_sk fee gas_limit storage_limit
                              counter fee_parameter operation)
                            (fun function_parameter =>
                              let '(_oph, _op, result) as res :=
                                function_parameter in
                              op_gtgteqquestion
                                (Lwt._return
                                  (Injection.originated_contracts
                                    (Tezos_protocol_alpha.Protocol.Apply_results.Single_result
                                      result)))
                                (fun contracts => _return (res, contracts))))).

src/proto_alpha/lib_client/michelson_v1_emacs.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Tezos_micheline
open Micheline

let print_expr ppf expr =
  let print_annot ppf = function
    | [] ->
        ()
    | annots ->
        Format.fprintf ppf " %s" (String.concat " " annots)
  in
  let rec print_expr ppf = function
    | Int (_, value) ->
        Format.fprintf ppf "%s" (Z.to_string value)
    | String (_, value) ->
        Micheline_printer.print_string ppf value
    | Bytes (_, value) ->
        Format.fprintf ppf "0x%a" Hex.pp (Hex.of_bytes value)
    | Seq (_, items) ->
        Format.fprintf
          ppf
          "(seq %a)"
          (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
          items
    | Prim (_, name, [], []) ->
        Format.fprintf ppf "%s" name
    | Prim (_, name, items, annot) ->
        Format.fprintf
          ppf
          "(%s%a%s%a)"
          name
          print_annot
          annot
          (if items = [] then "" else " ")
          (Format.pp_print_list ~pp_sep:Format.pp_print_space print_expr)
          items
  in
  let root = root (Michelson_v1_primitives.strings_of_prims expr) in
  Format.fprintf ppf "@[<h>%a@]" print_expr root

let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")

let print_annot_expr ppf (expr, annot) =
  Format.fprintf ppf "(%a%a)" print_var_annots annot print_expr expr

open Micheline_parser
open Script_tc_errors

let print_type_map ppf (parsed, type_map) =
  let rec print_expr_types ppf = function
    | Seq (loc, [])
    | Prim (loc, _, [], _)
    | Int (loc, _)
    | Bytes (loc, _)
    | String (loc, _) ->
        print_item ppf loc
    | Seq (loc, items) | Prim (loc, _, items, _) ->
        print_item ppf loc ;
        List.iter (print_expr_types ppf) items
  and print_stack ppf items =
    Format.fprintf
      ppf
      "(%a)"
      (Format.pp_print_list ~pp_sep:Format.pp_print_space print_annot_expr)
      items
  and print_item ppf loc =
    try
      let ({start = {point = s; _}; stop = {point = e; _}}, locs) =
        List.assoc loc parsed.Michelson_v1_parser.expansion_table
      in
      let locs = List.sort compare locs in
      let (bef, aft) = List.assoc (List.hd locs) type_map in
      Format.fprintf
        ppf
        "(@[<h>%d %d %a %a@])@,"
        s
        e
        print_stack
        bef
        print_stack
        aft
    with Not_found -> ()
  in
  Format.fprintf ppf "(@[<v 0>%a@])" print_expr_types (root parsed.unexpanded)

let first_error_location errs =
  let rec find = function
    | [] ->
        0
    | ( Inconsistent_type_annotations (loc, _, _)
      | Unexpected_annotation loc
      | Ill_formed_type (_, _, loc)
      | Invalid_arity (loc, _, _, _)
      | Invalid_namespace (loc, _, _, _)
      | Invalid_primitive (loc, _, _)
      | Invalid_kind (loc, _, _)
      | Fail_not_in_tail_position loc
      | Undefined_binop (loc, _, _, _)
      | Undefined_unop (loc, _, _)
      | Bad_return (loc, _, _)
      | Bad_stack (loc, _, _, _)
      | Unmatched_branches (loc, _, _)
      | Invalid_constant (loc, _, _)
      | Invalid_syntactic_constant (loc, _, _)
      | Invalid_contract (loc, _)
      | Comparable_type_expected (loc, _)
      | Michelson_v1_primitives.Invalid_primitive_name (_, loc) )
      :: _ ->
        loc
    | _ :: rest ->
        find rest
  in
  find errs

let report_errors ppf (parsed, errs) =
  let (eco, out) =
    List.fold_left
      (fun (eco, out) -> function Environment.Ecoproto_error err ->
            (err :: eco, out) | err -> (eco, err :: out))
      ([], [])
      errs
  in
  let (eco, out) = (List.rev eco, List.rev out) in
  Format.fprintf
    ppf
    "(@[<v 0>%a@,%a@])"
    (fun ppf errs ->
      let find_location loc =
        let oloc =
          List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
        in
        fst (List.assoc oloc parsed.expansion_table)
      in
      match errs with
      | top :: errs ->
          let (errs, loc) =
            ( List.map (fun e -> Environment.Ecoproto_error e) (top :: errs),
              match top with
              | Ill_typed_contract (expr, _) | Ill_typed_data (_, expr, _) ->
                  if expr = parsed.expanded then
                    find_location (first_error_location (top :: errs))
                  else find_location 0
              | Michelson_v1_primitives.Invalid_primitive_name (expr, loc) ->
                  if
                    Micheline.strip_locations
                      (Michelson_v1_macros.unexpand_rec (Micheline.root expr))
                    = parsed.Michelson_v1_parser.unexpanded
                  then find_location loc
                  else find_location 0
              | _ ->
                  find_location 0 )
          in
          let message =
            Format.asprintf
              "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
                 ~show_source:false
                 ~parsed)
              errs
          in
          let {start = {point = s; _}; stop = {point = e; _}} = loc in
          Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message
      | [] ->
          ())
    eco
    (Format.pp_print_list (fun ppf err ->
         let find_location loc =
           let oloc =
             List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
           in
           fst (List.assoc oloc parsed.expansion_table)
         in
         let loc =
           match err with
           | Invalid_utf8_sequence (point, _)
           | Unexpected_character (point, _)
           | Undefined_escape_sequence (point, _)
           | Missing_break_after_number point ->
               {start = point; stop = point}
           | Unterminated_string loc
           | Unterminated_integer loc
           | Unterminated_comment loc
           | Odd_lengthed_bytes loc
           | Unclosed {loc; _}
           | Unexpected {loc; _}
           | Extra {loc; _} ->
               loc
           | Misaligned node ->
               location node
           | _ ->
               find_location 0
         in
         let message =
           Format.asprintf
             "%a"
             (Michelson_v1_error_reporter.report_errors
                ~details:false
                ~show_source:false
                ~parsed)
             [err]
         in
         let {start = {point = s; _}; stop = {point = e; _}} = loc in
         Format.fprintf ppf "(%d %d %S)" (s + 1) (e + 1) message))
    out
src/proto_alpha/lib_client/michelson_v1_emacs.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Tezos_micheline.

Import Micheline.

Definition print_expr
  (ppf : Stdlib.Format.formatter)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
  let print_annot
    (ppf : Stdlib.Format.formatter) (function_parameter : list string) : unit :=
    match function_parameter with
    | [] => tt
    | annots =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal " " % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              CamlinternalFormatBasics.End_of_format)) " %s" % string)
        (String.concat " " % string annots)
    end in
  let fix print_expr {A : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter :
    Tezos_micheline.Micheline.node A string) : unit :=
    match function_parameter with
    | Tezos_micheline.Micheline.Int _ value =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string)
        (Z.to_string value)
    | Tezos_micheline.Micheline.String _ value =>
      Micheline_printer.print_string ppf value
    | Tezos_micheline.Micheline.Bytes _ value =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "0x" % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "0x%a" % string) Hex.pp
        (Hex.of_bytes None value)
    | Tezos_micheline.Micheline.Seq _ items =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "(seq " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "(seq %a)" % string)
        (Format.pp_print_list (Some Format.pp_print_space) print_expr) items
    | Tezos_micheline.Micheline.Prim _ name [] [] =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format) "%s" % string) name
    | Tezos_micheline.Micheline.Prim _ name items annot =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal ")" % char
                      CamlinternalFormatBasics.End_of_format))))))
          "(%s%a%s%a)" % string) name print_annot annot
        (if equiv_decb items [] then
          "" % string
        else
          " " % string)
        (Format.pp_print_list (Some Format.pp_print_space) print_expr) items
    end in
  let root := root (Michelson_v1_primitives.strings_of_prims expr) in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<h>" % string
              CamlinternalFormatBasics.End_of_format) "<h>" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[<h>%a@]" % string)
    print_expr root.

Definition print_var_annots (ppf : Stdlib.Format.formatter)
  : (list string) -> unit :=
  List.iter
    (Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal " " % char
            CamlinternalFormatBasics.End_of_format)) "%s " % string)).

Definition print_annot_expr
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
      (list string)) : unit :=
  let '(expr, annot) := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "(" % char
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))) "(%a%a)" % string)
    print_var_annots annot print_expr expr.

Import Micheline_parser.

Import Script_tc_errors.

Definition print_type_map
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_client_alpha.Michelson_v1_parser.parsed *
      (list
        (Z *
          ((list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))) *
            (list
              ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
                (list string))))))) : unit :=
  let '(parsed, type_map) := function_parameter in
  let fix print_expr_types {A : Type}
    (ppf : Stdlib.Format.formatter) (function_parameter :
    Tezos_micheline.Micheline.node Z A) : unit :=
    match function_parameter with
    |
      Tezos_micheline.Micheline.Seq loc [] |
        Tezos_micheline.Micheline.Prim loc _ [] _ |
        Tezos_micheline.Micheline.Int loc _ |
        Tezos_micheline.Micheline.Bytes loc _ |
        Tezos_micheline.Micheline.String loc _ => print_item ppf loc
    |
      Tezos_micheline.Micheline.Seq loc items |
        Tezos_micheline.Micheline.Prim loc _ items _ =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := print_item ppf loc in
      List.iter (print_expr_types ppf) items
    end
  with print_stack
    (ppf : Stdlib.Format.formatter) (items :
    list
      ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
        Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
        (list string))) : unit :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Char_literal "(" % char
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format))) "(%a)" % string)
      (Format.pp_print_list (Some Format.pp_print_space) print_annot_expr) items
  with print_item (ppf : Stdlib.Format.formatter) (loc : Z) : unit :=
    (* ❌ Try-with are not handled *)
    try
      (let '({| start := {| point := s |}; stop := {| point := e |} |}, locs) :=
        List.assoc loc (Michelson_v1_parser.expansion_table parsed) in
      let locs := List.sort OCaml.Stdlib.compare locs in
      let '(bef, aft) := List.assoc (List.hd locs) type_map in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Char_literal "(" % char
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<h>" % string
                    CamlinternalFormatBasics.End_of_format) "<h>" % string))
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.Char_literal " " % char
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0) CamlinternalFormatBasics.End_of_format))))))))))))
          "(@[<h>%d %d %a %a@])@," % string) s e print_stack bef print_stack aft)
    in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "(" % char
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format)))))
      "(@[<v 0>%a@])" % string) print_expr_types (root (unexpanded parsed)).

Definition first_error_location
  (errs : list Tezos_protocol_environment_alpha__Environment.Error_monad.error)
  : Z :=
  let fix find
    (function_parameter :
    list Tezos_protocol_environment_alpha__Environment.Error_monad.error) : Z :=
    match function_parameter with
    | [] => 0
    |
      cons
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
          loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
            loc |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
            _ _ loc |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc _ _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
            loc _ _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
            loc |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
            loc _ _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
            loc _ _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
            loc _ _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
            loc _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
            loc _ |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
            _ loc) _ => loc
    | cons _ rest => find rest
    end in
  find errs.

Definition report_errors
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_client_alpha.Michelson_v1_parser.parsed *
      (list Tezos_base__TzPervasives.Error_monad.error)) : unit :=
  let '(parsed, errs) := function_parameter in
  let '(eco, out) :=
    List.fold_left
      (fun function_parameter =>
        let '(eco, out) := function_parameter in
        fun function_parameter =>
          match function_parameter with
          | Tezos_base__TzPervasives.Error_monad.Ecoproto_error err =>
            ((cons err eco), out)
          | err => (eco, (cons err out))
          end) ([], []) errs in
  let '(eco, out) := ((List.rev eco), (List.rev out)) in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Char_literal "(" % char
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  (CamlinternalFormatBasics.Char_literal ")" % char
                    CamlinternalFormatBasics.End_of_format)))))))
      "(@[<v 0>%a@,%a@])" % string)
    (fun ppf =>
      fun errs =>
        let find_location (loc : Z)
          : Tezos_micheline.Micheline_parser.location :=
          let oloc :=
            List.assoc loc (Michelson_v1_parser.unexpansion_table parsed) in
          fst (List.assoc oloc (expansion_table parsed)) in
        match errs with
        | cons top errs =>
          let '(errs, loc) :=
            ((List.map
              (fun e => Tezos_base__TzPervasives.Error_monad.Ecoproto_error e)
              (cons top errs)),
              match top with
              |
                Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
                  expr _ |
                  Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
                    _ expr _ =>
                if equiv_decb expr (expanded parsed) then
                  find_location (first_error_location (cons top errs))
                else
                  find_location 0
              |
                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
                  expr loc =>
                if
                  equiv_decb
                    (Micheline.strip_locations
                      (Michelson_v1_macros.unexpand_rec (Micheline.root expr)))
                    (Michelson_v1_parser.unexpanded parsed) then
                  find_location loc
                else
                  find_location 0
              | _ => find_location 0
              end) in
          let message :=
            Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (Michelson_v1_error_reporter.report_errors false false
                (Some parsed)) errs in
          let '{| start := {| point := s |}; stop := {| point := e |} |} := loc
            in
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Char_literal "(" % char
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal " " % char
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))))
              "(%d %d %S)" % string) (Z.add s 1) (Z.add e 1) message
        | [] => tt
        end) eco
    (Format.pp_print_list None
      (fun ppf =>
        fun err =>
          let find_location (loc : Z)
            : Tezos_micheline.Micheline_parser.location :=
            let oloc :=
              List.assoc loc (Michelson_v1_parser.unexpansion_table parsed) in
            fst (List.assoc oloc (expansion_table parsed)) in
          let loc :=
            match err with
            |
              Tezos_error_monad.Error_monad.Invalid_utf8_sequence point _ |
                Tezos_error_monad.Error_monad.Unexpected_character point _ |
                Tezos_error_monad.Error_monad.Undefined_escape_sequence point _
                | Tezos_error_monad.Error_monad.Missing_break_after_number point
              => {| start := point; stop := point |}
            |
              Tezos_error_monad.Error_monad.Unterminated_string loc |
                Tezos_error_monad.Error_monad.Unterminated_integer loc |
                Tezos_error_monad.Error_monad.Unterminated_comment loc |
                Tezos_error_monad.Error_monad.Odd_lengthed_bytes loc |
                Tezos_error_monad.Error_monad.Unclosed {| loc := loc |} |
                Tezos_error_monad.Error_monad.Unexpected {| loc := loc |} |
                Tezos_error_monad.Error_monad.Extra {| loc := loc |} => loc
            | Tezos_error_monad.Error_monad.Misaligned node => location node
            | _ => find_location 0
            end in
          let message :=
            Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (Michelson_v1_error_reporter.report_errors false false
                (Some parsed)) (cons err []) in
          let '{| start := {| point := s |}; stop := {| point := e |} |} := loc
            in
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Char_literal "(" % char
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.Char_literal " " % char
                        (CamlinternalFormatBasics.Caml_string
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))))
              "(%d %d %S)" % string) (Z.add s 1) (Z.add e 1) message)) out.

src/proto_alpha/lib_client/michelson_v1_entrypoints.ml 168 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Protocol_client_context
open Alpha_context

type error += Contract_without_code of Contract.t

let () =
  register_error_kind
    `Permanent
    ~id:"contractWithoutCode"
    ~title:"The given contract has no code"
    ~description:
      "Attempt to get the code of a contract failed because it has nocode. No \
       scriptless contract should remain."
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract has no code %a." Contract.pp contract)
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Contract_without_code c -> Some c | _ -> None)
    (fun c -> Contract_without_code c)

let print_errors (cctxt : #Client_context.printer) errs =
  cctxt#error "%a" Error_monad.pp_print_error errs >>= fun () -> return_unit

let script_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    (program : Script.expr) ~entrypoint =
  Alpha_services.Helpers.Scripts.entrypoint_type
    cctxt
    (chain, block)
    (program, entrypoint)
  >>= function
  | Ok ty ->
      return_some ty
  | Error
      (Environment.Ecoproto_error (Script_tc_errors.No_such_entrypoint _) :: _)
    ->
      return None
  | Error _ as err ->
      Lwt.return err

let contract_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    ~contract ~entrypoint =
  Alpha_services.Contract.entrypoint_type
    cctxt
    (chain, block)
    contract
    entrypoint
  >>= function
  | Ok ty ->
      return_some ty
  | Error (RPC_context.Not_found _ :: _) ->
      return None
  | Error _ as err ->
      Lwt.return err

let print_entrypoint_type (cctxt : #Client_context.printer)
    ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name ~entrypoint
    = function
  | Ok (Some ty) ->
      ( if emacs then
        cctxt#message
          "@[<v 2>((entrypoint . %s) (type . %a))@]@."
          entrypoint
          Michelson_v1_emacs.print_expr
          ty
      else
        cctxt#message
          "@[<v 2>Entrypoint %s: %a@]@."
          entrypoint
          Michelson_v1_printer.print_expr
          ty )
      >>= fun () -> return_unit
  | Ok None ->
      cctxt#message
        "@[<v 2>No entrypoint named %s%a%a@]@."
        entrypoint
        (Option.pp ~default:"" (fun ppf ->
             Format.fprintf ppf " for contract %a" Contract.pp))
        contract
        (Option.pp ~default:"" (fun ppf -> Format.fprintf ppf " for script %s"))
        script_name
      >>= fun () -> return_unit
  | Error errs ->
      on_errors errs

let list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract =
  Alpha_services.Contract.list_entrypoints cctxt (chain, block) contract

let list_contract_unreachables cctxt ~chain ~block ~contract =
  list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
  >>=? fun (unreachables, _) -> return unreachables

let list_contract_entrypoints cctxt ~chain ~block ~contract =
  list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
  >>=? fun (_, entrypoints) ->
  if not @@ List.mem_assoc "default" entrypoints then
    contract_entrypoint_type
      cctxt
      ~chain
      ~block
      ~contract
      ~entrypoint:"default"
    >>= function
    | Ok (Some ty) ->
        return (("default", ty) :: entrypoints)
    | _ ->
        return entrypoints
  else return entrypoints

let list_unreachables cctxt ~chain ~block (program : Script.expr) =
  Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
  >>=? fun (unreachables, _) -> return unreachables

let list_entrypoints cctxt ~chain ~block (program : Script.expr) =
  Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
  >>=? fun (_, entrypoints) ->
  if not @@ List.mem_assoc "default" entrypoints then
    script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default"
    >>= function
    | Ok (Some ty) ->
        return (("default", ty) :: entrypoints)
    | _ ->
        return entrypoints
  else return entrypoints

let print_entrypoints_list (cctxt : #Client_context.printer)
    ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
  | Ok entrypoint_list ->
      ( if emacs then
        cctxt#message
          "@[<v 2>(@[%a@])@."
          (Format.pp_print_list
             ~pp_sep:Format.pp_print_cut
             (fun ppf (entrypoint, ty) ->
               Format.fprintf
                 ppf
                 "@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]"
                 entrypoint
                 Michelson_v1_emacs.print_expr
                 ty))
          entrypoint_list
      else
        cctxt#message
          "@[<v 2>Entrypoints%a%a: @,%a@]@."
          (Option.pp ~default:"" (fun ppf ->
               Format.fprintf ppf " for contract %a" Contract.pp))
          contract
          (Option.pp ~default:"" (fun ppf ->
               Format.fprintf ppf " for script %s"))
          script_name
          (Format.pp_print_list
             ~pp_sep:Format.pp_print_cut
             (fun ppf (entrypoint, ty) ->
               Format.fprintf
                 ppf
                 "@[<v 2>%s: @[%a@]@]"
                 entrypoint
                 Michelson_v1_printer.print_expr
                 ty))
          entrypoint_list )
      >>= fun () -> return_unit
  | Error errs ->
      on_errors errs

let print_unreachables (cctxt : #Client_context.printer)
    ?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
  | Ok unreachable ->
      ( if emacs then
        cctxt#message
          "@[<v 2>(@[%a@])@."
          (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path ->
               Format.fprintf
                 ppf
                 "@[<h>( unreachable-path . %a )@]"
                 (Format.pp_print_list
                    ~pp_sep:Format.pp_print_space
                    (fun ppf prim ->
                      Format.pp_print_string ppf
                      @@ Michelson_v1_primitives.string_of_prim prim))
                 path))
          unreachable
      else
        match unreachable with
        | [] ->
            cctxt#message "@[<v 2>None.@]@."
        | _ ->
            cctxt#message
              "@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@."
              (Option.pp ~default:"" (fun ppf ->
                   Format.fprintf ppf " of contract %a" Contract.pp))
              contract
              (Option.pp ~default:"" (fun ppf ->
                   Format.fprintf ppf " of script %s"))
              script_name
              (Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf ->
                   Format.fprintf
                     ppf
                     "@[<h> %a @]"
                     (Format.pp_print_list
                        ~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/")
                        (fun ppf prim ->
                          Format.pp_print_string ppf
                          @@ Michelson_v1_primitives.string_of_prim prim))))
              unreachable )
      >>= fun () -> return_unit
  | Error errs ->
      on_errors errs
src/proto_alpha/lib_client/michelson_v1_entrypoints.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Protocol_client_context.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition print_errors {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) (errs : Tezos_base__TzPervasives.Error_monad.trace)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    ((* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Error_monad.pp_print_error errs)
    (fun function_parameter =>
      let 'tt := function_parameter in
      return_unit).

Definition script_entrypoint_type {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  (entrypoint : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  op_gtgteq
    (Alpha_services.Helpers.Scripts.entrypoint_type cctxt (chain, block)
      (program, entrypoint))
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok ty => return_some ty
      |
        Stdlib.Error
          (cons
            (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
                _)) _) => _return None
      | (Stdlib.Error _) as err => Lwt._return err
      end).

Definition contract_entrypoint_type {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (entrypoint : string)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  op_gtgteq
    (Alpha_services.Contract.entrypoint_type cctxt (chain, block) contract
      entrypoint)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok ty => return_some ty
      | Stdlib.Error (cons (Tezos_error_monad.Error_monad.Not_found _) _) =>
        _return None
      | (Stdlib.Error _) as err => Lwt._return err
      end).

Definition print_entrypoint_type {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (op_staroptstar :
    option
      (Tezos_base__TzPervasives.Error_monad.trace ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
  : bool ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
      (option string) ->
        string ->
          (sum (option Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
            Tezos_base__TzPervasives.Error_monad.trace) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let on_errors :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => print_errors cctxt
    end in
  fun emacs =>
    fun contract =>
      fun script_name =>
        fun entrypoint =>
          fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok (Some ty) =>
              op_gtgteq
                (if emacs then
                  (* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "((entrypoint . " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              ") (type . " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  "))" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format))))))))
                      "@[<v 2>((entrypoint . %s) (type . %a))@]@." % string)
                    entrypoint Michelson_v1_emacs.print_expr ty
                else
                  (* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Entrypoint " % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              ": " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))))))
                      "@[<v 2>Entrypoint %s: %a@]@." % string) entrypoint
                    Michelson_v1_printer.print_expr ty)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)
            | Stdlib.Ok None =>
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "No entrypoint named " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>No entrypoint named %s%a%a@]@." % string) entrypoint
                  (Option.pp (Some "" % string)
                    (fun ppf =>
                      Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for contract " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          " for contract %a" % string) Contract.pp)) contract
                  (Option.pp (Some "" % string)
                    (fun ppf =>
                      Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for script " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          " for script %s" % string))) script_name)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)
            | Stdlib.Error errs => on_errors errs
            end.

Definition list_contract_unreachables_and_entrypoints
  {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
        (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
  Alpha_services.Contract.list_entrypoints cctxt (chain, block) contract.

Definition list_contract_unreachables {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))) :=
  op_gtgteqquestion
    (list_contract_unreachables_and_entrypoints cctxt chain block contract)
    (fun function_parameter =>
      let '(unreachables, _) := function_parameter in
      _return unreachables).

Definition list_contract_entrypoints {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
  op_gtgteqquestion
    (list_contract_unreachables_and_entrypoints cctxt chain block contract)
    (fun function_parameter =>
      let '(_, entrypoints) := function_parameter in
      if apply negb (List.mem_assoc "default" % string entrypoints) then
        op_gtgteq
          (contract_entrypoint_type cctxt chain block contract
            "default" % string)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok (Some ty) =>
              _return (cons ("default" % string, ty) entrypoints)
            | _ => _return entrypoints
            end)
      else
        _return entrypoints).

Definition list_unreachables {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))) :=
  op_gtgteqquestion
    (Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block)
      program)
    (fun function_parameter =>
      let '(unreachables, _) := function_parameter in
      _return unreachables).

Definition list_entrypoints {D E G I K L a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Chain_services.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Chain_services.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Chain_services.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Chain_services.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L *
      (Tezos_shell_services.Chain_services.chain * D))
  (chain : Tezos_shell_services.Chain_services.chain) (block : D)
  (program : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
  op_gtgteqquestion
    (Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block)
      program)
    (fun function_parameter =>
      let '(_, entrypoints) := function_parameter in
      if apply negb (List.mem_assoc "default" % string entrypoints) then
        op_gtgteq
          (script_entrypoint_type cctxt chain block program "default" % string)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok (Some ty) =>
              _return (cons ("default" % string, ty) entrypoints)
            | _ => _return entrypoints
            end)
      else
        _return entrypoints).

Definition print_entrypoints_list {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (op_staroptstar :
    option
      (Tezos_base__TzPervasives.Error_monad.trace ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
  : bool ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
      (option string) ->
        (sum (list (string * Tezos_protocol_alpha.Protocol.Script_repr.expr))
          Tezos_base__TzPervasives.Error_monad.trace) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let on_errors :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => print_errors cctxt
    end in
  fun emacs =>
    fun contract =>
      fun script_name =>
        fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok entrypoint_list =>
            op_gtgteq
              (if emacs then
                (* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.Char_literal "(" % char
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>(@[%a@])@." % string)
                  (Format.pp_print_list (Some Format.pp_print_cut)
                    (fun ppf =>
                      fun function_parameter =>
                        let '(entrypoint, ty) := function_parameter in
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<v 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<v 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "( ( entrypoint . " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " ) ( type . " % string
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          CamlinternalFormatBasics.End_of_format
                                          "" % string))
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.String_literal
                                            "))" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              CamlinternalFormatBasics.End_of_format)))))))))
                            "@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]" %
                              string) entrypoint Michelson_v1_emacs.print_expr
                          ty)) entrypoint_list
              else
                (* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.String_literal
                        "Entrypoints" % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              ": " % string
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      CamlinternalFormatBasics.End_of_format)))))))))
                    "@[<v 2>Entrypoints%a%a: @,%a@]@." % string)
                  (Option.pp (Some "" % string)
                    (fun ppf =>
                      Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for contract " % string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          " for contract %a" % string) Contract.pp)) contract
                  (Option.pp (Some "" % string)
                    (fun ppf =>
                      Format.fprintf ppf
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            " for script " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))
                          " for script %s" % string))) script_name
                  (Format.pp_print_list (Some Format.pp_print_cut)
                    (fun ppf =>
                      fun function_parameter =>
                        let '(entrypoint, ty) := function_parameter in
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<v 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<v 2>" % string))
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  ": " % string
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        CamlinternalFormatBasics.End_of_format
                                        "" % string))
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))
                            "@[<v 2>%s: @[%a@]@]" % string) entrypoint
                          Michelson_v1_printer.print_expr ty)) entrypoint_list)
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)
          | Stdlib.Error errs => on_errors errs
          end.

Definition print_unreachables {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (op_staroptstar :
    option
      (Tezos_base__TzPervasives.Error_monad.trace ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit)))
  : bool ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t) ->
      (option string) ->
        (sum
          (list
            (list Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim))
          Tezos_base__TzPervasives.Error_monad.trace) ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let on_errors :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => print_errors cctxt
    end in
  fun emacs =>
    fun contract =>
      fun script_name =>
        fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok unreachable =>
            op_gtgteq
              (if emacs then
                (* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 2>" % string))
                      (CamlinternalFormatBasics.Char_literal "(" % char
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              CamlinternalFormatBasics.End_of_format "" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Char_literal ")" % char
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format)))))))
                    "@[<v 2>(@[%a@])@." % string)
                  (Format.pp_print_list (Some Format.pp_print_cut)
                    (fun ppf =>
                      fun path =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<h>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<h>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "( unreachable-path . " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " )" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))
                            "@[<h>( unreachable-path . %a )@]" % string)
                          (Format.pp_print_list (Some Format.pp_print_space)
                            (fun ppf =>
                              fun prim =>
                                apply (Format.pp_print_string ppf)
                                  (Michelson_v1_primitives.string_of_prim prim)))
                          path)) unreachable
              else
                match unreachable with
                | [] =>
                  (* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "None." % string
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))
                      "@[<v 2>None.@]@." % string)
                | _ =>
                  (* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v 2>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v 2>" % string))
                        (CamlinternalFormatBasics.String_literal
                          "Unreachable paths in the argument" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ": " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      CamlinternalFormatBasics.End_of_format
                                      "" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Flush_newline
                                        CamlinternalFormatBasics.End_of_format)))))))))
                      "@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@." %
                        string)
                    (Option.pp (Some "" % string)
                      (fun ppf =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              " of contract " % string
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))
                            " of contract %a" % string) Contract.pp)) contract
                    (Option.pp (Some "" % string)
                      (fun ppf =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              " of script " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                CamlinternalFormatBasics.End_of_format))
                            " of script %s" % string))) script_name
                    (Format.pp_print_list (Some Format.pp_print_cut)
                      (fun ppf =>
                        Format.fprintf ppf
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<h>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<h>" % string))
                              (CamlinternalFormatBasics.Char_literal " " % char
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Char_literal
                                    " " % char
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))
                            "@[<h> %a @]" % string)
                          (Format.pp_print_list
                            (Some
                              (fun ppf =>
                                fun function_parameter =>
                                  let '_ := function_parameter in
                                  Format.pp_print_string ppf "/" % string))
                            (fun ppf =>
                              fun prim =>
                                apply (Format.pp_print_string ppf)
                                  (Michelson_v1_primitives.string_of_prim prim)))))
                    unreachable
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_unit)
          | Stdlib.Error errs => on_errors errs
          end.

src/proto_alpha/lib_client/michelson_v1_error_reporter.ml 65 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Script_tc_errors
open Script_interpreter
open Michelson_v1_printer

let print_ty ppf ty = Michelson_v1_printer.print_expr_unwrapped ppf ty

let print_var_annot ppf annot = List.iter (Format.fprintf ppf "@ %s") annot

let print_stack_ty ?(depth = max_int) ppf s =
  let rec loop depth ppf = function
    | [] ->
        ()
    | _ when depth <= 0 ->
        Format.fprintf ppf "..."
    | [(last, annot)] ->
        Format.fprintf ppf "%a%a" print_ty last print_var_annot annot
    | (last, annot) :: rest ->
        Format.fprintf
          ppf
          "%a%a@ :@ %a"
          print_ty
          last
          print_var_annot
          annot
          (loop (depth - 1))
          rest
  in
  match s with
  | [] ->
      Format.fprintf ppf "[]"
  | sty ->
      Format.fprintf ppf "@[<hov 2>[ %a ]@]" (loop depth) sty

let rec print_enumeration ppf = function
  | [single] ->
      Format.fprintf ppf "%a" Format.pp_print_text single
  | [prev; last] ->
      Format.fprintf
        ppf
        "%a@ or@ %a"
        Format.pp_print_text
        prev
        Format.pp_print_text
        last
  | first :: rest ->
      Format.fprintf
        ppf
        "%a,@ %a"
        Format.pp_print_text
        first
        print_enumeration
        rest
  | [] ->
      assert false

let collect_error_locations errs =
  let rec collect acc = function
    | Environment.Ecoproto_error
        ( Ill_formed_type (_, _, _)
        | No_such_entrypoint _
        | Duplicate_entrypoint _
        | Unreachable_entrypoint _
        | Runtime_contract_error (_, _)
        | Michelson_v1_primitives.Invalid_primitive_name (_, _)
        | Ill_typed_data (_, _, _)
        | Ill_typed_contract (_, _) )
      :: _
    | [] ->
        acc
    | Environment.Ecoproto_error
        ( Invalid_arity (loc, _, _, _)
        | Inconsistent_type_annotations (loc, _, _)
        | Unexpected_annotation loc
        | Ungrouped_annotations loc
        | Type_too_large (loc, _, _)
        | Invalid_namespace (loc, _, _, _)
        | Invalid_primitive (loc, _, _)
        | Invalid_kind (loc, _, _)
        | Duplicate_field (loc, _)
        | Unexpected_big_map loc
        | Unexpected_operation loc
        | Fail_not_in_tail_position loc
        | Undefined_binop (loc, _, _, _)
        | Undefined_unop (loc, _, _)
        | Bad_return (loc, _, _)
        | Bad_stack (loc, _, _, _)
        | Unmatched_branches (loc, _, _)
        | Self_in_lambda loc
        | Invalid_constant (loc, _, _)
        | Invalid_syntactic_constant (loc, _, _)
        | Invalid_contract (loc, _)
        | Comparable_type_expected (loc, _)
        | Overflow (loc, _)
        | Reject (loc, _, _) )
      :: rest ->
        collect (loc :: acc) rest
    | _ :: rest ->
        collect acc rest
  in
  collect [] errs

let report_errors ~details ~show_source ?parsed ppf errs =
  let rec print_trace locations errs =
    let print_loc ppf loc =
      match locations loc with
      | None ->
          Format.fprintf ppf "At (unshown) location %d, " loc
      | Some loc ->
          Format.fprintf
            ppf
            "%s,@ "
            (String.capitalize_ascii
               (Format.asprintf "%a" Micheline_parser.print_location loc))
    in
    let parsed_locations parsed loc =
      try
        let oloc =
          List.assoc loc parsed.Michelson_v1_parser.unexpansion_table
        in
        let (ploc, _) = List.assoc oloc parsed.expansion_table in
        Some ploc
      with Not_found -> None
    in
    let print_source ppf (parsed, _hilights (* TODO *)) =
      let lines =
        String.split_on_char '\n' parsed.Michelson_v1_parser.source
      in
      let cols = String.length (string_of_int (List.length lines)) in
      Format.fprintf
        ppf
        "@[<v 0>%a@]"
        (Format.pp_print_list (fun ppf (i, l) ->
             Format.fprintf ppf "%0*d: %s" cols i l))
        (List.mapi (fun i l -> (i + 1, l)) lines)
    in
    match errs with
    | [] ->
        ()
    | Environment.Ecoproto_error
        (Michelson_v1_primitives.Invalid_primitive_name (expr, loc))
      :: rest ->
        let parsed =
          match parsed with
          | Some parsed ->
              if
                Micheline.strip_locations
                  (Michelson_v1_macros.unexpand_rec (Micheline.root expr))
                = parsed.Michelson_v1_parser.unexpanded
              then parsed
              else Michelson_v1_printer.unparse_invalid expr
          | None ->
              Michelson_v1_printer.unparse_invalid expr
        in
        let hilights = loc :: collect_error_locations rest in
        if show_source then
          Format.fprintf
            ppf
            "@[<hov 0>@[<hov 2>Invalid primitive:@ %a@]@]"
            print_source
            (parsed, hilights)
        else Format.fprintf ppf "Invalid primitive." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (Ill_typed_data (name, expr, ty)) :: rest ->
        let parsed =
          match parsed with
          | Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_expression expr
        in
        let hilights = collect_error_locations rest in
        Format.fprintf
          ppf
          "@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ @[<hov 2>is not an \
           expression of type@ %a@]@]"
          (fun ppf -> function None -> () | Some s ->
                Format.fprintf ppf "%s " s)
          name
          print_source
          (parsed, hilights)
          print_ty
          ty ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (No_such_entrypoint entrypoint) :: rest ->
        Format.fprintf ppf "Contract has no entrypoint named %s" entrypoint ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Duplicate_entrypoint entrypoint) :: rest ->
        Format.fprintf ppf "Contract has two entrypoints named %s" entrypoint ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unreachable_entrypoint path) :: rest ->
        let path =
          String.concat
            "/"
            (List.map Michelson_v1_primitives.string_of_prim path)
        in
        Format.fprintf ppf "Entrypoint at path %s is not reachable" path ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Ill_formed_type (_, expr, loc)) :: rest ->
        let parsed =
          match parsed with
          | Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_expression expr
        in
        let hilights = loc :: collect_error_locations errs in
        if show_source then
          Format.fprintf
            ppf
            "@[<v 2>%aill formed type:@ %a@]"
            print_loc
            loc
            print_source
            (parsed, hilights)
        else Format.fprintf ppf "Ill formed type." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (Ill_typed_contract (expr, type_map)) :: rest
      ->
        let parsed =
          match parsed with
          | Some parsed
            when (not details) && expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_toplevel ~type_map expr
        in
        let hilights = collect_error_locations rest in
        if show_source then
          Format.fprintf
            ppf
            "@[<v 0>Ill typed contract:@,  %a@]"
            print_source
            (parsed, hilights)
        else Format.fprintf ppf "Ill typed contract." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error Apply.Gas_quota_exceeded_init_deserialize
      :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Not enough gas to deserialize the operation.@,\
           Injecting such a transaction could have you banned from mempools.@]" ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Cannot_serialize_error :: rest ->
        Format.fprintf
          ppf
          "Error too big to serialize within the provided gas bounds." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Deprecated_instruction prim) :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Use of deprecated instruction: %s@]"
          (Michelson_v1_primitives.string_of_prim prim) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Cannot_serialize_storage :: rest ->
        Format.fprintf
          ppf
          "Cannot serialize the resulting storage value within the provided \
           gas bounds." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Missing_field prim) :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Missing contract field: %s@]"
          (Michelson_v1_primitives.string_of_prim prim) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Duplicate_field (loc, prim)) :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>%aduplicate contract field: %s@]"
          print_loc
          loc
          (Michelson_v1_primitives.string_of_prim prim) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unexpected_big_map loc) :: rest ->
        Format.fprintf
          ppf
          "%abig_map type not allowed inside another big_map"
          print_loc
          loc ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unexpected_operation loc) :: rest ->
        Format.fprintf
          ppf
          "%aoperation type forbidden in parameter, storage and constants"
          print_loc
          loc ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Unexpected_contract loc) :: rest ->
        Format.fprintf
          ppf
          "%acontract type forbidden in storage and constants"
          print_loc
          loc ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error (Runtime_contract_error (contract, expr))
      :: rest ->
        let parsed =
          match parsed with
          | Some parsed when expr = parsed.Michelson_v1_parser.expanded ->
              parsed
          | Some _ | None ->
              Michelson_v1_printer.unparse_toplevel expr
        in
        let hilights = collect_error_locations rest in
        Format.fprintf
          ppf
          "@[<v 2>Runtime error in contract %a:@ %a@]"
          Contract.pp
          contract
          print_source
          (parsed, hilights) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace (parsed_locations parsed) rest
    | Environment.Ecoproto_error (Apply.Internal_operation_replay op) :: rest
      ->
        Format.fprintf
          ppf
          "@[<v 2>Internal operation replay attempt:@,%a@]"
          Operation_result.pp_internal_operation
          op ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Gas.Gas_limit_too_high :: rest ->
        Format.fprintf
          ppf
          "Gas limit for the operation is out of the protocol hard bounds." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Gas.Block_quota_exceeded :: rest ->
        Format.fprintf
          ppf
          "Gas limit for the block exceeded during typechecking or execution." ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Gas.Operation_quota_exceeded :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Gas limit exceeded during typechecking or execution.@,\
           Try again with a higher gas limit.@]" ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | Environment.Ecoproto_error Fees.Operation_quota_exceeded :: rest ->
        Format.fprintf
          ppf
          "@[<v 0>Storage limit exceeded during typechecking or execution.@,\
           Try again with a higher storage limit.@]" ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | [Environment.Ecoproto_error (Script_interpreter.Bad_contract_parameter c)]
      ->
        Format.fprintf
          ppf
          "@[<v 0>Account %a is not a smart contract, it does not take \
           arguments.@,\
           The `-arg' flag should not be used when transferring to an \
           account.@]"
          Contract.pp
          c
    | Environment.Ecoproto_error err :: rest ->
        ( match err with
        | Script_interpreter.Bad_contract_parameter c ->
            Format.fprintf
              ppf
              "Invalid argument passed to contract %a."
              Contract.pp
              c
        | Invalid_arity (loc, name, exp, got) ->
            Format.fprintf
              ppf
              "%aprimitive %s expects %d arguments but is given %d."
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              exp
              got
        | Invalid_namespace (loc, name, exp, got) ->
            let human_namespace = function
              | Instr_namespace ->
                  ("an", "instruction")
              | Type_namespace ->
                  ("a", "type name")
              | Constant_namespace ->
                  ("a", "constant constructor")
              | Keyword_namespace ->
                  ("a", "keyword")
            in
            Format.fprintf
              ppf
              "@[%aunexpected %s %s, only %s %s can be used here."
              print_loc
              loc
              (snd (human_namespace got))
              (Michelson_v1_primitives.string_of_prim name)
              (fst (human_namespace exp))
              (snd (human_namespace exp))
        | Invalid_primitive (loc, exp, got) ->
            Format.fprintf
              ppf
              "@[%ainvalid primitive %s, only %a can be used here."
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim got)
              print_enumeration
              (List.map Michelson_v1_primitives.string_of_prim exp)
        | Invalid_kind (loc, exp, got) ->
            let human_kind = function
              | Seq_kind ->
                  ("a", "sequence")
              | Prim_kind ->
                  ("a", "primitive")
              | Int_kind ->
                  ("an", "int")
              | String_kind ->
                  ("a", "string")
              | Bytes_kind ->
                  ("a", "byte sequence")
            in
            Format.fprintf
              ppf
              "@[%aunexpected %s, only@ %a@ can be used here."
              print_loc
              loc
              (snd (human_kind got))
              print_enumeration
              (List.map
                 (fun k ->
                   let (a, n) = human_kind k in
                   a ^ " " ^ n)
                 exp)
        | Duplicate_map_keys (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Map literals cannot contain duplicate keys, however a \
               duplicate key was found:@ @[%a@]"
              print_expr
              expr
        | Unordered_map_keys (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Keys in a map literal must be in strictly ascending \
               order, but they were unordered in literal:@ @[%a@]"
              print_expr
              expr
        | Duplicate_set_values (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Set literals cannot contain duplicate values, however a \
               duplicate value was found:@ @[%a@]"
              print_expr
              expr
        | Unordered_set_values (_, expr) ->
            Format.fprintf
              ppf
              "@[<v 2>Values in a set literal must be in strictly ascending \
               order, but they were unordered in literal:@ @[%a@]"
              print_expr
              expr
        | Fail_not_in_tail_position loc ->
            Format.fprintf
              ppf
              "%aThe FAIL instruction must appear in a tail position."
              print_loc
              loc
        | Undefined_binop (loc, name, tya, tyb) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ \
               @[<hov 2>and@ %a.@]@]"
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              print_ty
              tya
              print_ty
              tyb
        | Undefined_unop (loc, name, ty) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]"
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              print_ty
              ty
        | Bad_return (loc, got, exp) ->
            Format.fprintf
              ppf
              "@[<v 2>%awrong stack type at end of body:@,\
               - @[<v 0>expected return stack type:@ %a,@]@,\
               - @[<v 0>actual stack type:@ %a.@]@]"
              print_loc
              loc
              (fun ppf -> print_stack_ty ppf)
              [(exp, [])]
              (fun ppf -> print_stack_ty ppf)
              got
        | Bad_stack (loc, name, depth, sty) ->
            Format.fprintf
              ppf
              "@[<hov 2>%awrong stack type for instruction %s:@ %a.@]"
              print_loc
              loc
              (Michelson_v1_primitives.string_of_prim name)
              (print_stack_ty ~depth)
              sty
        | Unmatched_branches (loc, sta, stb) ->
            Format.fprintf
              ppf
              "@[<v 2>%atwo branches don't end with the same stack type:@,\
               - @[<hov>first stack type:@ %a,@]@,\
               - @[<hov>other stack type:@ %a.@]@]"
              print_loc
              loc
              (fun ppf -> print_stack_ty ppf)
              sta
              (fun ppf -> print_stack_ty ppf)
              stb
        | Inconsistent_annotations (annot1, annot2) ->
            Format.fprintf
              ppf
              "@[<v 2>The two annotations do not match:@,\
               - @[<v>%s@]@,\
               - @[<v>%s@]@]"
              annot1
              annot2
        | Inconsistent_field_annotations (annot1, annot2) ->
            Format.fprintf
              ppf
              "@[<v 2>The field access annotation does not match:@,\
               - @[<v>%s@]@,\
               - @[<v>%s@]@]"
              annot1
              annot2
        | Inconsistent_type_annotations (loc, ty1, ty2) ->
            Format.fprintf
              ppf
              "@[<v 2>%athe two types contain incompatible annotations:@,\
               - @[<hov>%a@]@,\
               - @[<hov>%a@]@]"
              print_loc
              loc
              print_ty
              ty1
              print_ty
              ty2
        | Unexpected_annotation loc ->
            Format.fprintf ppf "@[<v 2>%aunexpected annotation." print_loc loc
        | Ungrouped_annotations loc ->
            Format.fprintf
              ppf
              "@[<v 2>%aAnnotations of the same kind must be grouped."
              print_loc
              loc
        | Type_too_large (loc, size, maximum_size) ->
            Format.fprintf
              ppf
              "@[<v 2>%atype size (%d) exceeded maximum type size (%d)."
              print_loc
              loc
              size
              maximum_size
        | Self_in_lambda loc ->
            Format.fprintf
              ppf
              "%aThe SELF instruction cannot appear in a lambda."
              print_loc
              loc
        | Bad_stack_length ->
            Format.fprintf ppf "Bad stack length."
        | Bad_stack_item lvl ->
            Format.fprintf ppf "Bad stack item %d." lvl
        | Invalid_constant (loc, got, exp) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid for type@ \
               %a.@]@]"
              print_loc
              loc
              print_expr
              got
              print_ty
              exp
        | Invalid_syntactic_constant (loc, got, exp) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid, \
               expected@ %s@]@]"
              print_loc
              loc
              print_expr
              got
              exp
        | Invalid_contract (loc, contract) ->
            Format.fprintf
              ppf
              "%ainvalid contract %a."
              print_loc
              loc
              Contract.pp
              contract
        | Comparable_type_expected (loc, ty) ->
            Format.fprintf ppf "%acomparable type expected." print_loc loc ;
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]"
              print_ty
              ty
        | Inconsistent_types (tya, tyb) ->
            Format.fprintf
              ppf
              "@[<hov 0>@[<hov 2>Type@ %a@]@ @[<hov 2>is not compatible with \
               type@ %a.@]@]"
              print_ty
              tya
              print_ty
              tyb
        | Reject (loc, v, trace) ->
            Format.fprintf
              ppf
              "%ascript reached FAILWITH instruction@ @[<hov 2>with@ %a@]%a"
              print_loc
              loc
              print_expr
              v
              (fun ppf -> function None -> () | Some trace ->
                    Format.fprintf
                      ppf
                      "@,@[<v 2>trace@,%a@]"
                      print_execution_trace
                      trace)
              trace
        | Overflow (loc, trace) ->
            Format.fprintf
              ppf
              "%aunexpected arithmetic overflow%a"
              print_loc
              loc
              (fun ppf -> function None -> () | Some trace ->
                    Format.fprintf
                      ppf
                      "@,@[<v 2>trace@,%a@]"
                      print_execution_trace
                      trace)
              trace
        | err ->
            Format.fprintf ppf "%a" Environment.Error_monad.pp err ) ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
    | err :: rest ->
        Format.fprintf ppf "%a" Error_monad.pp err ;
        if rest <> [] then Format.fprintf ppf "@," ;
        print_trace locations rest
  in
  Format.fprintf ppf "@[<v 0>" ;
  print_trace (fun _ -> None) errs ;
  Format.fprintf ppf "@]"
src/proto_alpha/lib_client/michelson_v1_error_reporter.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Tezos_micheline.

Import Script_tc_errors.

Import Script_interpreter.

Import Michelson_v1_printer.

Definition print_ty
  (ppf : Stdlib.Format.formatter)
  (ty : Tezos_protocol_alpha.Protocol.Script_repr.expr) : unit :=
  Michelson_v1_printer.print_expr_unwrapped ppf ty.

Definition print_var_annot (ppf : Stdlib.Format.formatter) (annot : list string)
  : unit :=
  List.iter
    (Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@ " % string 1 0)
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            CamlinternalFormatBasics.End_of_format)) "@ %s" % string)) annot.

Definition print_stack_ty (op_staroptstar : option Z)
  : Stdlib.Format.formatter ->
    (list (Tezos_protocol_alpha.Protocol.Script_repr.expr * (list string))) ->
      unit :=
  let depth :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Stdlib.max_int
    end in
  fun ppf =>
    fun s =>
      let fix loop
        (depth : Z) (ppf : Stdlib.Format.formatter) (function_parameter :
        list (Tezos_protocol_alpha.Protocol.Script_repr.expr * (list string)))
        : unit :=
        match function_parameter with
        | [] => tt
        | _ =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "..." % string
                CamlinternalFormatBasics.End_of_format) "..." % string)
        | cons (last, annot) [] =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)) "%a%a" % string)
            print_ty last print_var_annot annot
        | cons (last, annot) rest =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Char_literal ":" % char
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))))))
              "%a%a@ :@ %a" % string) print_ty last print_var_annot annot
            (loop (Z.sub depth 1)) rest
        end in
      match s with
      | [] =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "[]" % string
              CamlinternalFormatBasics.End_of_format) "[]" % string)
      | sty =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
              (CamlinternalFormatBasics.String_literal "[ " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal " ]" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<hov 2>[ %a ]@]" % string) (loop depth) sty
      end.

Fixpoint print_enumeration
  (ppf : Stdlib.Format.formatter) (function_parameter : list string) : unit :=
  match function_parameter with
  | cons single [] =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) Format.pp_print_text single
  | cons prev (cons last []) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "or" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@ " % string 1 0)
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format)))))
        "%a@ or@ %a" % string) Format.pp_print_text prev Format.pp_print_text
      last
  | cons first rest =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Char_literal "," % char
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@ " % string 1 0)
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format)))) "%a,@ %a" % string)
      Format.pp_print_text first print_enumeration rest
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition collect_error_locations
  (errs : list Tezos_base__TzPervasives.Error_monad.error)
  : list Tezos_raw_protocol_alpha.Alpha_context.Script.location :=
  let fix collect
    (acc : list Tezos_raw_protocol_alpha.Alpha_context.Script.location)
    (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
    : list Tezos_raw_protocol_alpha.Alpha_context.Script.location :=
    match function_parameter with
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
            _ _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
              _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_entrypoint
              _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Unreachable_entrypoint
              _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Runtime_contract_error
              _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
              _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
              _ _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
              _ _)) _ | [] => acc
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc _ _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
              loc |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Ungrouped_annotations
              loc |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Type_too_large
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
              loc _ _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
              loc _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
              loc |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
              loc |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
              loc |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
              loc _ _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
              loc _ _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Self_in_lambda
              loc |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
              loc _ _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
              loc _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
              loc _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
              loc _ |
            Tezos_protocol_environment_alpha__Environment.Error_monad.Reject loc
              _ _)) rest => collect (cons loc acc) rest
    | cons _ rest => collect acc rest
    end in
  collect [] errs.

Definition report_errors
  (details : bool) (show_source : bool)
  (parsed : option Tezos_client_alpha.Michelson_v1_parser.parsed)
  (ppf : Stdlib.Format.formatter)
  (errs : list Tezos_base__TzPervasives.Error_monad.error) : unit :=
  let fix print_trace
    (locations : Z -> option Tezos_micheline.Micheline_parser.location) (errs :
    list Tezos_base__TzPervasives.Error_monad.error) : unit :=
    let print_loc (ppf : Stdlib.Format.formatter) (loc : Z) : unit :=
      match locations loc with
      | None =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "At (unshown) location " % string
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                (CamlinternalFormatBasics.String_literal ", " % string
                  CamlinternalFormatBasics.End_of_format)))
            "At (unshown) location %d, " % string) loc
      | Some loc =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal "," % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  CamlinternalFormatBasics.End_of_format))) "%s,@ " % string)
          (String.capitalize_ascii
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              Micheline_parser.print_location loc))
      end in
    let parsed_locations
      (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed) (loc : Z)
      : option Tezos_micheline.Micheline_parser.location :=
      (* ❌ Try-with are not handled *)
      try
        (let oloc :=
          List.assoc loc (Michelson_v1_parser.unexpansion_table parsed) in
        let '(ploc, _) := List.assoc oloc (expansion_table parsed) in
        Some ploc) in
    let print_source {A : Type}
      (ppf : Stdlib.Format.formatter) (function_parameter :
      Tezos_client_alpha.Michelson_v1_parser.parsed * A) : unit :=
      let '(parsed, _hilights) := function_parameter in
      let lines :=
        String.split_on_char "010" % char (Michelson_v1_parser.source parsed) in
      let cols := String.length (OCaml.Stdlib.string_of_int (List.length lines))
        in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
        (Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              let '(i, l) := function_parameter in
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    (CamlinternalFormatBasics.Arg_padding
                      CamlinternalFormatBasics.Zeros)
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal ": " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.End_of_format)))
                  "%0*d: %s" % string) cols i l))
        (List.mapi (fun i => fun l => ((Z.add i 1), l)) lines) in
    match errs with
    | [] => tt
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
            expr loc)) rest =>
      let parsed :=
        match parsed with
        | Some parsed =>
          if
            equiv_decb
              (Micheline.strip_locations
                (Michelson_v1_macros.unexpand_rec (Micheline.root expr)))
              (Michelson_v1_parser.unexpanded parsed) then
            parsed
          else
            Michelson_v1_printer.unparse_invalid expr
        | None => Michelson_v1_printer.unparse_invalid expr
        end in
      let hilights := cons loc (collect_error_locations rest) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if show_source then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.String_literal
                    "Invalid primitive:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            CamlinternalFormatBasics.End_of_format)))))))
              "@[<hov 0>@[<hov 2>Invalid primitive:@ %a@]@]" % string)
            print_source (parsed, hilights)
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Invalid primitive." % string
                CamlinternalFormatBasics.End_of_format)
              "Invalid primitive." % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace (parsed_locations parsed) rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
            name expr ty)) rest =>
      let parsed :=
        match parsed with
        | Some parsed => parsed
        | Some _ | None => Michelson_v1_printer.unparse_expression expr
        end in
      let hilights := collect_error_locations rest in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.String_literal "Ill typed " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal "data:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<hov 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<hov 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "is not an expression of type" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format)))))))))))))))
            "@[<hov 0>@[<hov 2>Ill typed %adata:@ %a@]@ @[<hov 2>is not an expression of type@ %a@]@]"
              % string)
          (fun ppf =>
            fun function_parameter =>
              match function_parameter with
              | None => tt
              | Some s =>
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal " " % char
                        CamlinternalFormatBasics.End_of_format)) "%s " % string)
                  s
              end) name print_source (parsed, hilights) print_ty ty in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace (parsed_locations parsed) rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
            entrypoint)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Contract has no entrypoint named " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Contract has no entrypoint named %s" % string) entrypoint in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_entrypoint
            entrypoint)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Contract has two entrypoints named " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Contract has two entrypoints named %s" % string) entrypoint in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unreachable_entrypoint
            path)) rest =>
      let path :=
        String.concat "/" % string
          (List.map Michelson_v1_primitives.string_of_prim path) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Entrypoint at path " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.String_literal
                  " is not reachable" % string
                  CamlinternalFormatBasics.End_of_format)))
            "Entrypoint at path %s is not reachable" % string) path in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
            _ expr loc)) rest =>
      let parsed :=
        match parsed with
        | Some parsed => parsed
        | Some _ | None => Michelson_v1_printer.unparse_expression expr
        end in
      let hilights := cons loc (collect_error_locations errs) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if show_source then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "ill formed type:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@[<v 2>%aill formed type:@ %a@]" % string) print_loc loc
            print_source (parsed, hilights)
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Ill formed type." % string
                CamlinternalFormatBasics.End_of_format)
              "Ill formed type." % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace (parsed_locations parsed) rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
            expr type_map)) rest =>
      let parsed :=
        match parsed with
        | Some parsed => parsed
        | Some _ | None =>
          Michelson_v1_printer.unparse_toplevel (Some type_map) expr
        end in
      let hilights := collect_error_locations rest in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if show_source then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Ill typed contract:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "  " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@[<v 0>Ill typed contract:@,  %a@]" % string) print_source
            (parsed, hilights)
        else
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Ill typed contract." % string
                CamlinternalFormatBasics.End_of_format)
              "Ill typed contract." % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace (parsed_locations parsed) rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "Not enough gas to deserialize the operation." % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "Injecting such a transaction could have you banned from mempools."
                      % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 0>Not enough gas to deserialize the operation.@,Injecting such a transaction could have you banned from mempools.@]"
              % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_error)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Error too big to serialize within the provided gas bounds." %
                string CamlinternalFormatBasics.End_of_format)
            "Error too big to serialize within the provided gas bounds." %
              string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
            prim)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "Use of deprecated instruction: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format))))
            "@[<v 0>Use of deprecated instruction: %s@]" % string)
          (Michelson_v1_primitives.string_of_prim prim) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_storage)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Cannot serialize the resulting storage value within the provided gas bounds."
                % string CamlinternalFormatBasics.End_of_format)
            "Cannot serialize the resulting storage value within the provided gas bounds."
              % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
            prim)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "Missing contract field: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format))))
            "@[<v 0>Missing contract field: %s@]" % string)
          (Michelson_v1_primitives.string_of_prim prim) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
            loc prim)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "duplicate contract field: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 0>%aduplicate contract field: %s@]" % string) print_loc loc
          (Michelson_v1_primitives.string_of_prim prim) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
            loc)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "big_map type not allowed inside another big_map" % string
                CamlinternalFormatBasics.End_of_format))
            "%abig_map type not allowed inside another big_map" % string)
          print_loc loc in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
            loc)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "operation type forbidden in parameter, storage and constants" %
                  string CamlinternalFormatBasics.End_of_format))
            "%aoperation type forbidden in parameter, storage and constants" %
              string) print_loc loc in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_contract
            loc)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                "contract type forbidden in storage and constants" % string
                CamlinternalFormatBasics.End_of_format))
            "%acontract type forbidden in storage and constants" % string)
          print_loc loc in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Runtime_contract_error
            contract expr)) rest =>
      let parsed :=
        match parsed with
        | Some parsed => parsed
        | Some _ | None => Michelson_v1_printer.unparse_toplevel None expr
        end in
      let hilights := collect_error_locations rest in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Runtime error in contract " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal ":" % char
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format)))))))
            "@[<v 2>Runtime error in contract %a:@ %a@]" % string) Contract.pp
          contract print_source (parsed, hilights) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace (parsed_locations parsed) rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Internal_operation_replay
            op)) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Internal operation replay attempt:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 2>Internal operation replay attempt:@,%a@]" % string)
          Operation_result.pp_internal_operation op in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_limit_too_high)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Gas limit for the operation is out of the protocol hard bounds."
                % string CamlinternalFormatBasics.End_of_format)
            "Gas limit for the operation is out of the protocol hard bounds." %
              string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Block_quota_exceeded)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Gas limit for the block exceeded during typechecking or execution."
                % string CamlinternalFormatBasics.End_of_format)
            "Gas limit for the block exceeded during typechecking or execution."
              % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "Gas limit exceeded during typechecking or execution." % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "Try again with a higher gas limit." % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 0>Gas limit exceeded during typechecking or execution.@,Try again with a higher gas limit.@]"
              % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded)
        rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "Storage limit exceeded during typechecking or execution." %
                  string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal
                    "Try again with a higher storage limit." % string
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format)))))
            "@[<v 0>Storage limit exceeded during typechecking or execution.@,Try again with a higher storage limit.@]"
              % string) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    |
      cons
        (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
            c)) [] =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal "Account " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " is not a smart contract, it does not take arguments." %
                    string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "The `-arg' flag should not be used when transferring to an account."
                        % string
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))
          "@[<v 0>Account %a is not a smart contract, it does not take arguments.@,The `-arg' flag should not be used when transferring to an account.@]"
            % string) Contract.pp c
    | cons (Tezos_base__TzPervasives.Error_monad.Ecoproto_error err) rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        match err with
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
            c =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Invalid argument passed to contract " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))
              "Invalid argument passed to contract %a." % string) Contract.pp c
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc name exp got =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal "primitive " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " expects " % string
                      (CamlinternalFormatBasics.Int
                        CamlinternalFormatBasics.Int_d
                        CamlinternalFormatBasics.No_padding
                        CamlinternalFormatBasics.No_precision
                        (CamlinternalFormatBasics.String_literal
                          " arguments but is given " % string
                          (CamlinternalFormatBasics.Int
                            CamlinternalFormatBasics.Int_d
                            CamlinternalFormatBasics.No_padding
                            CamlinternalFormatBasics.No_precision
                            (CamlinternalFormatBasics.Char_literal "." % char
                              CamlinternalFormatBasics.End_of_format))))))))
              "%aprimitive %s expects %d arguments but is given %d." % string)
            print_loc loc (Michelson_v1_primitives.string_of_prim name) exp got
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
            loc name exp got =>
          let human_namespace
            (function_parameter :
            Tezos_protocol_alpha.Protocol.Script_tc_errors.namespace)
            : string * string :=
            match function_parameter with
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Instr_namespace =>
              ("an" % string, "instruction" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Type_namespace =>
              ("a" % string, "type name" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Constant_namespace
              => ("a" % string, "constant constructor" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Keyword_namespace
              => ("a" % string, "keyword" % string)
            end in
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "unexpected " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal " " % char
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            ", only " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Char_literal " " % char
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    " can be used here." % string
                                    CamlinternalFormatBasics.End_of_format)))))))))))
              "@[%aunexpected %s %s, only %s %s can be used here." % string)
            print_loc loc (snd (human_namespace got))
            (Michelson_v1_primitives.string_of_prim name)
            (fst (human_namespace exp)) (snd (human_namespace exp))
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
            loc exp got =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "invalid primitive " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal
                        ", only " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " can be used here." % string
                            CamlinternalFormatBasics.End_of_format)))))))
              "@[%ainvalid primitive %s, only %a can be used here." % string)
            print_loc loc (Michelson_v1_primitives.string_of_prim got)
            print_enumeration
            (List.map Michelson_v1_primitives.string_of_prim exp)
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
            loc exp got =>
          let human_kind
            (function_parameter :
            Tezos_protocol_alpha.Protocol.Script_tc_errors.kind)
            : string * string :=
            match function_parameter with
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Seq_kind =>
              ("a" % string, "sequence" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Prim_kind =>
              ("a" % string, "primitive" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Int_kind =>
              ("an" % string, "int" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.String_kind =>
              ("a" % string, "string" % string)
            | Tezos_protocol_alpha.Protocol.Script_tc_errors.Bytes_kind =>
              ("a" % string, "byte sequence" % string)
            end in
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    CamlinternalFormatBasics.End_of_format "" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "unexpected " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.String_literal ", only" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.String_literal
                                "can be used here." % string
                                CamlinternalFormatBasics.End_of_format)))))))))
              "@[%aunexpected %s, only@ %a@ can be used here." % string)
            print_loc loc (snd (human_kind got)) print_enumeration
            (List.map
              (fun k =>
                let '(a, n) := human_kind k in
                String.append a (String.append " " % string n)) exp)
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_map_keys
            _ expr =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Map literals cannot contain duplicate keys, however a duplicate key was found:"
                    % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@[<v 2>Map literals cannot contain duplicate keys, however a duplicate key was found:@ @[%a@]"
                % string) print_expr expr
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_map_keys
            _ expr =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Keys in a map literal must be in strictly ascending order, but they were unordered in literal:"
                    % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@[<v 2>Keys in a map literal must be in strictly ascending order, but they were unordered in literal:@ @[%a@]"
                % string) print_expr expr
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_set_values
            _ expr =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Set literals cannot contain duplicate values, however a duplicate value was found:"
                    % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@[<v 2>Set literals cannot contain duplicate values, however a duplicate value was found:@ @[%a@]"
                % string) print_expr expr
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_set_values
            _ expr =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Values in a set literal must be in strictly ascending order, but they were unordered in literal:"
                    % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          CamlinternalFormatBasics.End_of_format "" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          CamlinternalFormatBasics.End_of_format))))))
              "@[<v 2>Values in a set literal must be in strictly ascending order, but they were unordered in literal:@ @[%a@]"
                % string) print_expr expr
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
            loc =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "The FAIL instruction must appear in a tail position." %
                    string CamlinternalFormatBasics.End_of_format))
              "%aThe FAIL instruction must appear in a tail position." % string)
            print_loc loc
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
            loc name tya tyb =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "operator " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          " is undefined between" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<hov 2>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<hov 2>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "and" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Char_literal
                                            "." % char
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                CamlinternalFormatBasics.End_of_format)))))))))))))))))
              "@[<hov 0>@[<hov 2>%aoperator %s is undefined between@ %a@]@ @[<hov 2>and@ %a.@]@]"
                % string) print_loc loc
            (Michelson_v1_primitives.string_of_prim name) print_ty tya print_ty
            tyb
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
            loc name ty =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      "operator " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.String_literal
                          " is undefined on" % string
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format))))))))))
              "@[<hov 0>@[<hov 2>%aoperator %s is undefined on@ %a@]@]" % string)
            print_loc loc (Michelson_v1_primitives.string_of_prim name) print_ty
            ty
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
            loc got exp =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "wrong stack type at end of body:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal "- " % string
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 0>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 0>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "expected return stack type:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  "," % char
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "- " % string
                                        (CamlinternalFormatBasics.Formatting_gen
                                          (CamlinternalFormatBasics.Open_box
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "<v 0>" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "<v 0>" % string))
                                          (CamlinternalFormatBasics.String_literal
                                            "actual stack type:" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "." % char
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format))))))))))))))))))))
              "@[<v 2>%awrong stack type at end of body:@,- @[<v 0>expected return stack type:@ %a,@]@,- @[<v 0>actual stack type:@ %a.@]@]"
                % string) print_loc loc (fun ppf => print_stack_ty None ppf)
            (cons (exp, []) []) (fun ppf => print_stack_ty None ppf) got
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
            loc name depth sty =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "wrong stack type for instruction " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Char_literal ":" % char
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal "." % char
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))))
              "@[<hov 2>%awrong stack type for instruction %s:@ %a.@]" % string)
            print_loc loc (Michelson_v1_primitives.string_of_prim name)
            (print_stack_ty (Some depth)) sty
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
            loc sta stb =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "two branches don't end with the same stack type:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal "- " % string
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<hov>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<hov>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "first stack type:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Char_literal
                                  "," % char
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@," % string 0 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "- " % string
                                        (CamlinternalFormatBasics.Formatting_gen
                                          (CamlinternalFormatBasics.Open_box
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "<hov>" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "<hov>" % string))
                                          (CamlinternalFormatBasics.String_literal
                                            "other stack type:" % string
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Char_literal
                                                  "." % char
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format))))))))))))))))))))
              "@[<v 2>%atwo branches don't end with the same stack type:@,- @[<hov>first stack type:@ %a,@]@,- @[<hov>other stack type:@ %a.@]@]"
                % string) print_loc loc (fun ppf => print_stack_ty None ppf) sta
            (fun ppf => print_stack_ty None ppf) stb
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_annotations
            annot1 annot2 =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "The two annotations do not match:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "- " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v>" % string))
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "- " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v>" % string))
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))))))))))
              "@[<v 2>The two annotations do not match:@,- @[<v>%s@]@,- @[<v>%s@]@]"
                % string) annot1 annot2
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_field_annotations
            annot1 annot2 =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "The field access annotation does not match:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "- " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "<v>" % string
                              CamlinternalFormatBasics.End_of_format)
                            "<v>" % string))
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "- " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v>" % string))
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format)))))))))))))
              "@[<v 2>The field access annotation does not match:@,- @[<v>%s@]@,- @[<v>%s@]@]"
                % string) annot1 annot2
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
            loc ty1 ty2 =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "the two types contain incompatible annotations:" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal "- " % string
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<hov>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<hov>" % string))
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "- " % string
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<hov>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<hov>" % string))
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))))))
              "@[<v 2>%athe two types contain incompatible annotations:@,- @[<hov>%a@]@,- @[<hov>%a@]@]"
                % string) print_loc loc print_ty ty1 print_ty ty2
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
            loc =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "unexpected annotation." % string
                    CamlinternalFormatBasics.End_of_format)))
              "@[<v 2>%aunexpected annotation." % string) print_loc loc
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Ungrouped_annotations
            loc =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "Annotations of the same kind must be grouped." % string
                    CamlinternalFormatBasics.End_of_format)))
              "@[<v 2>%aAnnotations of the same kind must be grouped." % string)
            print_loc loc
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Type_too_large
            loc size maximum_size =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "type size (" % string
                    (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.No_precision
                      (CamlinternalFormatBasics.String_literal
                        ") exceeded maximum type size (" % string
                        (CamlinternalFormatBasics.Int
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          (CamlinternalFormatBasics.String_literal ")." % string
                            CamlinternalFormatBasics.End_of_format)))))))
              "@[<v 2>%atype size (%d) exceeded maximum type size (%d)." %
                string) print_loc loc size maximum_size
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Self_in_lambda
            loc =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "The SELF instruction cannot appear in a lambda." % string
                  CamlinternalFormatBasics.End_of_format))
              "%aThe SELF instruction cannot appear in a lambda." % string)
            print_loc loc
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_length
          =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Bad stack length." % string
                CamlinternalFormatBasics.End_of_format)
              "Bad stack length." % string)
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
            lvl =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Bad stack item " % string
                (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                  CamlinternalFormatBasics.No_padding
                  CamlinternalFormatBasics.No_precision
                  (CamlinternalFormatBasics.Char_literal "." % char
                    CamlinternalFormatBasics.End_of_format)))
              "Bad stack item %d." % string) lvl
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
            loc got exp =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal "value" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<hov 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<hov 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "is invalid for type" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        "." % char
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))))))))))))
              "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid for type@ %a.@]@]"
                % string) print_loc loc print_expr got print_ty exp
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
            loc got exp =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal "value" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@ " % string 1 0)
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            CamlinternalFormatBasics.Close_box
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@ " % string 1 0)
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<hov 2>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<hov 2>" % string))
                                (CamlinternalFormatBasics.String_literal
                                  "is invalid, expected" % string
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@ " % string 1 0)
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))))))
              "@[<hov 0>@[<hov 2>%avalue@ %a@]@ @[<hov 2>is invalid, expected@ %s@]@]"
                % string) print_loc loc print_expr got exp
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
            loc contract =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "invalid contract " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Char_literal "." % char
                      CamlinternalFormatBasics.End_of_format))))
              "%ainvalid contract %a." % string) print_loc loc Contract.pp
            contract
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
            loc ty =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.String_literal
                    "comparable type expected." % string
                    CamlinternalFormatBasics.End_of_format))
                "%acomparable type expected." % string) print_loc loc in
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.String_literal "Type" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.String_literal
                              "is not comparable." % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))))
              "@[<hov 0>@[<hov 2>Type@ %a@]@ is not comparable.@]" % string)
            print_ty ty
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
            tya tyb =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
                (CamlinternalFormatBasics.Formatting_gen
                  (CamlinternalFormatBasics.Open_box
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "<hov 2>" % string
                        CamlinternalFormatBasics.End_of_format)
                      "<hov 2>" % string))
                  (CamlinternalFormatBasics.String_literal "Type" % string
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@ " % string 1 0)
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@ " % string 1 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<hov 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<hov 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "is not compatible with type" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "." % char
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          CamlinternalFormatBasics.End_of_format))))))))))))))
              "@[<hov 0>@[<hov 2>Type@ %a@]@ @[<hov 2>is not compatible with type@ %a.@]@]"
                % string) print_ty tya print_ty tyb
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Reject loc v
            trace =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "script reached FAILWITH instruction" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<hov 2>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<hov 2>" % string))
                      (CamlinternalFormatBasics.String_literal "with" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@ " % string 1 0)
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format)))))))))
              "%ascript reached FAILWITH instruction@ @[<hov 2>with@ %a@]%a" %
                string) print_loc loc print_expr v
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | None => tt
                | Some trace =>
                  Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "trace" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format))))))
                      "@,@[<v 2>trace@,%a@]" % string) print_execution_trace
                    trace
                end) trace
        |
          Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow loc
            trace =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  "unexpected arithmetic overflow" % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))
              "%aunexpected arithmetic overflow%a" % string) print_loc loc
            (fun ppf =>
              fun function_parameter =>
                match function_parameter with
                | None => tt
                | Some trace =>
                  Format.fprintf ppf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "trace" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Close_box
                                  CamlinternalFormatBasics.End_of_format))))))
                      "@,@[<v 2>trace@,%a@]" % string) print_execution_trace
                    trace
                end) trace
        | err =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Environment.Error_monad.pp err
        end in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    | cons err rest =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Error_monad.pp err in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if nequiv_decb rest [] then
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                CamlinternalFormatBasics.End_of_format) "@," % string)
        else
          tt in
      print_trace locations rest
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    print_trace
      (fun function_parameter =>
        let '_ := function_parameter in
        None) errs in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_lit
        CamlinternalFormatBasics.Close_box
        CamlinternalFormatBasics.End_of_format) "@]" % string).

src/proto_alpha/lib_client/michelson_v1_macros.ml 36 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Tezos_micheline
open Micheline
module IntMap = Map.Make (Compare.Int)

type 'l node = ('l, string) Micheline.node

type error += Unexpected_macro_annotation of string

type error += Sequence_expected of string

type error += Invalid_arity of string * int * int

let rec check_letters str i j f =
  i > j || (f str.[i] && check_letters str (i + 1) j f)

let expand_caddadr original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len > 3
        && str.[0] = 'C'
        && str.[len - 1] = 'R'
        && check_letters str 1 (len - 2) (function
               | 'A' | 'D' ->
                   true
               | _ ->
                   false)
      then
        ( match args with
        | [] ->
            ok ()
        | _ :: _ ->
            error (Invalid_arity (str, List.length args, 0)) )
        >>? fun () ->
        let path_annot =
          List.filter (function "@%" | "@%%" -> true | _ -> false) annot
        in
        let rec parse i acc =
          if i = 0 then Seq (loc, acc)
          else
            let annot = if i = len - 2 then annot else path_annot in
            match str.[i] with
            | 'A' ->
                parse (i - 1) (Prim (loc, "CAR", [], annot) :: acc)
            | 'D' ->
                parse (i - 1) (Prim (loc, "CDR", [], annot) :: acc)
            | _ ->
                assert false
        in
        ok (Some (parse (len - 2) []))
      else ok None
  | _ ->
      ok None

let extract_field_annots annot =
  List.partition
    (fun a ->
      match a.[0] with
      | '%' ->
          true
      | _ ->
          false
      | exception Invalid_argument _ ->
          false)
    annot

let expand_set_caddadr original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len >= 7
        && String.sub str 0 5 = "SET_C"
        && str.[len - 1] = 'R'
        && check_letters str 5 (len - 2) (function
               | 'A' | 'D' ->
                   true
               | _ ->
                   false)
      then
        ( match args with
        | [] ->
            ok ()
        | _ :: _ ->
            error (Invalid_arity (str, List.length args, 0)) )
        >>? fun () ->
        ( match extract_field_annots annot with
        | ([], annot) ->
            ok (None, annot)
        | ([f], annot) ->
            ok (Some f, annot)
        | (_, _) ->
            error (Unexpected_macro_annotation str) )
        >>? fun (field_annot, annot) ->
        let rec parse i acc =
          if i = 4 then acc
          else
            let annot = if i = 5 then annot else [] in
            match str.[i] with
            | 'A' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CDR", [], ["@%%"]);
                        Prim (loc, "SWAP", [], []);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | 'D' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CAR", [], ["@%%"]);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | _ ->
                assert false
        in
        match str.[len - 2] with
        | 'A' ->
            let access_check =
              match field_annot with
              | None ->
                  []
              | Some f ->
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CAR", [], [f]);
                    Prim (loc, "DROP", [], []) ]
            in
            let encoding =
              [Prim (loc, "CDR", [], ["@%%"]); Prim (loc, "SWAP", [], [])]
            in
            let pair =
              [ Prim
                  ( loc,
                    "PAIR",
                    [],
                    [Option.unopt field_annot ~default:"%"; "%@"] ) ]
            in
            let init = Seq (loc, access_check @ encoding @ pair) in
            ok (Some (parse (len - 3) init))
        | 'D' ->
            let access_check =
              match field_annot with
              | None ->
                  []
              | Some f ->
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CDR", [], [f]);
                    Prim (loc, "DROP", [], []) ]
            in
            let encoding = [Prim (loc, "CAR", [], ["@%%"])] in
            let pair =
              [ Prim
                  ( loc,
                    "PAIR",
                    [],
                    ["%@"; Option.unopt field_annot ~default:"%"] ) ]
            in
            let init = Seq (loc, access_check @ encoding @ pair) in
            ok (Some (parse (len - 3) init))
        | _ ->
            assert false
      else ok None
  | _ ->
      ok None

let expand_map_caddadr original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len >= 7
        && String.sub str 0 5 = "MAP_C"
        && str.[len - 1] = 'R'
        && check_letters str 5 (len - 2) (function
               | 'A' | 'D' ->
                   true
               | _ ->
                   false)
      then
        ( match args with
        | [(Seq _ as code)] ->
            ok code
        | [_] ->
            error (Sequence_expected str)
        | [] | _ :: _ :: _ ->
            error (Invalid_arity (str, List.length args, 1)) )
        >>? fun code ->
        ( match extract_field_annots annot with
        | ([], annot) ->
            ok (None, annot)
        | ([f], annot) ->
            ok (Some f, annot)
        | (_, _) ->
            error (Unexpected_macro_annotation str) )
        >>? fun (field_annot, annot) ->
        let rec parse i acc =
          if i = 4 then acc
          else
            let annot = if i = 5 then annot else [] in
            match str.[i] with
            | 'A' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CAR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CDR", [], ["@%%"]);
                        Prim (loc, "SWAP", [], []);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | 'D' ->
                let acc =
                  Seq
                    ( loc,
                      [ Prim (loc, "DUP", [], []);
                        Prim
                          ( loc,
                            "DIP",
                            [Seq (loc, [Prim (loc, "CDR", [], ["@%%"]); acc])],
                            [] );
                        Prim (loc, "CAR", [], ["@%%"]);
                        Prim (loc, "PAIR", [], "%@" :: "%@" :: annot) ] )
                in
                parse (i - 1) acc
            | _ ->
                assert false
        in
        let cr_annot =
          match field_annot with
          | None ->
              []
          | Some f ->
              ["@" ^ String.sub f 1 (String.length f - 1)]
        in
        match str.[len - 2] with
        | 'A' ->
            let init =
              Seq
                ( loc,
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CDR", [], ["@%%"]);
                    Prim
                      ( loc,
                        "DIP",
                        [Seq (loc, [Prim (loc, "CAR", [], cr_annot); code])],
                        [] );
                    Prim (loc, "SWAP", [], []);
                    Prim
                      ( loc,
                        "PAIR",
                        [],
                        [Option.unopt field_annot ~default:"%"; "%@"] ) ] )
            in
            ok (Some (parse (len - 3) init))
        | 'D' ->
            let init =
              Seq
                ( loc,
                  [ Prim (loc, "DUP", [], []);
                    Prim (loc, "CDR", [], cr_annot);
                    code;
                    Prim (loc, "SWAP", [], []);
                    Prim (loc, "CAR", [], ["@%%"]);
                    Prim
                      ( loc,
                        "PAIR",
                        [],
                        ["%@"; Option.unopt field_annot ~default:"%"] ) ] )
            in
            ok (Some (parse (len - 3) init))
        | _ ->
            assert false
      else ok None
  | _ ->
      ok None

exception Not_a_roman

let decimal_of_roman roman =
  (* http://rosettacode.org/wiki/Roman_numerals/Decode#OCaml *)
  let arabic = ref 0 in
  let lastval = ref 0 in
  for i = String.length roman - 1 downto 0 do
    let n =
      match roman.[i] with
      | 'M' ->
          1000
      | 'D' ->
          500
      | 'C' ->
          100
      | 'L' ->
          50
      | 'X' ->
          10
      | 'V' ->
          5
      | 'I' ->
          1
      | _ ->
          raise_notrace Not_a_roman
    in
    if Compare.Int.(n < !lastval) then arabic := !arabic - n
    else arabic := !arabic + n ;
    lastval := n
  done ;
  !arabic

let dip ~loc ?(annot = []) depth instr =
  assert (depth >= 0) ;
  if depth = 1 then Prim (loc, "DIP", [instr], annot)
  else Prim (loc, "DIP", [Int (loc, Z.of_int depth); instr], annot)

let expand_deprecated_dxiiivp original =
  (* transparently expands deprecated macro [DI...IP] to instruction [DIP n] *)
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if len > 3 && str.[0] = 'D' && str.[len - 1] = 'P' then
        try
          let depth = decimal_of_roman (String.sub str 1 (len - 2)) in
          match args with
          | [(Seq (_, _) as arg)] ->
              ok @@ Some (dip ~loc ~annot depth arg)
          | [_] ->
              error (Sequence_expected str)
          | [] | _ :: _ :: _ ->
              error (Invalid_arity (str, List.length args, 1))
        with Not_a_roman -> ok None
      else ok None
  | _ ->
      ok None

exception Not_a_pair

type pair_item = A | I | P of int * pair_item * pair_item

let parse_pair_substr str ~len start =
  let rec parse ?left i =
    if i = len - 1 then raise_notrace Not_a_pair
    else if str.[i] = 'P' then
      let (next_i, l) = parse ~left:true (i + 1) in
      let (next_i, r) = parse ~left:false next_i in
      (next_i, P (i, l, r))
    else if str.[i] = 'A' && left = Some true then (i + 1, A)
    else if str.[i] = 'I' && left <> Some true then (i + 1, I)
    else raise_notrace Not_a_pair
  in
  let (last, ast) = parse start in
  if last <> len - 1 then raise_notrace Not_a_pair else ast

let unparse_pair_item ast =
  let rec unparse ast acc =
    match ast with
    | P (_, l, r) ->
        unparse r (unparse l ("P" :: acc))
    | A ->
        "A" :: acc
    | I ->
        "I" :: acc
  in
  List.rev ("R" :: unparse ast []) |> String.concat ""

let pappaiir_annots_pos ast annot =
  let rec find_annots_pos p_pos ast annots acc =
    match (ast, annots) with
    | (_, []) ->
        (annots, acc)
    | (P (i, left, right), _) ->
        let (annots, acc) = find_annots_pos i left annots acc in
        find_annots_pos i right annots acc
    | (A, a :: annots) ->
        let pos =
          match IntMap.find_opt p_pos acc with
          | None ->
              ([a], [])
          | Some (_, cdr) ->
              ([a], cdr)
        in
        (annots, IntMap.add p_pos pos acc)
    | (I, a :: annots) ->
        let pos =
          match IntMap.find_opt p_pos acc with
          | None ->
              ([], [a])
          | Some (car, _) ->
              (car, [a])
        in
        (annots, IntMap.add p_pos pos acc)
  in
  snd (find_annots_pos 0 ast annot IntMap.empty)

let expand_pappaiir original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len > 4
        && str.[0] = 'P'
        && str.[len - 1] = 'R'
        && check_letters str 1 (len - 2) (function
               | 'P' | 'A' | 'I' ->
                   true
               | _ ->
                   false)
      then
        try
          let (field_annots, annot) = extract_field_annots annot in
          let ast = parse_pair_substr str ~len 0 in
          let field_annots_pos = pappaiir_annots_pos ast field_annots in
          let rec parse p (depth, acc) =
            match p with
            | P (i, left, right) ->
                let annot =
                  match (i, IntMap.find_opt i field_annots_pos) with
                  | (0, None) ->
                      annot
                  | (_, None) ->
                      []
                  | (0, Some ([], cdr_annot)) ->
                      ("%" :: cdr_annot) @ annot
                  | (_, Some ([], cdr_annot)) ->
                      "%" :: cdr_annot
                  | (0, Some (car_annot, cdr_annot)) ->
                      car_annot @ cdr_annot @ annot
                  | (_, Some (car_annot, cdr_annot)) ->
                      car_annot @ cdr_annot
                in
                let acc =
                  if depth = 0 then Prim (loc, "PAIR", [], annot) :: acc
                  else
                    dip ~loc depth (Seq (loc, [Prim (loc, "PAIR", [], annot)]))
                    :: acc
                in
                (depth, acc) |> parse left |> parse right
            | A | I ->
                (depth + 1, acc)
          in
          let (_, expanded) = parse ast (0, []) in
          ( match args with
          | [] ->
              ok ()
          | _ :: _ ->
              error (Invalid_arity (str, List.length args, 0)) )
          >>? fun () -> ok (Some (Seq (loc, expanded)))
        with Not_a_pair -> ok None
      else ok None
  | _ ->
      ok None

let expand_unpappaiir original =
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len >= 6
        && String.sub str 0 3 = "UNP"
        && str.[len - 1] = 'R'
        && check_letters str 3 (len - 2) (function
               | 'P' | 'A' | 'I' ->
                   true
               | _ ->
                   false)
      then
        try
          let unpair car_annot cdr_annot =
            Seq
              ( loc,
                [ Prim (loc, "DUP", [], []);
                  Prim (loc, "CAR", [], car_annot);
                  dip ~loc 1 (Seq (loc, [Prim (loc, "CDR", [], cdr_annot)])) ]
              )
          in
          let ast = parse_pair_substr str ~len 2 in
          let annots_pos = pappaiir_annots_pos ast annot in
          let rec parse p (depth, acc) =
            match p with
            | P (i, left, right) ->
                let (car_annot, cdr_annot) =
                  match IntMap.find_opt i annots_pos with
                  | None ->
                      ([], [])
                  | Some (car_annot, cdr_annot) ->
                      (car_annot, cdr_annot)
                in
                let acc =
                  if depth = 0 then unpair car_annot cdr_annot :: acc
                  else
                    dip ~loc depth (Seq (loc, [unpair car_annot cdr_annot]))
                    :: acc
                in
                (depth, acc) |> parse left |> parse right
            | A | I ->
                (depth + 1, acc)
          in
          let (_, rev_expanded) = parse ast (0, []) in
          let expanded = Seq (loc, List.rev rev_expanded) in
          ( match args with
          | [] ->
              ok ()
          | _ :: _ ->
              error (Invalid_arity (str, List.length args, 0)) )
          >>? fun () -> ok (Some expanded)
        with Not_a_pair -> ok None
      else ok None
  | _ ->
      ok None

exception Not_a_dup

let dupn loc nloc n annot =
  assert (n > 1) ;
  if n = 2 then
    (* keep the old expansion, shorter for [DUP 2] *)
    Seq
      ( loc,
        [ Prim (loc, "DIP", [Seq (loc, [Prim (nloc, "DUP", [], annot)])], []);
          Prim (loc, "SWAP", [], []) ] )
  else
    Seq
      ( loc,
        [ Prim
            ( loc,
              "DIP",
              [ Int (loc, Z.of_int (n - 1));
                Seq (loc, [Prim (loc, "DUP", [], annot)]) ],
              [] );
          Prim (loc, "DIG", [Int (nloc, Z.of_int n)], []) ] )

let expand_dupn original =
  match original with
  | Prim (loc, "DUP", [Int (nloc, n)], annot) ->
      ok (Some (dupn loc nloc (Z.to_int n) annot))
  | _ ->
      ok None

let expand_deprecated_duuuuup original =
  (* transparently expands deprecated macro [DU...UP] to [{ DIP n { DUP } ; DIG n }] *)
  match original with
  | Prim (loc, str, args, annot) ->
      let len = String.length str in
      if
        len > 3
        && str.[0] = 'D'
        && str.[len - 1] = 'P'
        && check_letters str 1 (len - 2) (( = ) 'U')
      then
        ( match args with
        | [] ->
            ok ()
        | _ :: _ ->
            error (Invalid_arity (str, List.length args, 0)) )
        >>? fun () ->
        try
          let rec parse i =
            if i = 1 then dupn loc loc (len - 2) annot
            else if str.[i] = 'U' then parse (i - 1)
            else raise_notrace Not_a_dup
          in
          ok (Some (parse (len - 2)))
        with Not_a_dup -> ok None
      else ok None
  | _ ->
      ok None

let expand_compare original =
  let cmp loc is annot =
    let is =
      match List.rev_map (fun i -> Prim (loc, i, [], [])) is with
      | Prim (loc, i, args, _) :: r ->
          List.rev (Prim (loc, i, args, annot) :: r)
      | is ->
          List.rev is
    in
    ok (Some (Seq (loc, is)))
  in
  let ifcmp loc is l r annot =
    let is =
      List.map (fun i -> Prim (loc, i, [], [])) is
      @ [Prim (loc, "IF", [l; r], annot)]
    in
    ok (Some (Seq (loc, is)))
  in
  match original with
  | Prim (loc, "CMPEQ", [], annot) ->
      cmp loc ["COMPARE"; "EQ"] annot
  | Prim (loc, "CMPNEQ", [], annot) ->
      cmp loc ["COMPARE"; "NEQ"] annot
  | Prim (loc, "CMPLT", [], annot) ->
      cmp loc ["COMPARE"; "LT"] annot
  | Prim (loc, "CMPGT", [], annot) ->
      cmp loc ["COMPARE"; "GT"] annot
  | Prim (loc, "CMPLE", [], annot) ->
      cmp loc ["COMPARE"; "LE"] annot
  | Prim (loc, "CMPGE", [], annot) ->
      cmp loc ["COMPARE"; "GE"] annot
  | Prim
      ( _,
        (("CMPEQ" | "CMPNEQ" | "CMPLT" | "CMPGT" | "CMPLE" | "CMPGE") as str),
        args,
        [] ) ->
      error (Invalid_arity (str, List.length args, 0))
  | Prim (loc, "IFCMPEQ", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "EQ"] l r annot
  | Prim (loc, "IFCMPNEQ", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "NEQ"] l r annot
  | Prim (loc, "IFCMPLT", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "LT"] l r annot
  | Prim (loc, "IFCMPGT", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "GT"] l r annot
  | Prim (loc, "IFCMPLE", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "LE"] l r annot
  | Prim (loc, "IFCMPGE", [l; r], annot) ->
      ifcmp loc ["COMPARE"; "GE"] l r annot
  | Prim (loc, "IFEQ", [l; r], annot) ->
      ifcmp loc ["EQ"] l r annot
  | Prim (loc, "IFNEQ", [l; r], annot) ->
      ifcmp loc ["NEQ"] l r annot
  | Prim (loc, "IFLT", [l; r], annot) ->
      ifcmp loc ["LT"] l r annot
  | Prim (loc, "IFGT", [l; r], annot) ->
      ifcmp loc ["GT"] l r annot
  | Prim (loc, "IFLE", [l; r], annot) ->
      ifcmp loc ["LE"] l r annot
  | Prim (loc, "IFGE", [l; r], annot) ->
      ifcmp loc ["GE"] l r annot
  | Prim
      ( _,
        ( ( "IFCMPEQ"
          | "IFCMPNEQ"
          | "IFCMPLT"
          | "IFCMPGT"
          | "IFCMPLE"
          | "IFCMPGE"
          | "IFEQ"
          | "IFNEQ"
          | "IFLT"
          | "IFGT"
          | "IFLE"
          | "IFGE" ) as str ),
        args,
        [] ) ->
      error (Invalid_arity (str, List.length args, 2))
  | Prim
      ( _,
        ( ( "IFCMPEQ"
          | "IFCMPNEQ"
          | "IFCMPLT"
          | "IFCMPGT"
          | "IFCMPLE"
          | "IFCMPGE"
          | "IFEQ"
          | "IFNEQ"
          | "IFLT"
          | "IFGT"
          | "IFLE"
          | "IFGE" ) as str ),
        [],
        _ :: _ ) ->
      error (Unexpected_macro_annotation str)
  | _ ->
      ok None

let expand_asserts original =
  let may_rename loc = function
    | [] ->
        Seq (loc, [])
    | annot ->
        Seq (loc, [Prim (loc, "RENAME", [], annot)])
  in
  let fail_false ?(annot = []) loc =
    [may_rename loc annot; Seq (loc, [Prim (loc, "FAIL", [], [])])]
  in
  let fail_true ?(annot = []) loc =
    [Seq (loc, [Prim (loc, "FAIL", [], [])]); may_rename loc annot]
  in
  match original with
  | Prim (loc, "ASSERT", [], []) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF", fail_false loc, [])]))
  | Prim (loc, "ASSERT_NONE", [], []) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_false loc, [])]))
  | Prim (loc, "ASSERT_SOME", [], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", fail_true ~annot loc, [])]))
  | Prim (loc, "ASSERT_LEFT", [], annot) ->
      ok
      @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_false ~annot loc, [])]))
  | Prim (loc, "ASSERT_RIGHT", [], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", fail_true ~annot loc, [])]))
  | Prim
      ( _,
        ( ( "ASSERT"
          | "ASSERT_NONE"
          | "ASSERT_SOME"
          | "ASSERT_LEFT"
          | "ASSERT_RIGHT" ) as str ),
        args,
        [] ) ->
      error (Invalid_arity (str, List.length args, 0))
  | Prim (_, (("ASSERT" | "ASSERT_NONE") as str), [], _ :: _) ->
      error (Unexpected_macro_annotation str)
  | Prim (loc, s, args, annot)
    when String.(length s > 7 && equal (sub s 0 7) "ASSERT_") -> (
      ( match args with
      | [] ->
          ok ()
      | _ :: _ ->
          error (Invalid_arity (s, List.length args, 0)) )
      >>? fun () ->
      ( match annot with
      | _ :: _ ->
          error (Unexpected_macro_annotation s)
      | [] ->
          ok () )
      >>? fun () ->
      let remaining = String.(sub s 7 (length s - 7)) in
      let remaining_prim = Prim (loc, remaining, [], []) in
      match remaining with
      | "EQ" | "NEQ" | "LT" | "LE" | "GE" | "GT" ->
          ok
          @@ Some
               (Seq
                  (loc, [remaining_prim; Prim (loc, "IF", fail_false loc, [])]))
      | _ -> (
          expand_compare remaining_prim
          >|? function
          | None ->
              None
          | Some seq ->
              Some (Seq (loc, [seq; Prim (loc, "IF", fail_false loc, [])])) ) )
  | _ ->
      ok None

let expand_if_some = function
  | Prim (loc, "IF_SOME", [right; left], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_NONE", [left; right], annot)]))
  | Prim (_, "IF_SOME", args, _annot) ->
      error (Invalid_arity ("IF_SOME", List.length args, 2))
  | _ ->
      ok @@ None

let expand_if_right = function
  | Prim (loc, "IF_RIGHT", [right; left], annot) ->
      ok @@ Some (Seq (loc, [Prim (loc, "IF_LEFT", [left; right], annot)]))
  | Prim (_, "IF_RIGHT", args, _annot) ->
      error (Invalid_arity ("IF_RIGHT", List.length args, 2))
  | _ ->
      ok @@ None

let expand_fail = function
  | Prim (loc, "FAIL", [], []) ->
      ok
      @@ Some
           (Seq
              ( loc,
                [Prim (loc, "UNIT", [], []); Prim (loc, "FAILWITH", [], [])] ))
  | _ ->
      ok @@ None

let expand original =
  let rec try_expansions = function
    | [] ->
        ok @@ original
    | expander :: expanders -> (
        expander original
        >>? function
        | None -> try_expansions expanders | Some rewritten -> ok rewritten )
  in
  try_expansions
    [ expand_caddadr;
      expand_set_caddadr;
      expand_map_caddadr;
      expand_deprecated_dxiiivp;
      (* expand_paaiair ; *)
      expand_pappaiir;
      (* expand_unpaaiair ; *)
      expand_unpappaiir;
      expand_deprecated_duuuuup;
      expand_dupn;
      expand_compare;
      expand_asserts;
      expand_if_some;
      expand_if_right;
      expand_fail ]

let expand_rec expr =
  let rec error_map (expanded, errors) f = function
    | [] ->
        (List.rev expanded, List.rev errors)
    | hd :: tl ->
        let (new_expanded, new_errors) = f hd in
        error_map
          (new_expanded :: expanded, List.rev_append new_errors errors)
          f
          tl
  in
  let error_map = error_map ([], []) in
  let rec expand_rec expr =
    match expand expr with
    | Ok expanded -> (
      match expanded with
      | Seq (loc, items) ->
          let (items, errors) = error_map expand_rec items in
          (Seq (loc, items), errors)
      | Prim (loc, name, args, annot) ->
          let (args, errors) = error_map expand_rec args in
          (Prim (loc, name, args, annot), errors)
      | (Int _ | String _ | Bytes _) as atom ->
          (atom, []) )
    | Error errors ->
        (expr, errors)
  in
  expand_rec expr

let unexpand_caddadr expanded =
  let rec rsteps acc = function
    | [] ->
        Some acc
    | Prim (_, "CAR", [], []) :: rest ->
        rsteps ("A" :: acc) rest
    | Prim (_, "CDR", [], []) :: rest ->
        rsteps ("D" :: acc) rest
    | _ ->
        None
  in
  match expanded with
  | Seq (loc, (Prim (_, "CAR", [], []) :: _ as nodes))
  | Seq (loc, (Prim (_, "CDR", [], []) :: _ as nodes)) -> (
    match rsteps [] nodes with
    | Some steps ->
        let name = String.concat "" ("C" :: List.rev ("R" :: steps)) in
        Some (Prim (loc, name, [], []))
    | None ->
        None )
  | _ ->
      None

let unexpand_set_caddadr expanded =
  let rec steps acc annots = function
    | Seq
        ( loc,
          [ Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, annots)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CAR", [], [field_annot]);
            Prim (_, "DROP", [], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, field_annot :: annots)
    | Seq (loc, [Prim (_, "CAR", [], _); Prim (_, "PAIR", [], _)]) ->
        Some (loc, "D" :: acc, annots)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], [field_annot]);
            Prim (_, "DROP", [], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "D" :: acc, field_annot :: annots)
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("A" :: acc) (List.rev_append pair_annots annots) sub
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], _); sub])], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("D" :: acc) (List.rev_append pair_annots annots) sub
    | _ ->
        None
  in
  match steps [] [] expanded with
  | Some (loc, steps, annots) ->
      let name = String.concat "" ("SET_C" :: List.rev ("R" :: steps)) in
      Some (Prim (loc, name, [], List.rev annots))
  | None ->
      None

let unexpand_map_caddadr expanded =
  let rec steps acc annots = function
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], []); code])], []);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, annots, code)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim
              ( _,
                "DIP",
                [Seq (_, [Prim (_, "CAR", [], [field_annot]); code])],
                [] );
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "A" :: acc, field_annot :: annots, code)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], []);
            code;
            Prim (_, "SWAP", [], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "D" :: acc, annots, code)
    | Seq
        ( loc,
          [ Prim (_, "DUP", [], []);
            Prim (_, "CDR", [], [field_annot]);
            code;
            Prim (_, "SWAP", [], []);
            Prim (_, "CAR", [], _);
            Prim (_, "PAIR", [], _) ] ) ->
        Some (loc, "D" :: acc, field_annot :: annots, code)
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CAR", [], _); sub])], []);
            Prim (_, "CDR", [], _);
            Prim (_, "SWAP", [], []);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("A" :: acc) (List.rev_append pair_annots annots) sub
    | Seq
        ( _,
          [ Prim (_, "DUP", [], []);
            Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], []); sub])], []);
            Prim (_, "CAR", [], []);
            Prim (_, "PAIR", [], pair_annots) ] ) ->
        let (_, pair_annots) = extract_field_annots pair_annots in
        steps ("D" :: acc) (List.rev_append pair_annots annots) sub
    | _ ->
        None
  in
  match steps [] [] expanded with
  | Some (loc, steps, annots, code) ->
      let name = String.concat "" ("MAP_C" :: List.rev ("R" :: steps)) in
      Some (Prim (loc, name, [code], List.rev annots))
  | None ->
      None

let unexpand_deprecated_dxiiivp expanded =
  (* transparently turn the old expansion of deprecated [DI...IP] to [DIP n] *)
  match expanded with
  | Seq
      ( loc,
        [Prim (_, "DIP", [(Seq (_, [Prim (_, "DIP", [_], [])]) as sub)], [])]
      ) ->
      let rec count acc = function
        | Seq (_, [Prim (_, "DIP", [sub], [])]) ->
            count (acc + 1) sub
        | sub ->
            (acc, sub)
      in
      let (depth, sub) = count 1 sub in
      Some (Prim (loc, "DIP", [Int (loc, Z.of_int depth); sub], []))
  | _ ->
      None

let unexpand_dupn expanded =
  match expanded with
  | Seq
      ( loc,
        [ Prim
            (_, "DIP", [Int (_, np); Seq (_, [Prim (_, "DUP", [], annot)])], []);
          Prim (_, "DIG", [Int (nloc, ng)], []) ] )
    when Z.equal np (Z.pred ng) ->
      Some (Prim (loc, "DUP", [Int (nloc, ng)], annot))
  | _ ->
      None

let unexpand_deprecated_duuuuup expanded =
  (* transparently turn the old expansion of deprecated [DU...UP] to [DUP n] *)
  let rec expand n = function
    | Seq (loc, [Prim (nloc, "DUP", [], annot)]) ->
        if n = 1 then None
        else Some (Prim (loc, "DUP", [Int (nloc, Z.of_int n)], annot))
    | Seq (_, [Prim (_, "DIP", [expanded'], []); Prim (_, "SWAP", [], [])]) ->
        expand (n + 1) expanded'
    | _ ->
        None
  in
  expand 1 expanded

let rec normalize_pair_item ?(right = false) = function
  | P (i, a, b) ->
      P (i, normalize_pair_item a, normalize_pair_item ~right:true b)
  | A when right ->
      I
  | A ->
      A
  | I ->
      I

let unexpand_pappaiir expanded =
  match expanded with
  | Seq (_, [Prim (_, "PAIR", [], [])]) ->
      Some expanded
  | Seq (loc, (_ :: _ as nodes)) -> (
      let rec exec stack nodes =
        match (nodes, stack) with
        | ([], _) ->
            stack
        (* support new expansion using [DIP n] *)
        | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
            a :: rstack )
          when Z.to_int n > 1 ->
            exec
              ( a
              :: exec
                   rstack
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
          when Z.to_int n = 1 ->
            exec (a :: exec rstack sub) rest
        | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
          when Z.to_int n > 1 ->
            exec
              ( A
              :: exec
                   []
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
          when Z.to_int n = 1 ->
            exec (A :: exec [] sub) rest
        (* support old expansion using [DIP] *)
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
            exec (a :: exec rstack sub) rest
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
            exec (A :: exec [] sub) rest
        | (Prim (_, "PAIR", [], []) :: rest, a :: b :: rstack) ->
            exec (P (0, a, b) :: rstack) rest
        | (Prim (_, "PAIR", [], []) :: rest, [a]) ->
            exec [P (0, a, I)] rest
        | (Prim (_, "PAIR", [], []) :: rest, []) ->
            exec [P (0, A, I)] rest
        | _ ->
            raise_notrace Not_a_pair
      in
      match exec [] nodes with
      | [] ->
          None
      | res :: _ ->
          let res = normalize_pair_item res in
          let name = unparse_pair_item res in
          Some (Prim (loc, name, [], []))
      | exception Not_a_pair ->
          None )
  | _ ->
      None

let unexpand_unpappaiir expanded =
  match expanded with
  | Seq (loc, (_ :: _ as nodes)) -> (
      let rec exec stack nodes =
        match (nodes, stack) with
        | ([], _) ->
            stack
        (* support new expansion using [DIP n] *)
        | ( Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest,
            a :: rstack )
          when Z.to_int n > 1 ->
            exec
              ( a
              :: exec
                   rstack
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, a :: rstack)
          when Z.to_int n = 1 ->
            exec (a :: exec rstack sub) rest
        | (Prim (ploc, "DIP", [Int (loc, n); Seq (sloc, sub)], []) :: rest, [])
          when Z.to_int n > 1 ->
            exec
              ( A
              :: exec
                   []
                   [ Prim
                       (ploc, "DIP", [Int (loc, Z.pred n); Seq (sloc, sub)], [])
                   ] )
              rest
        | (Prim (_, "DIP", [Int (_, n); Seq (_, sub)], []) :: rest, [])
          when Z.to_int n = 1 ->
            exec (A :: exec [] sub) rest
        (* support old expansion using [DIP] *)
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, a :: rstack) ->
            exec (a :: exec rstack sub) rest
        | (Prim (_, "DIP", [Seq (_, sub)], []) :: rest, []) ->
            exec (A :: exec [] sub) rest
        | ( Seq
              ( _,
                [ Prim (_, "DUP", [], []);
                  Prim (_, "CAR", [], []);
                  Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
              )
            :: rest,
            a :: b :: rstack ) ->
            exec (P (0, a, b) :: rstack) rest
        | ( Seq
              ( _,
                [ Prim (_, "DUP", [], []);
                  Prim (_, "CAR", [], []);
                  Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
              )
            :: rest,
            [a] ) ->
            exec [P (0, a, I)] rest
        | ( Seq
              ( _,
                [ Prim (_, "DUP", [], []);
                  Prim (_, "CAR", [], []);
                  Prim (_, "DIP", [Seq (_, [Prim (_, "CDR", [], [])])], []) ]
              )
            :: rest,
            [] ) ->
            exec [P (0, A, I)] rest
        | _ ->
            raise_notrace Not_a_pair
      in
      match exec [] (List.rev nodes) with
      | [] ->
          None
      | res :: _ ->
          let res = normalize_pair_item res in
          let name = "UN" ^ unparse_pair_item res in
          Some (Prim (loc, name, [], []))
      | exception Not_a_pair ->
          None )
  | _ ->
      None

let unexpand_compare expanded =
  match expanded with
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "EQ", [], annot)]) ->
      Some (Prim (loc, "CMPEQ", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "NEQ", [], annot)]) ->
      Some (Prim (loc, "CMPNEQ", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LT", [], annot)]) ->
      Some (Prim (loc, "CMPLT", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GT", [], annot)]) ->
      Some (Prim (loc, "CMPGT", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "LE", [], annot)]) ->
      Some (Prim (loc, "CMPLE", [], annot))
  | Seq (loc, [Prim (_, "COMPARE", [], _); Prim (_, "GE", [], annot)]) ->
      Some (Prim (loc, "CMPGE", [], annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "EQ", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPEQ", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "NEQ", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPNEQ", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "LT", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPLT", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "GT", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPGT", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "LE", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPLE", args, annot))
  | Seq
      ( loc,
        [ Prim (_, "COMPARE", [], _);
          Prim (_, "GE", [], _);
          Prim (_, "IF", args, annot) ] ) ->
      Some (Prim (loc, "IFCMPGE", args, annot))
  | Seq (loc, [Prim (_, "EQ", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFEQ", args, annot))
  | Seq (loc, [Prim (_, "NEQ", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFNEQ", args, annot))
  | Seq (loc, [Prim (_, "LT", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFLT", args, annot))
  | Seq (loc, [Prim (_, "GT", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFGT", args, annot))
  | Seq (loc, [Prim (_, "LE", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFLE", args, annot))
  | Seq (loc, [Prim (_, "GE", [], _); Prim (_, "IF", args, annot)]) ->
      Some (Prim (loc, "IFGE", args, annot))
  | _ ->
      None

let unexpand_asserts expanded =
  match expanded with
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT", [], []))
  | Seq
      ( loc,
        [ Seq (_, [Prim (_, "COMPARE", [], []); Prim (_, comparison, [], [])]);
          Prim
            ( _,
              "IF",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_CMP" ^ comparison, [], []))
  | Seq
      ( loc,
        [ Prim (_, comparison, [], []);
          Prim
            ( _,
              "IF",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_" ^ comparison, [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq (_, [Prim (_, "RENAME", [], annot)]);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_NONE", [], annot))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_NONE", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, []) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_SOME", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_NONE",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, [Prim (_, "RENAME", [], annot)]) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_SOME", [], annot))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq (_, []);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_LEFT", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq (_, [Prim (_, "RENAME", [], annot)]);
                Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] ) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_LEFT", [], annot))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, []) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_RIGHT", [], []))
  | Seq
      ( loc,
        [ Prim
            ( _,
              "IF_LEFT",
              [ Seq
                  ( _,
                    [ Seq
                        ( _,
                          [ Prim (_, "UNIT", [], []);
                            Prim (_, "FAILWITH", [], []) ] ) ] );
                Seq (_, [Prim (_, "RENAME", [], annot)]) ],
              [] ) ] ) ->
      Some (Prim (loc, "ASSERT_RIGHT", [], annot))
  | _ ->
      None

let unexpand_if_some = function
  | Seq (loc, [Prim (_, "IF_NONE", [left; right], annot)]) ->
      Some (Prim (loc, "IF_SOME", [right; left], annot))
  | _ ->
      None

let unexpand_if_right = function
  | Seq (loc, [Prim (_, "IF_LEFT", [left; right], annot)]) ->
      Some (Prim (loc, "IF_RIGHT", [right; left], annot))
  | _ ->
      None

let unexpand_fail = function
  | Seq (loc, [Prim (_, "UNIT", [], []); Prim (_, "FAILWITH", [], [])]) ->
      Some (Prim (loc, "FAIL", [], []))
  | _ ->
      None

let unexpand original =
  let try_unexpansions unexpanders =
    match
      List.fold_left
        (fun acc f ->
          match acc with
          | None ->
              f original
          | Some rewritten ->
              Some rewritten)
        None
        unexpanders
    with
    | None ->
        original
    | Some rewritten ->
        rewritten
  in
  try_unexpansions
    [ unexpand_asserts;
      unexpand_caddadr;
      unexpand_set_caddadr;
      unexpand_map_caddadr;
      unexpand_deprecated_dxiiivp;
      unexpand_pappaiir;
      unexpand_unpappaiir;
      unexpand_deprecated_duuuuup;
      unexpand_dupn;
      unexpand_compare;
      unexpand_if_some;
      unexpand_if_right;
      unexpand_fail ]

(*
   If an argument of Prim is a sequence, we do not want to unexpand
   its root in case the source already contains an expanded macro. In
   which case unexpansion would remove surrounding braces and generate
   ill-formed code.

   For example, DIIP { DIP { DUP }; SWAP } is not unexpandable but
   DIIP {{ DIP { DUP }; SWAP }} (note the double braces) is unexpanded
   to DIIP { DUUP }.

   unexpand_rec_but_root is the same as unexpand_rec but does not try
   to unexpand at root *)

let rec unexpand_rec expr = unexpand_rec_but_root (unexpand expr)

and unexpand_rec_but_root = function
  | Seq (loc, items) ->
      Seq (loc, List.map unexpand_rec items)
  | Prim (loc, name, args, annot) ->
      Prim (loc, name, List.map unexpand_rec_but_root args, annot)
  | (Int _ | String _ | Bytes _) as atom ->
      atom

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"michelson.macros.unexpected_annotation"
    ~title:"Unexpected annotation"
    ~description:
      "A macro had an annotation, but no annotation was permitted on this \
       macro."
    ~pp:(fun ppf -> Format.fprintf ppf "Unexpected annotation on macro %s.")
    (obj1 (req "macro_name" string))
    (function Unexpected_macro_annotation str -> Some str | _ -> None)
    (fun s -> Unexpected_macro_annotation s) ;
  register_error_kind
    `Permanent
    ~id:"michelson.macros.sequence_expected"
    ~title:"Macro expects a sequence"
    ~description:"An macro expects a sequence, but a sequence was not provided"
    ~pp:(fun ppf name ->
      Format.fprintf
        ppf
        "Macro %s expects a sequence, but did not receive one."
        name)
    (obj1 (req "macro_name" string))
    (function Sequence_expected name -> Some name | _ -> None)
    (fun name -> Sequence_expected name) ;
  register_error_kind
    `Permanent
    ~id:"michelson.macros.bas_arity"
    ~title:"Wrong number of arguments to macro"
    ~description:"A wrong number of arguments was provided to a macro"
    ~pp:(fun ppf (name, got, exp) ->
      Format.fprintf
        ppf
        "Macro %s expects %d arguments, was given %d."
        name
        exp
        got)
    (obj3
       (req "macro_name" string)
       (req "given_number_of_arguments" uint16)
       (req "expected_number_of_arguments" uint16))
    (function
      | Invalid_arity (name, got, exp) -> Some (name, got, exp) | _ -> None)
    (fun (name, got, exp) -> Invalid_arity (name, got, exp))
src/proto_alpha/lib_client/michelson_v1_macros.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol_client_context.

Import Tezos_micheline.

Import Micheline.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition node (l : Type) := Tezos_micheline.Micheline.node l string.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Fixpoint check_letters (str : string) (i : Z) (j : Z) (f : ascii -> bool)
  : bool :=
  orb (OCaml.Stdlib.gt i j)
    (andb (f (String.get str i)) (check_letters str (Z.add i 1) j f)).

Definition expand_caddadr {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.gt len 3)
        (andb (equiv_decb (String.get str 0) "C" % char)
          (andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
            (check_letters str 1 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "A" % char | "D" % char => true
                | _ => false
                end)))) then
      op_gtgtquestion
        match args with
        | [] => ok tt
        | cons _ _ =>
          error
            (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
        end
        (fun function_parameter =>
          let 'tt := function_parameter in
          let path_annot :=
            List.filter
              (fun function_parameter =>
                match function_parameter with
                | "@%" % string | "@%%" % string => true
                | _ => false
                end) annot in
          let fix parse
            (i : Z) (acc : list (Tezos_micheline.Micheline.node A string))
            : Tezos_micheline.Micheline.node A string :=
            if equiv_decb i 0 then
              Tezos_micheline.Micheline.Seq loc acc
            else
              let annot :=
                if equiv_decb i (Z.sub len 2) then
                  annot
                else
                  path_annot in
              match String.get str i with
              | "A" % char =>
                parse (Z.sub i 1)
                  (cons
                    (Tezos_micheline.Micheline.Prim loc "CAR" % string [] annot)
                    acc)
              | "D" % char =>
                parse (Z.sub i 1)
                  (cons
                    (Tezos_micheline.Micheline.Prim loc "CDR" % string [] annot)
                    acc)
              | _ =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              end in
          ok (Some (parse (Z.sub len 2) [])))
    else
      ok None
  | _ => ok None
  end.

Definition extract_field_annots (annot : list string)
  : (list string) * (list string) :=
  List.partition
    (fun a =>
      match String.get a 0 with
      | "%" % char => true
      | _ => false
      end) annot.

Definition expand_set_caddadr {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.ge len 7)
        (andb (equiv_decb (String.sub str 0 5) "SET_C" % string)
          (andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
            (check_letters str 5 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "A" % char | "D" % char => true
                | _ => false
                end)))) then
      op_gtgtquestion
        match args with
        | [] => ok tt
        | cons _ _ =>
          error
            (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
        end
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            match extract_field_annots annot with
            | ([], annot) => ok (None, annot)
            | (cons f [], annot) => ok ((Some f), annot)
            | (_, _) =>
              error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
            end
            (fun function_parameter =>
              let '(field_annot, annot) := function_parameter in
              let fix parse
                (i : Z) (acc : Tezos_micheline.Micheline.node A string)
                : Tezos_micheline.Micheline.node A string :=
                if equiv_decb i 4 then
                  acc
                else
                  let annot :=
                    if equiv_decb i 5 then
                      annot
                    else
                      [] in
                  match String.get str i with
                  | "A" % char =>
                    let acc :=
                      Tezos_micheline.Micheline.Seq loc
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DUP" % string []
                            [])
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "DIP" % string
                              (cons
                                (Tezos_micheline.Micheline.Seq loc
                                  (cons
                                    (Tezos_micheline.Micheline.Prim loc
                                      "CAR" % string [] (cons "@%%" % string []))
                                    (cons acc []))) []) [])
                            (cons
                              (Tezos_micheline.Micheline.Prim loc "CDR" % string
                                [] (cons "@%%" % string []))
                              (cons
                                (Tezos_micheline.Micheline.Prim loc
                                  "SWAP" % string [] [])
                                (cons
                                  (Tezos_micheline.Micheline.Prim loc
                                    "PAIR" % string []
                                    (cons "%@" % string
                                      (cons "%@" % string annot))) []))))) in
                    parse (Z.sub i 1) acc
                  | "D" % char =>
                    let acc :=
                      Tezos_micheline.Micheline.Seq loc
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DUP" % string []
                            [])
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "DIP" % string
                              (cons
                                (Tezos_micheline.Micheline.Seq loc
                                  (cons
                                    (Tezos_micheline.Micheline.Prim loc
                                      "CDR" % string [] (cons "@%%" % string []))
                                    (cons acc []))) []) [])
                            (cons
                              (Tezos_micheline.Micheline.Prim loc "CAR" % string
                                [] (cons "@%%" % string []))
                              (cons
                                (Tezos_micheline.Micheline.Prim loc
                                  "PAIR" % string []
                                  (cons "%@" % string (cons "%@" % string annot)))
                                [])))) in
                    parse (Z.sub i 1) acc
                  | _ =>
                    (* ❌ Assert instruction is not handled. *)
                    assert false
                  end in
              match String.get str (Z.sub len 2) with
              | "A" % char =>
                let access_check :=
                  match field_annot with
                  | None => []
                  | Some f =>
                    cons
                      (Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "CAR" % string []
                          (cons f []))
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DROP" % string []
                            []) []))
                  end in
                let encoding :=
                  cons
                    (Tezos_micheline.Micheline.Prim loc "CDR" % string []
                      (cons "@%%" % string []))
                    (cons
                      (Tezos_micheline.Micheline.Prim loc "SWAP" % string [] [])
                      []) in
                let pair :=
                  cons
                    (Tezos_micheline.Micheline.Prim loc "PAIR" % string []
                      (cons (Option.unopt "%" % string field_annot)
                        (cons "%@" % string []))) [] in
                let init :=
                  Tezos_micheline.Micheline.Seq loc
                    (OCaml.Stdlib.app access_check
                      (OCaml.Stdlib.app encoding pair)) in
                ok (Some (parse (Z.sub len 3) init))
              | "D" % char =>
                let access_check :=
                  match field_annot with
                  | None => []
                  | Some f =>
                    cons
                      (Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "CDR" % string []
                          (cons f []))
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DROP" % string []
                            []) []))
                  end in
                let encoding :=
                  cons
                    (Tezos_micheline.Micheline.Prim loc "CAR" % string []
                      (cons "@%%" % string [])) [] in
                let pair :=
                  cons
                    (Tezos_micheline.Micheline.Prim loc "PAIR" % string []
                      (cons "%@" % string
                        (cons (Option.unopt "%" % string field_annot) []))) []
                  in
                let init :=
                  Tezos_micheline.Micheline.Seq loc
                    (OCaml.Stdlib.app access_check
                      (OCaml.Stdlib.app encoding pair)) in
                ok (Some (parse (Z.sub len 3) init))
              | _ =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              end))
    else
      ok None
  | _ => ok None
  end.

Definition expand_map_caddadr {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.ge len 7)
        (andb (equiv_decb (String.sub str 0 5) "MAP_C" % string)
          (andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
            (check_letters str 5 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "A" % char | "D" % char => true
                | _ => false
                end)))) then
      op_gtgtquestion
        match args with
        | cons ((Tezos_micheline.Micheline.Seq _ _) as code) [] => ok code
        | cons _ [] => error (Tezos_base__TzPervasives.Sequence_expected str)
        | [] | cons _ (cons _ _) =>
          error
            (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 1)
        end
        (fun code =>
          op_gtgtquestion
            match extract_field_annots annot with
            | ([], annot) => ok (None, annot)
            | (cons f [], annot) => ok ((Some f), annot)
            | (_, _) =>
              error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
            end
            (fun function_parameter =>
              let '(field_annot, annot) := function_parameter in
              let fix parse
                (i : Z) (acc : Tezos_micheline.Micheline.node A string)
                : Tezos_micheline.Micheline.node A string :=
                if equiv_decb i 4 then
                  acc
                else
                  let annot :=
                    if equiv_decb i 5 then
                      annot
                    else
                      [] in
                  match String.get str i with
                  | "A" % char =>
                    let acc :=
                      Tezos_micheline.Micheline.Seq loc
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DUP" % string []
                            [])
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "DIP" % string
                              (cons
                                (Tezos_micheline.Micheline.Seq loc
                                  (cons
                                    (Tezos_micheline.Micheline.Prim loc
                                      "CAR" % string [] (cons "@%%" % string []))
                                    (cons acc []))) []) [])
                            (cons
                              (Tezos_micheline.Micheline.Prim loc "CDR" % string
                                [] (cons "@%%" % string []))
                              (cons
                                (Tezos_micheline.Micheline.Prim loc
                                  "SWAP" % string [] [])
                                (cons
                                  (Tezos_micheline.Micheline.Prim loc
                                    "PAIR" % string []
                                    (cons "%@" % string
                                      (cons "%@" % string annot))) []))))) in
                    parse (Z.sub i 1) acc
                  | "D" % char =>
                    let acc :=
                      Tezos_micheline.Micheline.Seq loc
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DUP" % string []
                            [])
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "DIP" % string
                              (cons
                                (Tezos_micheline.Micheline.Seq loc
                                  (cons
                                    (Tezos_micheline.Micheline.Prim loc
                                      "CDR" % string [] (cons "@%%" % string []))
                                    (cons acc []))) []) [])
                            (cons
                              (Tezos_micheline.Micheline.Prim loc "CAR" % string
                                [] (cons "@%%" % string []))
                              (cons
                                (Tezos_micheline.Micheline.Prim loc
                                  "PAIR" % string []
                                  (cons "%@" % string (cons "%@" % string annot)))
                                [])))) in
                    parse (Z.sub i 1) acc
                  | _ =>
                    (* ❌ Assert instruction is not handled. *)
                    assert false
                  end in
              let cr_annot :=
                match field_annot with
                | None => []
                | Some f =>
                  cons
                    (String.append "@" % string
                      (String.sub f 1 (Z.sub (String.length f) 1))) []
                end in
              match String.get str (Z.sub len 2) with
              | "A" % char =>
                let init :=
                  Tezos_micheline.Micheline.Seq loc
                    (cons
                      (Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "CDR" % string []
                          (cons "@%%" % string []))
                        (cons
                          (Tezos_micheline.Micheline.Prim loc "DIP" % string
                            (cons
                              (Tezos_micheline.Micheline.Seq loc
                                (cons
                                  (Tezos_micheline.Micheline.Prim loc
                                    "CAR" % string [] cr_annot) (cons code [])))
                              []) [])
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "SWAP" % string
                              [] [])
                            (cons
                              (Tezos_micheline.Micheline.Prim loc
                                "PAIR" % string []
                                (cons (Option.unopt "%" % string field_annot)
                                  (cons "%@" % string []))) []))))) in
                ok (Some (parse (Z.sub len 3) init))
              | "D" % char =>
                let init :=
                  Tezos_micheline.Micheline.Seq loc
                    (cons
                      (Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "CDR" % string []
                          cr_annot)
                        (cons code
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "SWAP" % string
                              [] [])
                            (cons
                              (Tezos_micheline.Micheline.Prim loc "CAR" % string
                                [] (cons "@%%" % string []))
                              (cons
                                (Tezos_micheline.Micheline.Prim loc
                                  "PAIR" % string []
                                  (cons "%@" % string
                                    (cons
                                      (Option.unopt "%" % string field_annot) [])))
                                [])))))) in
                ok (Some (parse (Z.sub len 3) init))
              | _ =>
                (* ❌ Assert instruction is not handled. *)
                assert false
              end))
    else
      ok None
  | _ => ok None
  end.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition decimal_of_roman (roman : string) : Z :=
  let arabic := Stdlib.ref 0 in
  let lastval := Stdlib.ref 0 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ For loops not handled. *)
    for in
  Stdlib.op_exclamation arabic.

Definition dip {A : Type}
  (loc : A) (op_staroptstar : option Tezos_micheline.Micheline.annot)
  : Z ->
    (Tezos_micheline.Micheline.node A string) ->
      Tezos_micheline.Micheline.node A string :=
  let annot :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun depth =>
    fun instr =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert (OCaml.Stdlib.ge depth 0) in
      if equiv_decb depth 1 then
        Tezos_micheline.Micheline.Prim loc "DIP" % string (cons instr []) annot
      else
        Tezos_micheline.Micheline.Prim loc "DIP" % string
          (cons (Tezos_micheline.Micheline.Int loc (Z.of_int depth))
            (cons instr [])) annot.

Definition expand_deprecated_dxiiivp {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.gt len 3)
        (andb (equiv_decb (String.get str 0) "D" % char)
          (equiv_decb (String.get str (Z.sub len 1)) "P" % char)) then
      (* ❌ Try-with are not handled *)
      try
        (let depth := decimal_of_roman (String.sub str 1 (Z.sub len 2)) in
        match args with
        | cons ((Tezos_micheline.Micheline.Seq _ _) as arg) [] =>
          apply ok (Some (dip loc (Some annot) depth arg))
        | cons _ [] => error (Tezos_base__TzPervasives.Sequence_expected str)
        | [] | cons _ (cons _ _) =>
          error
            (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 1)
        end)
    else
      ok None
  | _ => ok None
  end.

(* ❌ The definition of exceptions is not handled. *)
exception

Inductive pair_item : Type :=
| A : pair_item
| I : pair_item
| P : Z -> pair_item -> pair_item -> pair_item.

Definition parse_pair_substr (str : string) (len : Z) (start : Z) : pair_item :=
  let fix parse (left : option bool) (i : Z) : Z * pair_item :=
    if equiv_decb i (Z.sub len 1) then
      Stdlib.raise_notrace Not_a_pair
    else
      if equiv_decb (String.get str i) "P" % char then
        let '(next_i, l) := parse (Some true) (Z.add i 1) in
        let '(next_i, r) := parse (Some false) next_i in
        (next_i, (P i l r))
      else
        if
          andb (equiv_decb (String.get str i) "A" % char)
            (equiv_decb left (Some true)) then
          ((Z.add i 1), A)
        else
          if
            andb (equiv_decb (String.get str i) "I" % char)
              (nequiv_decb left (Some true)) then
            ((Z.add i 1), I)
          else
            Stdlib.raise_notrace Not_a_pair in
  let '(last, ast) := parse None start in
  if nequiv_decb last (Z.sub len 1) then
    Stdlib.raise_notrace Not_a_pair
  else
    ast.

Definition unparse_pair_item (ast : pair_item) : string :=
  let fix unparse (ast : pair_item) (acc : list string) : list string :=
    match ast with
    | P _ l r => unparse r (unparse l (cons "P" % string acc))
    | A => cons "A" % string acc
    | I => cons "I" % string acc
    end in
  OCaml.Stdlib.reverse_apply (List.rev (cons "R" % string (unparse ast [])))
    (String.concat "" % string).

Definition pappaiir_annots_pos {A : Type} (ast : pair_item) (annot : list A)
  : IntMap.t ((list A) * (list A)) :=
  let fix find_annots_pos {B : Type}
    (p_pos : IntMap.key) (ast : pair_item) (annots : list B) (acc :
    IntMap.t ((list B) * (list B)))
    : (list B) * (IntMap.t ((list B) * (list B))) :=
    match (ast, annots) with
    | (_, []) => (annots, acc)
    | (P i left right, _) =>
      let '(annots, acc) := find_annots_pos i left annots acc in
      find_annots_pos i right annots acc
    | (A, cons a annots) =>
      let pos :=
        match IntMap.find_opt p_pos acc with
        | None => ((cons a []), [])
        | Some (_, cdr) => ((cons a []), cdr)
        end in
      (annots, (IntMap.add p_pos pos acc))
    | (I, cons a annots) =>
      let pos :=
        match IntMap.find_opt p_pos acc with
        | None => ([], (cons a []))
        | Some (car, _) => (car, (cons a []))
        end in
      (annots, (IntMap.add p_pos pos acc))
    end in
  snd (find_annots_pos 0 ast annot IntMap.empty).

Definition expand_pappaiir {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.gt len 4)
        (andb (equiv_decb (String.get str 0) "P" % char)
          (andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
            (check_letters str 1 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "P" % char | "A" % char | "I" % char => true
                | _ => false
                end)))) then
      (* ❌ Try-with are not handled *)
      try
        (let '(field_annots, annot) := extract_field_annots annot in
        let ast := parse_pair_substr str len 0 in
        let field_annots_pos := pappaiir_annots_pos ast field_annots in
        let fix parse
          (p : pair_item) (function_parameter :
          Z * (list (Tezos_micheline.Micheline.node A string)))
          : Z * (list (Tezos_micheline.Micheline.node A string)) :=
          let '(depth, acc) := function_parameter in
          match p with
          | P i left right =>
            let annot :=
              match (i, (IntMap.find_opt i field_annots_pos)) with
              | (0, None) => annot
              | (_, None) => []
              | (0, Some ([], cdr_annot)) =>
                OCaml.Stdlib.app (cons "%" % string cdr_annot) annot
              | (_, Some ([], cdr_annot)) => cons "%" % string cdr_annot
              | (0, Some (car_annot, cdr_annot)) =>
                OCaml.Stdlib.app car_annot (OCaml.Stdlib.app cdr_annot annot)
              | (_, Some (car_annot, cdr_annot)) =>
                OCaml.Stdlib.app car_annot cdr_annot
              end in
            let acc :=
              if equiv_decb depth 0 then
                cons
                  (Tezos_micheline.Micheline.Prim loc "PAIR" % string [] annot)
                  acc
              else
                cons
                  (dip loc None depth
                    (Tezos_micheline.Micheline.Seq loc
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "PAIR" % string []
                          annot) []))) acc in
            OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply (depth, acc) (parse left))
              (parse right)
          | A | I => ((Z.add depth 1), acc)
          end in
        let '(_, expanded) := parse ast (0, []) in
        op_gtgtquestion
          match args with
          | [] => ok tt
          | cons _ _ =>
            error
              (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
          end
          (fun function_parameter =>
            let 'tt := function_parameter in
            ok (Some (Tezos_micheline.Micheline.Seq loc expanded))))
    else
      ok None
  | _ => ok None
  end.

Definition expand_unpappaiir {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.ge len 6)
        (andb (equiv_decb (String.sub str 0 3) "UNP" % string)
          (andb (equiv_decb (String.get str (Z.sub len 1)) "R" % char)
            (check_letters str 3 (Z.sub len 2)
              (fun function_parameter =>
                match function_parameter with
                | "P" % char | "A" % char | "I" % char => true
                | _ => false
                end)))) then
      (* ❌ Try-with are not handled *)
      try
        (let unpair
          (car_annot : Tezos_micheline.Micheline.annot) (cdr_annot :
          Tezos_micheline.Micheline.annot)
          : Tezos_micheline.Micheline.node A string :=
          Tezos_micheline.Micheline.Seq loc
            (cons (Tezos_micheline.Micheline.Prim loc "DUP" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim loc "CAR" % string [] car_annot)
                (cons
                  (dip loc None 1
                    (Tezos_micheline.Micheline.Seq loc
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "CDR" % string []
                          cdr_annot) []))) []))) in
        let ast := parse_pair_substr str len 2 in
        let annots_pos := pappaiir_annots_pos ast annot in
        let fix parse
          (p : pair_item) (function_parameter :
          Z * (list (Tezos_micheline.Micheline.node A string)))
          : Z * (list (Tezos_micheline.Micheline.node A string)) :=
          let '(depth, acc) := function_parameter in
          match p with
          | P i left right =>
            let '(car_annot, cdr_annot) :=
              match IntMap.find_opt i annots_pos with
              | None => ([], [])
              | Some (car_annot, cdr_annot) => (car_annot, cdr_annot)
              end in
            let acc :=
              if equiv_decb depth 0 then
                cons (unpair car_annot cdr_annot) acc
              else
                cons
                  (dip loc None depth
                    (Tezos_micheline.Micheline.Seq loc
                      (cons (unpair car_annot cdr_annot) []))) acc in
            OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply (depth, acc) (parse left))
              (parse right)
          | A | I => ((Z.add depth 1), acc)
          end in
        let '(_, rev_expanded) := parse ast (0, []) in
        let expanded :=
          Tezos_micheline.Micheline.Seq loc (List.rev rev_expanded) in
        op_gtgtquestion
          match args with
          | [] => ok tt
          | cons _ _ =>
            error
              (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
          end
          (fun function_parameter =>
            let 'tt := function_parameter in
            ok (Some expanded)))
    else
      ok None
  | _ => ok None
  end.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition dupn {A : Type}
  (loc : A) (nloc : A) (n : Z) (annot : Tezos_micheline.Micheline.annot)
  : Tezos_micheline.Micheline.node A string :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.gt n 1) in
  if equiv_decb n 2 then
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim loc "DIP" % string
          (cons
            (Tezos_micheline.Micheline.Seq loc
              (cons
                (Tezos_micheline.Micheline.Prim nloc "DUP" % string [] annot) []))
            []) [])
        (cons (Tezos_micheline.Micheline.Prim loc "SWAP" % string [] []) []))
  else
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim loc "DIP" % string
          (cons (Tezos_micheline.Micheline.Int loc (Z.of_int (Z.sub n 1)))
            (cons
              (Tezos_micheline.Micheline.Seq loc
                (cons
                  (Tezos_micheline.Micheline.Prim loc "DUP" % string [] annot)
                  [])) [])) [])
        (cons
          (Tezos_micheline.Micheline.Prim loc "DIG" % string
            (cons (Tezos_micheline.Micheline.Int nloc (Z.of_int n)) []) []) [])).

Definition expand_dupn {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  |
    Tezos_micheline.Micheline.Prim loc "DUP" % string
      (cons (Tezos_micheline.Micheline.Int nloc n) []) annot =>
    ok (Some (dupn loc nloc (Z.to_int n) annot))
  | _ => ok None
  end.

Definition expand_deprecated_duuuuup {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match original with
  | Tezos_micheline.Micheline.Prim loc str args annot =>
    let len := String.length str in
    if
      andb (OCaml.Stdlib.gt len 3)
        (andb (equiv_decb (String.get str 0) "D" % char)
          (andb (equiv_decb (String.get str (Z.sub len 1)) "P" % char)
            (check_letters str 1 (Z.sub len 2) (equiv_decb "U" % char)))) then
      op_gtgtquestion
        match args with
        | [] => ok tt
        | cons _ _ =>
          error
            (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
        end
        (fun function_parameter =>
          let 'tt := function_parameter in
          (* ❌ Try-with are not handled *)
          try
            (let fix parse (i : Z) : Tezos_micheline.Micheline.node A string :=
              if equiv_decb i 1 then
                dupn loc loc (Z.sub len 2) annot
              else
                if equiv_decb (String.get str i) "U" % char then
                  parse (Z.sub i 1)
                else
                  Stdlib.raise_notrace Not_a_dup in
            ok (Some (parse (Z.sub len 2)))))
    else
      ok None
  | _ => ok None
  end.

Definition expand_compare {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  let cmp {B C : Type}
    (loc : B) (is : list C) (annot : Tezos_micheline.Micheline.annot)
    : Tezos_base__TzPervasives.tzresult
      (option (Tezos_micheline.Micheline.node B C)) :=
    let is :=
      match
        List.rev_map (fun i => Tezos_micheline.Micheline.Prim loc i [] []) is
        with
      | cons (Tezos_micheline.Micheline.Prim loc i args _) r =>
        List.rev (cons (Tezos_micheline.Micheline.Prim loc i args annot) r)
      | is => List.rev is
      end in
    ok (Some (Tezos_micheline.Micheline.Seq loc is)) in
  let ifcmp {B : Type}
    (loc : B) (is : list string) (l : Tezos_micheline.Micheline.node B string)
    (r : Tezos_micheline.Micheline.node B string) (annot :
    Tezos_micheline.Micheline.annot)
    : Tezos_base__TzPervasives.tzresult
      (option (Tezos_micheline.Micheline.node B string)) :=
    let is :=
      OCaml.Stdlib.app
        (List.map (fun i => Tezos_micheline.Micheline.Prim loc i [] []) is)
        (cons
          (Tezos_micheline.Micheline.Prim loc "IF" % string (cons l (cons r []))
            annot) []) in
    ok (Some (Tezos_micheline.Micheline.Seq loc is)) in
  match original with
  | Tezos_micheline.Micheline.Prim loc "CMPEQ" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "EQ" % string [])) annot
  | Tezos_micheline.Micheline.Prim loc "CMPNEQ" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "NEQ" % string [])) annot
  | Tezos_micheline.Micheline.Prim loc "CMPLT" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "LT" % string [])) annot
  | Tezos_micheline.Micheline.Prim loc "CMPGT" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "GT" % string [])) annot
  | Tezos_micheline.Micheline.Prim loc "CMPLE" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "LE" % string [])) annot
  | Tezos_micheline.Micheline.Prim loc "CMPGE" % string [] annot =>
    cmp loc (cons "COMPARE" % string (cons "GE" % string [])) annot
  |
    Tezos_micheline.Micheline.Prim _
      (("CMPEQ" % string | "CMPNEQ" % string | "CMPLT" % string |
        "CMPGT" % string | "CMPLE" % string | "CMPGE" % string) as str) args []
    => error (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
  |
    Tezos_micheline.Micheline.Prim loc "IFCMPEQ" % string (cons l (cons r []))
      annot =>
    ifcmp loc (cons "COMPARE" % string (cons "EQ" % string [])) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFCMPNEQ" % string (cons l (cons r []))
      annot =>
    ifcmp loc (cons "COMPARE" % string (cons "NEQ" % string [])) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFCMPLT" % string (cons l (cons r []))
      annot =>
    ifcmp loc (cons "COMPARE" % string (cons "LT" % string [])) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFCMPGT" % string (cons l (cons r []))
      annot =>
    ifcmp loc (cons "COMPARE" % string (cons "GT" % string [])) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFCMPLE" % string (cons l (cons r []))
      annot =>
    ifcmp loc (cons "COMPARE" % string (cons "LE" % string [])) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFCMPGE" % string (cons l (cons r []))
      annot =>
    ifcmp loc (cons "COMPARE" % string (cons "GE" % string [])) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFEQ" % string (cons l (cons r []))
      annot => ifcmp loc (cons "EQ" % string []) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFNEQ" % string (cons l (cons r []))
      annot => ifcmp loc (cons "NEQ" % string []) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFLT" % string (cons l (cons r []))
      annot => ifcmp loc (cons "LT" % string []) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFGT" % string (cons l (cons r []))
      annot => ifcmp loc (cons "GT" % string []) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFLE" % string (cons l (cons r []))
      annot => ifcmp loc (cons "LE" % string []) l r annot
  |
    Tezos_micheline.Micheline.Prim loc "IFGE" % string (cons l (cons r []))
      annot => ifcmp loc (cons "GE" % string []) l r annot
  |
    Tezos_micheline.Micheline.Prim _
      (("IFCMPEQ" % string | "IFCMPNEQ" % string | "IFCMPLT" % string |
        "IFCMPGT" % string | "IFCMPLE" % string | "IFCMPGE" % string |
        "IFEQ" % string | "IFNEQ" % string | "IFLT" % string | "IFGT" % string |
        "IFLE" % string | "IFGE" % string) as str) args [] =>
    error (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 2)
  |
    Tezos_micheline.Micheline.Prim _
      (("IFCMPEQ" % string | "IFCMPNEQ" % string | "IFCMPLT" % string |
        "IFCMPGT" % string | "IFCMPLE" % string | "IFCMPGE" % string |
        "IFEQ" % string | "IFNEQ" % string | "IFLT" % string | "IFGT" % string |
        "IFLE" % string | "IFGE" % string) as str) [] (cons _ _) =>
    error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
  | _ => ok None
  end.

Definition expand_asserts {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  let may_rename {B : Type}
    (loc : B) (function_parameter : Tezos_micheline.Micheline.annot)
    : Tezos_micheline.Micheline.node B string :=
    match function_parameter with
    | [] => Tezos_micheline.Micheline.Seq loc []
    | annot =>
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim loc "RENAME" % string [] annot) [])
    end in
  let fail_false {B : Type}
    (op_staroptstar : option Tezos_micheline.Micheline.annot)
    : B -> list (Tezos_micheline.Micheline.node B string) :=
    let annot :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun loc =>
      cons (may_rename loc annot)
        (cons
          (Tezos_micheline.Micheline.Seq loc
            (cons (Tezos_micheline.Micheline.Prim loc "FAIL" % string [] []) []))
          []) in
  let fail_true {B : Type}
    (op_staroptstar : option Tezos_micheline.Micheline.annot)
    : B -> list (Tezos_micheline.Micheline.node B string) :=
    let annot :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun loc =>
      cons
        (Tezos_micheline.Micheline.Seq loc
          (cons (Tezos_micheline.Micheline.Prim loc "FAIL" % string [] []) []))
        (cons (may_rename loc annot) []) in
  match original with
  | Tezos_micheline.Micheline.Prim loc "ASSERT" % string [] [] =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF" % string
              (fail_false None loc) []) [])))
  | Tezos_micheline.Micheline.Prim loc "ASSERT_NONE" % string [] [] =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF_NONE" % string
              (fail_false None loc) []) [])))
  | Tezos_micheline.Micheline.Prim loc "ASSERT_SOME" % string [] annot =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF_NONE" % string
              (fail_true (Some annot) loc) []) [])))
  | Tezos_micheline.Micheline.Prim loc "ASSERT_LEFT" % string [] annot =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF_LEFT" % string
              (fail_false (Some annot) loc) []) [])))
  | Tezos_micheline.Micheline.Prim loc "ASSERT_RIGHT" % string [] annot =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF_LEFT" % string
              (fail_true (Some annot) loc) []) [])))
  |
    Tezos_micheline.Micheline.Prim _
      (("ASSERT" % string | "ASSERT_NONE" % string | "ASSERT_SOME" % string |
        "ASSERT_LEFT" % string | "ASSERT_RIGHT" % string) as str) args [] =>
    error (Tezos_base__TzPervasives.Invalid_arity str (List.length args) 0)
  |
    Tezos_micheline.Micheline.Prim _
      (("ASSERT" % string | "ASSERT_NONE" % string) as str) [] (cons _ _) =>
    error (Tezos_base__TzPervasives.Unexpected_macro_annotation str)
  | Tezos_micheline.Micheline.Prim loc s args annot =>
    op_gtgtquestion
      match args with
      | [] => ok tt
      | cons _ _ =>
        error (Tezos_base__TzPervasives.Invalid_arity s (List.length args) 0)
      end
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgtquestion
          match annot with
          | cons _ _ =>
            error (Tezos_base__TzPervasives.Unexpected_macro_annotation s)
          | [] => ok tt
          end
          (fun function_parameter =>
            let 'tt := function_parameter in
            let remaining := sub s 7 (Z.sub (length s) 7) in
            let remaining_prim :=
              Tezos_micheline.Micheline.Prim loc remaining [] [] in
            match remaining with
            |
              "EQ" % string | "NEQ" % string | "LT" % string | "LE" % string |
                "GE" % string | "GT" % string =>
              apply ok
                (Some
                  (Tezos_micheline.Micheline.Seq loc
                    (cons remaining_prim
                      (cons
                        (Tezos_micheline.Micheline.Prim loc "IF" % string
                          (fail_false None loc) []) []))))
            | _ =>
              op_gtpipequestion (expand_compare remaining_prim)
                (fun function_parameter =>
                  match function_parameter with
                  | None => None
                  | Some seq =>
                    Some
                      (Tezos_micheline.Micheline.Seq loc
                        (cons seq
                          (cons
                            (Tezos_micheline.Micheline.Prim loc "IF" % string
                              (fail_false None loc) []) [])))
                  end)
            end))
  | _ => ok None
  end.

Definition expand_if_some {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match function_parameter with
  |
    Tezos_micheline.Micheline.Prim loc "IF_SOME" % string
      (cons right (cons left [])) annot =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF_NONE" % string
              (cons left (cons right [])) annot) [])))
  | Tezos_micheline.Micheline.Prim _ "IF_SOME" % string args _annot =>
    error
      (Tezos_base__TzPervasives.Invalid_arity "IF_SOME" % string
        (List.length args) 2)
  | _ => apply ok None
  end.

Definition expand_if_right {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match function_parameter with
  |
    Tezos_micheline.Micheline.Prim loc "IF_RIGHT" % string
      (cons right (cons left [])) annot =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons
            (Tezos_micheline.Micheline.Prim loc "IF_LEFT" % string
              (cons left (cons right [])) annot) [])))
  | Tezos_micheline.Micheline.Prim _ "IF_RIGHT" % string args _annot =>
    error
      (Tezos_base__TzPervasives.Invalid_arity "IF_RIGHT" % string
        (List.length args) 2)
  | _ => apply ok None
  end.

Definition expand_fail {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult
    (option (Tezos_micheline.Micheline.node A string)) :=
  match function_parameter with
  | Tezos_micheline.Micheline.Prim loc "FAIL" % string [] [] =>
    apply ok
      (Some
        (Tezos_micheline.Micheline.Seq loc
          (cons (Tezos_micheline.Micheline.Prim loc "UNIT" % string [] [])
            (cons (Tezos_micheline.Micheline.Prim loc "FAILWITH" % string [] [])
              []))))
  | _ => apply ok None
  end.

Definition expand {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_base__TzPervasives.tzresult (Tezos_micheline.Micheline.node A string) :=
  let fix try_expansions
    (function_parameter :
    list
      ((Tezos_micheline.Micheline.node A string) ->
        Tezos_base__TzPervasives.tzresult
          (option (Tezos_micheline.Micheline.node A string))))
    : Tezos_base__TzPervasives.tzresult
      (Tezos_micheline.Micheline.node A string) :=
    match function_parameter with
    | [] => apply ok original
    | cons expander expanders =>
      op_gtgtquestion (expander original)
        (fun function_parameter =>
          match function_parameter with
          | None => try_expansions expanders
          | Some rewritten => ok rewritten
          end)
    end in
  try_expansions
    (cons expand_caddadr
      (cons expand_set_caddadr
        (cons expand_map_caddadr
          (cons expand_deprecated_dxiiivp
            (cons expand_pappaiir
              (cons expand_unpappaiir
                (cons expand_deprecated_duuuuup
                  (cons expand_dupn
                    (cons expand_compare
                      (cons expand_asserts
                        (cons expand_if_some
                          (cons expand_if_right (cons expand_fail []))))))))))))).

Definition expand_rec {A : Type}
  (expr : Tezos_micheline.Micheline.node A string)
  : (Tezos_micheline.Micheline.node A string) * Tezos_base__TzPervasives.trace :=
  let fix error_map {B C D : Type} (function_parameter : (list B) * (list C))
    : (D -> B * (list C)) -> (list D) -> (list B) * (list C) :=
    let '(expanded, errors) := function_parameter in
    fun f =>
      fun function_parameter =>
        match function_parameter with
        | [] => ((List.rev expanded), (List.rev errors))
        | cons hd tl =>
          let '(new_expanded, new_errors) := f hd in
          error_map
            ((cons new_expanded expanded), (List.rev_append new_errors errors))
            f tl
        end in
  let error_map := error_map ([], []) in
  let fix expand_rec (expr : Tezos_micheline.Micheline.node A string)
    : (Tezos_micheline.Micheline.node A string) * Tezos_base__TzPervasives.trace :=
    match expand expr with
    | Stdlib.Ok expanded =>
      match expanded with
      | Tezos_micheline.Micheline.Seq loc items =>
        let '(items, errors) := error_map expand_rec items in
        ((Tezos_micheline.Micheline.Seq loc items), errors)
      | Tezos_micheline.Micheline.Prim loc name args annot =>
        let '(args, errors) := error_map expand_rec args in
        ((Tezos_micheline.Micheline.Prim loc name args annot), errors)
      |
        (Tezos_micheline.Micheline.Int _ _ |
          Tezos_micheline.Micheline.String _ _ |
          Tezos_micheline.Micheline.Bytes _ _) as atom => (atom, [])
      end
    | Stdlib.Error errors => (expr, errors)
    end in
  expand_rec expr.

Definition unexpand_caddadr {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix rsteps {B : Type}
    (acc : list string) (function_parameter :
    list (Tezos_micheline.Micheline.node B string)) : option (list string) :=
    match function_parameter with
    | [] => Some acc
    | cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] []) rest =>
      rsteps (cons "A" % string acc) rest
    | cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] []) rest =>
      rsteps (cons "D" % string acc) rest
    | _ => None
    end in
  match expanded with
  |
    Tezos_micheline.Micheline.Seq loc
      ((cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] []) _) as nodes)
      |
      Tezos_micheline.Micheline.Seq loc
        ((cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] []) _) as
          nodes) =>
    match rsteps [] nodes with
    | Some steps =>
      let name :=
        String.concat "" % string
          (cons "C" % string (List.rev (cons "R" % string steps))) in
      Some (Tezos_micheline.Micheline.Prim loc name [] [])
    | None => None
    end
  | _ => None
  end.

Definition unexpand_set_caddadr {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix steps {B : Type}
    (acc : list string) (annots : list string) (function_parameter :
    Tezos_micheline.Micheline.node B string)
    : option (B * (list string) * (list string)) :=
    match function_parameter with
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] _)
            (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))
      => Some (loc, (cons "A" % string acc), annots)
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "CAR" % string []
              (cons field_annot []))
            (cons (Tezos_micheline.Micheline.Prim _ "DROP" % string [] [])
              (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
                (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
                  (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _)
                    [])))))) =>
      Some (loc, (cons "A" % string acc), (cons field_annot annots))
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])) =>
      Some (loc, (cons "D" % string acc), annots)
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "CDR" % string []
              (cons field_annot []))
            (cons (Tezos_micheline.Micheline.Prim _ "DROP" % string [] [])
              (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
                (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))))
      => Some (loc, (cons "D" % string acc), (cons field_annot annots))
    |
      Tezos_micheline.Micheline.Seq _
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "DIP" % string
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
                    (cons sub []))) []) [])
            (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
              (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim _ "PAIR" % string []
                    pair_annots) []))))) =>
      let '(_, pair_annots) := extract_field_annots pair_annots in
      steps (cons "A" % string acc) (List.rev_append pair_annots annots) sub
    |
      Tezos_micheline.Micheline.Seq _
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "DIP" % string
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
                    (cons sub []))) []) [])
            (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
              (cons
                (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] pair_annots)
                [])))) =>
      let '(_, pair_annots) := extract_field_annots pair_annots in
      steps (cons "D" % string acc) (List.rev_append pair_annots annots) sub
    | _ => None
    end in
  match steps [] [] expanded with
  | Some (loc, steps, annots) =>
    let name :=
      String.concat "" % string
        (cons "SET_C" % string (List.rev (cons "R" % string steps))) in
    Some (Tezos_micheline.Micheline.Prim loc name [] (List.rev annots))
  | None => None
  end.

Definition unexpand_map_caddadr {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix steps {B : Type}
    (acc : list string) (annots : list string) (function_parameter :
    Tezos_micheline.Micheline.node B string)
    : option
      (B * (list string) * (list string) *
        (Tezos_micheline.Micheline.node B string)) :=
    match function_parameter with
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
            (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim _ "DIP" % string
                  (cons
                    (Tezos_micheline.Micheline.Seq _
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
                        (cons code []))) []) [])
                (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))))
      => Some (loc, (cons "A" % string acc), annots, code)
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
            (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim _ "DIP" % string
                  (cons
                    (Tezos_micheline.Micheline.Seq _
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "CAR" % string []
                          (cons field_annot [])) (cons code []))) []) [])
                (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _) [])))))
      => Some (loc, (cons "A" % string acc), (cons field_annot annots), code)
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
            (cons code
              (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
                (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
                  (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _)
                    [])))))) =>
      Some (loc, (cons "D" % string acc), annots, code)
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "CDR" % string []
              (cons field_annot []))
            (cons code
              (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
                (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
                  (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] _)
                    [])))))) =>
      Some (loc, (cons "D" % string acc), (cons field_annot annots), code)
    |
      Tezos_micheline.Micheline.Seq _
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "DIP" % string
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] _)
                    (cons sub []))) []) [])
            (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] _)
              (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim _ "PAIR" % string []
                    pair_annots) []))))) =>
      let '(_, pair_annots) := extract_field_annots pair_annots in
      steps (cons "A" % string acc) (List.rev_append pair_annots annots) sub
    |
      Tezos_micheline.Micheline.Seq _
        (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim _ "DIP" % string
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
                    (cons sub []))) []) [])
            (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] pair_annots)
                [])))) =>
      let '(_, pair_annots) := extract_field_annots pair_annots in
      steps (cons "D" % string acc) (List.rev_append pair_annots annots) sub
    | _ => None
    end in
  match steps [] [] expanded with
  | Some (loc, steps, annots, code) =>
    let name :=
      String.concat "" % string
        (cons "MAP_C" % string (List.rev (cons "R" % string steps))) in
    Some
      (Tezos_micheline.Micheline.Prim loc name (cons code []) (List.rev annots))
  | None => None
  end.

Definition unexpand_deprecated_dxiiivp {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "DIP" % string
          (cons
            ((Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Prim _ "DIP" % string (cons _ []) [])
                [])) as sub) []) []) []) =>
    let fix count {B : Type}
      (acc : Z) (function_parameter : Tezos_micheline.Micheline.node B string)
      : Z * (Tezos_micheline.Micheline.node B string) :=
      match function_parameter with
      |
        Tezos_micheline.Micheline.Seq _
          (cons
            (Tezos_micheline.Micheline.Prim _ "DIP" % string (cons sub []) [])
            []) => count (Z.add acc 1) sub
      | sub => (acc, sub)
      end in
    let '(depth, sub) := count 1 sub in
    Some
      (Tezos_micheline.Micheline.Prim loc "DIP" % string
        (cons (Tezos_micheline.Micheline.Int loc (Z.of_int depth)) (cons sub []))
        [])
  | _ => None
  end.

Definition unexpand_dupn {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "DIP" % string
          (cons (Tezos_micheline.Micheline.Int _ np)
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] annot)
                  [])) [])) [])
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIG" % string
            (cons (Tezos_micheline.Micheline.Int nloc ng) []) []) [])) =>
    Some
      (Tezos_micheline.Micheline.Prim loc "DUP" % string
        (cons (Tezos_micheline.Micheline.Int nloc ng) []) annot)
  | _ => None
  end.

Definition unexpand_deprecated_duuuuup {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  let fix expand {B : Type}
    (n : Z) (function_parameter : Tezos_micheline.Micheline.node B string)
    : option (Tezos_micheline.Micheline.node B string) :=
    match function_parameter with
    |
      Tezos_micheline.Micheline.Seq loc
        (cons (Tezos_micheline.Micheline.Prim nloc "DUP" % string [] annot) [])
      =>
      if equiv_decb n 1 then
        None
      else
        Some
          (Tezos_micheline.Micheline.Prim loc "DUP" % string
            (cons (Tezos_micheline.Micheline.Int nloc (Z.of_int n)) []) annot)
    |
      Tezos_micheline.Micheline.Seq _
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string (cons expanded' [])
            [])
          (cons (Tezos_micheline.Micheline.Prim _ "SWAP" % string [] []) [])) =>
      expand (Z.add n 1) expanded'
    | _ => None
    end in
  expand 1 expanded.

Fixpoint normalize_pair_item (op_staroptstar : option bool)
  : pair_item -> pair_item :=
  let right :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun function_parameter =>
    match function_parameter with
    | P i a b =>
      P i (normalize_pair_item None a) (normalize_pair_item (Some true) b)
    | A => I
    | A => A
    | I => I
    end.

Definition unexpand_pappaiir {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Tezos_micheline.Micheline.Seq _
      (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) []) =>
    Some expanded
  | Tezos_micheline.Micheline.Seq loc ((cons _ _) as nodes) =>
    let fix exec {B : Type}
      (stack : list pair_item) (nodes :
      list (Tezos_micheline.Micheline.node B string)) : list pair_item :=
      match (nodes, stack) with
      | ([], _) => stack
      |
        (cons
          (Tezos_micheline.Micheline.Prim ploc "DIP" % string
            (cons (Tezos_micheline.Micheline.Int loc n)
              (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest,
          cons a rstack) =>
        exec
          (cons a
            (exec rstack
              (cons
                (Tezos_micheline.Micheline.Prim ploc "DIP" % string
                  (cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
                    (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
          rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Int _ n)
              (cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest,
          cons a rstack) => exec (cons a (exec rstack sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim ploc "DIP" % string
            (cons (Tezos_micheline.Micheline.Int loc n)
              (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest, [])
        =>
        exec
          (cons A
            (exec []
              (cons
                (Tezos_micheline.Micheline.Prim ploc "DIP" % string
                  (cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
                    (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
          rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Int _ n)
              (cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest, []) =>
        exec (cons A (exec [] sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest,
          cons a rstack) => exec (cons a (exec rstack sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest, []) =>
        exec (cons A (exec [] sub)) rest
      |
        (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) rest,
          cons a (cons b rstack)) => exec (cons (P 0 a b) rstack) rest
      |
        (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) rest,
          cons a []) => exec (cons (P 0 a I) []) rest
      | (cons (Tezos_micheline.Micheline.Prim _ "PAIR" % string [] []) rest, [])
        => exec (cons (P 0 A I) []) rest
      | _ => Stdlib.raise_notrace Not_a_pair
      end in
    match exec [] nodes with
    | [] => None
    | cons res _ =>
      let res := normalize_pair_item None res in
      let name := unparse_pair_item res in
      Some (Tezos_micheline.Micheline.Prim loc name [] [])
    end
  | _ => None
  end.

Definition unexpand_unpappaiir {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  | Tezos_micheline.Micheline.Seq loc ((cons _ _) as nodes) =>
    let fix exec {B : Type}
      (stack : list pair_item) (nodes :
      list (Tezos_micheline.Micheline.node B string)) : list pair_item :=
      match (nodes, stack) with
      | ([], _) => stack
      |
        (cons
          (Tezos_micheline.Micheline.Prim ploc "DIP" % string
            (cons (Tezos_micheline.Micheline.Int loc n)
              (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest,
          cons a rstack) =>
        exec
          (cons a
            (exec rstack
              (cons
                (Tezos_micheline.Micheline.Prim ploc "DIP" % string
                  (cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
                    (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
          rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Int _ n)
              (cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest,
          cons a rstack) => exec (cons a (exec rstack sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim ploc "DIP" % string
            (cons (Tezos_micheline.Micheline.Int loc n)
              (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) rest, [])
        =>
        exec
          (cons A
            (exec []
              (cons
                (Tezos_micheline.Micheline.Prim ploc "DIP" % string
                  (cons (Tezos_micheline.Micheline.Int loc (Z.pred n))
                    (cons (Tezos_micheline.Micheline.Seq sloc sub) [])) []) [])))
          rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Int _ n)
              (cons (Tezos_micheline.Micheline.Seq _ sub) [])) []) rest, []) =>
        exec (cons A (exec [] sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest,
          cons a rstack) => exec (cons a (exec rstack sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Prim _ "DIP" % string
            (cons (Tezos_micheline.Micheline.Seq _ sub) []) []) rest, []) =>
        exec (cons A (exec [] sub)) rest
      |
        (cons
          (Tezos_micheline.Micheline.Seq _
            (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
              (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim _ "DIP" % string
                    (cons
                      (Tezos_micheline.Micheline.Seq _
                        (cons
                          (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
                          [])) []) []) [])))) rest, cons a (cons b rstack)) =>
        exec (cons (P 0 a b) rstack) rest
      |
        (cons
          (Tezos_micheline.Micheline.Seq _
            (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
              (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim _ "DIP" % string
                    (cons
                      (Tezos_micheline.Micheline.Seq _
                        (cons
                          (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
                          [])) []) []) [])))) rest, cons a []) =>
        exec (cons (P 0 a I) []) rest
      |
        (cons
          (Tezos_micheline.Micheline.Seq _
            (cons (Tezos_micheline.Micheline.Prim _ "DUP" % string [] [])
              (cons (Tezos_micheline.Micheline.Prim _ "CAR" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim _ "DIP" % string
                    (cons
                      (Tezos_micheline.Micheline.Seq _
                        (cons
                          (Tezos_micheline.Micheline.Prim _ "CDR" % string [] [])
                          [])) []) []) [])))) rest, []) =>
        exec (cons (P 0 A I) []) rest
      | _ => Stdlib.raise_notrace Not_a_pair
      end in
    match exec [] (List.rev nodes) with
    | [] => None
    | cons res _ =>
      let res := normalize_pair_item None res in
      let name := String.append "UN" % string (unparse_pair_item res) in
      Some (Tezos_micheline.Micheline.Prim loc name [] [])
    end
  | _ => None
  end.

Definition unexpand_compare {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "EQ" % string [] annot) [])) =>
    Some (Tezos_micheline.Micheline.Prim loc "CMPEQ" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "NEQ" % string [] annot) [])) =>
    Some (Tezos_micheline.Micheline.Prim loc "CMPNEQ" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "LT" % string [] annot) [])) =>
    Some (Tezos_micheline.Micheline.Prim loc "CMPLT" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "GT" % string [] annot) [])) =>
    Some (Tezos_micheline.Micheline.Prim loc "CMPGT" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "LE" % string [] annot) [])) =>
    Some (Tezos_micheline.Micheline.Prim loc "CMPLE" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "GE" % string [] annot) [])) =>
    Some (Tezos_micheline.Micheline.Prim loc "CMPGE" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "EQ" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
    => Some (Tezos_micheline.Micheline.Prim loc "IFCMPEQ" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "NEQ" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
    => Some (Tezos_micheline.Micheline.Prim loc "IFCMPNEQ" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "LT" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
    => Some (Tezos_micheline.Micheline.Prim loc "IFCMPLT" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "GT" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
    => Some (Tezos_micheline.Micheline.Prim loc "IFCMPGT" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "LE" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
    => Some (Tezos_micheline.Micheline.Prim loc "IFCMPLE" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "GE" % string [] _)
          (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) [])))
    => Some (Tezos_micheline.Micheline.Prim loc "IFCMPGE" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "EQ" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
    => Some (Tezos_micheline.Micheline.Prim loc "IFEQ" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "NEQ" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
    => Some (Tezos_micheline.Micheline.Prim loc "IFNEQ" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "LT" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
    => Some (Tezos_micheline.Micheline.Prim loc "IFLT" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "GT" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
    => Some (Tezos_micheline.Micheline.Prim loc "IFGT" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "LE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
    => Some (Tezos_micheline.Micheline.Prim loc "IFLE" % string args annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "GE" % string [] _)
        (cons (Tezos_micheline.Micheline.Prim _ "IF" % string args annot) []))
    => Some (Tezos_micheline.Micheline.Prim loc "IFGE" % string args annot)
  | _ => None
  end.

Definition unexpand_asserts {A : Type}
  (expanded : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match expanded with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF" % string
          (cons (Tezos_micheline.Micheline.Seq _ [])
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Seq _
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                          []) []))) [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT" % string [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Seq _
          (cons (Tezos_micheline.Micheline.Prim _ "COMPARE" % string [] [])
            (cons (Tezos_micheline.Micheline.Prim _ comparison [] []) [])))
        (cons
          (Tezos_micheline.Micheline.Prim _ "IF" % string
            (cons (Tezos_micheline.Micheline.Seq _ [])
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons
                    (Tezos_micheline.Micheline.Seq _
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                        (cons
                          (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string
                            [] []) []))) [])) [])) []) [])) =>
    Some
      (Tezos_micheline.Micheline.Prim loc
        (String.append "ASSERT_CMP" % string comparison) [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ comparison [] [])
        (cons
          (Tezos_micheline.Micheline.Prim _ "IF" % string
            (cons (Tezos_micheline.Micheline.Seq _ [])
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons
                    (Tezos_micheline.Micheline.Seq _
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                        (cons
                          (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string
                            [] []) []))) [])) [])) []) [])) =>
    Some
      (Tezos_micheline.Micheline.Prim loc
        (String.append "ASSERT_" % string comparison) [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
          (cons
            (Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot) []))
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Seq _
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                          []) []))) [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_NONE" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
          (cons (Tezos_micheline.Micheline.Seq _ [])
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Seq _
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                          []) []))) [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_NONE" % string [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
          (cons
            (Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                        []) []))) []))
            (cons (Tezos_micheline.Micheline.Seq _ []) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_SOME" % string [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
          (cons
            (Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                        []) []))) []))
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot)
                  [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_SOME" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
          (cons (Tezos_micheline.Micheline.Seq _ [])
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Seq _
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                          []) []))) [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_LEFT" % string [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
          (cons
            (Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot) []))
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Seq _
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                      (cons
                        (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                          []) []))) [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_LEFT" % string [] annot)
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
          (cons
            (Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                        []) []))) []))
            (cons (Tezos_micheline.Micheline.Seq _ []) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_RIGHT" % string [] [])
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
          (cons
            (Tezos_micheline.Micheline.Seq _
              (cons
                (Tezos_micheline.Micheline.Seq _
                  (cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
                    (cons
                      (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string []
                        []) []))) []))
            (cons
              (Tezos_micheline.Micheline.Seq _
                (cons
                  (Tezos_micheline.Micheline.Prim _ "RENAME" % string [] annot)
                  [])) [])) []) []) =>
    Some (Tezos_micheline.Micheline.Prim loc "ASSERT_RIGHT" % string [] annot)
  | _ => None
  end.

Definition unexpand_if_some {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match function_parameter with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_NONE" % string
          (cons left (cons right [])) annot) []) =>
    Some
      (Tezos_micheline.Micheline.Prim loc "IF_SOME" % string
        (cons right (cons left [])) annot)
  | _ => None
  end.

Definition unexpand_if_right {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match function_parameter with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons
        (Tezos_micheline.Micheline.Prim _ "IF_LEFT" % string
          (cons left (cons right [])) annot) []) =>
    Some
      (Tezos_micheline.Micheline.Prim loc "IF_RIGHT" % string
        (cons right (cons left [])) annot)
  | _ => None
  end.

Definition unexpand_fail {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : option (Tezos_micheline.Micheline.node A string) :=
  match function_parameter with
  |
    Tezos_micheline.Micheline.Seq loc
      (cons (Tezos_micheline.Micheline.Prim _ "UNIT" % string [] [])
        (cons (Tezos_micheline.Micheline.Prim _ "FAILWITH" % string [] []) []))
    => Some (Tezos_micheline.Micheline.Prim loc "FAIL" % string [] [])
  | _ => None
  end.

Definition unexpand {A : Type}
  (original : Tezos_micheline.Micheline.node A string)
  : Tezos_micheline.Micheline.node A string :=
  let try_unexpansions
    (unexpanders :
    list
      ((Tezos_micheline.Micheline.node A string) ->
        option (Tezos_micheline.Micheline.node A string)))
    : Tezos_micheline.Micheline.node A string :=
    match
      List.fold_left
        (fun acc =>
          fun f =>
            match acc with
            | None => f original
            | Some rewritten => Some rewritten
            end) None unexpanders with
    | None => original
    | Some rewritten => rewritten
    end in
  try_unexpansions
    (cons unexpand_asserts
      (cons unexpand_caddadr
        (cons unexpand_set_caddadr
          (cons unexpand_map_caddadr
            (cons unexpand_deprecated_dxiiivp
              (cons unexpand_pappaiir
                (cons unexpand_unpappaiir
                  (cons unexpand_deprecated_duuuuup
                    (cons unexpand_dupn
                      (cons unexpand_compare
                        (cons unexpand_if_some
                          (cons unexpand_if_right (cons unexpand_fail []))))))))))))).

Fixpoint unexpand_rec {A : Type}
  (expr : Tezos_micheline.Micheline.node A string)
  : Tezos_micheline.Micheline.node A string :=
  unexpand_rec_but_root (unexpand expr)

with unexpand_rec_but_root {A : Type}
  (function_parameter : Tezos_micheline.Micheline.node A string)
  : Tezos_micheline.Micheline.node A string :=
  match function_parameter with
  | Tezos_micheline.Micheline.Seq loc items =>
    Tezos_micheline.Micheline.Seq loc (List.map unexpand_rec items)
  | Tezos_micheline.Micheline.Prim loc name args annot =>
    Tezos_micheline.Micheline.Prim loc name
      (List.map unexpand_rec_but_root args) annot
  |
    (Tezos_micheline.Micheline.Int _ _ | Tezos_micheline.Micheline.String _ _ |
      Tezos_micheline.Micheline.Bytes _ _) as atom => atom
  end.



src/proto_alpha/lib_client/michelson_v1_parser.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Tezos_micheline
open Micheline_parser
open Micheline

type parsed = {
  source : string;
  unexpanded : string canonical;
  expanded : Michelson_v1_primitives.prim canonical;
  expansion_table : (int * (Micheline_parser.location * int list)) list;
  unexpansion_table : (int * int) list;
}

(* Unexpanded toplevel expression should be a sequence *)
let expand_all source ast errors =
  let (unexpanded, loc_table) = extract_locations ast in
  let (expanded, expansion_errors) =
    Michelson_v1_macros.expand_rec (root unexpanded)
  in
  let (expanded, unexpansion_table) = extract_locations expanded in
  let expansion_table =
    let sorted =
      List.sort (fun (_, a) (_, b) -> compare a b) unexpansion_table
    in
    let grouped =
      let rec group = function
        | (acc, []) ->
            acc
        | ([], (u, e) :: r) ->
            group ([(e, [u])], r)
        | (((pe, us) :: racc as acc), (u, e) :: r) ->
            if e = pe then group ((e, u :: us) :: racc, r)
            else group ((e, [u]) :: acc, r)
      in
      group ([], sorted)
    in
    List.map2
      (fun (l, ploc) (l', elocs) ->
        assert (l = l') ;
        (l, (ploc, elocs)))
      (List.sort compare loc_table)
      (List.sort compare grouped)
  in
  match
    Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded)
  with
  | Ok expanded ->
      ( {source; unexpanded; expanded; expansion_table; unexpansion_table},
        errors @ expansion_errors )
  | Error errs ->
      ( {
          source;
          unexpanded;
          expanded = Micheline.strip_locations (Seq ((), []));
          expansion_table;
          unexpansion_table;
        },
        errors @ expansion_errors @ errs )

let parse_toplevel ?check source =
  let (tokens, lexing_errors) = Micheline_parser.tokenize source in
  let (asts, parsing_errors) = Micheline_parser.parse_toplevel ?check tokens in
  let ast =
    let start = min_point asts and stop = max_point asts in
    Seq ({start; stop}, asts)
  in
  expand_all source ast (lexing_errors @ parsing_errors)

let parse_expression ?check source =
  let (tokens, lexing_errors) = Micheline_parser.tokenize source in
  let (ast, parsing_errors) =
    Micheline_parser.parse_expression ?check tokens
  in
  expand_all source ast (lexing_errors @ parsing_errors)

let expand_all ~source ~original = expand_all source original []
src/proto_alpha/lib_client/michelson_v1_parser.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Tezos_micheline.

Import Micheline_parser.

Import Micheline.

Record parsed := {
  source : string;
  unexpanded : Tezos_micheline.Micheline.canonical string;
  expanded :
    Tezos_micheline.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim;
  expansion_table :
    list (Z * (Tezos_micheline.Micheline_parser.location * (list Z)));
  unexpansion_table : list (Z * Z) }.

Definition expand_all
  (source : string)
  (ast :
    Tezos_micheline.Micheline.node Tezos_micheline.Micheline_parser.location
      string) (errors : list Tezos_base__TzPervasives.error)
  : parsed * (list Tezos_base__TzPervasives.error) :=
  let '(unexpanded, loc_table) := extract_locations ast in
  let '(expanded, expansion_errors) :=
    Michelson_v1_macros.expand_rec (root unexpanded) in
  let '(expanded, unexpansion_table) := extract_locations expanded in
  let expansion_table :=
    let sorted :=
      List.sort
        (fun function_parameter =>
          let '(_, a) := function_parameter in
          fun function_parameter =>
            let '(_, b) := function_parameter in
            OCaml.Stdlib.compare a b) unexpansion_table in
    let grouped :=
      let fix group {A B : Type}
        (function_parameter : (list (A * (list B))) * (list (B * A)))
        : list (A * (list B)) :=
        match function_parameter with
        | (acc, []) => acc
        | ([], cons (u, e) r) => group ((cons (e, (cons u [])) []), r)
        | ((cons (pe, us) racc) as acc, cons (u, e) r) =>
          if equiv_decb e pe then
            group ((cons (e, (cons u us)) racc), r)
          else
            group ((cons (e, (cons u [])) acc), r)
        end in
      group ([], sorted) in
    List.map2
      (fun function_parameter =>
        let '(l, ploc) := function_parameter in
        fun function_parameter =>
          let '(l', elocs) := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Assert instruction is not handled. *)
            assert (equiv_decb l l') in
          (l, (ploc, elocs))) (List.sort OCaml.Stdlib.compare loc_table)
      (List.sort OCaml.Stdlib.compare grouped) in
  match
    Environment.wrap_error (Michelson_v1_primitives.prims_of_strings expanded)
    with
  | Stdlib.Ok expanded =>
    ({| source := source; unexpanded := unexpanded; expanded := expanded;
      expansion_table := expansion_table; unexpansion_table := unexpansion_table
      |}, (OCaml.Stdlib.app errors expansion_errors))
  | Stdlib.Error errs =>
    ({| source := source; unexpanded := unexpanded;
      expanded :=
        Micheline.strip_locations (Tezos_micheline.Micheline.Seq tt []);
      expansion_table := expansion_table; unexpansion_table := unexpansion_table
      |}, (OCaml.Stdlib.app errors (OCaml.Stdlib.app expansion_errors errs)))
  end.

Definition parse_toplevel (check : option bool) (source : string)
  : parsed * (list Tezos_base__TzPervasives.error) :=
  let '(tokens, lexing_errors) := Micheline_parser.tokenize source in
  let '(asts, parsing_errors) := Micheline_parser.parse_toplevel check tokens in
  let ast :=
    let start : Tezos_micheline.Micheline_parser.point :=
      min_point asts
    with stop : Tezos_micheline.Micheline_parser.point :=
      max_point asts in
    Tezos_micheline.Micheline.Seq {| start := start; stop := stop |} asts in
  expand_all source ast (OCaml.Stdlib.app lexing_errors parsing_errors).

Definition parse_expression (check : option bool) (source : string)
  : parsed * (list Tezos_base__TzPervasives.error) :=
  let '(tokens, lexing_errors) := Micheline_parser.tokenize source in
  let '(ast, parsing_errors) := Micheline_parser.parse_expression check tokens
    in
  expand_all source ast (OCaml.Stdlib.app lexing_errors parsing_errors).

Definition expand_all
  (source : string)
  (original :
    Tezos_micheline.Micheline.node Tezos_micheline.Micheline_parser.location
      string) : parsed * (list Tezos_base__TzPervasives.error) :=
  expand_all source original [].

src/proto_alpha/lib_client/michelson_v1_printer.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Micheline
open Micheline_printer

let anon = {comment = None}

let print_expr ppf expr =
  expr |> Michelson_v1_primitives.strings_of_prims
  |> Micheline.inject_locations (fun _ -> anon)
  |> print_expr ppf

let print_expr_unwrapped ppf expr =
  expr |> Michelson_v1_primitives.strings_of_prims
  |> Micheline.inject_locations (fun _ -> anon)
  |> print_expr_unwrapped ppf

let print_var_annots ppf = List.iter (Format.fprintf ppf "%s ")

let print_annot_expr_unwrapped ppf (expr, annot) =
  Format.fprintf ppf "%a%a" print_var_annots annot print_expr_unwrapped expr

let print_stack ppf = function
  | [] ->
      Format.fprintf ppf "[]"
  | more ->
      Format.fprintf
        ppf
        "@[<hov 0>[ %a ]@]"
        (Format.pp_print_list
           ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ : ")
           print_annot_expr_unwrapped)
        more

let print_execution_trace ppf trace =
  Format.pp_print_list
    (fun ppf (loc, gas, stack) ->
      Format.fprintf
        ppf
        "- @[<v 0>location: %d (remaining gas: %a)@,[ @[<v 0>%a ]@]@]"
        loc
        Gas.pp
        gas
        (Format.pp_print_list (fun ppf (e, annot) ->
             Format.fprintf
               ppf
               "@[<v 0>%a  \t%s@]"
               print_expr
               e
               (match annot with None -> "" | Some a -> a)))
        stack)
    ppf
    trace

let print_big_map_diff ppf diff =
  let pp_map ppf id =
    if Compare.Z.(id < Z.zero) then
      Format.fprintf ppf "temp(%s)" (Z.to_string (Z.neg id))
    else Format.fprintf ppf "map(%s)" (Z.to_string id)
  in
  Format.fprintf
    ppf
    "@[<v 0>%a@]"
    (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf ->
       function
       | Contract.Clear id ->
           Format.fprintf ppf "Clear %a" pp_map id
       | Contract.Alloc {big_map; key_type; value_type} ->
           Format.fprintf
             ppf
             "New %a of type (big_map %a %a)"
             pp_map
             big_map
             print_expr
             key_type
             print_expr
             value_type
       | Contract.Copy (src, dst) ->
           Format.fprintf ppf "Copy %a to %a" pp_map src pp_map dst
       | Contract.Update {big_map; diff_key; diff_value; _} ->
           Format.fprintf
             ppf
             "%s %a[%a]%a"
             (match diff_value with None -> "Unset" | Some _ -> "Set")
             pp_map
             big_map
             print_expr
             diff_key
             (fun ppf -> function None -> () | Some x ->
                   Format.fprintf ppf " to %a" print_expr x)
             diff_value))
    diff

let inject_types type_map parsed =
  let rec inject_expr = function
    | Seq (loc, items) ->
        Seq (inject_loc `before loc, List.map inject_expr items)
    | Prim (loc, name, items, annot) ->
        Prim (inject_loc `after loc, name, List.map inject_expr items, annot)
    | Int (loc, value) ->
        Int (inject_loc `after loc, value)
    | String (loc, value) ->
        String (inject_loc `after loc, value)
    | Bytes (loc, value) ->
        Bytes (inject_loc `after loc, value)
  and inject_loc which loc =
    try
      let stack =
        let locs =
          List.assoc loc parsed.Michelson_v1_parser.expansion_table
          |> snd |> List.sort compare
        in
        let (bef, aft) = List.assoc (List.hd locs) type_map in
        match which with `before -> bef | `after -> aft
      in
      {comment = Some (Format.asprintf "%a" print_stack stack)}
    with Not_found -> {comment = None}
  in
  inject_expr (root parsed.unexpanded)

let unparse ?type_map parse expanded =
  let source =
    match type_map with
    | Some type_map ->
        let (unexpanded, unexpansion_table) =
          expanded |> Michelson_v1_primitives.strings_of_prims |> root
          |> Michelson_v1_macros.unexpand_rec |> Micheline.extract_locations
        in
        let rec inject_expr = function
          | Seq (loc, items) ->
              Seq (inject_loc `before loc, List.map inject_expr items)
          | Prim (loc, name, items, annot) ->
              Prim
                (inject_loc `after loc, name, List.map inject_expr items, annot)
          | Int (loc, value) ->
              Int (inject_loc `after loc, value)
          | String (loc, value) ->
              String (inject_loc `after loc, value)
          | Bytes (loc, value) ->
              Bytes (inject_loc `after loc, value)
        and inject_loc which loc =
          try
            let stack =
              let (bef, aft) =
                List.assoc (List.assoc loc unexpansion_table) type_map
              in
              match which with `before -> bef | `after -> aft
            in
            {comment = Some (Format.asprintf "%a" print_stack stack)}
          with Not_found -> {comment = None}
        in
        unexpanded |> root |> inject_expr
        |> Format.asprintf "%a" Micheline_printer.print_expr
    | None ->
        expanded |> Michelson_v1_primitives.strings_of_prims |> root
        |> Michelson_v1_macros.unexpand_rec |> Micheline.strip_locations
        |> Micheline_printer.printable (fun n -> n)
        |> Format.asprintf "%a" Micheline_printer.print_expr
  in
  match parse source with
  | (res, []) ->
      res
  | (_, _ :: _) ->
      Pervasives.failwith "Michelson_v1_printer.unparse"

let unparse_toplevel ?type_map =
  unparse ?type_map Michelson_v1_parser.parse_toplevel

let unparse_expression = unparse Michelson_v1_parser.parse_expression

let unparse_invalid expanded =
  let source =
    expanded |> root |> Michelson_v1_macros.unexpand_rec
    |> Micheline.strip_locations
    |> Micheline_printer.printable (fun n -> n)
    |> Format.asprintf "%a" Micheline_printer.print_expr_unwrapped
  in
  fst (Michelson_v1_parser.parse_toplevel source)
src/proto_alpha/lib_client/michelson_v1_printer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Tezos_micheline.

Import Micheline.

Import Micheline_printer.

Definition anon : Tezos_micheline.Micheline_printer.location :=
  {| comment := None |}.

Definition print_expr
  (ppf : Stdlib.Format.formatter)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply expr Michelson_v1_primitives.strings_of_prims)
      (Micheline.inject_locations
        (fun function_parameter =>
          let '_ := function_parameter in
          anon))) (print_expr ppf).

Definition print_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : unit :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply expr Michelson_v1_primitives.strings_of_prims)
      (Micheline.inject_locations
        (fun function_parameter =>
          let '_ := function_parameter in
          anon))) (print_expr_unwrapped ppf).

Definition print_var_annots (ppf : Stdlib.Format.formatter)
  : (list string) -> unit :=
  List.iter
    (Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Char_literal " " % char
            CamlinternalFormatBasics.End_of_format)) "%s " % string)).

Definition print_annot_expr_unwrapped
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
      (list string)) : unit :=
  let '(expr, annot) := function_parameter in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Alpha
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
      "%a%a" % string) print_var_annots annot print_expr_unwrapped expr.

Definition print_stack
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    list
      ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
        Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
        (list string))) : unit :=
  match function_parameter with
  | [] =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "[]" % string
          CamlinternalFormatBasics.End_of_format) "[]" % string)
  | more =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<hov 0>" % string
                CamlinternalFormatBasics.End_of_format) "<hov 0>" % string))
          (CamlinternalFormatBasics.String_literal "[ " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " ]" % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))))
        "@[<hov 0>[ %a ]@]" % string)
      (Format.pp_print_list
        (Some
          (fun ppf =>
            fun function_parameter =>
              let 'tt := function_parameter in
              Format.fprintf ppf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.String_literal ": " % string
                      CamlinternalFormatBasics.End_of_format)) "@ : " % string)))
        print_annot_expr_unwrapped) more
  end.

Definition print_execution_trace
  (ppf : Stdlib.Format.formatter)
  (trace :
    list
      (Z * Tezos_protocol_alpha.Protocol.Alpha_context.Gas.t *
        (list
          ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
            (option string))))) : unit :=
  Format.pp_print_list None
    (fun ppf =>
      fun function_parameter =>
        let '(loc, gas, stack) := function_parameter in
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "- " % string
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 0>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
                (CamlinternalFormatBasics.String_literal "location: " % string
                  (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.No_precision
                    (CamlinternalFormatBasics.String_literal
                      " (remaining gas: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal ")" % char
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "[ " % string
                              (CamlinternalFormatBasics.Formatting_gen
                                (CamlinternalFormatBasics.Open_box
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "<v 0>" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "<v 0>" % string))
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " ]" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))
            "- @[<v 0>location: %d (remaining gas: %a)@,[ @[<v 0>%a ]@]@]" %
              string) loc Gas.pp gas
          (Format.pp_print_list None
            (fun ppf =>
              fun function_parameter =>
                let '(e, annot) := function_parameter in
                Format.fprintf ppf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<v 0>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<v 0>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal "  	" % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))
                    "@[<v 0>%a  	%s@]" % string) print_expr e
                  match annot with
                  | None => "" % string
                  | Some a => a
                  end)) stack) ppf trace.

Definition print_big_map_diff
  (ppf : Stdlib.Format.formatter)
  (diff :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.big_map_diff_item)
  : unit :=
  let pp_map
    (ppf : Stdlib.Format.formatter) (id : Tezos_base__TzPervasives.Compare.Z.t)
    : unit :=
    if op_lt id Z.zero then
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "temp(" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "temp(%s)" % string)
        (Z.to_string (Z.neg id))
    else
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "map(" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ")" % char
                CamlinternalFormatBasics.End_of_format))) "map(%s)" % string)
        (Z.to_string id) in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal "<v 0>" % string
              CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
    (Format.pp_print_list (Some Format.pp_print_space)
      (fun ppf =>
        fun function_parameter =>
          match function_parameter with
          | Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Clear id =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Clear " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)) "Clear %a" % string)
              pp_map id
          |
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Alloc {|
              big_map := big_map;
                key_type := key_type;
                value_type := value_type
                |} =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "New " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal
                      " of type (big_map " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Char_literal " " % char
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal ")" % char
                              CamlinternalFormatBasics.End_of_format)))))))
                "New %a of type (big_map %a %a)" % string) pp_map big_map
              print_expr key_type print_expr value_type
          | Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Copy src dst =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "Copy " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.String_literal " to " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))))
                "Copy %a to %a" % string) pp_map src pp_map dst
          |
            Tezos_protocol_alpha.Protocol.Alpha_context.Contract.Update {|
              big_map := big_map;
                diff_key := diff_key;
                diff_value := diff_value
                |} =>
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal " " % char
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "[" % char
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal "]" % char
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)))))))
                "%s %a[%a]%a" % string)
              match diff_value with
              | None => "Unset" % string
              | Some _ => "Set" % string
              end pp_map big_map print_expr diff_key
              (fun ppf =>
                fun function_parameter =>
                  match function_parameter with
                  | None => tt
                  | Some x =>
                    Format.fprintf ppf
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal " to " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        " to %a" % string) print_expr x
                  end) diff_value
          end)) diff.

Definition inject_types
  (type_map :
    list
      (Z *
        ((list
          ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
            Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
            (list string))) *
          (list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))))))
  (parsed : Tezos_client_alpha.Michelson_v1_parser.parsed)
  : Tezos_micheline.Micheline.node Tezos_micheline.Micheline_printer.location
    string :=
  let fix inject_expr {A : Type}
    (function_parameter : Tezos_micheline.Micheline.node Z A)
    : Tezos_micheline.Micheline.node Tezos_micheline.Micheline_printer.location
      A :=
    match function_parameter with
    | Tezos_micheline.Micheline.Seq loc items =>
      Tezos_micheline.Micheline.Seq
        (inject_loc
          (* ❌ Variants not supported *)
          variant loc) (List.map inject_expr items)
    | Tezos_micheline.Micheline.Prim loc name items annot =>
      Tezos_micheline.Micheline.Prim
        (inject_loc
          (* ❌ Variants not supported *)
          variant loc) name (List.map inject_expr items) annot
    | Tezos_micheline.Micheline.Int loc value =>
      Tezos_micheline.Micheline.Int
        (inject_loc
          (* ❌ Variants not supported *)
          variant loc) value
    | Tezos_micheline.Micheline.String loc value =>
      Tezos_micheline.Micheline.String
        (inject_loc
          (* ❌ Variants not supported *)
          variant loc) value
    | Tezos_micheline.Micheline.Bytes loc value =>
      Tezos_micheline.Micheline.Bytes
        (inject_loc
          (* ❌ Variants not supported *)
          variant loc) value
    end
  with inject_loc (which : variant) (loc : Z)
    : Tezos_micheline.Micheline_printer.location :=
    (* ❌ Try-with are not handled *)
    try
      (let stack :=
        let locs :=
          OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (List.assoc loc (Michelson_v1_parser.expansion_table parsed)) snd)
            (List.sort OCaml.Stdlib.compare) in
        let '(bef, aft) := List.assoc (List.hd locs) type_map in
        match which with
        | before => bef
        | after => aft
        end in
      {|
        comment :=
          Some
            (Format.asprintf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              print_stack stack) |}) in
  inject_expr (root (unexpanded parsed)).

Definition unparse {A B : Type}
  (type_map :
    option
      (list
        (Tezos_micheline.Micheline.canonical_location *
          ((list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))) *
            (list
              ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
                (list string))))))) (parse : string -> A * (list B))
  (expanded :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) : A :=
  let source :=
    match type_map with
    | Some type_map =>
      let '(unexpanded, unexpansion_table) :=
        OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply expanded
                Michelson_v1_primitives.strings_of_prims) root)
            Michelson_v1_macros.unexpand_rec) Micheline.extract_locations in
      let fix inject_expr {C : Type}
        (function_parameter :
        Tezos_micheline.Micheline.node
          Tezos_micheline.Micheline.canonical_location C)
        : Tezos_micheline.Micheline.node
          Tezos_micheline.Micheline_printer.location C :=
        match function_parameter with
        | Tezos_micheline.Micheline.Seq loc items =>
          Tezos_micheline.Micheline.Seq
            (inject_loc
              (* ❌ Variants not supported *)
              variant loc) (List.map inject_expr items)
        | Tezos_micheline.Micheline.Prim loc name items annot =>
          Tezos_micheline.Micheline.Prim
            (inject_loc
              (* ❌ Variants not supported *)
              variant loc) name (List.map inject_expr items) annot
        | Tezos_micheline.Micheline.Int loc value =>
          Tezos_micheline.Micheline.Int
            (inject_loc
              (* ❌ Variants not supported *)
              variant loc) value
        | Tezos_micheline.Micheline.String loc value =>
          Tezos_micheline.Micheline.String
            (inject_loc
              (* ❌ Variants not supported *)
              variant loc) value
        | Tezos_micheline.Micheline.Bytes loc value =>
          Tezos_micheline.Micheline.Bytes
            (inject_loc
              (* ❌ Variants not supported *)
              variant loc) value
        end
      with inject_loc
        (which : variant) (loc : Tezos_micheline.Micheline.canonical_location)
        : Tezos_micheline.Micheline_printer.location :=
        (* ❌ Try-with are not handled *)
        try
          (let stack :=
            let '(bef, aft) :=
              List.assoc (List.assoc loc unexpansion_table) type_map in
            match which with
            | before => bef
            | after => aft
            end in
          {|
            comment :=
              Some
                (Format.asprintf
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format) "%a" % string)
                  print_stack stack) |}) in
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply unexpanded root)
          inject_expr)
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Micheline_printer.print_expr)
    | None =>
      OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply
              (OCaml.Stdlib.reverse_apply
                (OCaml.Stdlib.reverse_apply expanded
                  Michelson_v1_primitives.strings_of_prims) root)
              Michelson_v1_macros.unexpand_rec) Micheline.strip_locations)
          (Micheline_printer.printable None (fun n => n)))
        (Format.asprintf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format) "%a" % string)
          Micheline_printer.print_expr)
    end in
  match parse source with
  | (res, []) => res
  | (_, cons _ _) => Pervasives.failwith "Michelson_v1_printer.unparse" % string
  end.

Definition unparse_toplevel
  (type_map :
    option
      (list
        (Tezos_micheline.Micheline.canonical_location *
          ((list
            ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
              Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
              (list string))) *
            (list
              ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) *
                (list string)))))))
  : (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) ->
    Tezos_client_alpha.Michelson_v1_parser.parsed :=
  unparse type_map
    (let arg := Michelson_v1_parser.parse_toplevel in
    fun eta => arg None eta).

Definition unparse_expression
  : (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_protocol_alpha.Protocol.Michelson_v1_primitives.prim) ->
    Tezos_client_alpha.Michelson_v1_parser.parsed :=
  unparse None
    (let arg := Michelson_v1_parser.parse_expression in
    fun eta => arg None eta).

Definition unparse_invalid
  (expanded : Tezos_micheline.Micheline.canonical string)
  : Tezos_client_alpha.Michelson_v1_parser.parsed :=
  let source :=
    OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply (OCaml.Stdlib.reverse_apply expanded root)
            Michelson_v1_macros.unexpand_rec) Micheline.strip_locations)
        (Micheline_printer.printable None (fun n => n)))
      (Format.asprintf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
          "%a" % string) Micheline_printer.print_expr_unwrapped) in
  fst (Michelson_v1_parser.parse_toplevel None source).

src/proto_alpha/lib_client/operation_result.ml 87 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Apply_results

let pp_manager_operation_content (type kind) source internal pp_result ppf
    ((operation, result) : kind manager_operation * _) =
  Format.fprintf ppf "@[<v 0>" ;
  ( match operation with
  | Transaction {destination; amount; parameters; entrypoint} ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,Amount: %s%a@,From: %a@,To: %a"
        (if internal then "Internal transaction" else "Transaction")
        Client_proto_args.tez_sym
        Tez.pp
        amount
        Contract.pp
        source
        Contract.pp
        destination ;
      ( match entrypoint with
      | "default" ->
          ()
      | _ ->
          Format.fprintf ppf "@,Entrypoint: %s" entrypoint ) ;
      ( if not (Script_repr.is_unit_parameter parameters) then
        let expr =
          Option.unopt_exn
            (Failure "ill-serialized argument")
            (Data_encoding.force_decode parameters)
        in
        Format.fprintf
          ppf
          "@,Parameter: @[<v 0>%a@]"
          Michelson_v1_printer.print_expr
          expr ) ;
      pp_result ppf result ; Format.fprintf ppf "@]"
  | Origination {delegate; credit; script = {code; storage}; preorigination = _}
    ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,From: %a@,Credit: %s%a"
        (if internal then "Internal origination" else "Origination")
        Contract.pp
        source
        Client_proto_args.tez_sym
        Tez.pp
        credit ;
      let code =
        Option.unopt_exn
          (Failure "ill-serialized code")
          (Data_encoding.force_decode code)
      and storage =
        Option.unopt_exn
          (Failure "ill-serialized storage")
          (Data_encoding.force_decode storage)
      in
      let {Michelson_v1_parser.source; _} =
        Michelson_v1_printer.unparse_toplevel code
      in
      Format.fprintf
        ppf
        "@,@[<hv 2>Script:@ @[<h>%a@]@,@[<hv 2>Initial storage:@ %a@]"
        Format.pp_print_text
        source
        Michelson_v1_printer.print_expr
        storage ;
      ( match delegate with
      | None ->
          Format.fprintf ppf "@,No delegate for this contract"
      | Some delegate ->
          Format.fprintf
            ppf
            "@,Delegate: %a"
            Signature.Public_key_hash.pp
            delegate ) ;
      pp_result ppf result ; Format.fprintf ppf "@]"
  | Reveal key ->
      Format.fprintf
        ppf
        "@[<v 2>%s of manager public key:@,Contract: %a@,Key: %a%a@]"
        (if internal then "Internal revelation" else "Revelation")
        Contract.pp
        source
        Signature.Public_key.pp
        key
        pp_result
        result
  | Delegation None ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,Contract: %a@,To: nobody%a@]"
        (if internal then "Internal Delegation" else "Delegation")
        Contract.pp
        source
        pp_result
        result
  | Delegation (Some delegate) ->
      Format.fprintf
        ppf
        "@[<v 2>%s:@,Contract: %a@,To: %a%a@]"
        (if internal then "Internal Delegation" else "Delegation")
        Contract.pp
        source
        Signature.Public_key_hash.pp
        delegate
        pp_result
        result ) ;
  Format.fprintf ppf "@]"

let pp_balance_updates ppf = function
  | [] ->
      ()
  | balance_updates ->
      let open Delegate in
      let balance_updates =
        List.map
          (fun (balance, update) ->
            let balance =
              match balance with
              | Contract c ->
                  Format.asprintf "%a" Contract.pp c
              | Rewards (pkh, l) ->
                  Format.asprintf
                    "rewards(%a,%a)"
                    Signature.Public_key_hash.pp
                    pkh
                    Cycle.pp
                    l
              | Fees (pkh, l) ->
                  Format.asprintf
                    "fees(%a,%a)"
                    Signature.Public_key_hash.pp
                    pkh
                    Cycle.pp
                    l
              | Deposits (pkh, l) ->
                  Format.asprintf
                    "deposits(%a,%a)"
                    Signature.Public_key_hash.pp
                    pkh
                    Cycle.pp
                    l
            in
            (balance, update))
          balance_updates
      in
      let column_size =
        List.fold_left
          (fun acc (balance, _) -> Compare.Int.max acc (String.length balance))
          0
          balance_updates
      in
      let pp_update ppf = function
        | Credited amount ->
            Format.fprintf ppf "+%s%a" Client_proto_args.tez_sym Tez.pp amount
        | Debited amount ->
            Format.fprintf ppf "-%s%a" Client_proto_args.tez_sym Tez.pp amount
      in
      let pp_one ppf (balance, update) =
        let to_fill = column_size + 3 - String.length balance in
        let filler = String.make to_fill '.' in
        Format.fprintf ppf "%s %s %a" balance filler pp_update update
      in
      Format.fprintf
        ppf
        "@[<v 0>%a@]"
        (Format.pp_print_list pp_one)
        balance_updates

let pp_manager_operation_contents_and_result ppf
    ( Manager_operation
        {source; fee; operation; counter; gas_limit; storage_limit},
      Manager_operation_result
        {balance_updates; operation_result; internal_operation_results} ) =
  let pp_transaction_result
      (Transaction_result
        { balance_updates;
          consumed_gas;
          storage;
          originated_contracts;
          storage_size;
          paid_storage_size_diff;
          big_map_diff;
          allocated_destination_contract = _ }) =
    ( match originated_contracts with
    | [] ->
        ()
    | contracts ->
        Format.fprintf
          ppf
          "@,@[<v 2>Originated contracts:@,%a@]"
          (Format.pp_print_list Contract.pp)
          contracts ) ;
    ( match storage with
    | None ->
        ()
    | Some expr ->
        Format.fprintf
          ppf
          "@,@[<hv 2>Updated storage:@ %a@]"
          Michelson_v1_printer.print_expr
          expr ) ;
    ( match big_map_diff with
    | None | Some [] ->
        ()
    | Some diff ->
        Format.fprintf
          ppf
          "@,@[<v 2>Updated big_maps:@ %a@]"
          Michelson_v1_printer.print_big_map_diff
          diff ) ;
    if storage_size <> Z.zero then
      Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ;
    if paid_storage_size_diff <> Z.zero then
      Format.fprintf
        ppf
        "@,Paid storage size diff: %s bytes"
        (Z.to_string paid_storage_size_diff) ;
    Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas) ;
    match balance_updates with
    | [] ->
        ()
    | balance_updates ->
        Format.fprintf
          ppf
          "@,Balance updates:@,  %a"
          pp_balance_updates
          balance_updates
  in
  let pp_origination_result
      (Origination_result
        { big_map_diff;
          balance_updates;
          consumed_gas;
          originated_contracts;
          storage_size;
          paid_storage_size_diff }) =
    ( match originated_contracts with
    | [] ->
        ()
    | contracts ->
        Format.fprintf
          ppf
          "@,@[<v 2>Originated contracts:@,%a@]"
          (Format.pp_print_list Contract.pp)
          contracts ) ;
    if storage_size <> Z.zero then
      Format.fprintf ppf "@,Storage size: %s bytes" (Z.to_string storage_size) ;
    ( match big_map_diff with
    | None | Some [] ->
        ()
    | Some diff ->
        Format.fprintf
          ppf
          "@,@[<v 2>Updated big_maps:@ %a@]"
          Michelson_v1_printer.print_big_map_diff
          diff ) ;
    if paid_storage_size_diff <> Z.zero then
      Format.fprintf
        ppf
        "@,Paid storage size diff: %s bytes"
        (Z.to_string paid_storage_size_diff) ;
    Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas) ;
    match balance_updates with
    | [] ->
        ()
    | balance_updates ->
        Format.fprintf
          ppf
          "@,Balance updates:@,  %a"
          pp_balance_updates
          balance_updates
  in
  let pp_result (type kind) ppf (result : kind manager_operation_result) =
    Format.fprintf ppf "@," ;
    match result with
    | Skipped _ ->
        Format.fprintf ppf "This operation was skipped"
    | Failed (_, _errs) ->
        Format.fprintf ppf "This operation FAILED."
    | Applied (Reveal_result {consumed_gas}) ->
        Format.fprintf ppf "This revelation was successfully applied" ;
        Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas)
    | Backtracked (Reveal_result _, _) ->
        Format.fprintf
          ppf
          "@[<v 0>This revelation was BACKTRACKED, its expected effects were \
           NOT applied.@]"
    | Applied (Delegation_result {consumed_gas}) ->
        Format.fprintf ppf "This delegation was successfully applied" ;
        Format.fprintf ppf "@,Consumed gas: %s" (Z.to_string consumed_gas)
    | Backtracked (Delegation_result _, _) ->
        Format.fprintf
          ppf
          "@[<v 0>This delegation was BACKTRACKED, its expected effects were \
           NOT applied.@]"
    | Applied (Transaction_result _ as tx) ->
        Format.fprintf ppf "This transaction was successfully applied" ;
        pp_transaction_result tx
    | Backtracked ((Transaction_result _ as tx), _errs) ->
        Format.fprintf
          ppf
          "@[<v 0>This transaction was BACKTRACKED, its expected effects (as \
           follow) were NOT applied.@]" ;
        pp_transaction_result tx
    | Applied (Origination_result _ as op) ->
        Format.fprintf ppf "This origination was successfully applied" ;
        pp_origination_result op
    | Backtracked ((Origination_result _ as op), _errs) ->
        Format.fprintf
          ppf
          "@[<v 0>This origination was BACKTRACKED, its expected effects (as \
           follow) were NOT applied.@]" ;
        pp_origination_result op
  in
  Format.fprintf
    ppf
    "@[<v 0>@[<v 2>Manager signed operations:@,\
     From: %a@,\
     Fee to the baker: %s%a@,\
     Expected counter: %s@,\
     Gas limit: %s@,\
     Storage limit: %s bytes"
    Signature.Public_key_hash.pp
    source
    Client_proto_args.tez_sym
    Tez.pp
    fee
    (Z.to_string counter)
    (Z.to_string gas_limit)
    (Z.to_string storage_limit) ;
  ( match balance_updates with
  | [] ->
      ()
  | balance_updates ->
      Format.fprintf
        ppf
        "@,Balance updates:@,  %a"
        pp_balance_updates
        balance_updates ) ;
  Format.fprintf
    ppf
    "@,%a"
    (pp_manager_operation_content
       (Contract.implicit_contract source)
       false
       pp_result)
    (operation, operation_result) ;
  ( match internal_operation_results with
  | [] ->
      ()
  | _ :: _ ->
      Format.fprintf
        ppf
        "@,@[<v 2>Internal operations:@ %a@]"
        (Format.pp_print_list (fun ppf (Internal_operation_result (op, res)) ->
             pp_manager_operation_content
               op.source
               false
               pp_result
               ppf
               (op.operation, res)))
        internal_operation_results ) ;
  Format.fprintf ppf "@]"

let rec pp_contents_and_result_list :
    type kind. Format.formatter -> kind contents_and_result_list -> unit =
 fun ppf -> function
  | Single_and_result
      (Seed_nonce_revelation {level; nonce}, Seed_nonce_revelation_result bus)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Seed nonce revelation:@,\
         Level: %a@,\
         Nonce (hash): %a@,\
         Balance updates:@,\
        \  %a@]"
        Raw_level.pp
        level
        Nonce_hash.pp
        (Nonce.hash nonce)
        pp_balance_updates
        bus
  | Single_and_result
      (Double_baking_evidence {bh1; bh2}, Double_baking_evidence_result bus) ->
      Format.fprintf
        ppf
        "@[<v 2>Double baking evidence:@,\
         Exhibit A: %a@,\
         Exhibit B: %a@,\
         Balance updates:@,\
        \  %a@]"
        Block_hash.pp
        (Block_header.hash bh1)
        Block_hash.pp
        (Block_header.hash bh2)
        pp_balance_updates
        bus
  | Single_and_result
      ( Double_endorsement_evidence {op1; op2},
        Double_endorsement_evidence_result bus ) ->
      Format.fprintf
        ppf
        "@[<v 2>Double endorsement evidence:@,\
         Exhibit A: %a@,\
         Exhibit B: %a@,\
         Balance updates:@,\
        \  %a@]"
        Operation_hash.pp
        (Operation.hash op1)
        Operation_hash.pp
        (Operation.hash op2)
        pp_balance_updates
        bus
  | Single_and_result (Activate_account {id; _}, Activate_account_result bus)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Genesis account activation:@,\
         Account: %a@,\
         Balance updates:@,\
        \  %a@]"
        Ed25519.Public_key_hash.pp
        id
        pp_balance_updates
        bus
  | Single_and_result
      ( Endorsement {level},
        Endorsement_result {balance_updates; delegate; slots} ) ->
      Format.fprintf
        ppf
        "@[<v 2>Endorsement:@,\
         Level: %a@,\
         Balance updates:%a@,\
         Delegate: %a@,\
         Slots: %a@]"
        Raw_level.pp
        level
        pp_balance_updates
        balance_updates
        Signature.Public_key_hash.pp
        delegate
        (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
        slots
  | Single_and_result (Proposals {source; period; proposals}, Proposals_result)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Proposals:@,From: %a@,Period: %a@,Protocols:@,  @[<v 0>%a@]@]"
        Signature.Public_key_hash.pp
        source
        Voting_period.pp
        period
        (Format.pp_print_list Protocol_hash.pp)
        proposals
  | Single_and_result (Ballot {source; period; proposal; ballot}, Ballot_result)
    ->
      Format.fprintf
        ppf
        "@[<v 2>Ballot:@,From: %a@,Period: %a@,Protocol: %a@,Vote: %a@]"
        Signature.Public_key_hash.pp
        source
        Voting_period.pp
        period
        Protocol_hash.pp
        proposal
        Data_encoding.Json.pp
        (Data_encoding.Json.construct Vote.ballot_encoding ballot)
  | Single_and_result
      ((Manager_operation _ as op), (Manager_operation_result _ as res)) ->
      Format.fprintf ppf "%a" pp_manager_operation_contents_and_result (op, res)
  | Cons_and_result
      ((Manager_operation _ as op), (Manager_operation_result _ as res), rest)
    ->
      Format.fprintf
        ppf
        "%a@\n%a"
        pp_manager_operation_contents_and_result
        (op, res)
        pp_contents_and_result_list
        rest

let pp_operation_result ppf
    ((op, res) : 'kind contents_list * 'kind contents_result_list) =
  Format.fprintf ppf "@[<v 0>" ;
  let contents_and_result_list = Apply_results.pack_contents_list op res in
  pp_contents_and_result_list ppf contents_and_result_list ;
  Format.fprintf ppf "@]@."

let pp_internal_operation ppf
    (Internal_operation {source; operation; nonce = _}) =
  pp_manager_operation_content
    source
    true
    (fun _ppf () -> ())
    ppf
    (operation, ())
src/proto_alpha/lib_client/operation_result.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Apply_results.

Definition pp_manager_operation_content {A B : Type}
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (internal : bool) (pp_result : Stdlib.Format.formatter -> A -> unit)
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation B) * A)
  : unit :=
  let '(operation, result) := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    match operation with
    |
      Tezos_protocol_alpha.Protocol.Alpha_context.Transaction {|
        amount := amount;
          parameters := parameters;
          entrypoint := entrypoint;
          destination := destination
          |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ":" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "Amount: " % string
                      (CamlinternalFormatBasics.String
                        CamlinternalFormatBasics.No_padding
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.String_literal
                              "From: " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@," % string
                                    0 0)
                                  (CamlinternalFormatBasics.String_literal
                                    "To: " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format)))))))))))))
            "@[<v 2>%s:@,Amount: %s%a@,From: %a@,To: %a" % string)
          (if internal then
            "Internal transaction" % string
          else
            "Transaction" % string) Client_proto_args.tez_sym Tez.pp amount
          Contract.pp source Contract.pp destination in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        match entrypoint with
        | "default" % string => tt
        | _ =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "Entrypoint: " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    CamlinternalFormatBasics.End_of_format)))
              "@,Entrypoint: %s" % string) entrypoint
        end in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        if negb (Script_repr.is_unit_parameter parameters) then
          let expr :=
            Option.unopt_exn (OCaml.Failure "ill-serialized argument" % string)
              (Data_encoding.force_decode parameters) in
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "Parameter: " % string
                  (CamlinternalFormatBasics.Formatting_gen
                    (CamlinternalFormatBasics.Open_box
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "<v 0>" % string
                          CamlinternalFormatBasics.End_of_format)
                        "<v 0>" % string))
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))
              "@,Parameter: @[<v 0>%a@]" % string)
            Michelson_v1_printer.print_expr expr
        else
          tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := pp_result ppf result in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format) "@]" % string)
    |
      Tezos_protocol_alpha.Protocol.Alpha_context.Origination {|
        delegate := delegate;
          script := {| code := code; storage := storage |};
          credit := credit;
          preorigination := _
          |} =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal ":" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "From: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Credit: " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format))))))))))
            "@[<v 2>%s:@,From: %a@,Credit: %s%a" % string)
          (if internal then
            "Internal origination" % string
          else
            "Origination" % string) Contract.pp source Client_proto_args.tez_sym
          Tez.pp credit in
      let code : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
        Option.unopt_exn (OCaml.Failure "ill-serialized code" % string)
          (Data_encoding.force_decode code)
      with storage : Tezos_protocol_alpha.Protocol.Alpha_context.Script.expr :=
        Option.unopt_exn (OCaml.Failure "ill-serialized storage" % string)
          (Data_encoding.force_decode storage) in
      let '{| Michelson_v1_parser.source := source |} :=
        Michelson_v1_printer.unparse_toplevel None code in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hv 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hv 2>" % string))
                (CamlinternalFormatBasics.String_literal "Script:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Formatting_gen
                      (CamlinternalFormatBasics.Open_box
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "<h>" % string
                            CamlinternalFormatBasics.End_of_format)
                          "<h>" % string))
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Close_box
                          (CamlinternalFormatBasics.Formatting_lit
                            (CamlinternalFormatBasics.Break "@," % string 0 0)
                            (CamlinternalFormatBasics.Formatting_gen
                              (CamlinternalFormatBasics.Open_box
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "<hv 2>" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "<hv 2>" % string))
                              (CamlinternalFormatBasics.String_literal
                                "Initial storage:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))
            "@,@[<hv 2>Script:@ @[<h>%a@]@,@[<hv 2>Initial storage:@ %a@]" %
              string) Format.pp_print_text source
          Michelson_v1_printer.print_expr storage in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        match delegate with
        | None =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal
                  "No delegate for this contract" % string
                  CamlinternalFormatBasics.End_of_format))
              "@,No delegate for this contract" % string)
        | Some delegate =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "Delegate: " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))
              "@,Delegate: %a" % string) Signature.Public_key_hash.pp delegate
        end in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := pp_result ppf result in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Close_box
            CamlinternalFormatBasics.End_of_format) "@]" % string)
    | Tezos_protocol_alpha.Protocol.Alpha_context.Reveal key =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal
                " of manager public key:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Contract: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "Key: " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))))))
          "@[<v 2>%s of manager public key:@,Contract: %a@,Key: %a%a@]" % string)
        (if internal then
          "Internal revelation" % string
        else
          "Revelation" % string) Contract.pp source Signature.Public_key.pp key
        pp_result result
    | Tezos_protocol_alpha.Protocol.Alpha_context.Delegation None =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Contract: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal
                          "To: nobody" % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format))))))))))
          "@[<v 2>%s:@,Contract: %a@,To: nobody%a@]" % string)
        (if internal then
          "Internal Delegation" % string
        else
          "Delegation" % string) Contract.pp source pp_result result
    | Tezos_protocol_alpha.Protocol.Alpha_context.Delegation (Some delegate) =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.Char_literal ":" % char
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@," % string 0 0)
                  (CamlinternalFormatBasics.String_literal "Contract: " % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal "To: " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Close_box
                                CamlinternalFormatBasics.End_of_format)))))))))))
          "@[<v 2>%s:@,Contract: %a@,To: %a%a@]" % string)
        (if internal then
          "Internal Delegation" % string
        else
          "Delegation" % string) Contract.pp source Signature.Public_key_hash.pp
        delegate pp_result result
    end in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_lit
        CamlinternalFormatBasics.Close_box
        CamlinternalFormatBasics.End_of_format) "@]" % string).

Definition pp_balance_updates
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    list
      (Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance *
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update))
  : unit :=
  match function_parameter with
  | [] => tt
  | balance_updates =>
    let balance_updates :=
      List.map
        (fun function_parameter =>
          let '(balance, update) := function_parameter in
          let balance :=
            match balance with
            | Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Contract c =>
              Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                Contract.pp c
            | Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Rewards pkh l
              =>
              Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "rewards(" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "," % char
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))
                  "rewards(%a,%a)" % string) Signature.Public_key_hash.pp pkh
                Cycle.pp l
            | Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Fees pkh l =>
              Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "fees(" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "," % char
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))
                  "fees(%a,%a)" % string) Signature.Public_key_hash.pp pkh
                Cycle.pp l
            |
              Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Deposits pkh
                l =>
              Format.asprintf
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "deposits(" % string
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Char_literal "," % char
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.Char_literal ")" % char
                            CamlinternalFormatBasics.End_of_format)))))
                  "deposits(%a,%a)" % string) Signature.Public_key_hash.pp pkh
                Cycle.pp l
            end in
          (balance, update)) balance_updates in
    let column_size :=
      List.fold_left
        (fun acc =>
          fun function_parameter =>
            let '(balance, _) := function_parameter in
            Compare.Int.max acc (String.length balance)) 0 balance_updates in
    let pp_update
      (ppf : Stdlib.Format.formatter) (function_parameter :
      Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update)
      : unit :=
      match function_parameter with
      | Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Credited amount =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "+" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))) "+%s%a" % string)
          Client_proto_args.tez_sym Tez.pp amount
      | Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.Debited amount =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Char_literal "-" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))) "-%s%a" % string)
          Client_proto_args.tez_sym Tez.pp amount
      end in
    let pp_one
      (ppf : Stdlib.Format.formatter) (function_parameter :
      string *
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.balance_update)
      : unit :=
      let '(balance, update) := function_parameter in
      let to_fill := Z.sub (Z.add column_size 3) (String.length balance) in
      let filler := String.make to_fill "." % char in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal " " % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal " " % char
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "%s %s %a" % string) balance filler pp_update update in
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Formatting_lit
              CamlinternalFormatBasics.Close_box
              CamlinternalFormatBasics.End_of_format))) "@[<v 0>%a@]" % string)
      (Format.pp_print_list None pp_one) balance_updates
  end.

Definition pp_manager_operation_contents_and_result {A B : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents
      (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager A)) *
      (Tezos_protocol_alpha.Protocol.Apply_results.contents_result
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager B))) : unit :=
  let
    '(Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
      source := source;
        fee := fee;
        counter := counter;
        operation := operation;
        gas_limit := gas_limit;
        storage_limit := storage_limit
        |},
      Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
        balance_updates := balance_updates;
          operation_result := operation_result;
          internal_operation_results := internal_operation_results
          |}) := function_parameter in
  let pp_transaction_result
    (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.successful_manager_operation_result
      Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction) : unit :=
    let
      'Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result {|
        storage := storage;
          big_map_diff := big_map_diff;
          balance_updates := balance_updates;
          originated_contracts := originated_contracts;
          consumed_gas := consumed_gas;
          storage_size := storage_size;
          paid_storage_size_diff := paid_storage_size_diff;
          allocated_destination_contract := _
          |} := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match originated_contracts with
      | [] => tt
      | contracts =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Originated contracts:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@,@[<v 2>Originated contracts:@,%a@]" % string)
          (Format.pp_print_list None Contract.pp) contracts
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match storage with
      | None => tt
      | Some expr =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<hv 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<hv 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Updated storage:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@,@[<hv 2>Updated storage:@ %a@]" % string)
          Michelson_v1_printer.print_expr expr
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match big_map_diff with
      | None | Some [] => tt
      | Some diff =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Updated big_maps:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@,@[<v 2>Updated big_maps:@ %a@]" % string)
          Michelson_v1_printer.print_big_map_diff diff
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb storage_size Z.zero then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Storage size: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " bytes" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@,Storage size: %s bytes" % string) (Z.to_string storage_size)
      else
        tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb paid_storage_size_diff Z.zero then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal
                "Paid storage size diff: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " bytes" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@,Paid storage size diff: %s bytes" % string)
          (Z.to_string paid_storage_size_diff)
      else
        tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))
          "@,Consumed gas: %s" % string) (Z.to_string consumed_gas) in
    match balance_updates with
    | [] => tt
    | balance_updates =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Balance updates:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "  " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "@,Balance updates:@,  %a" % string) pp_balance_updates
        balance_updates
    end in
  let pp_origination_result
    (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.successful_manager_operation_result
      Tezos_raw_protocol_alpha.Alpha_context.Kind.origination) : unit :=
    let
      'Tezos_protocol_alpha.Protocol.Apply_results.Origination_result {|
        big_map_diff := big_map_diff;
          balance_updates := balance_updates;
          originated_contracts := originated_contracts;
          consumed_gas := consumed_gas;
          storage_size := storage_size;
          paid_storage_size_diff := paid_storage_size_diff
          |} := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match originated_contracts with
      | [] => tt
      | contracts =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Originated contracts:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@,@[<v 2>Originated contracts:@,%a@]" % string)
          (Format.pp_print_list None Contract.pp) contracts
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb storage_size Z.zero then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Storage size: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " bytes" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@,Storage size: %s bytes" % string) (Z.to_string storage_size)
      else
        tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      match big_map_diff with
      | None | Some [] => tt
      | Some diff =>
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.Formatting_gen
                (CamlinternalFormatBasics.Open_box
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal "<v 2>" % string
                      CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
                (CamlinternalFormatBasics.String_literal
                  "Updated big_maps:" % string
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@ " % string 1 0)
                    (CamlinternalFormatBasics.Alpha
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format))))))
            "@,@[<v 2>Updated big_maps:@ %a@]" % string)
          Michelson_v1_printer.print_big_map_diff diff
      end in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      if nequiv_decb paid_storage_size_diff Z.zero then
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal
                "Paid storage size diff: " % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.String_literal " bytes" % string
                    CamlinternalFormatBasics.End_of_format))))
            "@,Paid storage size diff: %s bytes" % string)
          (Z.to_string paid_storage_size_diff)
      else
        tt in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))
          "@,Consumed gas: %s" % string) (Z.to_string consumed_gas) in
    match balance_updates with
    | [] => tt
    | balance_updates =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Balance updates:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "  " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "@,Balance updates:@,  %a" % string) pp_balance_updates
        balance_updates
    end in
  let pp_result {C : Type}
    (ppf : Stdlib.Format.formatter) (result :
    Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
    : unit :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            CamlinternalFormatBasics.End_of_format) "@," % string) in
    match result with
    | Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "This operation was skipped" % string
            CamlinternalFormatBasics.End_of_format)
          "This operation was skipped" % string)
    | Tezos_protocol_alpha.Protocol.Apply_results.Failed _ _errs =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "This operation FAILED." % string
            CamlinternalFormatBasics.End_of_format)
          "This operation FAILED." % string)
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result {|
          consumed_gas := consumed_gas |}) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This revelation was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This revelation was successfully applied" % string) in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))
          "@,Consumed gas: %s" % string) (Z.to_string consumed_gas)
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
        (Tezos_protocol_alpha.Protocol.Apply_results.Reveal_result _) _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "This revelation was BACKTRACKED, its expected effects were NOT applied."
                % string
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format)))
          "@[<v 0>This revelation was BACKTRACKED, its expected effects were NOT applied.@]"
            % string)
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        (Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result {|
          consumed_gas := consumed_gas |}) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This delegation was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This delegation was successfully applied" % string) in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Consumed gas: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))
          "@,Consumed gas: %s" % string) (Z.to_string consumed_gas)
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
        (Tezos_protocol_alpha.Protocol.Apply_results.Delegation_result _) _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 0>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
            (CamlinternalFormatBasics.String_literal
              "This delegation was BACKTRACKED, its expected effects were NOT applied."
                % string
              (CamlinternalFormatBasics.Formatting_lit
                CamlinternalFormatBasics.Close_box
                CamlinternalFormatBasics.End_of_format)))
          "@[<v 0>This delegation was BACKTRACKED, its expected effects were NOT applied.@]"
            % string)
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        ((Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result _) as
          tx) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This transaction was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This transaction was successfully applied" % string) in
      pp_transaction_result tx
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
        ((Tezos_protocol_alpha.Protocol.Apply_results.Transaction_result _) as
          tx) _errs =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "This transaction was BACKTRACKED, its expected effects (as follow) were NOT applied."
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>This transaction was BACKTRACKED, its expected effects (as follow) were NOT applied.@]"
              % string) in
      pp_transaction_result tx
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Applied
        ((Tezos_protocol_alpha.Protocol.Apply_results.Origination_result _) as
          op) =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "This origination was successfully applied" % string
              CamlinternalFormatBasics.End_of_format)
            "This origination was successfully applied" % string) in
      pp_origination_result op
    |
      Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
        ((Tezos_protocol_alpha.Protocol.Apply_results.Origination_result _) as
          op) _errs =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 0>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
              (CamlinternalFormatBasics.String_literal
                "This origination was BACKTRACKED, its expected effects (as follow) were NOT applied."
                  % string
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format)))
            "@[<v 0>This origination was BACKTRACKED, its expected effects (as follow) were NOT applied.@]"
              % string) in
      pp_origination_result op
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal "<v 2>" % string
                  CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
            (CamlinternalFormatBasics.String_literal
              "Manager signed operations:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "From: " % string
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      (CamlinternalFormatBasics.Break "@," % string 0 0)
                      (CamlinternalFormatBasics.String_literal
                        "Fee to the baker: " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "Expected counter: " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Formatting_lit
                                    (CamlinternalFormatBasics.Break
                                      "@," % string 0 0)
                                    (CamlinternalFormatBasics.String_literal
                                      "Gas limit: " % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        (CamlinternalFormatBasics.Formatting_lit
                                          (CamlinternalFormatBasics.Break
                                            "@," % string 0 0)
                                          (CamlinternalFormatBasics.String_literal
                                            "Storage limit: " % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.String_literal
                                                " bytes" % string
                                                CamlinternalFormatBasics.End_of_format))))))))))))))))))))
        "@[<v 0>@[<v 2>Manager signed operations:@,From: %a@,Fee to the baker: %s%a@,Expected counter: %s@,Gas limit: %s@,Storage limit: %s bytes"
          % string) Signature.Public_key_hash.pp source
      Client_proto_args.tez_sym Tez.pp fee (Z.to_string counter)
      (Z.to_string gas_limit) (Z.to_string storage_limit) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    match balance_updates with
    | [] => tt
    | balance_updates =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.String_literal "Balance updates:" % string
              (CamlinternalFormatBasics.Formatting_lit
                (CamlinternalFormatBasics.Break "@," % string 0 0)
                (CamlinternalFormatBasics.String_literal "  " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format)))))
          "@,Balance updates:@,  %a" % string) pp_balance_updates
        balance_updates
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_lit
          (CamlinternalFormatBasics.Break "@," % string 0 0)
          (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format))
        "@,%a" % string)
      (pp_manager_operation_content (Contract.implicit_contract source) false
        pp_result) (operation, operation_result) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    match internal_operation_results with
    | [] => tt
    | cons _ _ =>
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@," % string 0 0)
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v 2>" % string
                    CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
              (CamlinternalFormatBasics.String_literal
                "Internal operations:" % string
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.Alpha
                    (CamlinternalFormatBasics.Formatting_lit
                      CamlinternalFormatBasics.Close_box
                      CamlinternalFormatBasics.End_of_format))))))
          "@,@[<v 2>Internal operations:@ %a@]" % string)
        (Format.pp_print_list None
          (fun ppf =>
            fun function_parameter =>
              let
                'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
                  op res := function_parameter in
              pp_manager_operation_content (source op) false pp_result ppf
                ((operation op), res))) internal_operation_results
    end in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_lit
        CamlinternalFormatBasics.Close_box
        CamlinternalFormatBasics.End_of_format) "@]" % string).

Fixpoint pp_contents_and_result_list {kind : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Apply_results.contents_and_result_list kind)
  : unit :=
  match function_parameter with
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Seed_nonce_revelation {|
        level := level; nonce := nonce |})
      (Tezos_protocol_alpha.Protocol.Apply_results.Seed_nonce_revelation_result
        bus) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Seed nonce revelation:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Level: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Nonce (hash): " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Balance updates:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))))))))
        "@[<v 2>Seed nonce revelation:@,Level: %a@,Nonce (hash): %a@,Balance updates:@,  %a@]"
          % string) Raw_level.pp level Nonce_hash.pp (Nonce.hash nonce)
      pp_balance_updates bus
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Double_baking_evidence {|
        bh1 := bh1; bh2 := bh2 |})
      (Tezos_protocol_alpha.Protocol.Apply_results.Double_baking_evidence_result
        bus) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Double baking evidence:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Exhibit A: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Exhibit B: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Balance updates:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))))))))
        "@[<v 2>Double baking evidence:@,Exhibit A: %a@,Exhibit B: %a@,Balance updates:@,  %a@]"
          % string) Block_hash.pp (Block_header.hash bh1) Block_hash.pp
      (Block_header.hash bh2) pp_balance_updates bus
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Double_endorsement_evidence
        {| op1 := op1; op2 := op2 |})
      (Tezos_protocol_alpha.Protocol.Apply_results.Double_endorsement_evidence_result
        bus) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Double endorsement evidence:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Exhibit A: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Exhibit B: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Balance updates:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    CamlinternalFormatBasics.End_of_format))))))))))))))
        "@[<v 2>Double endorsement evidence:@,Exhibit A: %a@,Exhibit B: %a@,Balance updates:@,  %a@]"
          % string) Operation_hash.pp (Operation.hash op1) Operation_hash.pp
      (Operation.hash op2) pp_balance_updates bus
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account {|
        id := id |})
      (Tezos_protocol_alpha.Protocol.Apply_results.Activate_account_result bus)
    =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal
            "Genesis account activation:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Account: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Balance updates:" % string
                      (CamlinternalFormatBasics.Formatting_lit
                        (CamlinternalFormatBasics.Break "@," % string 0 0)
                        (CamlinternalFormatBasics.String_literal "  " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Close_box
                              CamlinternalFormatBasics.End_of_format)))))))))))
        "@[<v 2>Genesis account activation:@,Account: %a@,Balance updates:@,  %a@]"
          % string) Ed25519.Public_key_hash.pp id pp_balance_updates bus
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement {|
        level := level |})
      (Tezos_protocol_alpha.Protocol.Apply_results.Endorsement_result {|
        balance_updates := balance_updates;
          delegate := delegate;
          slots := slots
          |}) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Endorsement:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "Level: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal
                      "Balance updates:" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Delegate: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "Slots: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[<v 2>Endorsement:@,Level: %a@,Balance updates:%a@,Delegate: %a@,Slots: %a@]"
          % string) Raw_level.pp level pp_balance_updates balance_updates
      Signature.Public_key_hash.pp delegate
      (Format.pp_print_list (Some Format.pp_print_space) Format.pp_print_int)
      slots
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Proposals {|
        source := source; period := period; proposals := proposals |})
      Tezos_protocol_alpha.Protocol.Apply_results.Proposals_result =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Proposals:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "From: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "Period: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Protocols:" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              (CamlinternalFormatBasics.Break "@," % string 0 0)
                              (CamlinternalFormatBasics.String_literal
                                "  " % string
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v 0>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v 0>" % string))
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        CamlinternalFormatBasics.End_of_format))))))))))))))))
        "@[<v 2>Proposals:@,From: %a@,Period: %a@,Protocols:@,  @[<v 0>%a@]@]" %
          string) Signature.Public_key_hash.pp source Voting_period.pp period
      (Format.pp_print_list None Protocol_hash.pp) proposals
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      (Tezos_protocol_alpha.Protocol.Alpha_context.Ballot {|
        source := source;
          period := period;
          proposal := proposal;
          ballot := ballot
          |}) Tezos_protocol_alpha.Protocol.Apply_results.Ballot_result =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 2>" % string
                CamlinternalFormatBasics.End_of_format) "<v 2>" % string))
          (CamlinternalFormatBasics.String_literal "Ballot:" % string
            (CamlinternalFormatBasics.Formatting_lit
              (CamlinternalFormatBasics.Break "@," % string 0 0)
              (CamlinternalFormatBasics.String_literal "From: " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    (CamlinternalFormatBasics.Break "@," % string 0 0)
                    (CamlinternalFormatBasics.String_literal "Period: " % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.Formatting_lit
                          (CamlinternalFormatBasics.Break "@," % string 0 0)
                          (CamlinternalFormatBasics.String_literal
                            "Protocol: " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                (CamlinternalFormatBasics.Break "@," % string 0
                                  0)
                                (CamlinternalFormatBasics.String_literal
                                  "Vote: " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[<v 2>Ballot:@,From: %a@,Period: %a@,Protocol: %a@,Vote: %a@]" %
          string) Signature.Public_key_hash.pp source Voting_period.pp period
      Protocol_hash.pp proposal Data_encoding.Json.pp
      (Data_encoding.Json.construct Vote.ballot_encoding ballot)
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Single_and_result
      ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _) as op)
      ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
        as res) =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) pp_manager_operation_contents_and_result (op, res)
  |
    Tezos_protocol_alpha.Protocol.Apply_results.Cons_and_result
      ((Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation _) as op)
      ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result _)
        as res) rest =>
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha
          (CamlinternalFormatBasics.Formatting_lit
            CamlinternalFormatBasics.Force_newline
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))) "%a@
%a" % string)
      pp_manager_operation_contents_and_result (op, res)
      pp_contents_and_result_list rest
  end.

Definition pp_operation_result {kind : Type}
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list kind) *
      (Tezos_protocol_alpha.Protocol.Apply_results.contents_result_list kind))
  : unit :=
  let '(op, res) := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Format.fprintf ppf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal "<v 0>" % string
                CamlinternalFormatBasics.End_of_format) "<v 0>" % string))
          CamlinternalFormatBasics.End_of_format) "@[<v 0>" % string) in
  let contents_and_result_list := Apply_results.pack_contents_list op res in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := pp_contents_and_result_list ppf contents_and_result_list in
  Format.fprintf ppf
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_lit
        CamlinternalFormatBasics.Close_box
        (CamlinternalFormatBasics.Formatting_lit
          CamlinternalFormatBasics.Flush_newline
          CamlinternalFormatBasics.End_of_format)) "@]@." % string).

Definition pp_internal_operation
  (ppf : Stdlib.Format.formatter)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.packed_internal_operation)
  : unit :=
  let
    'Tezos_protocol_alpha.Protocol.Alpha_context.Internal_operation {|
      source := source; operation := operation; nonce := _ |} :=
    function_parameter in
  pp_manager_operation_content source true
    (fun _ppf =>
      fun function_parameter =>
        let 'tt := function_parameter in
        tt) ppf (operation, tt).

src/proto_alpha/lib_client/protocol_client_context.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Alpha_block_services = Block_services.Make (Protocol) (Protocol)

(** Client RPC context *)

class type rpc_context =
  object
    inherit RPC_context.json

    inherit
      [Shell_services.chain * Shell_services.block] Protocol.Environment
                                                    .RPC_context
                                                    .simple
  end

class wrap_rpc_context (t : RPC_context.json) : rpc_context =
  object
    method base : Uri.t = t#base

    method generic_json_call = t#generic_json_call

    method call_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t -> 'p ->
          'q -> 'i -> 'o tzresult Lwt.t =
      t#call_service

    method call_streamed_service
        : 'm 'p 'q 'i 'o.
          (([< Resto.meth] as 'm), unit, 'p, 'q, 'i, 'o) RPC_service.t ->
          on_chunk:('o -> unit) -> on_close:(unit -> unit) -> 'p -> 'q -> 'i ->
          (unit -> unit) tzresult Lwt.t =
      t#call_streamed_service

    inherit
      [Shell_services.chain, Shell_services.block] Protocol.Environment
                                                   .proto_rpc_context
        (t :> RPC_context.t)
        Shell_services.Blocks.path
  end

class type full =
  object
    inherit Client_context.full

    inherit
      [Shell_services.chain * Shell_services.block] Protocol.Environment
                                                    .RPC_context
                                                    .simple

    inherit
      [Shell_services.chain, Shell_services.block] Protocol.Environment
                                                   .proto_rpc_context
  end

class wrap_full (t : Client_context.full) : full =
  object
    inherit Client_context.proxy_context t

    inherit
      [Shell_services.chain, Shell_services.block] Protocol.Environment
                                                   .proto_rpc_context
        (t :> RPC_context.t)
        Shell_services.Blocks.path
  end

let register_error_kind category ~id ~title ~description ?pp encoding
    from_error to_error =
  let id = "client." ^ Protocol.name ^ "." ^ id in
  register_error_kind
    category
    ~id
    ~title
    ~description
    ?pp
    encoding
    from_error
    to_error

let () =
  let open Tezos_data_encoding.Data_encoding.Registration in
  let open Tezos_data_encoding.Data_encoding in
  let stamp_proto id ids = String.concat "." (Protocol.name :: id :: ids) in
  register
  @@ def (stamp_proto "parameters" []) Protocol.Parameters_repr.encoding ;
  register ~pp:Protocol.Alpha_context.Tez.pp
  @@ def (stamp_proto "tez" []) Protocol.Alpha_context.Tez.encoding ;
  register @@ def (stamp_proto "roll" []) Protocol.Alpha_context.Roll.encoding ;
  register ~pp:Protocol.Alpha_context.Fitness.pp
  @@ def (stamp_proto "fitness" []) Protocol.Alpha_context.Fitness.encoding ;
  register ~pp:Protocol.Alpha_context.Timestamp.pp
  @@ def (stamp_proto "timestamp" []) Protocol.Alpha_context.Timestamp.encoding ;
  register ~pp:Protocol.Alpha_context.Raw_level.pp
  @@ def (stamp_proto "raw_level" []) Protocol.Alpha_context.Raw_level.encoding ;
  register
  @@ def
       (stamp_proto "vote" ["ballot"])
       Protocol.Alpha_context.Vote.ballot_encoding ;
  register
  @@ def
       (stamp_proto "vote" ["ballots"])
       Protocol.Alpha_context.Vote.ballots_encoding ;
  register
  @@ def
       (stamp_proto "vote" ["listings"])
       Protocol.Alpha_context.Vote.listings_encoding ;
  register
  @@ def (stamp_proto "seed" []) Protocol.Alpha_context.Seed.seed_encoding ;
  register ~pp:Protocol.Alpha_context.Gas.pp
  @@ def (stamp_proto "gas" []) Protocol.Alpha_context.Gas.encoding ;
  register ~pp:Protocol.Alpha_context.Gas.pp_cost
  @@ def (stamp_proto "gas" ["cost"]) Protocol.Alpha_context.Gas.cost_encoding ;
  register
  @@ def (stamp_proto "script" []) Protocol.Alpha_context.Script.encoding ;
  register
  @@ def
       (stamp_proto "script" ["expr"])
       Protocol.Alpha_context.Script.expr_encoding ;
  register
  @@ def
       (stamp_proto "script" ["prim"])
       Protocol.Alpha_context.Script.prim_encoding ;
  register
  @@ def
       (stamp_proto "script" ["lazy_expr"])
       Protocol.Alpha_context.Script.lazy_expr_encoding ;
  register
  @@ def
       (stamp_proto "script" ["loc"])
       Protocol.Alpha_context.Script.location_encoding ;
  register ~pp:Protocol.Alpha_context.Contract.pp
  @@ def (stamp_proto "contract" []) Protocol.Alpha_context.Contract.encoding ;
  register
  @@ def
       (stamp_proto "contract" ["big_map_diff"])
       Protocol.Alpha_context.Contract.big_map_diff_encoding ;
  register
  @@ def
       (stamp_proto "delegate" ["frozen_balance"])
       Protocol.Alpha_context.Delegate.frozen_balance_encoding ;
  register
  @@ def
       (stamp_proto "delegate" ["balance_updates"])
       Protocol.Alpha_context.Delegate.balance_updates_encoding ;
  register
  @@ def
       (stamp_proto "delegate" ["frozen_balance_by_cycles"])
       Protocol.Alpha_context.Delegate.frozen_balance_by_cycle_encoding ;
  register ~pp:Protocol.Alpha_context.Level.pp_full
  @@ def (stamp_proto "level" []) Protocol.Alpha_context.Level.encoding ;
  register
  @@ def (stamp_proto "operation" []) Protocol.Alpha_context.Operation.encoding ;
  register
  @@ def
       (stamp_proto "operation" ["contents"])
       Protocol.Alpha_context.Operation.contents_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["contents_list"])
       Protocol.Alpha_context.Operation.contents_list_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["protocol_data"])
       Protocol.Alpha_context.Operation.protocol_data_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["raw"])
       Protocol.Alpha_context.Operation.raw_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["internal"])
       Protocol.Alpha_context.Operation.internal_operation_encoding ;
  register
  @@ def
       (stamp_proto "operation" ["unsigned"])
       Protocol.Alpha_context.Operation.unsigned_encoding ;
  register ~pp:Protocol.Alpha_context.Period.pp
  @@ def (stamp_proto "period" []) Protocol.Alpha_context.Period.encoding ;
  register ~pp:Protocol.Alpha_context.Cycle.pp
  @@ def (stamp_proto "cycle" []) Protocol.Alpha_context.Cycle.encoding ;
  register
  @@ def (stamp_proto "constants" []) Protocol.Alpha_context.Constants.encoding ;
  register
  @@ def
       (stamp_proto "constants" ["fixed"])
       Protocol.Alpha_context.Constants.fixed_encoding ;
  register
  @@ def
       (stamp_proto "constants" ["parametric"])
       Protocol.Alpha_context.Constants.parametric_encoding ;
  register
  @@ def (stamp_proto "nonce" []) Protocol.Alpha_context.Nonce.encoding ;
  register
  @@ def
       (stamp_proto "block_header" [])
       Protocol.Alpha_context.Block_header.encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["unsigned"])
       Protocol.Alpha_context.Block_header.unsigned_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["raw"])
       Protocol.Alpha_context.Block_header.raw_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["contents"])
       Protocol.Alpha_context.Block_header.contents_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["shell_header"])
       Protocol.Alpha_context.Block_header.shell_header_encoding ;
  register
  @@ def
       (stamp_proto "block_header" ["protocol_data"])
       Protocol.Alpha_context.Block_header.protocol_data_encoding ;
  register ~pp:Protocol.Alpha_context.Voting_period.pp
  @@ def
       (stamp_proto "voting_period" [])
       Protocol.Alpha_context.Voting_period.encoding ;
  register
  @@ def
       (stamp_proto "voting_period" ["kind"])
       Protocol.Alpha_context.Voting_period.kind_encoding ;
  register
  @@ Data_encoding.def
       (stamp_proto "errors" [])
       ~description:
         "The full list of RPC errors would be too long to include.It is\n\
          available through the RPC `/errors` (GET)."
       error_encoding
src/proto_alpha/lib_client/protocol_client_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class` not handled. *)
class

(* ❌ Structure item `class_type` not handled. *)
class_type

(* ❌ Structure item `class` not handled. *)
class

Definition register_error_kind {A : Type}
  (category : Tezos_error_monad.Sig.error_category) (id : string)
  (title : string) (description : string)
  (pp : option (Stdlib.Format.formatter -> A -> unit))
  (encoding : Tezos_data_encoding.Data_encoding.t A)
  (from_error : Tezos_base__TzPervasives.error -> option A)
  (to_error : A -> Tezos_base__TzPervasives.error) : unit :=
  let id :=
    String.append "client." % string
      (String.append Protocol.name (String.append "." % string id)) in
  register_error_kind category id title description pp encoding from_error
    to_error.



src/proto_alpha/lib_client/test/assert.ml success
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let default_printer _ = ""

let equal ?(eq = ( = )) ?(print = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (print x) (print y) msg
src/proto_alpha/lib_client/test/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf Pervasives.failwith
    (CamlinternalFormatBasics.Format
      (CamlinternalFormatBasics.Formatting_gen
        (CamlinternalFormatBasics.Open_box
          (CamlinternalFormatBasics.Format
            CamlinternalFormatBasics.End_of_format "" % string))
        (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
          (CamlinternalFormatBasics.Formatting_lit
            (CamlinternalFormatBasics.Break "@ " % string 1 0)
            (CamlinternalFormatBasics.String_literal "expected: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Formatting_lit
                  (CamlinternalFormatBasics.Break "@ " % string 1 0)
                  (CamlinternalFormatBasics.String_literal "got: " % string
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      (CamlinternalFormatBasics.Formatting_lit
                        CamlinternalFormatBasics.Close_box
                        CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb
    end in
  fun op_staroptstar =>
    let print :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if negb (eq x y) then
            fail (print x) (print y) msg
          else
            tt.

src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml 210 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let print expr : string =
  expr
  |> Micheline_printer.printable (fun s -> s)
  |> Format.asprintf "%a" Micheline_printer.print_expr

(* expands : expression with macros fully expanded *)

let assert_expands
    (original : (Micheline_parser.location, string) Micheline.node)
    (expanded : (Micheline_parser.location, string) Micheline.node) =
  let ({Michelson_v1_parser.expanded = expansion; _}, errors) =
    let source = print (Micheline.strip_locations original) in
    Michelson_v1_parser.expand_all ~source ~original
  in
  match errors with
  | [] ->
      Assert.equal
        ~print
        (Michelson_v1_primitives.strings_of_prims expansion)
        (Micheline.strip_locations expanded) ;
      ok ()
  | errors ->
      Error errors

(****************************************************************************)

open Micheline

let zero_loc = Micheline_parser.location_zero

let left_branch = Seq (zero_loc, [Prim (zero_loc, "SWAP", [], [])])

let right_branch = Seq (zero_loc, [])

(***************************************************************************)
(* Test expands *)
(***************************************************************************)

let assert_compare_macro prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "COMPARE", [], []);
           Prim (zero_loc, compare_name, [], []) ] ))

let test_compare_marco_expansion () =
  assert_compare_macro "CMPEQ" "EQ"
  >>? fun () ->
  assert_compare_macro "CMPNEQ" "NEQ"
  >>? fun () ->
  assert_compare_macro "CMPLT" "LT"
  >>? fun () ->
  assert_compare_macro "CMPGT" "GT"
  >>? fun () ->
  assert_compare_macro "CMPLE" "LE"
  >>? fun () -> assert_compare_macro "CMPGE" "GE"

let assert_if_macro prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [left_branch; right_branch], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", [left_branch; right_branch], []) ] ))

let test_if_compare_macros_expansion () =
  assert_if_macro "IFEQ" "EQ"
  >>? fun () ->
  assert_if_macro "IFNEQ" "NEQ"
  >>? fun () ->
  assert_if_macro "IFLT" "LT"
  >>? fun () ->
  assert_if_macro "IFGT" "GT"
  >>? fun () ->
  assert_if_macro "IFLE" "LE" >>? fun () -> assert_if_macro "IFGE" "GE"

let assert_if_cmp_macros prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [left_branch; right_branch], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "COMPARE", [], []);
           Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", [left_branch; right_branch], []) ] ))

let test_if_cmp_macros_expansion () =
  assert_if_cmp_macros "IFCMPEQ" "EQ"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPNEQ" "NEQ"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPLT" "LT"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPGT" "GT"
  >>? fun () ->
  assert_if_cmp_macros "IFCMPLE" "LE"
  >>? fun () -> assert_if_cmp_macros "IFCMPGE" "GE"

(****************************************************************************)
(* Fail *)

let test_fail_expansion () =
  assert_expands
    (Prim (zero_loc, "FAIL", [], []))
    (Seq
       ( zero_loc,
         [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])]
       ))

(**********************************************************************)
(* assertion *)

let seq_unit_failwith =
  Seq
    ( zero_loc,
      [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])] )

(* {} {FAIL} *)
let fail_false = [Seq (zero_loc, []); Seq (zero_loc, [seq_unit_failwith])]

(* {FAIL} {} *)
let fail_true = [Seq (zero_loc, [seq_unit_failwith]); Seq (zero_loc, [])]

let test_assert_expansion () =
  assert_expands
    (Prim (zero_loc, "ASSERT", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])]))

let assert_assert_if_compare prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", fail_false, []) ] ))

let test_assert_if () =
  assert_assert_if_compare "ASSERT_EQ" "EQ"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_NEQ" "NEQ"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_LT" "LT"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_LE" "LE"
  >>? fun () ->
  assert_assert_if_compare "ASSERT_GT" "GT"
  >>? fun () -> assert_assert_if_compare "ASSERT_GE" "GE"

let assert_cmp_if prim_name compare_name =
  assert_expands
    (Prim (zero_loc, prim_name, [], []))
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "COMPARE", [], []);
                 Prim (zero_loc, compare_name, [], []) ] );
           Prim (zero_loc, "IF", fail_false, []) ] ))

let test_assert_cmp_if () =
  assert_cmp_if "ASSERT_CMPEQ" "EQ"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPNEQ" "NEQ"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPLT" "LT"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPLE" "LE"
  >>? fun () ->
  assert_cmp_if "ASSERT_CMPGT" "GT"
  >>? fun () -> assert_cmp_if "ASSERT_CMPGE" "GE"

(* The work of merge request !628
   > ASSERT_LEFT @x  =>  IF_LEFT {RENAME @x} {FAIL}
   > ASSERT_RIGHT @x  =>  IF_LEFT {FAIL} {RENAME @x}
   > ASSERT_SOME @x  =>  IF_NONE {FAIL} {RENAME @x}
*)

let may_rename annot = Seq (zero_loc, [Prim (zero_loc, "RENAME", [], annot)])

let fail_false_may_rename =
  [ may_rename ["@annot"];
    Seq
      ( zero_loc,
        [ Seq
            ( zero_loc,
              [ Prim (zero_loc, "UNIT", [], []);
                Prim (zero_loc, "FAILWITH", [], []) ] ) ] ) ]

let fail_true_may_rename =
  [ Seq
      ( zero_loc,
        [ Seq
            ( zero_loc,
              [ Prim (zero_loc, "UNIT", [], []);
                Prim (zero_loc, "FAILWITH", [], []) ] ) ] );
    may_rename ["@annot"] ]

let test_assert_some_annot () =
  assert_expands
    (Prim (zero_loc, "ASSERT_SOME", [], ["@annot"]))
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])]))

let test_assert_left_annot () =
  assert_expands
    (Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"]))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])]))

let test_assert_right_annot () =
  assert_expands
    (Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"]))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])]))

let test_assert_none () =
  assert_expands
    (Prim (zero_loc, "ASSERT_NONE", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])]))

let test_assert_some () =
  assert_expands
    (Prim (zero_loc, "ASSERT_SOME", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])]))

let test_assert_left () =
  assert_expands
    (Prim (zero_loc, "ASSERT_LEFT", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])]))

let test_assert_right () =
  assert_expands
    (Prim (zero_loc, "ASSERT_RIGHT", [], []))
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])]))

(***********************************************************************)
(*Syntactic Conveniences*)

(* diip *)

let test_diip () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_expands
    (Prim (zero_loc, "DIP", [code], []))
    (Prim (zero_loc, "DIP", [code], []))
  >>? fun () ->
  assert_expands
    (Prim (zero_loc, "DIIIIIIIIP", [code], []))
    (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 8); code], []))
  >>? fun () ->
  assert_expands
    (Prim (zero_loc, "DIIP", [code], []))
    (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []))

(* pair *)

let test_pair () =
  assert_expands
    (Prim (zero_loc, "PAIR", [], []))
    (Prim (zero_loc, "PAIR", [], []))

let test_pappaiir () =
  let pair = Prim (zero_loc, "PAIR", [], []) in
  assert_expands
    (Prim (zero_loc, "PAPPAIIR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []);
           Prim (zero_loc, "DIP", [Seq (zero_loc, [pair])], []);
           pair ] ))

(* unpair *)

let test_unpair () =
  assert_expands
    (Prim (zero_loc, "UNPAIR", [], []))
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "DUP", [], []);
                 Prim (zero_loc, "CAR", [], []);
                 Prim
                   ( zero_loc,
                     "DIP",
                     [Seq (zero_loc, [Prim (zero_loc, "CDR", [], [])])],
                     [] ) ] ) ] ))

(* duup *)

let test_duup () =
  let dup = Prim (zero_loc, "DUP", [], []) in
  assert_expands
    (Prim (zero_loc, "DUUP", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DIP", [Seq (zero_loc, [dup])], []);
           Prim (zero_loc, "SWAP", [], []) ] ))

(* car/cdr *)

let test_caddadr_expansion () =
  let car = Prim (zero_loc, "CAR", [], []) in
  assert_expands (Prim (zero_loc, "CAR", [], [])) car
  >>? fun () ->
  let cdr = Prim (zero_loc, "CDR", [], []) in
  assert_expands (Prim (zero_loc, "CDR", [], [])) cdr
  >>? fun () ->
  assert_expands (Prim (zero_loc, "CADR", [], [])) (Seq (zero_loc, [car; cdr]))
  >>? fun () ->
  assert_expands (Prim (zero_loc, "CDAR", [], [])) (Seq (zero_loc, [cdr; car]))

(* if_some *)

let test_if_some () =
  assert_expands
    (Prim (zero_loc, "IF_SOME", [right_branch; left_branch], []))
    (Seq
       (zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])]))

(*set_caddadr*)

let test_set_car_expansion () =
  assert_expands
    (Prim (zero_loc, "SET_CAR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))

let test_set_cdr_expansion () =
  assert_expands
    (Prim (zero_loc, "SET_CDR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))

let test_set_cadr_expansion () =
  let set_car =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "SET_CADR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

let test_set_cdar_expansion () =
  let set_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "SET_CDAR", [], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

(* TO BE CHANGE IN THE DOCUMENTATION: @MR!791
   FROM:
   > MAP_CAR code  =>  DUP ; CDR ; DIP { CAR ; code } ; SWAP ; PAIR
   TO:
   > MAP_CAR code  =>  DUP ; CDR ; DIP { CAR ; {code} } ; SWAP ; PAIR
*)

let test_map_car () =
  (* code is a sequence *)
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_expands
    (Prim (zero_loc, "MAP_CAR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], []); code])],
               [] );
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))

let test_map_cdr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_expands
    (Prim (zero_loc, "MAP_CDR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], []);
           code;
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))

let test_map_caadr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim (zero_loc, "CDR", [], []);
          code;
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  let map_cadr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "MAP_CAADR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cadr])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

let test_map_cdadr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim (zero_loc, "CDR", [], []);
          code;
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  let map_cadr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_expands
    (Prim (zero_loc, "MAP_CDADR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cadr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

(****************************************************************************)
(* Unexpand tests *)
(****************************************************************************)

(* unpexpanded : original expression with macros *)

let assert_unexpansion original ex =
  let ({Michelson_v1_parser.expanded; _}, errors) =
    let source = print (Micheline.strip_locations original) in
    Michelson_v1_parser.expand_all ~source ~original
  in
  let unparse = Michelson_v1_printer.unparse_expression expanded in
  match errors with
  | [] ->
      Assert.equal
        ~print
        unparse.Michelson_v1_parser.unexpanded
        (Micheline.strip_locations ex) ;
      ok ()
  | _ :: _ ->
      Error errors

let assert_unexpansion_consistent original =
  let ({Michelson_v1_parser.expanded; _}, errors) =
    let source = print (Micheline.strip_locations original) in
    Michelson_v1_parser.expand_all ~source ~original
  in
  match errors with
  | _ :: _ ->
      Error errors
  | [] ->
      let {Michelson_v1_parser.unexpanded; _} =
        Michelson_v1_printer.unparse_expression expanded
      in
      Assert.equal ~print unexpanded (Micheline.strip_locations original) ;
      ok ()

let test_unexpand_fail () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [Prim (zero_loc, "UNIT", [], []); Prim (zero_loc, "FAILWITH", [], [])]
       ))
    (Prim (zero_loc, "FAIL", [], []))

let test_unexpand_if_right () =
  assert_unexpansion
    (Seq
       (zero_loc, [Prim (zero_loc, "IF_LEFT", [left_branch; right_branch], [])]))
    (Prim (zero_loc, "IF_RIGHT", [right_branch; left_branch], []))

let test_unexpand_if_some () =
  assert_unexpansion
    (Seq
       (zero_loc, [Prim (zero_loc, "IF_NONE", [left_branch; right_branch], [])]))
    (Prim (zero_loc, "IF_SOME", [right_branch; left_branch], []))

let test_unexpand_assert () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF", fail_false, [])]))
    (Prim (zero_loc, "ASSERT", [], []))

let assert_unexpansion_assert_if_compare compare_name prim_name =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, compare_name, [], []);
           Prim (zero_loc, "IF", fail_false, []) ] ))
    (Prim (zero_loc, prim_name, [], []))

let test_unexpand_assert_if () =
  assert_unexpansion_assert_if_compare "EQ" "ASSERT_EQ"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "NEQ" "ASSERT_NEQ"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "LT" "ASSERT_LT"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "LE" "ASSERT_LE"
  >>? fun () ->
  assert_unexpansion_assert_if_compare "GT" "ASSERT_GT"
  >>? fun () -> assert_unexpansion_assert_if_compare "GE" "ASSERT_GE"

let assert_unexpansion_assert_cmp_if_compare compare_name prim_name =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "COMPARE", [], []);
                 Prim (zero_loc, compare_name, [], []) ] );
           Prim (zero_loc, "IF", fail_false, []) ] ))
    (Prim (zero_loc, prim_name, [], []))

let test_unexpansion_assert_cmp_if () =
  assert_unexpansion_assert_cmp_if_compare "EQ" "ASSERT_CMPEQ"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "NEQ" "ASSERT_CMPNEQ"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "LT" "ASSERT_CMPLT"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "LE" "ASSERT_CMPLE"
  >>? fun () ->
  assert_unexpansion_assert_cmp_if_compare "GT" "ASSERT_CMPGT"
  >>? fun () -> assert_unexpansion_assert_cmp_if_compare "GE" "ASSERT_CMPGE"

let test_unexpand_assert_some_annot () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true_may_rename, [])]))
    (Prim (zero_loc, "ASSERT_SOME", [], ["@annot"]))

let test_unexpand_assert_left_annot () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false_may_rename, [])]))
    (Prim (zero_loc, "ASSERT_LEFT", [], ["@annot"]))

let test_unexpand_assert_right_annot () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true_may_rename, [])]))
    (Prim (zero_loc, "ASSERT_RIGHT", [], ["@annot"]))

let test_unexpand_assert_none () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_false, [])]))
    (Prim (zero_loc, "ASSERT_NONE", [], []))

let test_unexpand_assert_some () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_NONE", fail_true, [])]))
    (Prim (zero_loc, "ASSERT_SOME", [], []))

let test_unexpand_assert_left () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_false, [])]))
    (Prim (zero_loc, "ASSERT_LEFT", [], []))

let test_unexpand_assert_right () =
  assert_unexpansion
    (Seq (zero_loc, [Prim (zero_loc, "IF_LEFT", fail_true, [])]))
    (Prim (zero_loc, "ASSERT_RIGHT", [], []))

let test_unexpand_unpair () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Seq
             ( zero_loc,
               [ Prim (zero_loc, "DUP", [], []);
                 Prim (zero_loc, "CAR", [], []);
                 Prim
                   ( zero_loc,
                     "DIP",
                     [Seq (zero_loc, [Prim (zero_loc, "CDR", [], [])])],
                     [] ) ] ) ] ))
    (Prim (zero_loc, "UNPAIR", [], []))

let test_unexpand_pair () =
  assert_unexpansion
    (Prim (zero_loc, "PAIR", [], []))
    (Prim (zero_loc, "PAIR", [], []))

let test_unexpand_pappaiir () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
               [] );
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "PAIR", [], [])])],
               [] );
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "PAPPAIIR", [], []))

let test_unexpand_duup () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "DUP", [], [])])],
               [] );
           Prim (zero_loc, "SWAP", [], []) ] ))
    (Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []))

let test_unexpand_caddadr () =
  let car = Prim (zero_loc, "CAR", [], []) in
  let cdr = Prim (zero_loc, "CDR", [], []) in
  assert_unexpansion (Seq (zero_loc, [car])) car
  >>? fun () ->
  assert_unexpansion (Seq (zero_loc, [cdr])) cdr
  >>? fun () ->
  assert_unexpansion
    (Seq (zero_loc, [car; cdr]))
    (Prim (zero_loc, "CADR", [], []))
  >>? fun () ->
  assert_unexpansion
    (Seq (zero_loc, [cdr; car]))
    (Prim (zero_loc, "CDAR", [], []))

let test_unexpand_set_car () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))
    (Prim (zero_loc, "SET_CAR", [], []))

let test_unexpand_set_cdr () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ))
    (Prim (zero_loc, "SET_CDR", [], []))

let test_unexpand_set_car_annot () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CAR", [], ["%@"]);
           Prim (zero_loc, "DROP", [], []);
           Prim (zero_loc, "CDR", [], []);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "SET_CAR", [], ["%@"]))

let test_unexpand_set_cdr_annot () =
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], ["%@"]);
           Prim (zero_loc, "DROP", [], []);
           Prim (zero_loc, "CAR", [], []);
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "SET_CDR", [], ["%@"]))

let test_unexpand_set_cadr () =
  let set_car =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CAR", [], ["@%%"]);
          Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] )
  in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); set_car])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
    (Prim (zero_loc, "SET_CADR", [], []))

let test_unexpand_set_cdar () =
  let set_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] )
  in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); set_cdr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
    (Prim (zero_loc, "SET_CDAR", [], []))

(* FIXME: Seq()(Prim): does not parse, raise an error unparse *)
let test_unexpand_map_car () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_unexpansion
    (Prim (zero_loc, "MAP_CAR", [code], []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim
             ( zero_loc,
               "DIP",
               [ Seq
                   ( zero_loc,
                     [ Prim (zero_loc, "CAR", [], []);
                       Prim (zero_loc, "CAR", [], []) ] ) ],
               [] );
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%"; "%@"]) ] ))

(***********************************************************************)
(*BUG: DIIP and the test with MAP_CDR: or any map with "D" inside fail *)

let test_unexpand_diip () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_unexpansion
    (Prim (zero_loc, "DIIP", [code], []))
    (Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], []))

let test_unexpand_map_cdr () =
  let code = Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]) in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim (zero_loc, "CDR", [], []);
           code;
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "CAR", [], []);
           Prim (zero_loc, "PAIR", [], []) ] ))
    (Prim (zero_loc, "MAP_CDR", [code], []))

let test_unexpand_map_caadr () =
  let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [ Seq
                  ( zero_loc,
                    [ Prim (zero_loc, "CAR", [], ["@%%"]);
                      Seq
                        ( zero_loc,
                          [ Prim (zero_loc, "DUP", [], []);
                            Prim (zero_loc, "CDR", [], []);
                            Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]);
                            Prim (zero_loc, "SWAP", [], []);
                            Prim (zero_loc, "CAR", [], ["@%%"]);
                            Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ) ] ) ],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_unexpansion
    (Prim (zero_loc, "MAP_CAAR", code, []))
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CAR", [], ["@%%"]); map_cdr])],
               [] );
           Prim (zero_loc, "CDR", [], ["@%%"]);
           Prim (zero_loc, "SWAP", [], []);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))

let test_unexpand_map_cdadr () =
  let code = [Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])])] in
  let map_cdr =
    Seq
      ( zero_loc,
        [ Prim (zero_loc, "DUP", [], []);
          Prim
            ( zero_loc,
              "DIP",
              [ Seq
                  ( zero_loc,
                    [ Prim (zero_loc, "CAR", [], ["@%%"]);
                      Seq
                        ( zero_loc,
                          [ Prim (zero_loc, "DUP", [], []);
                            Prim (zero_loc, "CDR", [], []);
                            Seq (zero_loc, [Prim (zero_loc, "CAR", [], [])]);
                            Prim (zero_loc, "SWAP", [], []);
                            Prim (zero_loc, "CAR", [], ["@%%"]);
                            Prim (zero_loc, "PAIR", [], ["%@"; "%"]) ] ) ] ) ],
              [] );
          Prim (zero_loc, "CDR", [], ["@%%"]);
          Prim (zero_loc, "SWAP", [], []);
          Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] )
  in
  assert_unexpansion
    (Seq
       ( zero_loc,
         [ Prim (zero_loc, "DUP", [], []);
           Prim
             ( zero_loc,
               "DIP",
               [Seq (zero_loc, [Prim (zero_loc, "CDR", [], ["@%%"]); map_cdr])],
               [] );
           Prim (zero_loc, "CAR", [], ["@%%"]);
           Prim (zero_loc, "PAIR", [], ["%@"; "%@"]) ] ))
    (Prim (zero_loc, "MAP_CDADR", code, []))

let test_unexpand_diip_duup1 () =
  let single code = Seq (zero_loc, [code]) in
  let cst str = Prim (zero_loc, str, [], []) in
  let app str code = Prim (zero_loc, str, [code], []) in
  let dip = app "DIP" in
  let diip code =
    Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])
  in
  let dup = cst "DUP" in
  let swap = cst "SWAP" in
  let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in
  assert_unexpansion
    (* { DIP { DIP { DIP { DUP }; SWAP }}} *)
    (single (dip (single (dip dip_dup_swap))))
    (* DIIP { DIP { DUP }; SWAP } *)
    (diip dip_dup_swap)

let test_unexpand_diip_duup2 () =
  let single code = Seq (zero_loc, [code]) in
  let cst str = Prim (zero_loc, str, [], []) in
  let app str code = Prim (zero_loc, str, [code], []) in
  let dip = app "DIP" in
  let diip code =
    Prim (zero_loc, "DIP", [Int (zero_loc, Z.of_int 2); code], [])
  in
  let dup = cst "DUP" in
  let duup = Prim (zero_loc, "DUP", [Int (zero_loc, Z.of_int 2)], []) in
  let swap = cst "SWAP" in
  let dip_dup_swap = Seq (zero_loc, [dip (single dup); swap]) in
  assert_unexpansion
    (* { DIP { DIP {{ DIP { DUP }; SWAP }}}} *)
    (single (dip (single (dip (single dip_dup_swap)))))
    (* DIIP { DUUP } *)
    (diip (single duup))

(*****************************************************************************)
(* Test           *)
(*****************************************************************************)

let tests =
  [ (*compare*)
    ("compare expansion", fun _ -> Lwt.return (test_compare_marco_expansion ()));
    ( "if compare expansion",
      fun _ -> Lwt.return (test_if_compare_macros_expansion ()) );
    ( "if compare expansion: IFCMP",
      fun _ -> Lwt.return (test_if_cmp_macros_expansion ()) );
    (*fail*)
    ("fail expansion", fun _ -> Lwt.return (test_fail_expansion ()));
    (*assertion*)
    ("assert expansion", fun _ -> Lwt.return (test_assert_expansion ()));
    ("assert if expansion", fun _ -> Lwt.return (test_assert_if ()));
    ("assert cmpif expansion", fun _ -> Lwt.return (test_assert_cmp_if ()));
    ("assert none expansion", fun _ -> Lwt.return (test_assert_none ()));
    ("assert some expansion", fun _ -> Lwt.return (test_assert_some ()));
    ("assert left expansion", fun _ -> Lwt.return (test_assert_left ()));
    ("assert right expansion", fun _ -> Lwt.return (test_assert_right ()));
    ( "assert some annot expansion",
      fun _ -> Lwt.return (test_assert_some_annot ()) );
    ( "assert left annot expansion",
      fun _ -> Lwt.return (test_assert_left_annot ()) );
    ( "assert right annot expansion",
      fun _ -> Lwt.return (test_assert_right_annot ()) );
    (*syntactic conveniences*)
    ("diip expansion", fun _ -> Lwt.return (test_diip ()));
    ("duup expansion", fun _ -> Lwt.return (test_duup ()));
    ("pair expansion", fun _ -> Lwt.return (test_pair ()));
    ("pappaiir expansion", fun _ -> Lwt.return (test_pappaiir ()));
    ("unpair expansion", fun _ -> Lwt.return (test_unpair ()));
    ("caddadr expansion", fun _ -> Lwt.return (test_caddadr_expansion ()));
    ("if_some expansion", fun _ -> Lwt.return (test_if_some ()));
    ("set_car expansion", fun _ -> Lwt.return (test_set_car_expansion ()));
    ("set_cdr expansion", fun _ -> Lwt.return (test_set_cdr_expansion ()));
    ("set_cadr expansion", fun _ -> Lwt.return (test_set_cadr_expansion ()));
    ("set_cdar expansion", fun _ -> Lwt.return (test_set_cdar_expansion ()));
    ("map_car expansion", fun _ -> Lwt.return (test_map_car ()));
    ("map_cdr expansion", fun _ -> Lwt.return (test_map_cdr ()));
    ("map_caadr expansion", fun _ -> Lwt.return (test_map_caadr ()));
    ("map_cdadr expansion", fun _ -> Lwt.return (test_map_cdadr ()));
    (*Unexpand*)
    ("fail unexpansion", fun _ -> Lwt.return (test_unexpand_fail ()));
    ("if_right unexpansion", fun _ -> Lwt.return (test_unexpand_if_right ()));
    ("if_some unexpansion", fun _ -> Lwt.return (test_unexpand_if_some ()));
    ("assert unexpansion", fun _ -> Lwt.return (test_unexpand_assert ()));
    ("assert_if unexpansion", fun _ -> Lwt.return (test_unexpand_assert_if ()));
    ( "assert_cmp_if unexpansion",
      fun _ -> Lwt.return (test_unexpansion_assert_cmp_if ()) );
    ( "assert_none unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_none ()) );
    ( "assert_some unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_some ()) );
    ( "assert_left unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_left ()) );
    ( "assert_right unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_right ()) );
    ( "assert_some annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_some_annot ()) );
    ( "assert_left annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_left_annot ()) );
    ( "assert_right annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_assert_right_annot ()) );
    ("unpair unexpansion", fun _ -> Lwt.return (test_unexpand_unpair ()));
    ("pair unexpansion", fun _ -> Lwt.return (test_unexpand_pair ()));
    ("pappaiir unexpansion", fun _ -> Lwt.return (test_unexpand_pappaiir ()));
    ("duup unexpansion", fun _ -> Lwt.return (test_unexpand_duup ()));
    ("caddadr unexpansion", fun _ -> Lwt.return (test_unexpand_caddadr ()));
    ("set_car unexpansion", fun _ -> Lwt.return (test_unexpand_set_car ()));
    ("set_cdr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cdr ()));
    ("set_cadr unexpansion", fun _ -> Lwt.return (test_unexpand_set_cadr ()));
    ( "set_car annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_set_car_annot ()) );
    ( "set_cdr annot unexpansion",
      fun _ -> Lwt.return (test_unexpand_set_cdr_annot ()) );
    ("map_car unexpansion", fun _ -> Lwt.return (test_unexpand_map_car ()));
    ( "diip_duup1 unexpansion",
      fun _ -> Lwt.return (test_unexpand_diip_duup1 ()) );
    ( "diip_duup2 unexpansion",
      fun _ -> Lwt.return (test_unexpand_diip_duup2 ()) )
    (***********************************************************************)
    (*BUG
      the function in Michelson_v1_macros.unexpand_map_caddadr
      failed to test the case with the character "D".
      It returns an empty {} for the expand *)
    (*"diip unexpansion",  (fun _ -> Lwt.return (test_unexpand_diip ())) ;*)
    (*"map_cdr unexpansion",  (fun _ -> Lwt.return (test_unexpand_map_cdr ())) ;*)
    (*"map_caadr unexpansion",  (fun _ -> Lwt.return (test_unexpand_map_caadr ())) ;*)
    (*"map_cdadr unexpansion",  (fun _ -> Lwt.return (test_unexpand_map_cdadr ())) ;*)
   ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let () =
  Alcotest.run
    ~argv:[|""|]
    "tezos-lib-client"
    [("micheline v1 macros", List.map wrap tests)]
src/proto_alpha/lib_client/test/test_michelson_v1_macros.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition print {A : Type} (expr : A) : string :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply expr (op_startypeminuserrorstar (fun s => s)))
    (Format.asprintf
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Alpha CamlinternalFormatBasics.End_of_format)
        "%a" % string) op_startypeminuserrorstar).

Definition assert_expands {A B : Type} (function_parameter : A)
  : B -> Tezos_base__TzPervasives.tzresult unit :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    let '({| Michelson_v1_parser.expanded := expansion |}, errors) :=
      let source := print (op_startypeminuserrorstar op_startypeminuserrorstar)
        in
      Michelson_v1_parser.expand_all source op_startypeminuserrorstar in
    match errors with
    | [] =>
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_startypeminuserrorstar print
          (Michelson_v1_primitives.strings_of_prims expansion)
          (op_startypeminuserrorstar op_startypeminuserrorstar) in
      ok tt
    | errors => Stdlib.Error errors
    end.

Definition zero_loc {A : Type} : A := op_startypeminuserrorstar.

Definition left_branch {A : Type} : A := op_startypeminuserrorstar.

Definition right_branch {A : Type} : A := op_startypeminuserrorstar.

Definition assert_compare_macro {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_compare_marco_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion (assert_compare_macro "CMPEQ" % string "EQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion (assert_compare_macro "CMPNEQ" % string "NEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (assert_compare_macro "CMPLT" % string "LT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion
                (assert_compare_macro "CMPGT" % string "GT" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_compare_macro "CMPLE" % string "LE" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_compare_macro "CMPGE" % string "GE" % string))))).

Definition assert_if_macro {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_if_compare_macros_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion (assert_if_macro "IFEQ" % string "EQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion (assert_if_macro "IFNEQ" % string "NEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (assert_if_macro "IFLT" % string "LT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion (assert_if_macro "IFGT" % string "GT" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_if_macro "IFLE" % string "LE" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_if_macro "IFGE" % string "GE" % string))))).

Definition assert_if_cmp_macros {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_if_cmp_macros_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion (assert_if_cmp_macros "IFCMPEQ" % string "EQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion (assert_if_cmp_macros "IFCMPNEQ" % string "NEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            (assert_if_cmp_macros "IFCMPLT" % string "LT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion
                (assert_if_cmp_macros "IFCMPGT" % string "GT" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_if_cmp_macros "IFCMPLE" % string "LE" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_if_cmp_macros "IFCMPGE" % string "GE" % string))))).

Definition test_fail_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition seq_unit_failwith {A : Type} : A := op_startypeminuserrorstar.

Definition fail_false {A : Type} : list A :=
  cons op_startypeminuserrorstar (cons op_startypeminuserrorstar []).

Definition fail_true {A : Type} : list A :=
  cons op_startypeminuserrorstar (cons op_startypeminuserrorstar []).

Definition test_assert_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition assert_assert_if_compare {A B : Type}
  (prim_name : A) (compare_name : B) : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion (assert_assert_if_compare "ASSERT_EQ" % string "EQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion
        (assert_assert_if_compare "ASSERT_NEQ" % string "NEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            (assert_assert_if_compare "ASSERT_LT" % string "LT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion
                (assert_assert_if_compare "ASSERT_LE" % string "LE" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_assert_if_compare "ASSERT_GT" % string "GT" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_assert_if_compare "ASSERT_GE" % string
                        "GE" % string))))).

Definition assert_cmp_if {A B : Type} (prim_name : A) (compare_name : B)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_cmp_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion (assert_cmp_if "ASSERT_CMPEQ" % string "EQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion (assert_cmp_if "ASSERT_CMPNEQ" % string "NEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (assert_cmp_if "ASSERT_CMPLT" % string "LT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion
                (assert_cmp_if "ASSERT_CMPLE" % string "LE" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_cmp_if "ASSERT_CMPGT" % string "GT" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_cmp_if "ASSERT_CMPGE" % string "GE" % string))))).

Definition may_rename {A B : Type} (annot : A) : B := op_startypeminuserrorstar.

Definition fail_false_may_rename {A : Type} : list A :=
  cons (may_rename (cons "@annot" % string []))
    (cons op_startypeminuserrorstar []).

Definition fail_true_may_rename {A : Type} : list A :=
  cons op_startypeminuserrorstar
    (cons (may_rename (cons "@annot" % string [])) []).

Definition test_assert_some_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_left_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_right_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_none (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_left (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_assert_right (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_diip (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  op_gtgtquestion
    (assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion
        (assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let 'tt := function_parameter in
          assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)).

Definition test_pair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_pappaiir (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let pair := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_unpair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_duup (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let dup := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_caddadr_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let car := op_startypeminuserrorstar in
  op_gtgtquestion (assert_expands op_startypeminuserrorstar car)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let cdr := op_startypeminuserrorstar in
      op_gtgtquestion (assert_expands op_startypeminuserrorstar cdr)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            (assert_expands op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              assert_expands op_startypeminuserrorstar op_startypeminuserrorstar))).

Definition test_if_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_set_car_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_set_cdr_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_set_cadr_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let set_car := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_set_cdar_expansion (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let set_cdr := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_map_car (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_map_cdr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_map_caadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  let map_cdr := op_startypeminuserrorstar in
  let map_cadr := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition test_map_cdadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  let map_cdr := op_startypeminuserrorstar in
  let map_cadr := op_startypeminuserrorstar in
  assert_expands op_startypeminuserrorstar op_startypeminuserrorstar.

Definition assert_unexpansion {A : Type}
  (original : Tezos_micheline.Micheline_parser.node) (ex : A)
  : Tezos_base__TzPervasives.tzresult unit :=
  let '({| Michelson_v1_parser.expanded := expanded |}, errors) :=
    let source := print (op_startypeminuserrorstar original) in
    Michelson_v1_parser.expand_all source original in
  let unparse := Michelson_v1_printer.unparse_expression expanded in
  match errors with
  | [] =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      op_startypeminuserrorstar print (Michelson_v1_parser.unexpanded unparse)
        (op_startypeminuserrorstar ex) in
    ok tt
  | cons _ _ => Stdlib.Error errors
  end.

Definition assert_unexpansion_consistent
  (original : Tezos_micheline.Micheline_parser.node)
  : sum unit Tezos_base__TzPervasives.trace :=
  let '({| Michelson_v1_parser.expanded := expanded |}, errors) :=
    let source := print (op_startypeminuserrorstar original) in
    Michelson_v1_parser.expand_all source original in
  match errors with
  | cons _ _ => Stdlib.Error errors
  | [] =>
    let '{| Michelson_v1_parser.unexpanded := unexpanded |} :=
      Michelson_v1_printer.unparse_expression expanded in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      op_startypeminuserrorstar print unexpanded
        (op_startypeminuserrorstar original) in
    ok tt
  end.

Definition test_unexpand_fail (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "UNIT" % string [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "FAILWITH" % string [] []) [])))
    op_startypeminuserrorstar.

Definition test_unexpand_if_right (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string
          (cons left_branch (cons right_branch [])) []) []))
    op_startypeminuserrorstar.

Definition test_unexpand_if_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string
          (cons left_branch (cons right_branch [])) []) []))
    op_startypeminuserrorstar.

Definition test_unexpand_assert (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF" % string fail_false []) []))
    op_startypeminuserrorstar.

Definition assert_unexpansion_assert_if_compare {A : Type}
  (compare_name : string) (prim_name : A)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc compare_name [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "IF" % string fail_false [])
          []))) op_startypeminuserrorstar.

Definition test_unexpand_assert_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion
    (assert_unexpansion_assert_if_compare "EQ" % string "ASSERT_EQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion
        (assert_unexpansion_assert_if_compare "NEQ" % string
          "ASSERT_NEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            (assert_unexpansion_assert_if_compare "LT" % string
              "ASSERT_LT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion
                (assert_unexpansion_assert_if_compare "LE" % string
                  "ASSERT_LE" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_unexpansion_assert_if_compare "GT" % string
                      "ASSERT_GT" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_unexpansion_assert_if_compare "GE" % string
                        "ASSERT_GE" % string))))).

Definition assert_unexpansion_assert_cmp_if_compare {A : Type}
  (compare_name : string) (prim_name : A)
  : Tezos_base__TzPervasives.tzresult unit :=
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Seq zero_loc
          (cons
            (Tezos_micheline.Micheline.Prim zero_loc "COMPARE" % string [] [])
            (cons (Tezos_micheline.Micheline.Prim zero_loc compare_name [] [])
              [])))
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "IF" % string fail_false [])
          []))) op_startypeminuserrorstar.

Definition test_unexpansion_assert_cmp_if (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  op_gtgtquestion
    (assert_unexpansion_assert_cmp_if_compare "EQ" % string
      "ASSERT_CMPEQ" % string)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion
        (assert_unexpansion_assert_cmp_if_compare "NEQ" % string
          "ASSERT_CMPNEQ" % string)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            (assert_unexpansion_assert_cmp_if_compare "LT" % string
              "ASSERT_CMPLT" % string)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgtquestion
                (assert_unexpansion_assert_cmp_if_compare "LE" % string
                  "ASSERT_CMPLE" % string)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgtquestion
                    (assert_unexpansion_assert_cmp_if_compare "GT" % string
                      "ASSERT_CMPGT" % string)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      assert_unexpansion_assert_cmp_if_compare "GE" % string
                        "ASSERT_CMPGE" % string))))).

Definition test_unexpand_assert_some_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string
          fail_true_may_rename []) [])) op_startypeminuserrorstar.

Definition test_unexpand_assert_left_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string
          fail_false_may_rename []) [])) op_startypeminuserrorstar.

Definition test_unexpand_assert_right_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string
          fail_true_may_rename []) [])) op_startypeminuserrorstar.

Definition test_unexpand_assert_none (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string fail_false
          []) [])) op_startypeminuserrorstar.

Definition test_unexpand_assert_some (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_NONE" % string fail_true [])
        [])) op_startypeminuserrorstar.

Definition test_unexpand_assert_left (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string fail_false
          []) [])) op_startypeminuserrorstar.

Definition test_unexpand_assert_right (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "IF_LEFT" % string fail_true [])
        [])) op_startypeminuserrorstar.

Definition test_unexpand_unpair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Seq zero_loc
          (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
            (cons (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
                  (cons
                    (Tezos_micheline.Micheline.Seq zero_loc
                      (cons
                        (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string
                          [] []) [])) []) []) [])))) []))
    op_startypeminuserrorstar.

Definition test_unexpand_pair (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
    op_startypeminuserrorstar.

Definition test_unexpand_pappaiir (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
          (cons
            (Tezos_micheline.Micheline.Seq zero_loc
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
                [])) []) [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
            (cons
              (Tezos_micheline.Micheline.Seq zero_loc
                (cons
                  (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
                  [])) []) [])
          (cons (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
            [])))) op_startypeminuserrorstar.

Definition test_unexpand_duup (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
          (cons
            (Tezos_micheline.Micheline.Seq zero_loc
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
                [])) []) [])
        (cons (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] []) [])))
    op_startypeminuserrorstar.

Definition test_unexpand_caddadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let car := op_startypeminuserrorstar in
  let cdr := op_startypeminuserrorstar in
  op_gtgtquestion
    (assert_unexpansion (Tezos_micheline.Micheline.Seq zero_loc (cons car []))
      car)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion
        (assert_unexpansion
          (Tezos_micheline.Micheline.Seq zero_loc (cons cdr [])) cdr)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion
            (assert_unexpansion
              (Tezos_micheline.Micheline.Seq zero_loc (cons car (cons cdr [])))
              op_startypeminuserrorstar)
            (fun function_parameter =>
              let 'tt := function_parameter in
              assert_unexpansion
                (Tezos_micheline.Micheline.Seq zero_loc (cons cdr (cons car [])))
                op_startypeminuserrorstar))).

Definition test_unexpand_set_car (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
          (cons "@%%" % string []))
        (cons (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
          (cons
            (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
              (cons "%" % string (cons "%@" % string []))) []))))
    op_startypeminuserrorstar.

Definition test_unexpand_set_cdr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons
        (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
          (cons "@%%" % string []))
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
            (cons "%@" % string (cons "%" % string []))) [])))
    op_startypeminuserrorstar.

Definition test_unexpand_set_car_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
            (cons "%@" % string []))
          (cons (Tezos_micheline.Micheline.Prim zero_loc "DROP" % string [] [])
            (cons (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
                  []))))))) op_startypeminuserrorstar.

Definition test_unexpand_set_cdr_annot (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
            (cons "%@" % string []))
          (cons (Tezos_micheline.Micheline.Prim zero_loc "DROP" % string [] [])
            (cons (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
                [])))))) op_startypeminuserrorstar.

Definition test_unexpand_set_cadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let set_car := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
            (cons
              (Tezos_micheline.Micheline.Seq zero_loc
                (cons
                  (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
                    (cons "@%%" % string [])) (cons set_car []))) []) [])
          (cons
            (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
              (cons "@%%" % string []))
            (cons
              (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
                  (cons "%@" % string (cons "%@" % string []))) []))))))
    op_startypeminuserrorstar.

Definition test_unexpand_set_cdar (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let set_cdr := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
            (cons
              (Tezos_micheline.Micheline.Seq zero_loc
                (cons
                  (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
                    (cons "@%%" % string [])) (cons set_cdr []))) []) [])
          (cons
            (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
              (cons "@%%" % string []))
            (cons
              (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
                (cons "%@" % string (cons "%@" % string []))) [])))))
    op_startypeminuserrorstar.

Definition test_unexpand_map_car (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Prim zero_loc "MAP_CAR" % string (cons code [])
      []) op_startypeminuserrorstar.

Definition test_unexpand_diip (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Prim zero_loc "DIIP" % string (cons code []) [])
    op_startypeminuserrorstar.

Definition test_unexpand_map_cdr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
        (cons (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string [] [])
          (cons code
            (cons
              (Tezos_micheline.Micheline.Prim zero_loc "SWAP" % string [] [])
              (cons
                (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string [] [])
                (cons
                  (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string [] [])
                  []))))))) op_startypeminuserrorstar.

Definition test_unexpand_map_caadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := cons op_startypeminuserrorstar [] in
  let map_cdr := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Prim zero_loc "MAP_CAAR" % string code [])
    op_startypeminuserrorstar.

Definition test_unexpand_map_cdadr (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let code := cons op_startypeminuserrorstar [] in
  let map_cdr := op_startypeminuserrorstar in
  assert_unexpansion
    (Tezos_micheline.Micheline.Seq zero_loc
      (cons (Tezos_micheline.Micheline.Prim zero_loc "DUP" % string [] [])
        (cons
          (Tezos_micheline.Micheline.Prim zero_loc "DIP" % string
            (cons
              (Tezos_micheline.Micheline.Seq zero_loc
                (cons
                  (Tezos_micheline.Micheline.Prim zero_loc "CDR" % string []
                    (cons "@%%" % string [])) (cons map_cdr []))) []) [])
          (cons
            (Tezos_micheline.Micheline.Prim zero_loc "CAR" % string []
              (cons "@%%" % string []))
            (cons
              (Tezos_micheline.Micheline.Prim zero_loc "PAIR" % string []
                (cons "%@" % string (cons "%@" % string []))) [])))))
    op_startypeminuserrorstar.

Definition test_unexpand_diip_duup1 (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let single {A B : Type} (code : A) : B :=
    op_startypeminuserrorstar in
  let cst {A B : Type} (str : A) : B :=
    op_startypeminuserrorstar in
  let app {A B C : Type} (str : A) (code : B) : C :=
    op_startypeminuserrorstar in
  let dip := app "DIP" % string in
  let diip {A B : Type} (code : A) : B :=
    op_startypeminuserrorstar in
  let dup := cst "DUP" % string in
  let swap := cst "SWAP" % string in
  let dip_dup_swap := op_startypeminuserrorstar in
  assert_unexpansion (single (dip (single (dip dip_dup_swap))))
    (diip dip_dup_swap).

Definition test_unexpand_diip_duup2 (function_parameter : unit)
  : Tezos_base__TzPervasives.tzresult unit :=
  let 'tt := function_parameter in
  let single {A B : Type} (code : A) : B :=
    op_startypeminuserrorstar in
  let cst {A B : Type} (str : A) : B :=
    op_startypeminuserrorstar in
  let app {A B C : Type} (str : A) (code : B) : C :=
    op_startypeminuserrorstar in
  let dip := app "DIP" % string in
  let diip {A B : Type} (code : A) : B :=
    op_startypeminuserrorstar in
  let dup := cst "DUP" % string in
  let duup := op_startypeminuserrorstar in
  let swap := cst "SWAP" % string in
  let dip_dup_swap := op_startypeminuserrorstar in
  assert_unexpansion (single (dip (single (dip (single dip_dup_swap)))))
    (diip (single duup)).

Definition tests {A : Type}
  : list (string * (A -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))) :=
  cons
    ("compare expansion" % string,
      (fun function_parameter =>
        let '_ := function_parameter in
        Lwt._return (test_compare_marco_expansion tt)))
    (cons
      ("if compare expansion" % string,
        (fun function_parameter =>
          let '_ := function_parameter in
          Lwt._return (test_if_compare_macros_expansion tt)))
      (cons
        ("if compare expansion: IFCMP" % string,
          (fun function_parameter =>
            let '_ := function_parameter in
            Lwt._return (test_if_cmp_macros_expansion tt)))
        (cons
          ("fail expansion" % string,
            (fun function_parameter =>
              let '_ := function_parameter in
              Lwt._return (test_fail_expansion tt)))
          (cons
            ("assert expansion" % string,
              (fun function_parameter =>
                let '_ := function_parameter in
                Lwt._return (test_assert_expansion tt)))
            (cons
              ("assert if expansion" % string,
                (fun function_parameter =>
                  let '_ := function_parameter in
                  Lwt._return (test_assert_if tt)))
              (cons
                ("assert cmpif expansion" % string,
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    Lwt._return (test_assert_cmp_if tt)))
                (cons
                  ("assert none expansion" % string,
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      Lwt._return (test_assert_none tt)))
                  (cons
                    ("assert some expansion" % string,
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        Lwt._return (test_assert_some tt)))
                    (cons
                      ("assert left expansion" % string,
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          Lwt._return (test_assert_left tt)))
                      (cons
                        ("assert right expansion" % string,
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            Lwt._return (test_assert_right tt)))
                        (cons
                          ("assert some annot expansion" % string,
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              Lwt._return (test_assert_some_annot tt)))
                          (cons
                            ("assert left annot expansion" % string,
                              (fun function_parameter =>
                                let '_ := function_parameter in
                                Lwt._return (test_assert_left_annot tt)))
                            (cons
                              ("assert right annot expansion" % string,
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  Lwt._return (test_assert_right_annot tt)))
                              (cons
                                ("diip expansion" % string,
                                  (fun function_parameter =>
                                    let '_ := function_parameter in
                                    Lwt._return (test_diip tt)))
                                (cons
                                  ("duup expansion" % string,
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      Lwt._return (test_duup tt)))
                                  (cons
                                    ("pair expansion" % string,
                                      (fun function_parameter =>
                                        let '_ := function_parameter in
                                        Lwt._return (test_pair tt)))
                                    (cons
                                      ("pappaiir expansion" % string,
                                        (fun function_parameter =>
                                          let '_ := function_parameter in
                                          Lwt._return (test_pappaiir tt)))
                                      (cons
                                        ("unpair expansion" % string,
                                          (fun function_parameter =>
                                            let '_ := function_parameter in
                                            Lwt._return (test_unpair tt)))
                                        (cons
                                          ("caddadr expansion" % string,
                                            (fun function_parameter =>
                                              let '_ := function_parameter in
                                              Lwt._return
                                                (test_caddadr_expansion tt)))
                                          (cons
                                            ("if_some expansion" % string,
                                              (fun function_parameter =>
                                                let '_ := function_parameter in
                                                Lwt._return (test_if_some tt)))
                                            (cons
                                              ("set_car expansion" % string,
                                                (fun function_parameter =>
                                                  let '_ := function_parameter
                                                    in
                                                  Lwt._return
                                                    (test_set_car_expansion tt)))
                                              (cons
                                                ("set_cdr expansion" % string,
                                                  (fun function_parameter =>
                                                    let '_ := function_parameter
                                                      in
                                                    Lwt._return
                                                      (test_set_cdr_expansion tt)))
                                                (cons
                                                  ("set_cadr expansion" % string,
                                                    (fun function_parameter =>
                                                      let '_ :=
                                                        function_parameter in
                                                      Lwt._return
                                                        (test_set_cadr_expansion
                                                          tt)))
                                                  (cons
                                                    ("set_cdar expansion" %
                                                      string,
                                                      (fun function_parameter =>
                                                        let '_ :=
                                                          function_parameter in
                                                        Lwt._return
                                                          (test_set_cdar_expansion
                                                            tt)))
                                                    (cons
                                                      ("map_car expansion" %
                                                        string,
                                                        (fun function_parameter
                                                          =>
                                                          let '_ :=
                                                            function_parameter
                                                            in
                                                          Lwt._return
                                                            (test_map_car tt)))
                                                      (cons
                                                        ("map_cdr expansion" %
                                                          string,
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let '_ :=
                                                              function_parameter
                                                              in
                                                            Lwt._return
                                                              (test_map_cdr tt)))
                                                        (cons
                                                          ("map_caadr expansion"
                                                            % string,
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let '_ :=
                                                                function_parameter
                                                                in
                                                              Lwt._return
                                                                (test_map_caadr
                                                                  tt)))
                                                          (cons
                                                            ("map_cdadr expansion"
                                                              % string,
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let '_ :=
                                                                  function_parameter
                                                                  in
                                                                Lwt._return
                                                                  (test_map_cdadr
                                                                    tt)))
                                                            (cons
                                                              ("fail unexpansion"
                                                                % string,
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let '_ :=
                                                                    function_parameter
                                                                    in
                                                                  Lwt._return
                                                                    (test_unexpand_fail
                                                                      tt)))
                                                              (cons
                                                                ("if_right unexpansion"
                                                                  % string,
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let '_ :=
                                                                      function_parameter
                                                                      in
                                                                    Lwt._return
                                                                      (test_unexpand_if_right
                                                                        tt)))
                                                                (cons
                                                                  ("if_some unexpansion"
                                                                    % string,
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let '_ :=
                                                                        function_parameter
                                                                        in
                                                                      Lwt._return
                                                                        (test_unexpand_if_some
                                                                          tt)))
                                                                  (cons
                                                                    ("assert unexpansion"
                                                                      % string,
                                                                      (fun
                                                                        function_parameter
                                                                        =>
                                                                        let
                                                                          '_ :=
                                                                          function_parameter
                                                                          in
                                                                        Lwt._return
                                                                          (test_unexpand_assert
                                                                            tt)))
                                                                    (cons
                                                                      ("assert_if unexpansion"
                                                                        % string,
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            '_ :=
                                                                            function_parameter
                                                                            in
                                                                          Lwt._return
                                                                            (test_unexpand_assert_if
                                                                              tt)))
                                                                      (cons
                                                                        ("assert_cmp_if unexpansion"
                                                                          %
                                                                          string,
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              '_ :=
                                                                              function_parameter
                                                                              in
                                                                            Lwt._return
                                                                              (test_unexpansion_assert_cmp_if
                                                                                tt)))
                                                                        (cons
                                                                          ("assert_none unexpansion"
                                                                            %
                                                                            string,
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                '_ :=
                                                                                function_parameter
                                                                                in
                                                                              Lwt._return
                                                                                (test_unexpand_assert_none
                                                                                  tt)))
                                                                          (cons
                                                                            ("assert_some unexpansion"
                                                                              %
                                                                              string,
                                                                              (fun
                                                                                function_parameter
                                                                                =>
                                                                                let
                                                                                  '_ :=
                                                                                  function_parameter
                                                                                  in
                                                                                Lwt._return
                                                                                  (test_unexpand_assert_some
                                                                                    tt)))
                                                                            (cons
                                                                              ("assert_left unexpansion"
                                                                                %
                                                                                string,
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    '_ :=
                                                                                    function_parameter
                                                                                    in
                                                                                  Lwt._return
                                                                                    (test_unexpand_assert_left
                                                                                      tt)))
                                                                              (cons
                                                                                ("assert_right unexpansion"
                                                                                  %
                                                                                  string,
                                                                                  (fun
                                                                                    function_parameter
                                                                                    =>
                                                                                    let
                                                                                      '_ :=
                                                                                      function_parameter
                                                                                      in
                                                                                    Lwt._return
                                                                                      (test_unexpand_assert_right
                                                                                        tt)))
                                                                                (cons
                                                                                  ("assert_some annot unexpansion"
                                                                                    %
                                                                                    string,
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        '_ :=
                                                                                        function_parameter
                                                                                        in
                                                                                      Lwt._return
                                                                                        (test_unexpand_assert_some_annot
                                                                                          tt)))
                                                                                  (cons
                                                                                    ("assert_left annot unexpansion"
                                                                                      %
                                                                                      string,
                                                                                      (fun
                                                                                        function_parameter
                                                                                        =>
                                                                                        let
                                                                                          '_ :=
                                                                                          function_parameter
                                                                                          in
                                                                                        Lwt._return
                                                                                          (test_unexpand_assert_left_annot
                                                                                            tt)))
                                                                                    (cons
                                                                                      ("assert_right annot unexpansion"
                                                                                        %
                                                                                        string,
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            '_ :=
                                                                                            function_parameter
                                                                                            in
                                                                                          Lwt._return
                                                                                            (test_unexpand_assert_right_annot
                                                                                              tt)))
                                                                                      (cons
                                                                                        ("unpair unexpansion"
                                                                                          %
                                                                                          string,
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              '_ :=
                                                                                              function_parameter
                                                                                              in
                                                                                            Lwt._return
                                                                                              (test_unexpand_unpair
                                                                                                tt)))
                                                                                        (cons
                                                                                          ("pair unexpansion"
                                                                                            %
                                                                                            string,
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                '_ :=
                                                                                                function_parameter
                                                                                                in
                                                                                              Lwt._return
                                                                                                (test_unexpand_pair
                                                                                                  tt)))
                                                                                          (cons
                                                                                            ("pappaiir unexpansion"
                                                                                              %
                                                                                              string,
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                let
                                                                                                  '_ :=
                                                                                                  function_parameter
                                                                                                  in
                                                                                                Lwt._return
                                                                                                  (test_unexpand_pappaiir
                                                                                                    tt)))
                                                                                            (cons
                                                                                              ("duup unexpansion"
                                                                                                %
                                                                                                string,
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    '_ :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  Lwt._return
                                                                                                    (test_unexpand_duup
                                                                                                      tt)))
                                                                                              (cons
                                                                                                ("caddadr unexpansion"
                                                                                                  %
                                                                                                  string,
                                                                                                  (fun
                                                                                                    function_parameter
                                                                                                    =>
                                                                                                    let
                                                                                                      '_ :=
                                                                                                      function_parameter
                                                                                                      in
                                                                                                    Lwt._return
                                                                                                      (test_unexpand_caddadr
                                                                                                        tt)))
                                                                                                (cons
                                                                                                  ("set_car unexpansion"
                                                                                                    %
                                                                                                    string,
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        '_ :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      Lwt._return
                                                                                                        (test_unexpand_set_car
                                                                                                          tt)))
                                                                                                  (cons
                                                                                                    ("set_cdr unexpansion"
                                                                                                      %
                                                                                                      string,
                                                                                                      (fun
                                                                                                        function_parameter
                                                                                                        =>
                                                                                                        let
                                                                                                          '_ :=
                                                                                                          function_parameter
                                                                                                          in
                                                                                                        Lwt._return
                                                                                                          (test_unexpand_set_cdr
                                                                                                            tt)))
                                                                                                    (cons
                                                                                                      ("set_cadr unexpansion"
                                                                                                        %
                                                                                                        string,
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            '_ :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          Lwt._return
                                                                                                            (test_unexpand_set_cadr
                                                                                                              tt)))
                                                                                                      (cons
                                                                                                        ("set_car annot unexpansion"
                                                                                                          %
                                                                                                          string,
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            let
                                                                                                              '_ :=
                                                                                                              function_parameter
                                                                                                              in
                                                                                                            Lwt._return
                                                                                                              (test_unexpand_set_car_annot
                                                                                                                tt)))
                                                                                                        (cons
                                                                                                          ("set_cdr annot unexpansion"
                                                                                                            %
                                                                                                            string,
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                '_ :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              Lwt._return
                                                                                                                (test_unexpand_set_cdr_annot
                                                                                                                  tt)))
                                                                                                          (cons
                                                                                                            ("map_car unexpansion"
                                                                                                              %
                                                                                                              string,
                                                                                                              (fun
                                                                                                                function_parameter
                                                                                                                =>
                                                                                                                let
                                                                                                                  '_ :=
                                                                                                                  function_parameter
                                                                                                                  in
                                                                                                                Lwt._return
                                                                                                                  (test_unexpand_map_car
                                                                                                                    tt)))
                                                                                                            (cons
                                                                                                              ("diip_duup1 unexpansion"
                                                                                                                %
                                                                                                                string,
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    '_ :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  Lwt._return
                                                                                                                    (test_unexpand_diip_duup1
                                                                                                                      tt)))
                                                                                                              (cons
                                                                                                                ("diip_duup2 unexpansion"
                                                                                                                  %
                                                                                                                  string,
                                                                                                                  (fun
                                                                                                                    function_parameter
                                                                                                                    =>
                                                                                                                    let
                                                                                                                      '_ :=
                                                                                                                      function_parameter
                                                                                                                      in
                                                                                                                    Lwt._return
                                                                                                                      (test_unexpand_diip_duup2
                                                                                                                        tt)))
                                                                                                                [])))))))))))))))))))))))))))))))))))))))))))))))))))))).

Definition wrap {A B : Type}
  (function_parameter :
    A * (unit -> Lwt.t (sum unit Tezos_base__TzPervasives.trace))) : B :=
  let '(n, f) := function_parameter in
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (f tt)
          (fun function_parameter =>
            match function_parameter with
            | Stdlib.Ok tt => Lwt.return_unit
            | Stdlib.Error error =>
              Format.kasprintf Pervasives.failwith
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format) "%a" % string)
                pp_print_error error
            end)).



src/proto_alpha/lib_client_commands/alpha_commands_registration.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Client_commands.register Protocol.hash
  @@ fun network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Client_proto_programs_commands.commands ()
  @ Client_proto_contracts_commands.commands ()
  @ Client_proto_context_commands.commands network ()
  @ Client_proto_multisig_commands.commands ()
src/proto_alpha/lib_client_commands/alpha_commands_registration.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/proto_alpha/lib_client_commands/client_proto_context_commands.ml 217 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Tezos_micheline
open Client_proto_context
open Client_proto_contracts
open Client_proto_programs
open Client_keys
open Client_proto_args

let encrypted_switch =
  Clic.switch ~long:"encrypted" ~doc:"encrypt the key on-disk" ()

let dry_run_switch =
  Clic.switch
    ~long:"dry-run"
    ~short:'D'
    ~doc:"don't inject the operation, just display it"
    ()

let verbose_signing_switch =
  Clic.switch
    ~long:"verbose-signing"
    ~doc:"display extra information before signing the operation"
    ()

let report_michelson_errors ?(no_print_source = false) ~msg
    (cctxt : #Client_context.printer) = function
  | Error errs ->
      cctxt#warning
        "%a"
        (Michelson_v1_error_reporter.report_errors
           ~details:(not no_print_source)
           ~show_source:(not no_print_source)
           ?parsed:None)
        errs
      >>= fun () -> cctxt#error "%s" msg >>= fun () -> Lwt.return_none
  | Ok data ->
      Lwt.return_some data

let json_file_or_text_parameter =
  Clic.parameter (fun _ p ->
      match String.split ~limit:1 ':' p with
      | ["text"; text] ->
          return (Ezjsonm.from_string text)
      | ["file"; path] ->
          Lwt_utils_unix.Json.read_file path
      | _ -> (
          if Sys.file_exists p then Lwt_utils_unix.Json.read_file p
          else
            try return (Ezjsonm.from_string p)
            with Ezjsonm.Parse_error _ ->
              failwith "Neither an existing file nor valid JSON: '%s'" p ))

let data_parameter =
  Clic.parameter (fun _ data ->
      Lwt.return
        ( Micheline_parser.no_parsing_error
        @@ Michelson_v1_parser.parse_expression data ))

let non_negative_param =
  Clic.parameter (fun _ s ->
      match int_of_string_opt s with
      | Some i when i >= 0 ->
          return i
      | _ ->
          failwith "Parameter should be a non-negative integer literal")

let block_hash_param =
  Clic.parameter (fun _ s ->
      try return (Block_hash.of_b58check_exn s)
      with _ -> failwith "Parameter '%s' is an invalid block hash" s)

let group =
  {
    Clic.name = "context";
    title = "Block contextual commands (see option -block)";
  }

let alphanet = {Clic.name = "alphanet"; title = "Alphanet only commands"}

let binary_description =
  {Clic.name = "description"; title = "Binary Description"}

let commands version () =
  let open Clic in
  [ command
      ~group
      ~desc:"Access the timestamp of the block."
      (args1
         (switch ~doc:"output time in seconds" ~short:'s' ~long:"seconds" ()))
      (fixed ["get"; "timestamp"])
      (fun seconds (cctxt : Protocol_client_context.full) ->
        Shell_services.Blocks.Header.shell_header
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ()
        >>=? fun {timestamp = v; _} ->
        ( if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v)
        else cctxt#message "%s" (Time.Protocol.to_notation v) )
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Lists all non empty contracts of the block."
      no_options
      (fixed ["list"; "contracts"])
      (fun () (cctxt : Protocol_client_context.full) ->
        list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block
        >>=? fun contracts ->
        Lwt_list.iter_s
          (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias)
          contracts
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get the balance of a contract."
      no_options
      ( prefixes ["get"; "balance"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract
        >>=? fun amount ->
        cctxt#answer "%a %s" Tez.pp amount Client_proto_args.tez_sym
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get the storage of a contract."
      no_options
      ( prefixes ["get"; "contract"; "storage"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        get_storage cctxt ~chain:cctxt#chain ~block:cctxt#block contract
        >>=? function
        | None ->
            cctxt#error "This is not a smart contract."
        | Some storage ->
            cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Get the value associated to a key in the big map storage of a \
         contract (deprecated)."
      no_options
      ( prefixes ["get"; "big"; "map"; "value"; "for"]
      @@ Clic.param ~name:"key" ~desc:"the key to look for" data_parameter
      @@ prefixes ["of"; "type"]
      @@ Clic.param ~name:"type" ~desc:"type of the key" data_parameter
      @@ prefix "in"
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () key key_type (_, contract) (cctxt : Protocol_client_context.full) ->
        get_contract_big_map_value
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          contract
          (key.expanded, key_type.expanded)
        >>=? function
        | None ->
            cctxt#error "No value associated to this key."
        | Some value ->
            cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get a value in a big map."
      no_options
      ( prefixes ["get"; "element"]
      @@ Clic.param
           ~name:"key"
           ~desc:"the key to look for"
           (Clic.parameter (fun _ s ->
                return (Script_expr_hash.of_b58check_exn s)))
      @@ prefixes ["of"; "big"; "map"]
      @@ Clic.param
           ~name:"big_map"
           ~desc:"identifier of the big_map"
           int_parameter
      @@ stop )
      (fun () key id (cctxt : Protocol_client_context.full) ->
        get_big_map_value
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          (Z.of_int id)
          key
        >>=? fun value ->
        cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Get the code of a contract."
      no_options
      ( prefixes ["get"; "contract"; "code"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        get_script cctxt ~chain:cctxt#chain ~block:cctxt#block contract
        >>=? function
        | None ->
            cctxt#error "This is not a smart contract."
        | Some {code; storage = _} -> (
          match Script_repr.force_decode code with
          | Error errs ->
              cctxt#error
                "%a"
                (Format.pp_print_list
                   ~pp_sep:Format.pp_print_newline
                   Environment.Error_monad.pp)
                errs
          | Ok (code, _) ->
              let {Michelson_v1_parser.source; _} =
                Michelson_v1_printer.unparse_toplevel code
              in
              cctxt#answer "%a" Format.pp_print_text source >>= return ));
    command
      ~group
      ~desc:"Get the type of an entrypoint of a contract."
      no_options
      ( prefixes ["get"; "contract"; "entrypoint"; "type"; "of"]
      @@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe"
      @@ prefixes ["for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () entrypoint (_, contract) (cctxt : Protocol_client_context.full) ->
        Michelson_v1_entrypoints.contract_entrypoint_type
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~contract
          ~entrypoint
        >>= Michelson_v1_entrypoints.print_entrypoint_type
              cctxt
              ~emacs:false
              ~contract
              ~entrypoint);
    command
      ~group
      ~desc:"Get the entrypoint list of a contract."
      no_options
      ( prefixes ["get"; "contract"; "entrypoints"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        Michelson_v1_entrypoints.list_contract_entrypoints
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~contract
        >>= Michelson_v1_entrypoints.print_entrypoints_list
              cctxt
              ~emacs:false
              ~contract);
    command
      ~group
      ~desc:"Get the list of unreachable pathsin a contract's parameter type."
      no_options
      ( prefixes ["get"; "contract"; "unreachable"; "paths"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        Michelson_v1_entrypoints.list_contract_unreachables
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~contract
        >>= Michelson_v1_entrypoints.print_unreachables
              cctxt
              ~emacs:false
              ~contract);
    command
      ~group
      ~desc:"Get the delegate of a contract."
      no_options
      ( prefixes ["get"; "delegate"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        Client_proto_contracts.get_delegate
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          contract
        >>=? function
        | None ->
            cctxt#message "none" >>= fun () -> return_unit
        | Some delegate ->
            Public_key_hash.rev_find cctxt delegate
            >>=? fun mn ->
            Public_key_hash.to_source delegate
            >>=? fun m ->
            cctxt#message
              "%s (%s)"
              m
              (match mn with None -> "unknown" | Some n -> "known as " ^ n)
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Set the delegate of a contract."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["set"; "delegate"; "for"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ prefix "to"
      @@ Public_key_hash.alias_param
           ~name:"mgr"
           ~desc:"new delegate of the contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           (_, contract)
           (_, delegate)
           (cctxt : Protocol_client_context.full) ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        match Contract.is_implicit contract with
        | None ->
            Managed_contract.get_contract_manager cctxt contract
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~source
              ~src_pk
              ~src_sk
              contract
              (Some delegate)
            >>= fun errors ->
            report_michelson_errors
              ~no_print_source:true
              ~msg:"Setting delegate through entrypoints failed."
              cctxt
              errors
            >>= fun _ -> return_unit
        | Some mgr ->
            Client_keys.get_key cctxt mgr
            >>=? fun (_, src_pk, manager_sk) ->
            set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              mgr
              (Some delegate)
              ~src_pk
              ~manager_sk
            >>=? fun _ -> return_unit);
    command
      ~group
      ~desc:"Withdraw the delegate from a contract."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["withdraw"; "delegate"; "from"]
      @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           (_, contract)
           (cctxt : Protocol_client_context.full) ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        match Contract.is_implicit contract with
        | None ->
            Managed_contract.get_contract_manager cctxt contract
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~source
              ~src_pk
              ~src_sk
              contract
              None
            >>= fun errors ->
            report_michelson_errors
              ~no_print_source:true
              ~msg:"Withdrawing delegate through entrypoints failed."
              cctxt
              errors
            >>= fun _ -> return_unit
        | Some mgr ->
            Client_keys.get_key cctxt mgr
            >>=? fun (_, src_pk, manager_sk) ->
            set_delegate
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              mgr
              None
              ?fee
              ~src_pk
              ~manager_sk
            >>= fun _ -> return_unit);
    command
      ~group
      ~desc:"Launch a smart contract on the blockchain."
      (args15
         fee_arg
         dry_run_switch
         verbose_signing_switch
         gas_limit_arg
         storage_limit_arg
         delegate_arg
         (Client_keys.force_switch ())
         init_arg
         no_print_source_flag
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["originate"; "contract"]
      @@ RawContractAlias.fresh_alias_param
           ~name:"new"
           ~desc:"name of the new contract"
      @@ prefix "transferring"
      @@ tez_param ~name:"qty" ~desc:"amount taken from source"
      @@ prefix "from"
      @@ ContractAlias.destination_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ prefix "running"
      @@ Program.source_param
           ~name:"prg"
           ~desc:
             "script of the account\n\
              Combine with -init if the storage type is not unit."
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             gas_limit,
             storage_limit,
             delegate,
             force,
             initial_storage,
             no_print_source,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           alias_name
           balance
           (_, source)
           program
           (cctxt : Protocol_client_context.full) ->
        RawContractAlias.of_fresh cctxt force alias_name
        >>=? fun alias_name ->
        Lwt.return (Micheline_parser.no_parsing_error program)
        >>=? fun {expanded = code; _} ->
        match Contract.is_implicit source with
        | None ->
            failwith
              "only implicit accounts can be the source of an origination"
        | Some source -> (
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            let fee_parameter =
              {
                Injection.minimal_fees;
                minimal_nanotez_per_byte;
                minimal_nanotez_per_gas_unit;
                force_low_fee;
                fee_cap;
                burn_cap;
              }
            in
            originate_contract
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ?fee
              ?gas_limit
              ?storage_limit
              ~delegate
              ~initial_storage
              ~balance
              ~source
              ~src_pk
              ~src_sk
              ~code
              ~fee_parameter
              ()
            >>= fun errors ->
            report_michelson_errors
              ~no_print_source
              ~msg:"origination simulation failed"
              cctxt
              errors
            >>= function
            | None ->
                return_unit
            | Some (_res, contract) ->
                if dry_run then return_unit
                else
                  save_contract ~force cctxt alias_name contract
                  >>=? fun () -> return_unit ));
    command
      ~group
      ~desc:"Transfer tokens / call a smart contract."
      (args15
         fee_arg
         dry_run_switch
         verbose_signing_switch
         gas_limit_arg
         storage_limit_arg
         counter_arg
         arg_arg
         no_print_source_flag
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg
         entrypoint_arg)
      ( prefixes ["transfer"]
      @@ tez_param ~name:"qty" ~desc:"amount taken from source"
      @@ prefix "from"
      @@ ContractAlias.destination_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ prefix "to"
      @@ ContractAlias.destination_param
           ~name:"dst"
           ~desc:"name/literal of the destination contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             gas_limit,
             storage_limit,
             counter,
             arg,
             no_print_source,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap,
             entrypoint )
           amount
           (_, source)
           (_, destination)
           cctxt ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        ( match Contract.is_implicit source with
        | None ->
            let contract = source in
            Managed_contract.get_contract_manager cctxt source
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~contract
              ~source
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              ()
        | Some source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ~source
              ?fee
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              () )
        >>= report_michelson_errors
              ~no_print_source
              ~msg:"transfer simulation failed"
              cctxt
        >>= function
        | None -> return_unit | Some (_res, _contracts) -> return_unit);
    command
      ~group
      ~desc:"Call a smart contract (same as 'transfer 0')."
      (args15
         fee_arg
         dry_run_switch
         verbose_signing_switch
         gas_limit_arg
         storage_limit_arg
         counter_arg
         arg_arg
         no_print_source_flag
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg
         entrypoint_arg)
      ( prefixes ["call"]
      @@ prefix "from"
      @@ ContractAlias.destination_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ prefix "to"
      @@ ContractAlias.destination_param
           ~name:"dst"
           ~desc:"name/literal of the destination contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             gas_limit,
             storage_limit,
             counter,
             arg,
             no_print_source,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap,
             entrypoint )
           (_, source)
           (_, destination)
           cctxt ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        let amount = Tez.zero in
        ( match Contract.is_implicit source with
        | None ->
            let contract = source in
            Managed_contract.get_contract_manager cctxt source
            >>=? fun source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            Managed_contract.transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ?fee
              ~contract
              ~source
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              ()
        | Some source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            transfer
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              ~verbose_signing
              ~fee_parameter
              ~source
              ?fee
              ~src_pk
              ~src_sk
              ~destination
              ?entrypoint
              ?arg
              ~amount
              ?gas_limit
              ?storage_limit
              ?counter
              () )
        >>= report_michelson_errors
              ~no_print_source
              ~msg:"transfer simulation failed"
              cctxt
        >>= function
        | None -> return_unit | Some (_res, _contracts) -> return_unit);
    command
      ~group
      ~desc:"Reveal the public key of the contract manager."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["reveal"; "key"; "for"]
      @@ ContractAlias.alias_param
           ~name:"src"
           ~desc:"name of the source contract"
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           (_, source)
           cctxt ->
        match Contract.is_implicit source with
        | None ->
            failwith "only implicit accounts can be revealed"
        | Some source ->
            Client_keys.get_key cctxt source
            >>=? fun (_, src_pk, src_sk) ->
            let fee_parameter =
              {
                Injection.minimal_fees;
                minimal_nanotez_per_byte;
                minimal_nanotez_per_gas_unit;
                force_low_fee;
                fee_cap;
                burn_cap;
              }
            in
            reveal
              cctxt
              ~dry_run
              ~verbose_signing
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~source
              ?fee
              ~src_pk
              ~src_sk
              ~fee_parameter
              ()
            >>=? fun _res -> return_unit);
    command
      ~group
      ~desc:"Register the public key hash as a delegate."
      (args9
         fee_arg
         dry_run_switch
         verbose_signing_switch
         minimal_fees_arg
         minimal_nanotez_per_byte_arg
         minimal_nanotez_per_gas_unit_arg
         force_low_fee_arg
         fee_cap_arg
         burn_cap_arg)
      ( prefixes ["register"; "key"]
      @@ Public_key_hash.source_param ~name:"mgr" ~desc:"the delegate key"
      @@ prefixes ["as"; "delegate"]
      @@ stop )
      (fun ( fee,
             dry_run,
             verbose_signing,
             minimal_fees,
             minimal_nanotez_per_byte,
             minimal_nanotez_per_gas_unit,
             force_low_fee,
             fee_cap,
             burn_cap )
           src_pkh
           cctxt ->
        Client_keys.get_key cctxt src_pkh
        >>=? fun (_, src_pk, src_sk) ->
        let fee_parameter =
          {
            Injection.minimal_fees;
            minimal_nanotez_per_byte;
            minimal_nanotez_per_gas_unit;
            force_low_fee;
            fee_cap;
            burn_cap;
          }
        in
        register_as_delegate
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ?confirmations:cctxt#confirmations
          ~dry_run
          ~fee_parameter
          ~verbose_signing
          ?fee
          ~manager_sk:src_sk
          src_pk
        >>= function
        | Ok _ ->
            return_unit
        | Error [Environment.Ecoproto_error Delegate_storage.Active_delegate]
          ->
            cctxt#message "Delegate already activated."
            >>= fun () -> return_unit
        | Error el ->
            Lwt.return_error el) ]
  @ ( if version = Some `Mainnet then []
    else
      [ command
          ~group
          ~desc:"Register and activate an Alphanet/Zeronet faucet account."
          (args2 (Secret_key.force_switch ()) encrypted_switch)
          ( prefixes ["activate"; "account"]
          @@ Secret_key.fresh_alias_param
          @@ prefixes ["with"]
          @@ param
               ~name:"activation_key"
               ~desc:
                 "Activate an Alphanet/Zeronet faucet account from the JSON \
                  (file or directly inlined)."
               json_file_or_text_parameter
          @@ stop )
          (fun (force, encrypted) name activation_json cctxt ->
            Secret_key.of_fresh cctxt force name
            >>=? fun name ->
            match
              Data_encoding.Json.destruct
                Client_proto_context.activation_key_encoding
                activation_json
            with
            | exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
                Format.kasprintf
                  (fun s -> failwith "%s" s)
                  "Invalid activation file: %a %a"
                  (fun ppf -> Data_encoding.Json.print_error ppf)
                  exn
                  Data_encoding.Json.pp
                  activation_json
            | key ->
                activate_account
                  cctxt
                  ~chain:cctxt#chain
                  ~block:cctxt#block
                  ?confirmations:cctxt#confirmations
                  ~encrypted
                  ~force
                  key
                  name
                >>=? fun _res -> return_unit) ] )
  @ ( if version <> Some `Mainnet then []
    else
      [ command
          ~group
          ~desc:"Activate a fundraiser account."
          (args1 dry_run_switch)
          ( prefixes ["activate"; "fundraiser"; "account"]
          @@ Public_key_hash.alias_param
          @@ prefixes ["with"]
          @@ param
               ~name:"code"
               (Clic.parameter (fun _ctx code ->
                    protect (fun () ->
                        return
                          (Blinded_public_key_hash.activation_code_of_hex code))))
               ~desc:"Activation code obtained from the Tezos foundation."
          @@ stop )
          (fun dry_run (name, _pkh) code cctxt ->
            activate_existing_account
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ?confirmations:cctxt#confirmations
              ~dry_run
              name
              code
            >>=? fun _res -> return_unit) ] )
  @ [ command
        ~desc:"Wait until an operation is included in a block"
        (args3
           (default_arg
              ~long:"confirmations"
              ~placeholder:"num_blocks"
              ~doc:
                "wait until 'N' additional blocks after the operation appears \
                 in the considered chain"
              ~default:"0"
              non_negative_param)
           (default_arg
              ~long:"check-previous"
              ~placeholder:"num_blocks"
              ~doc:"number of previous blocks to check"
              ~default:"10"
              non_negative_param)
           (arg
              ~long:"branch"
              ~placeholder:"block_hash"
              ~doc:
                "hash of the oldest block where we should look for the \
                 operation"
              block_hash_param))
        ( prefixes ["wait"; "for"]
        @@ param
             ~name:"operation"
             ~desc:"Operation to be included"
             (parameter (fun _ x ->
                  match Operation_hash.of_b58check_opt x with
                  | None ->
                      Error_monad.failwith "Invalid operation hash: '%s'" x
                  | Some hash ->
                      return hash))
        @@ prefixes ["to"; "be"; "included"]
        @@ stop )
        (fun (confirmations, predecessors, branch)
             operation_hash
             (ctxt : Protocol_client_context.full) ->
          Client_confirmations.wait_for_operation_inclusion
            ctxt
            ~chain:ctxt#chain
            ~confirmations
            ~predecessors
            ?branch
            operation_hash
          >>=? fun _ -> return_unit);
      command
        ~desc:"Get receipt for past operation"
        (args1
           (default_arg
              ~long:"check-previous"
              ~placeholder:"num_blocks"
              ~doc:"number of previous blocks to check"
              ~default:"10"
              non_negative_param))
        ( prefixes ["get"; "receipt"; "for"]
        @@ param
             ~name:"operation"
             ~desc:"Operation to be looked up"
             (parameter (fun _ x ->
                  match Operation_hash.of_b58check_opt x with
                  | None ->
                      Error_monad.failwith "Invalid operation hash: '%s'" x
                  | Some hash ->
                      return hash))
        @@ stop )
        (fun predecessors operation_hash (ctxt : Protocol_client_context.full) ->
          display_receipt_for_operation
            ctxt
            ~chain:ctxt#chain
            ~predecessors
            operation_hash
          >>=? fun _ -> return_unit);
      command
        ~group:binary_description
        ~desc:"Describe unsigned block header"
        no_options
        (fixed ["describe"; "unsigned"; "block"; "header"])
        (fun () (cctxt : Protocol_client_context.full) ->
          cctxt#message
            "%a"
            Data_encoding.Binary_schema.pp
            (Data_encoding.Binary.describe
               Alpha_context.Block_header.unsigned_encoding)
          >>= fun () -> return_unit);
      command
        ~group:binary_description
        ~desc:"Describe unsigned block header"
        no_options
        (fixed ["describe"; "unsigned"; "operation"])
        (fun () (cctxt : Protocol_client_context.full) ->
          cctxt#message
            "%a"
            Data_encoding.Binary_schema.pp
            (Data_encoding.Binary.describe
               Alpha_context.Operation.unsigned_encoding)
          >>= fun () -> return_unit);
      command
        ~group
        ~desc:"Submit protocol proposals"
        (args3
           dry_run_switch
           verbose_signing_switch
           (switch
              ~doc:
                "Do not fail when the checks that try to prevent the user \
                 from shooting themselves in the foot do."
              ~long:"force"
              ()))
        ( prefixes ["submit"; "proposals"; "for"]
        @@ Client_keys.Secret_key.alias_param
             ~name:"delegate"
             ~desc:"the delegate who makes the proposal"
        @@ seq_of_param
             (param
                ~name:"proposal"
                ~desc:"the protocol hash proposal to be submitted"
                (parameter (fun _ x ->
                     match Protocol_hash.of_b58check_opt x with
                     | None ->
                         Error_monad.failwith "Invalid proposal hash: '%s'" x
                     | Some hash ->
                         return hash))) )
        (fun (dry_run, verbose_signing, force)
             (src_name, src_sk)
             proposals
             (cctxt : Protocol_client_context.full) ->
          Client_keys.neuterize src_sk
          >>=? fun src_pk ->
          Client_keys.public_key_hash src_pk
          >>=? fun (src_pkh, _) ->
          get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun info ->
          ( match info.current_period_kind with
          | Proposal ->
              return_unit
          | _ ->
              cctxt#error "Not in a proposal period" )
          >>=? fun () ->
          Shell_services.Protocol.list cctxt
          >>=? fun known_protos ->
          get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun known_proposals ->
          Alpha_services.Voting.listings cctxt (cctxt#chain, cctxt#block)
          >>=? fun listings ->
          (* for a proposal to be valid it must either a protocol that was already
           proposed by somebody else or a protocol known by the node, because
           the user is the first proposer and just injected it with
           tezos-admin-client *)
          let check_proposals proposals : bool tzresult Lwt.t =
            let n = List.length proposals in
            let errors = ref [] in
            let error ppf =
              Format.kasprintf (fun s -> errors := s :: !errors) ppf
            in
            if n = 0 then error "Empty proposal list." ;
            if n > Constants.fixed.max_proposals_per_delegate then
              error
                "Too many proposals: %d > %d."
                n
                Constants.fixed.max_proposals_per_delegate ;
            ( match
                Base.List.find_all_dups
                  ~compare:Protocol_hash.compare
                  proposals
              with
            | [] ->
                ()
            | dups ->
                error
                  "There %s: %a."
                  ( if List.length dups = 1 then "is a duplicate proposal"
                  else "are duplicate proposals" )
                  Format.(
                    pp_print_list
                      ~pp_sep:(fun ppf () -> pp_print_string ppf ", ")
                      Protocol_hash.pp)
                  dups ) ;
            List.iter
              (fun (p : Protocol_hash.t) ->
                if
                  List.mem p known_protos
                  || Environment.Protocol_hash.Map.mem p known_proposals
                then ()
                else
                  error
                    "Protocol %a is not a known proposal."
                    Protocol_hash.pp
                    p)
              proposals ;
            if
              not
                (List.exists
                   (fun (pkh, _) ->
                     Signature.Public_key_hash.equal pkh src_pkh)
                   listings)
            then
              error
                "Public-key-hash `%a` from account `%s` does not appear to \
                 have voting rights."
                Signature.Public_key_hash.pp
                src_pkh
                src_name ;
            if !errors <> [] then
              cctxt#message
                "There %s with the submission:%t"
                ( if List.length !errors = 1 then "is an issue"
                else "are issues" )
                Format.(
                  fun ppf ->
                    pp_print_cut ppf () ;
                    pp_open_vbox ppf 0 ;
                    List.iter
                      (fun msg ->
                        pp_open_hovbox ppf 2 ;
                        pp_print_string ppf "* " ;
                        pp_print_text ppf msg ;
                        pp_close_box ppf () ;
                        pp_print_cut ppf ())
                      !errors ;
                    pp_close_box ppf ())
              >>= fun () -> return_false
            else return_true
          in
          check_proposals proposals
          >>=? fun all_valid ->
          ( if all_valid then cctxt#message "All proposals are valid."
          else if force then
            cctxt#message
              "Some proposals are not valid, but `--force` was used."
          else cctxt#error "Submission failed because of invalid proposals." )
          >>= fun () ->
          submit_proposals
            ~dry_run
            ~verbose_signing
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~src_sk
            src_pkh
            proposals
          >>= function
          | Ok _res ->
              return_unit
          | Error errs ->
              ( match errs with
              | [ Unregistred_error
                    (`O [("kind", `String "generic"); ("error", `String msg)])
                ] ->
                  cctxt#message
                    "Error:@[<hov>@.%a@]"
                    Format.pp_print_text
                    ( String.split_on_char ' ' msg
                    |> List.filter (function "" | "\n" -> false | _ -> true)
                    |> String.concat " "
                    |> String.map (function '\n' | '\t' -> ' ' | c -> c) )
              | el ->
                  cctxt#message "Error:@ %a" pp_print_error el )
              >>= fun () -> failwith "Failed to submit proposals");
      command
        ~group
        ~desc:"Submit a ballot"
        (args2 verbose_signing_switch dry_run_switch)
        ( prefixes ["submit"; "ballot"; "for"]
        @@ Client_keys.Secret_key.alias_param
             ~name:"delegate"
             ~desc:"the delegate who votes"
        @@ param
             ~name:"proposal"
             ~desc:"the protocol hash proposal to vote for"
             (parameter (fun _ x ->
                  match Protocol_hash.of_b58check_opt x with
                  | None ->
                      failwith "Invalid proposal hash: '%s'" x
                  | Some hash ->
                      return hash))
        @@ param
             ~name:"ballot"
             ~desc:"the ballot value (yea/yay, nay, or pass)"
             (parameter
                ~autocomplete:(fun _ -> return ["yea"; "nay"; "pass"])
                (fun _ s ->
                  (* We should have [Vote.of_string]. *)
                  match String.lowercase_ascii s with
                  | "yay" | "yea" ->
                      return Vote.Yay
                  | "nay" ->
                      return Vote.Nay
                  | "pass" ->
                      return Vote.Pass
                  | s ->
                      failwith "Invalid ballot: '%s'" s))
        @@ stop )
        (fun (verbose_signing, dry_run)
             (_, src_sk)
             proposal
             ballot
             (cctxt : Protocol_client_context.full) ->
          Client_keys.neuterize src_sk
          >>=? fun src_pk ->
          Client_keys.public_key_hash src_pk
          >>=? fun (src_pkh, _) ->
          get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun info ->
          ( match info.current_period_kind with
          | Testing_vote | Promotion_vote ->
              return_unit
          | _ ->
              cctxt#error "Not in a Testing_vote or Promotion_vote period" )
          >>=? fun () ->
          submit_ballot
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~src_sk
            src_pkh
            ~verbose_signing
            ~dry_run
            proposal
            ballot
          >>=? fun _res -> return_unit);
      command
        ~group
        ~desc:"Summarize the current voting period"
        no_options
        (fixed ["show"; "voting"; "period"])
        (fun () (cctxt : Protocol_client_context.full) ->
          get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun info ->
          cctxt#message
            "Current period: %a\nBlocks remaining until end of period: %ld"
            Data_encoding.Json.pp
            (Data_encoding.Json.construct
               Alpha_context.Voting_period.kind_encoding
               info.current_period_kind)
            info.remaining
          >>= fun () ->
          Shell_services.Protocol.list cctxt
          >>=? fun known_protos ->
          get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt
          >>=? fun props ->
          let ranks =
            Environment.Protocol_hash.Map.bindings props
            |> List.sort (fun (_, v1) (_, v2) -> Int32.(compare v2 v1))
          in
          let print_proposal = function
            | None ->
                assert false (* not called during proposal phase *)
            | Some proposal ->
                cctxt#message "Current proposal: %a" Protocol_hash.pp proposal
          in
          match info.current_period_kind with
          | Proposal ->
              cctxt#answer
                "Current proposals:%t"
                Format.(
                  fun ppf ->
                    pp_print_cut ppf () ;
                    pp_open_vbox ppf 0 ;
                    List.iter
                      (fun (p, w) ->
                        fprintf
                          ppf
                          "* %a %ld (%sknown by the node)@."
                          Protocol_hash.pp
                          p
                          w
                          (if List.mem p known_protos then "" else "not "))
                      ranks ;
                    pp_close_box ppf ())
              >>= fun () -> return_unit
          | Testing_vote | Promotion_vote ->
              print_proposal info.current_proposal
              >>= fun () ->
              get_ballots_info ~chain:cctxt#chain ~block:cctxt#block cctxt
              >>=? fun ballots_info ->
              cctxt#answer
                "Ballots: %a@,\
                 Current participation %.2f%%, necessary quorum %.2f%%@,\
                 Current in favor %ld, needed supermajority %ld"
                Data_encoding.Json.pp
                (Data_encoding.Json.construct
                   Vote.ballots_encoding
                   ballots_info.ballots)
                (Int32.to_float ballots_info.participation /. 100.)
                (Int32.to_float ballots_info.current_quorum /. 100.)
                ballots_info.ballots.yay
                ballots_info.supermajority
              >>= fun () -> return_unit
          | Testing ->
              print_proposal info.current_proposal >>= fun () -> return_unit)
    ]
src/proto_alpha/lib_client_commands/client_proto_context_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Tezos_micheline.

Import Client_proto_context.

Import Client_proto_contracts.

Import Client_proto_programs.

Import Client_keys.

Import Client_proto_args.

Definition encrypted_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.switch "encrypt the key on-disk" % string None "encrypted" % string tt.

Definition dry_run_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.switch "don't inject the operation, just display it" % string
    (Some "D" % char) "dry-run" % string tt.

Definition verbose_signing_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.switch "display extra information before signing the operation" % string
    None "verbose-signing" % string tt.

Definition report_michelson_errors {C D a b : Type}
  (op_staroptstar : option bool)
  : string ->
    (((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C) ->
      (sum D (list Tezos_base__TzPervasives.Error_monad.error)) ->
        Lwt.t (option D) :=
  let no_print_source :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun msg =>
    fun cctxt =>
      fun function_parameter =>
        match function_parameter with
        | Stdlib.Error errs =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format) "%a" % string)
              (Michelson_v1_error_reporter.report_errors (negb no_print_source)
                (negb no_print_source) None) errs)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String
                      CamlinternalFormatBasics.No_padding
                      CamlinternalFormatBasics.End_of_format) "%s" % string) msg)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Lwt.return_none))
        | Stdlib.Ok data => Lwt.return_some data
        end.

Definition json_file_or_text_parameter
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_data_encoding.Data_encoding.json
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun p =>
        match String.split ":" % char None (Some 1) p with
        | cons "text" % string (cons text []) =>
          _return (Ezjsonm.from_string text)
        | cons "file" % string (cons path []) =>
          Lwt_utils_unix.Json.read_file path
        | _ =>
          if Sys.file_exists p then
            Lwt_utils_unix.Json.read_file p
          else
            (* ❌ Try-with are not handled *)
            try (_return (Ezjsonm.from_string p))
        end).

Definition data_parameter
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_client_alpha.Michelson_v1_parser.parsed
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun data =>
        Lwt._return
          (apply Micheline_parser.no_parsing_error
            (Michelson_v1_parser.parse_expression None data))).

Definition non_negative_param
  : Tezos_base__TzPervasives.Clic.parameter Z
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        match Stdlib.int_of_string_opt s with
        | Some i => _return i
        | _ =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Parameter should be a non-negative integer literal" % string
                CamlinternalFormatBasics.End_of_format)
              "Parameter should be a non-negative integer literal" % string)
        end).

Definition block_hash_param
  : Tezos_base__TzPervasives.Clic.parameter
    Tezos_base__TzPervasives.Block_hash.t
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun s =>
        (* ❌ Try-with are not handled *)
        try (_return (Block_hash.of_b58check_exn s))).

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "context" % string;
    Clic.title := "Block contextual commands (see option -block)" % string |}.

Definition alphanet : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "alphanet" % string;
    Clic.title := "Alphanet only commands" % string |}.

Definition binary_description : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "description" % string;
    Clic.title := "Binary Description" % string |}.

Definition commands (version : option variant) (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  OCaml.Stdlib.app
    (cons
      (command (Some group) "Access the timestamp of the block." % string
        (args1
          (switch "output time in seconds" % string (Some "s" % char)
            "seconds" % string tt))
        (fixed (cons "get" % string (cons "timestamp" % string [])))
        (fun seconds =>
          fun cctxt =>
            op_gtgteqquestion
              (Shell_services.Blocks.Header.shell_header cctxt
                (Some
                  (* ❌ Sending method message is not handled *)
                  send)
                (Some
                  (* ❌ Sending method message is not handled *)
                  send) tt)
              (fun function_parameter =>
                let '{| timestamp := v |} := function_parameter in
                op_gtgteq
                  (if seconds then
                    (* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Int64
                          CamlinternalFormatBasics.Int_d
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.No_precision
                          CamlinternalFormatBasics.End_of_format) "%Ld" % string)
                      (Time.Protocol.to_seconds v)
                  else
                    (* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.End_of_format) "%s" % string)
                      (Time.Protocol.to_notation v))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit))))
      (cons
        (command (Some group)
          "Lists all non empty contracts of the block." % string no_options
          (fixed (cons "list" % string (cons "contracts" % string [])))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun cctxt =>
              op_gtgteqquestion
                (list_contract_labels cctxt
                  (* ❌ Sending method message is not handled *)
                  send
                  (* ❌ Sending method message is not handled *)
                  send)
                (fun contracts =>
                  op_gtgteq
                    (Lwt_list.iter_s
                      (fun function_parameter =>
                        let '(alias, hash, kind) := function_parameter in
                        (* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format)))
                            "%s%s%s" % string) hash kind alias) contracts)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit))))
        (cons
          (command (Some group) "Get the balance of a contract." % string
            no_options
            (apply
              (prefixes
                (cons "get" % string
                  (cons "balance" % string (cons "for" % string []))))
              (apply
                (ContractAlias.destination_param (Some "src" % string)
                  (Some "source contract" % string)) stop))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let '(_, contract) := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion
                    (get_balance cctxt
                      (* ❌ Sending method message is not handled *)
                      send
                      (* ❌ Sending method message is not handled *)
                      send contract)
                    (fun amount =>
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Char_literal " " % char
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  CamlinternalFormatBasics.End_of_format)))
                            "%a %s" % string) Tez.pp amount
                          Client_proto_args.tez_sym)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit))))
          (cons
            (command (Some group) "Get the storage of a contract." % string
              no_options
              (apply
                (prefixes
                  (cons "get" % string
                    (cons "contract" % string
                      (cons "storage" % string (cons "for" % string [])))))
                (apply
                  (ContractAlias.destination_param (Some "src" % string)
                    (Some "source contract" % string)) stop))
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun function_parameter =>
                  let '(_, contract) := function_parameter in
                  fun cctxt =>
                    op_gtgteqquestion
                      (get_storage cctxt
                        (* ❌ Sending method message is not handled *)
                        send
                        (* ❌ Sending method message is not handled *)
                        send contract)
                      (fun function_parameter =>
                        match function_parameter with
                        | None =>
                          (* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "This is not a smart contract." % string
                                CamlinternalFormatBasics.End_of_format)
                              "This is not a smart contract." % string)
                        | Some storage =>
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format)
                                "%a" % string)
                              Michelson_v1_printer.print_expr_unwrapped storage)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit)
                        end)))
            (cons
              (command (Some group)
                "Get the value associated to a key in the big map storage of a contract (deprecated)."
                  % string no_options
                (apply
                  (prefixes
                    (cons "get" % string
                      (cons "big" % string
                        (cons "map" % string
                          (cons "value" % string (cons "for" % string []))))))
                  (apply
                    (Clic.param "key" % string "the key to look for" % string
                      data_parameter)
                    (apply
                      (prefixes (cons "of" % string (cons "type" % string [])))
                      (apply
                        (Clic.param "type" % string "type of the key" % string
                          data_parameter)
                        (apply (prefix "in" % string)
                          (apply
                            (ContractAlias.destination_param
                              (Some "src" % string)
                              (Some "source contract" % string)) stop))))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  fun key =>
                    fun key_type =>
                      fun function_parameter =>
                        let '(_, contract) := function_parameter in
                        fun cctxt =>
                          op_gtgteqquestion
                            (get_contract_big_map_value cctxt
                              (* ❌ Sending method message is not handled *)
                              send
                              (* ❌ Sending method message is not handled *)
                              send contract
                              ((expanded key), (expanded key_type)))
                            (fun function_parameter =>
                              match function_parameter with
                              | None =>
                                (* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "No value associated to this key." %
                                        string
                                      CamlinternalFormatBasics.End_of_format)
                                    "No value associated to this key." % string)
                              | Some value =>
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format)
                                      "%a" % string)
                                    Michelson_v1_printer.print_expr_unwrapped
                                    value)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit)
                              end)))
              (cons
                (command (Some group) "Get a value in a big map." % string
                  no_options
                  (apply
                    (prefixes (cons "get" % string (cons "element" % string [])))
                    (apply
                      (Clic.param "key" % string "the key to look for" % string
                        (Clic.parameter None
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            fun s =>
                              _return (Script_expr_hash.of_b58check_exn s))))
                      (apply
                        (prefixes
                          (cons "of" % string
                            (cons "big" % string (cons "map" % string []))))
                        (apply
                          (Clic.param "big_map" % string
                            "identifier of the big_map" % string int_parameter)
                          stop))))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    fun key =>
                      fun id =>
                        fun cctxt =>
                          op_gtgteqquestion
                            (get_big_map_value cctxt
                              (* ❌ Sending method message is not handled *)
                              send
                              (* ❌ Sending method message is not handled *)
                              send (Z.of_int id) key)
                            (fun value =>
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format)
                                    "%a" % string)
                                  Michelson_v1_printer.print_expr_unwrapped
                                  value)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit))))
                (cons
                  (command (Some group) "Get the code of a contract." % string
                    no_options
                    (apply
                      (prefixes
                        (cons "get" % string
                          (cons "contract" % string
                            (cons "code" % string (cons "for" % string [])))))
                      (apply
                        (ContractAlias.destination_param (Some "src" % string)
                          (Some "source contract" % string)) stop))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      fun function_parameter =>
                        let '(_, contract) := function_parameter in
                        fun cctxt =>
                          op_gtgteqquestion
                            (get_script cctxt
                              (* ❌ Sending method message is not handled *)
                              send
                              (* ❌ Sending method message is not handled *)
                              send contract)
                            (fun function_parameter =>
                              match function_parameter with
                              | None =>
                                (* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "This is not a smart contract." % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "This is not a smart contract." % string)
                              | Some {| code := code; storage := _ |} =>
                                match Script_repr.force_decode code with
                                | Stdlib.Error errs =>
                                  (* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format)
                                      "%a" % string)
                                    (Format.pp_print_list
                                      (Some Format.pp_print_newline)
                                      Environment.Error_monad.pp) errs
                                | Stdlib.Ok (code, _) =>
                                  let '{|
                                    Michelson_v1_parser.source := source |} :=
                                    Michelson_v1_printer.unparse_toplevel None
                                      code in
                                  op_gtgteq
                                    ((* ❌ Sending method message is not handled *)
                                    send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format)
                                        "%a" % string) Format.pp_print_text
                                      source) _return
                                end
                              end)))
                  (cons
                    (command (Some group)
                      "Get the type of an entrypoint of a contract." % string
                      no_options
                      (apply
                        (prefixes
                          (cons "get" % string
                            (cons "contract" % string
                              (cons "entrypoint" % string
                                (cons "type" % string (cons "of" % string []))))))
                        (apply
                          (Clic.string "entrypoint" % string
                            "the entrypoint to describe" % string)
                          (apply (prefixes (cons "for" % string []))
                            (apply
                              (ContractAlias.destination_param
                                (Some "src" % string)
                                (Some "source contract" % string)) stop))))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        fun entrypoint =>
                          fun function_parameter =>
                            let '(_, contract) := function_parameter in
                            fun cctxt =>
                              op_gtgteq
                                (Michelson_v1_entrypoints.contract_entrypoint_type
                                  cctxt
                                  (* ❌ Sending method message is not handled *)
                                  send
                                  (* ❌ Sending method message is not handled *)
                                  send contract entrypoint)
                                (let arg :=
                                  Michelson_v1_entrypoints.print_entrypoint_type
                                    cctxt
                                    (* ❌ expected an argument *)
                                    expected_argument false (Some contract)
                                    (* ❌ expected an argument *)
                                    expected_argument entrypoint in
                                fun eta => arg None None eta)))
                    (cons
                      (command (Some group)
                        "Get the entrypoint list of a contract." % string
                        no_options
                        (apply
                          (prefixes
                            (cons "get" % string
                              (cons "contract" % string
                                (cons "entrypoints" % string
                                  (cons "for" % string [])))))
                          (apply
                            (ContractAlias.destination_param
                              (Some "src" % string)
                              (Some "source contract" % string)) stop))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          fun function_parameter =>
                            let '(_, contract) := function_parameter in
                            fun cctxt =>
                              op_gtgteq
                                (Michelson_v1_entrypoints.list_contract_entrypoints
                                  cctxt
                                  (* ❌ Sending method message is not handled *)
                                  send
                                  (* ❌ Sending method message is not handled *)
                                  send contract)
                                (let arg :=
                                  Michelson_v1_entrypoints.print_entrypoints_list
                                    cctxt
                                    (* ❌ expected an argument *)
                                    expected_argument false (Some contract) in
                                fun eta => arg None None eta)))
                      (cons
                        (command (Some group)
                          "Get the list of unreachable pathsin a contract's parameter type."
                            % string no_options
                          (apply
                            (prefixes
                              (cons "get" % string
                                (cons "contract" % string
                                  (cons "unreachable" % string
                                    (cons "paths" % string
                                      (cons "for" % string []))))))
                            (apply
                              (ContractAlias.destination_param
                                (Some "src" % string)
                                (Some "source contract" % string)) stop))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            fun function_parameter =>
                              let '(_, contract) := function_parameter in
                              fun cctxt =>
                                op_gtgteq
                                  (Michelson_v1_entrypoints.list_contract_unreachables
                                    cctxt
                                    (* ❌ Sending method message is not handled *)
                                    send
                                    (* ❌ Sending method message is not handled *)
                                    send contract)
                                  (let arg :=
                                    Michelson_v1_entrypoints.print_unreachables
                                      cctxt
                                      (* ❌ expected an argument *)
                                      expected_argument false (Some contract) in
                                  fun eta => arg None None eta)))
                        (cons
                          (command (Some group)
                            "Get the delegate of a contract." % string
                            no_options
                            (apply
                              (prefixes
                                (cons "get" % string
                                  (cons "delegate" % string
                                    (cons "for" % string []))))
                              (apply
                                (ContractAlias.destination_param
                                  (Some "src" % string)
                                  (Some "source contract" % string)) stop))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              fun function_parameter =>
                                let '(_, contract) := function_parameter in
                                fun cctxt =>
                                  op_gtgteqquestion
                                    (Client_proto_contracts.get_delegate cctxt
                                      (* ❌ Sending method message is not handled *)
                                      send
                                      (* ❌ Sending method message is not handled *)
                                      send contract)
                                    (fun function_parameter =>
                                      match function_parameter with
                                      | None =>
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "none" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "none" % string))
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            return_unit)
                                      | Some delegate =>
                                        op_gtgteqquestion
                                          (Public_key_hash.rev_find cctxt
                                            delegate)
                                          (fun mn =>
                                            op_gtgteqquestion
                                              (Public_key_hash.to_source
                                                delegate)
                                              (fun m =>
                                                op_gtgteq
                                                  ((* ❌ Sending method message is not handled *)
                                                  send
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String
                                                        CamlinternalFormatBasics.No_padding
                                                        (CamlinternalFormatBasics.String_literal
                                                          " (" % string
                                                          (CamlinternalFormatBasics.String
                                                            CamlinternalFormatBasics.No_padding
                                                            (CamlinternalFormatBasics.Char_literal
                                                              ")" % char
                                                              CamlinternalFormatBasics.End_of_format))))
                                                      "%s (%s)" % string) m
                                                    match mn with
                                                    | None => "unknown" % string
                                                    | Some n =>
                                                      String.append
                                                        "known as " % string n
                                                    end)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    return_unit)))
                                      end)))
                          (cons
                            (command (Some group)
                              "Set the delegate of a contract." % string
                              (args9 fee_arg dry_run_switch
                                verbose_signing_switch minimal_fees_arg
                                minimal_nanotez_per_byte_arg
                                minimal_nanotez_per_gas_unit_arg
                                force_low_fee_arg fee_cap_arg burn_cap_arg)
                              (apply
                                (prefixes
                                  (cons "set" % string
                                    (cons "delegate" % string
                                      (cons "for" % string []))))
                                (apply
                                  (ContractAlias.destination_param
                                    (Some "src" % string)
                                    (Some "source contract" % string))
                                  (apply (prefix "to" % string)
                                    (apply
                                      (Public_key_hash.alias_param
                                        (Some "mgr" % string)
                                        (Some
                                          "new delegate of the contract" %
                                            string)) stop))))
                              (fun function_parameter =>
                                let
                                  '(fee, dry_run, verbose_signing, minimal_fees,
                                    minimal_nanotez_per_byte,
                                    minimal_nanotez_per_gas_unit, force_low_fee,
                                    fee_cap, burn_cap) := function_parameter in
                                fun function_parameter =>
                                  let '(_, contract) := function_parameter in
                                  fun function_parameter =>
                                    let '(_, delegate) := function_parameter in
                                    fun cctxt =>
                                      let fee_parameter :=
                                        {|
                                          Injection.minimal_fees := minimal_fees;
                                          Injection.minimal_nanotez_per_byte :=
                                            minimal_nanotez_per_byte;
                                          Injection.minimal_nanotez_per_gas_unit :=
                                            minimal_nanotez_per_gas_unit;
                                          Injection.force_low_fee :=
                                            force_low_fee;
                                          Injection.fee_cap := fee_cap;
                                          Injection.burn_cap := burn_cap |} in
                                      match Contract.is_implicit contract with
                                      | None =>
                                        op_gtgteqquestion
                                          (Managed_contract.get_contract_manager
                                            cctxt contract)
                                          (fun source =>
                                            op_gtgteqquestion
                                              (Client_keys.get_key cctxt source)
                                              (fun function_parameter =>
                                                let '(_, src_pk, src_sk) :=
                                                  function_parameter in
                                                op_gtgteq
                                                  (Managed_contract.set_delegate
                                                    cctxt
                                                    (* ❌ Sending method message is not handled *)
                                                    send
                                                    (* ❌ Sending method message is not handled *)
                                                    send
                                                    (* ❌ Sending method message is not handled *)
                                                    send (Some dry_run)
                                                    (Some verbose_signing) None
                                                    fee_parameter fee source
                                                    src_pk src_sk contract
                                                    (Some delegate))
                                                  (fun errors =>
                                                    op_gtgteq
                                                      (report_michelson_errors
                                                        (Some true)
                                                        "Setting delegate through entrypoints failed."
                                                          % string cctxt errors)
                                                      (fun function_parameter =>
                                                        let '_ :=
                                                          function_parameter in
                                                        return_unit))))
                                      | Some mgr =>
                                        op_gtgteqquestion
                                          (Client_keys.get_key cctxt mgr)
                                          (fun function_parameter =>
                                            let '(_, src_pk, manager_sk) :=
                                              function_parameter in
                                            op_gtgteqquestion
                                              (set_delegate cctxt
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                (* ❌ Sending method message is not handled *)
                                                send (Some dry_run)
                                                (Some verbose_signing) fee mgr
                                                src_pk manager_sk fee_parameter
                                                (Some delegate))
                                              (fun function_parameter =>
                                                let '_ := function_parameter in
                                                return_unit))
                                      end))
                            (cons
                              (command (Some group)
                                "Withdraw the delegate from a contract." %
                                  string
                                (args9 fee_arg dry_run_switch
                                  verbose_signing_switch minimal_fees_arg
                                  minimal_nanotez_per_byte_arg
                                  minimal_nanotez_per_gas_unit_arg
                                  force_low_fee_arg fee_cap_arg burn_cap_arg)
                                (apply
                                  (prefixes
                                    (cons "withdraw" % string
                                      (cons "delegate" % string
                                        (cons "from" % string []))))
                                  (apply
                                    (ContractAlias.destination_param
                                      (Some "src" % string)
                                      (Some "source contract" % string)) stop))
                                (fun function_parameter =>
                                  let
                                    '(fee, dry_run, verbose_signing,
                                      minimal_fees, minimal_nanotez_per_byte,
                                      minimal_nanotez_per_gas_unit,
                                      force_low_fee, fee_cap, burn_cap) :=
                                    function_parameter in
                                  fun function_parameter =>
                                    let '(_, contract) := function_parameter in
                                    fun cctxt =>
                                      let fee_parameter :=
                                        {|
                                          Injection.minimal_fees := minimal_fees;
                                          Injection.minimal_nanotez_per_byte :=
                                            minimal_nanotez_per_byte;
                                          Injection.minimal_nanotez_per_gas_unit :=
                                            minimal_nanotez_per_gas_unit;
                                          Injection.force_low_fee :=
                                            force_low_fee;
                                          Injection.fee_cap := fee_cap;
                                          Injection.burn_cap := burn_cap |} in
                                      match Contract.is_implicit contract with
                                      | None =>
                                        op_gtgteqquestion
                                          (Managed_contract.get_contract_manager
                                            cctxt contract)
                                          (fun source =>
                                            op_gtgteqquestion
                                              (Client_keys.get_key cctxt source)
                                              (fun function_parameter =>
                                                let '(_, src_pk, src_sk) :=
                                                  function_parameter in
                                                op_gtgteq
                                                  (Managed_contract.set_delegate
                                                    cctxt
                                                    (* ❌ Sending method message is not handled *)
                                                    send
                                                    (* ❌ Sending method message is not handled *)
                                                    send
                                                    (* ❌ Sending method message is not handled *)
                                                    send (Some dry_run)
                                                    (Some verbose_signing) None
                                                    fee_parameter fee source
                                                    src_pk src_sk contract None)
                                                  (fun errors =>
                                                    op_gtgteq
                                                      (report_michelson_errors
                                                        (Some true)
                                                        "Withdrawing delegate through entrypoints failed."
                                                          % string cctxt errors)
                                                      (fun function_parameter =>
                                                        let '_ :=
                                                          function_parameter in
                                                        return_unit))))
                                      | Some mgr =>
                                        op_gtgteqquestion
                                          (Client_keys.get_key cctxt mgr)
                                          (fun function_parameter =>
                                            let '(_, src_pk, manager_sk) :=
                                              function_parameter in
                                            op_gtgteq
                                              (set_delegate cctxt
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                (* ❌ Sending method message is not handled *)
                                                send (Some dry_run)
                                                (Some verbose_signing) fee mgr
                                                src_pk manager_sk fee_parameter
                                                None)
                                              (fun function_parameter =>
                                                let '_ := function_parameter in
                                                return_unit))
                                      end))
                              (cons
                                (command (Some group)
                                  "Launch a smart contract on the blockchain." %
                                    string
                                  (args15 fee_arg dry_run_switch
                                    verbose_signing_switch gas_limit_arg
                                    storage_limit_arg delegate_arg
                                    (Client_keys.force_switch tt) init_arg
                                    no_print_source_flag minimal_fees_arg
                                    minimal_nanotez_per_byte_arg
                                    minimal_nanotez_per_gas_unit_arg
                                    force_low_fee_arg fee_cap_arg burn_cap_arg)
                                  (apply
                                    (prefixes
                                      (cons "originate" % string
                                        (cons "contract" % string [])))
                                    (apply
                                      (RawContractAlias.fresh_alias_param
                                        (Some "new" % string)
                                        (Some
                                          "name of the new contract" % string))
                                      (apply (prefix "transferring" % string)
                                        (apply
                                          (tez_param "qty" % string
                                            "amount taken from source" % string)
                                          (apply (prefix "from" % string)
                                            (apply
                                              (ContractAlias.destination_param
                                                (Some "src" % string)
                                                (Some
                                                  "name of the source contract"
                                                    % string))
                                              (apply (prefix "running" % string)
                                                (apply
                                                  (Program.source_param
                                                    (Some "prg" % string)
                                                    (Some
                                                      "script of the account
Combine with -init if the storage type is not unit."
                                                        % string)) stop))))))))
                                  (fun function_parameter =>
                                    let
                                      '(fee, dry_run, verbose_signing,
                                        gas_limit, storage_limit, delegate,
                                        force, initial_storage, no_print_source,
                                        minimal_fees, minimal_nanotez_per_byte,
                                        minimal_nanotez_per_gas_unit,
                                        force_low_fee, fee_cap, burn_cap) :=
                                      function_parameter in
                                    fun alias_name =>
                                      fun balance =>
                                        fun function_parameter =>
                                          let '(_, source) := function_parameter
                                            in
                                          fun program =>
                                            fun cctxt =>
                                              op_gtgteqquestion
                                                (RawContractAlias.of_fresh cctxt
                                                  force alias_name)
                                                (fun alias_name =>
                                                  op_gtgteqquestion
                                                    (Lwt._return
                                                      (Micheline_parser.no_parsing_error
                                                        program))
                                                    (fun function_parameter =>
                                                      let '{|
                                                        expanded := code |} :=
                                                        function_parameter in
                                                      match
                                                        Contract.is_implicit
                                                          source with
                                                      | None =>
                                                        failwith
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "only implicit accounts can be the source of an origination"
                                                                % string
                                                              CamlinternalFormatBasics.End_of_format)
                                                            "only implicit accounts can be the source of an origination"
                                                              % string)
                                                      | Some source =>
                                                        op_gtgteqquestion
                                                          (Client_keys.get_key
                                                            cctxt source)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let
                                                              '(_, src_pk,
                                                                src_sk) :=
                                                              function_parameter
                                                              in
                                                            let fee_parameter :=
                                                              {|
                                                                Injection.minimal_fees :=
                                                                  minimal_fees;
                                                                Injection.minimal_nanotez_per_byte :=
                                                                  minimal_nanotez_per_byte;
                                                                Injection.minimal_nanotez_per_gas_unit :=
                                                                  minimal_nanotez_per_gas_unit;
                                                                Injection.force_low_fee :=
                                                                  force_low_fee;
                                                                Injection.fee_cap :=
                                                                  fee_cap;
                                                                Injection.burn_cap :=
                                                                  burn_cap |} in
                                                            op_gtgteq
                                                              (originate_contract
                                                                cctxt
                                                                (* ❌ Sending method message is not handled *)
                                                                send
                                                                (* ❌ Sending method message is not handled *)
                                                                send
                                                                (* ❌ Sending method message is not handled *)
                                                                send
                                                                (Some dry_run)
                                                                (Some
                                                                  verbose_signing)
                                                                None fee
                                                                gas_limit
                                                                storage_limit
                                                                delegate
                                                                initial_storage
                                                                balance source
                                                                src_pk src_sk
                                                                code
                                                                fee_parameter tt)
                                                              (fun errors =>
                                                                op_gtgteq
                                                                  (report_michelson_errors
                                                                    (Some
                                                                      no_print_source)
                                                                    "origination simulation failed"
                                                                      % string
                                                                    cctxt errors)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | None =>
                                                                      return_unit
                                                                    |
                                                                      Some
                                                                        (_res,
                                                                          contract)
                                                                      =>
                                                                      if dry_run
                                                                        then
                                                                        return_unit
                                                                      else
                                                                        op_gtgteqquestion
                                                                          (save_contract
                                                                            force
                                                                            cctxt
                                                                            alias_name
                                                                            contract)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              'tt :=
                                                                              function_parameter
                                                                              in
                                                                            return_unit)
                                                                    end)))
                                                      end))))
                                (cons
                                  (command (Some group)
                                    "Transfer tokens / call a smart contract." %
                                      string
                                    (args15 fee_arg dry_run_switch
                                      verbose_signing_switch gas_limit_arg
                                      storage_limit_arg counter_arg arg_arg
                                      no_print_source_flag minimal_fees_arg
                                      minimal_nanotez_per_byte_arg
                                      minimal_nanotez_per_gas_unit_arg
                                      force_low_fee_arg fee_cap_arg burn_cap_arg
                                      entrypoint_arg)
                                    (apply
                                      (prefixes (cons "transfer" % string []))
                                      (apply
                                        (tez_param "qty" % string
                                          "amount taken from source" % string)
                                        (apply (prefix "from" % string)
                                          (apply
                                            (ContractAlias.destination_param
                                              (Some "src" % string)
                                              (Some
                                                "name of the source contract" %
                                                  string))
                                            (apply (prefix "to" % string)
                                              (apply
                                                (ContractAlias.destination_param
                                                  (Some "dst" % string)
                                                  (Some
                                                    "name/literal of the destination contract"
                                                      % string)) stop))))))
                                    (fun function_parameter =>
                                      let
                                        '(fee, dry_run, verbose_signing,
                                          gas_limit, storage_limit, counter,
                                          arg, no_print_source, minimal_fees,
                                          minimal_nanotez_per_byte,
                                          minimal_nanotez_per_gas_unit,
                                          force_low_fee, fee_cap, burn_cap,
                                          entrypoint) := function_parameter in
                                      fun amount =>
                                        fun function_parameter =>
                                          let '(_, source) := function_parameter
                                            in
                                          fun function_parameter =>
                                            let '(_, destination) :=
                                              function_parameter in
                                            fun cctxt =>
                                              let fee_parameter :=
                                                {|
                                                  Injection.minimal_fees :=
                                                    minimal_fees;
                                                  Injection.minimal_nanotez_per_byte :=
                                                    minimal_nanotez_per_byte;
                                                  Injection.minimal_nanotez_per_gas_unit :=
                                                    minimal_nanotez_per_gas_unit;
                                                  Injection.force_low_fee :=
                                                    force_low_fee;
                                                  Injection.fee_cap := fee_cap;
                                                  Injection.burn_cap := burn_cap
                                                  |} in
                                              op_gtgteq
                                                (op_gtgteq
                                                  match
                                                    Contract.is_implicit source
                                                    with
                                                  | None =>
                                                    let contract := source in
                                                    op_gtgteqquestion
                                                      (Managed_contract.get_contract_manager
                                                        cctxt source)
                                                      (fun source =>
                                                        op_gtgteqquestion
                                                          (Client_keys.get_key
                                                            cctxt source)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let
                                                              '(_, src_pk,
                                                                src_sk) :=
                                                              function_parameter
                                                              in
                                                            Managed_contract.transfer
                                                              cctxt
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                              (Some dry_run)
                                                              (Some
                                                                verbose_signing)
                                                              None source src_pk
                                                              src_sk contract
                                                              destination
                                                              entrypoint arg
                                                              amount fee
                                                              gas_limit
                                                              storage_limit
                                                              counter
                                                              fee_parameter tt))
                                                  | Some source =>
                                                    op_gtgteqquestion
                                                      (Client_keys.get_key cctxt
                                                        source)
                                                      (fun function_parameter =>
                                                        let
                                                          '(_, src_pk, src_sk) :=
                                                          function_parameter in
                                                        transfer cctxt
                                                          (* ❌ Sending method message is not handled *)
                                                          send
                                                          (* ❌ Sending method message is not handled *)
                                                          send
                                                          (* ❌ Sending method message is not handled *)
                                                          send (Some dry_run)
                                                          (Some verbose_signing)
                                                          None source src_pk
                                                          src_sk destination
                                                          entrypoint arg amount
                                                          fee gas_limit
                                                          storage_limit counter
                                                          fee_parameter tt)
                                                  end
                                                  (report_michelson_errors
                                                    (Some no_print_source)
                                                    "transfer simulation failed"
                                                      % string cctxt))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | None => return_unit
                                                  | Some (_res, _contracts) =>
                                                    return_unit
                                                  end)))
                                  (cons
                                    (command (Some group)
                                      "Call a smart contract (same as 'transfer 0')."
                                        % string
                                      (args15 fee_arg dry_run_switch
                                        verbose_signing_switch gas_limit_arg
                                        storage_limit_arg counter_arg arg_arg
                                        no_print_source_flag minimal_fees_arg
                                        minimal_nanotez_per_byte_arg
                                        minimal_nanotez_per_gas_unit_arg
                                        force_low_fee_arg fee_cap_arg
                                        burn_cap_arg entrypoint_arg)
                                      (apply
                                        (prefixes (cons "call" % string []))
                                        (apply (prefix "from" % string)
                                          (apply
                                            (ContractAlias.destination_param
                                              (Some "src" % string)
                                              (Some
                                                "name of the source contract" %
                                                  string))
                                            (apply (prefix "to" % string)
                                              (apply
                                                (ContractAlias.destination_param
                                                  (Some "dst" % string)
                                                  (Some
                                                    "name/literal of the destination contract"
                                                      % string)) stop)))))
                                      (fun function_parameter =>
                                        let
                                          '(fee, dry_run, verbose_signing,
                                            gas_limit, storage_limit, counter,
                                            arg, no_print_source, minimal_fees,
                                            minimal_nanotez_per_byte,
                                            minimal_nanotez_per_gas_unit,
                                            force_low_fee, fee_cap, burn_cap,
                                            entrypoint) := function_parameter in
                                        fun function_parameter =>
                                          let '(_, source) := function_parameter
                                            in
                                          fun function_parameter =>
                                            let '(_, destination) :=
                                              function_parameter in
                                            fun cctxt =>
                                              let fee_parameter :=
                                                {|
                                                  Injection.minimal_fees :=
                                                    minimal_fees;
                                                  Injection.minimal_nanotez_per_byte :=
                                                    minimal_nanotez_per_byte;
                                                  Injection.minimal_nanotez_per_gas_unit :=
                                                    minimal_nanotez_per_gas_unit;
                                                  Injection.force_low_fee :=
                                                    force_low_fee;
                                                  Injection.fee_cap := fee_cap;
                                                  Injection.burn_cap := burn_cap
                                                  |} in
                                              let amount := Tez.zero in
                                              op_gtgteq
                                                (op_gtgteq
                                                  match
                                                    Contract.is_implicit source
                                                    with
                                                  | None =>
                                                    let contract := source in
                                                    op_gtgteqquestion
                                                      (Managed_contract.get_contract_manager
                                                        cctxt source)
                                                      (fun source =>
                                                        op_gtgteqquestion
                                                          (Client_keys.get_key
                                                            cctxt source)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let
                                                              '(_, src_pk,
                                                                src_sk) :=
                                                              function_parameter
                                                              in
                                                            Managed_contract.transfer
                                                              cctxt
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                              (* ❌ Sending method message is not handled *)
                                                              send
                                                              (Some dry_run)
                                                              (Some
                                                                verbose_signing)
                                                              None source src_pk
                                                              src_sk contract
                                                              destination
                                                              entrypoint arg
                                                              amount fee
                                                              gas_limit
                                                              storage_limit
                                                              counter
                                                              fee_parameter tt))
                                                  | Some source =>
                                                    op_gtgteqquestion
                                                      (Client_keys.get_key cctxt
                                                        source)
                                                      (fun function_parameter =>
                                                        let
                                                          '(_, src_pk, src_sk) :=
                                                          function_parameter in
                                                        transfer cctxt
                                                          (* ❌ Sending method message is not handled *)
                                                          send
                                                          (* ❌ Sending method message is not handled *)
                                                          send
                                                          (* ❌ Sending method message is not handled *)
                                                          send (Some dry_run)
                                                          (Some verbose_signing)
                                                          None source src_pk
                                                          src_sk destination
                                                          entrypoint arg amount
                                                          fee gas_limit
                                                          storage_limit counter
                                                          fee_parameter tt)
                                                  end
                                                  (report_michelson_errors
                                                    (Some no_print_source)
                                                    "transfer simulation failed"
                                                      % string cctxt))
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | None => return_unit
                                                  | Some (_res, _contracts) =>
                                                    return_unit
                                                  end)))
                                    (cons
                                      (command (Some group)
                                        "Reveal the public key of the contract manager."
                                          % string
                                        (args9 fee_arg dry_run_switch
                                          verbose_signing_switch
                                          minimal_fees_arg
                                          minimal_nanotez_per_byte_arg
                                          minimal_nanotez_per_gas_unit_arg
                                          force_low_fee_arg fee_cap_arg
                                          burn_cap_arg)
                                        (apply
                                          (prefixes
                                            (cons "reveal" % string
                                              (cons "key" % string
                                                (cons "for" % string []))))
                                          (apply
                                            (ContractAlias.alias_param
                                              (Some "src" % string)
                                              (Some
                                                "name of the source contract" %
                                                  string)) stop))
                                        (fun function_parameter =>
                                          let
                                            '(fee, dry_run, verbose_signing,
                                              minimal_fees,
                                              minimal_nanotez_per_byte,
                                              minimal_nanotez_per_gas_unit,
                                              force_low_fee, fee_cap, burn_cap) :=
                                            function_parameter in
                                          fun function_parameter =>
                                            let '(_, source) :=
                                              function_parameter in
                                            fun cctxt =>
                                              match Contract.is_implicit source
                                                with
                                              | None =>
                                                failwith
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "only implicit accounts can be revealed"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "only implicit accounts can be revealed"
                                                      % string)
                                              | Some source =>
                                                op_gtgteqquestion
                                                  (Client_keys.get_key cctxt
                                                    source)
                                                  (fun function_parameter =>
                                                    let '(_, src_pk, src_sk) :=
                                                      function_parameter in
                                                    let fee_parameter :=
                                                      {|
                                                        Injection.minimal_fees :=
                                                          minimal_fees;
                                                        Injection.minimal_nanotez_per_byte :=
                                                          minimal_nanotez_per_byte;
                                                        Injection.minimal_nanotez_per_gas_unit :=
                                                          minimal_nanotez_per_gas_unit;
                                                        Injection.force_low_fee :=
                                                          force_low_fee;
                                                        Injection.fee_cap :=
                                                          fee_cap;
                                                        Injection.burn_cap :=
                                                          burn_cap |} in
                                                    op_gtgteqquestion
                                                      (reveal cctxt
                                                        (* ❌ Sending method message is not handled *)
                                                        send
                                                        (* ❌ Sending method message is not handled *)
                                                        send
                                                        (* ❌ Sending method message is not handled *)
                                                        send (Some dry_run)
                                                        (Some verbose_signing)
                                                        None source src_pk
                                                        src_sk fee fee_parameter
                                                        tt)
                                                      (fun _res => return_unit))
                                              end))
                                      (cons
                                        (command (Some group)
                                          "Register the public key hash as a delegate."
                                            % string
                                          (args9 fee_arg dry_run_switch
                                            verbose_signing_switch
                                            minimal_fees_arg
                                            minimal_nanotez_per_byte_arg
                                            minimal_nanotez_per_gas_unit_arg
                                            force_low_fee_arg fee_cap_arg
                                            burn_cap_arg)
                                          (apply
                                            (prefixes
                                              (cons "register" % string
                                                (cons "key" % string [])))
                                            (apply
                                              (Public_key_hash.source_param
                                                (Some "mgr" % string)
                                                (Some
                                                  "the delegate key" % string))
                                              (apply
                                                (prefixes
                                                  (cons "as" % string
                                                    (cons "delegate" % string [])))
                                                stop)))
                                          (fun function_parameter =>
                                            let
                                              '(fee, dry_run, verbose_signing,
                                                minimal_fees,
                                                minimal_nanotez_per_byte,
                                                minimal_nanotez_per_gas_unit,
                                                force_low_fee, fee_cap, burn_cap) :=
                                              function_parameter in
                                            fun src_pkh =>
                                              fun cctxt =>
                                                op_gtgteqquestion
                                                  (Client_keys.get_key cctxt
                                                    src_pkh)
                                                  (fun function_parameter =>
                                                    let '(_, src_pk, src_sk) :=
                                                      function_parameter in
                                                    let fee_parameter :=
                                                      {|
                                                        Injection.minimal_fees :=
                                                          minimal_fees;
                                                        Injection.minimal_nanotez_per_byte :=
                                                          minimal_nanotez_per_byte;
                                                        Injection.minimal_nanotez_per_gas_unit :=
                                                          minimal_nanotez_per_gas_unit;
                                                        Injection.force_low_fee :=
                                                          force_low_fee;
                                                        Injection.fee_cap :=
                                                          fee_cap;
                                                        Injection.burn_cap :=
                                                          burn_cap |} in
                                                    op_gtgteq
                                                      (register_as_delegate
                                                        cctxt
                                                        (* ❌ Sending method message is not handled *)
                                                        send
                                                        (* ❌ Sending method message is not handled *)
                                                        send
                                                        (* ❌ Sending method message is not handled *)
                                                        send (Some dry_run)
                                                        (Some verbose_signing)
                                                        fee src_sk fee_parameter
                                                        src_pk)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | Stdlib.Ok _ =>
                                                          return_unit
                                                        |
                                                          Stdlib.Error
                                                            (cons
                                                              (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
                                                                Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate)
                                                              []) =>
                                                          op_gtgteq
                                                            ((* ❌ Sending method message is not handled *)
                                                            send
                                                              (CamlinternalFormatBasics.Format
                                                                (CamlinternalFormatBasics.String_literal
                                                                  "Delegate already activated."
                                                                    % string
                                                                  CamlinternalFormatBasics.End_of_format)
                                                                "Delegate already activated."
                                                                  % string))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              return_unit)
                                                        | Stdlib.Error el =>
                                                          Lwt.return_error el
                                                        end)))) []))))))))))))))))))
    (OCaml.Stdlib.app
      (if
        equiv_decb version
          (Some
            (* ❌ Variants not supported *)
            variant) then
        []
      else
        cons
          (command (Some group)
            "Register and activate an Alphanet/Zeronet faucet account." % string
            (args2 (Secret_key.force_switch tt) encrypted_switch)
            (apply
              (prefixes (cons "activate" % string (cons "account" % string [])))
              (apply
                (let arg := Secret_key.fresh_alias_param in
                fun eta => arg None None eta)
                (apply (prefixes (cons "with" % string []))
                  (apply
                    (param "activation_key" % string
                      "Activate an Alphanet/Zeronet faucet account from the JSON (file or directly inlined)."
                        % string json_file_or_text_parameter) stop))))
            (fun function_parameter =>
              let '(force, encrypted) := function_parameter in
              fun name =>
                fun activation_json =>
                  fun cctxt =>
                    op_gtgteqquestion (Secret_key.of_fresh cctxt force name)
                      (fun name =>
                        let 'key :=
                          Data_encoding.Json.destruct
                            Client_proto_context.activation_key_encoding
                            activation_json in
                        op_gtgteqquestion
                          (activate_account cctxt
                            (* ❌ Sending method message is not handled *)
                            send
                            (* ❌ Sending method message is not handled *)
                            send
                            (* ❌ Sending method message is not handled *)
                            send None (Some encrypted) (Some force) key name)
                          (fun _res => return_unit)))) [])
      (OCaml.Stdlib.app
        (if
          nequiv_decb version
            (Some
              (* ❌ Variants not supported *)
              variant) then
          []
        else
          cons
            (command (Some group) "Activate a fundraiser account." % string
              (args1 dry_run_switch)
              (apply
                (prefixes
                  (cons "activate" % string
                    (cons "fundraiser" % string (cons "account" % string []))))
                (apply
                  (let arg := Public_key_hash.alias_param in
                  fun eta => arg None None eta)
                  (apply (prefixes (cons "with" % string []))
                    (apply
                      (param "code" % string
                        "Activation code obtained from the Tezos foundation." %
                          string
                        (Clic.parameter None
                          (fun _ctx =>
                            fun code =>
                              protect None None
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  _return
                                    (Blinded_public_key_hash.activation_code_of_hex
                                      code))))) stop))))
              (fun dry_run =>
                fun function_parameter =>
                  let '(name, _pkh) := function_parameter in
                  fun code =>
                    fun cctxt =>
                      op_gtgteqquestion
                        (activate_existing_account cctxt
                          (* ❌ Sending method message is not handled *)
                          send
                          (* ❌ Sending method message is not handled *)
                          send
                          (* ❌ Sending method message is not handled *)
                          send (Some dry_run) name code)
                        (fun _res => return_unit))) [])
        (cons
          (command None
            "Wait until an operation is included in a block" % string
            (args3
              (default_arg
                "wait until 'N' additional blocks after the operation appears in the considered chain"
                  % string None "confirmations" % string "num_blocks" % string
                "0" % string non_negative_param)
              (default_arg "number of previous blocks to check" % string None
                "check-previous" % string "num_blocks" % string "10" % string
                non_negative_param)
              (arg
                "hash of the oldest block where we should look for the operation"
                  % string None "branch" % string "block_hash" % string
                block_hash_param))
            (apply (prefixes (cons "wait" % string (cons "for" % string [])))
              (apply
                (param "operation" % string "Operation to be included" % string
                  (parameter None
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      fun x =>
                        match Operation_hash.of_b58check_opt x with
                        | None =>
                          Error_monad.failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Invalid operation hash: '" % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.Char_literal
                                    "'" % char
                                    CamlinternalFormatBasics.End_of_format)))
                              "Invalid operation hash: '%s'" % string) x
                        | Some hash => _return hash
                        end)))
                (apply
                  (prefixes
                    (cons "to" % string
                      (cons "be" % string (cons "included" % string [])))) stop)))
            (fun function_parameter =>
              let '(confirmations, predecessors, branch) := function_parameter
                in
              fun operation_hash =>
                fun ctxt =>
                  op_gtgteqquestion
                    (Client_confirmations.wait_for_operation_inclusion ctxt
                      (* ❌ Sending method message is not handled *)
                      send (Some predecessors) (Some confirmations) branch
                      operation_hash)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      return_unit)))
          (cons
            (command None "Get receipt for past operation" % string
              (args1
                (default_arg "number of previous blocks to check" % string None
                  "check-previous" % string "num_blocks" % string "10" % string
                  non_negative_param))
              (apply
                (prefixes
                  (cons "get" % string
                    (cons "receipt" % string (cons "for" % string []))))
                (apply
                  (param "operation" % string
                    "Operation to be looked up" % string
                    (parameter None
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        fun x =>
                          match Operation_hash.of_b58check_opt x with
                          | None =>
                            Error_monad.failwith
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Invalid operation hash: '" % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.Char_literal
                                      "'" % char
                                      CamlinternalFormatBasics.End_of_format)))
                                "Invalid operation hash: '%s'" % string) x
                          | Some hash => _return hash
                          end))) stop))
              (fun predecessors =>
                fun operation_hash =>
                  fun ctxt =>
                    op_gtgteqquestion
                      (display_receipt_for_operation ctxt
                        (* ❌ Sending method message is not handled *)
                        send (Some predecessors) operation_hash)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        return_unit)))
            (cons
              (command (Some binary_description)
                "Describe unsigned block header" % string no_options
                (fixed
                  (cons "describe" % string
                    (cons "unsigned" % string
                      (cons "block" % string (cons "header" % string [])))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  fun cctxt =>
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)
                          "%a" % string) Data_encoding.Binary_schema.pp
                        (Data_encoding.Binary.describe
                          Alpha_context.Block_header.unsigned_encoding))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)))
              (cons
                (command (Some binary_description)
                  "Describe unsigned block header" % string no_options
                  (fixed
                    (cons "describe" % string
                      (cons "unsigned" % string (cons "operation" % string []))))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    fun cctxt =>
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format)
                            "%a" % string) Data_encoding.Binary_schema.pp
                          (Data_encoding.Binary.describe
                            Alpha_context.Operation.unsigned_encoding))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit)))
                (cons
                  (command (Some group) "Submit protocol proposals" % string
                    (args3 dry_run_switch verbose_signing_switch
                      (switch
                        "Do not fail when the checks that try to prevent the user from shooting themselves in the foot do."
                          % string None "force" % string tt))
                    (apply
                      (prefixes
                        (cons "submit" % string
                          (cons "proposals" % string (cons "for" % string []))))
                      (apply
                        (Client_keys.Secret_key.alias_param
                          (Some "delegate" % string)
                          (Some "the delegate who makes the proposal" % string))
                        (seq_of_param
                          (param "proposal" % string
                            "the protocol hash proposal to be submitted" %
                              string
                            (parameter None
                              (fun function_parameter =>
                                let '_ := function_parameter in
                                fun x =>
                                  match Protocol_hash.of_b58check_opt x with
                                  | None =>
                                    Error_monad.failwith
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Invalid proposal hash: '" % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.Char_literal
                                              "'" % char
                                              CamlinternalFormatBasics.End_of_format)))
                                        "Invalid proposal hash: '%s'" % string)
                                      x
                                  | Some hash => _return hash
                                  end))))))
                    (fun function_parameter =>
                      let '(dry_run, verbose_signing, force) :=
                        function_parameter in
                      fun function_parameter =>
                        let '(src_name, src_sk) := function_parameter in
                        fun proposals =>
                          fun cctxt =>
                            op_gtgteqquestion (Client_keys.neuterize src_sk)
                              (fun src_pk =>
                                op_gtgteqquestion
                                  (Client_keys.public_key_hash src_pk)
                                  (fun function_parameter =>
                                    let '(src_pkh, _) := function_parameter in
                                    op_gtgteqquestion
                                      (get_period_info cctxt
                                        (* ❌ Sending method message is not handled *)
                                        send
                                        (* ❌ Sending method message is not handled *)
                                        send)
                                      (fun info =>
                                        op_gtgteqquestion
                                          match current_period_kind info with
                                          |
                                            Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Proposal
                                            => return_unit
                                          | _ =>
                                            (* ❌ Sending method message is not handled *)
                                            send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Not in a proposal period" %
                                                    string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "Not in a proposal period" %
                                                  string)
                                          end
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_gtgteqquestion
                                              (Shell_services.Protocol.list
                                                cctxt)
                                              (fun known_protos =>
                                                op_gtgteqquestion
                                                  (get_proposals cctxt
                                                    (* ❌ Sending method message is not handled *)
                                                    send
                                                    (* ❌ Sending method message is not handled *)
                                                    send)
                                                  (fun known_proposals =>
                                                    op_gtgteqquestion
                                                      (Alpha_services.Voting.listings
                                                        cctxt
                                                        ((* ❌ Sending method message is not handled *)
                                                        send,
                                                          (* ❌ Sending method message is not handled *)
                                                          send))
                                                      (fun listings =>
                                                        let check_proposals
                                                          (proposals :
                                                          Base.List.t
                                                            Tezos_base__TzPervasives.Protocol_hash.t)
                                                          : Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              bool) :=
                                                          let n :=
                                                            List.length
                                                              proposals in
                                                          let errors :=
                                                            Stdlib.ref [] in
                                                          let error {A : Type}
                                                            (ppf :
                                                            Stdlib.format4 A
                                                              Stdlib.Format.formatter
                                                              unit unit) : A :=
                                                            Format.kasprintf
                                                              (fun s =>
                                                                Stdlib.op_coloneq
                                                                  errors
                                                                  (cons s
                                                                    (Stdlib.op_exclamation
                                                                      errors)))
                                                              ppf in
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            if equiv_decb n 0
                                                              then
                                                              error
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Empty proposal list."
                                                                      % string
                                                                    CamlinternalFormatBasics.End_of_format)
                                                                  "Empty proposal list."
                                                                    % string)
                                                            else
                                                              tt in
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            if
                                                              OCaml.Stdlib.gt n
                                                                (max_proposals_per_delegate
                                                                  Constants.fixed)
                                                              then
                                                              error
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Too many proposals: "
                                                                      % string
                                                                    (CamlinternalFormatBasics.Int
                                                                      CamlinternalFormatBasics.Int_d
                                                                      CamlinternalFormatBasics.No_padding
                                                                      CamlinternalFormatBasics.No_precision
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        " > " %
                                                                          string
                                                                        (CamlinternalFormatBasics.Int
                                                                          CamlinternalFormatBasics.Int_d
                                                                          CamlinternalFormatBasics.No_padding
                                                                          CamlinternalFormatBasics.No_precision
                                                                          (CamlinternalFormatBasics.Char_literal
                                                                            "."
                                                                              %
                                                                              char
                                                                            CamlinternalFormatBasics.End_of_format)))))
                                                                  "Too many proposals: %d > %d."
                                                                    % string) n
                                                                (max_proposals_per_delegate
                                                                  Constants.fixed)
                                                            else
                                                              tt in
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            match
                                                              Base.List.find_all_dups
                                                                Protocol_hash.compare
                                                                proposals with
                                                            | [] => tt
                                                            | dups =>
                                                              error
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "There " %
                                                                      string
                                                                    (CamlinternalFormatBasics.String
                                                                      CamlinternalFormatBasics.No_padding
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        ": " %
                                                                          string
                                                                        (CamlinternalFormatBasics.Alpha
                                                                          (CamlinternalFormatBasics.Char_literal
                                                                            "."
                                                                              %
                                                                              char
                                                                            CamlinternalFormatBasics.End_of_format)))))
                                                                  "There %s: %a."
                                                                    % string)
                                                                (if
                                                                  equiv_decb
                                                                    (List.length
                                                                      dups) 1
                                                                  then
                                                                  "is a duplicate proposal"
                                                                    % string
                                                                else
                                                                  "are duplicate proposals"
                                                                    % string)
                                                                (pp_print_list
                                                                  (Some
                                                                    (fun ppf =>
                                                                      fun
                                                                        function_parameter
                                                                        =>
                                                                        let
                                                                          'tt :=
                                                                          function_parameter
                                                                          in
                                                                        pp_print_string
                                                                          ppf
                                                                          ", " %
                                                                            string))
                                                                  Protocol_hash.pp)
                                                                dups
                                                            end in
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            List.iter
                                                              (fun p =>
                                                                if
                                                                  orb
                                                                    (List.mem p
                                                                      known_protos)
                                                                    (Environment.Protocol_hash.Map.mem
                                                                      p
                                                                      known_proposals)
                                                                  then
                                                                  tt
                                                                else
                                                                  error
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Protocol "
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Alpha
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            " is not a known proposal."
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)))
                                                                      "Protocol %a is not a known proposal."
                                                                        % string)
                                                                    Protocol_hash.pp
                                                                    p) proposals
                                                            in
                                                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                          let _ :=
                                                            if
                                                              negb
                                                                (List._exists
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let
                                                                      '(pkh, _) :=
                                                                      function_parameter
                                                                      in
                                                                    Signature.Public_key_hash.equal
                                                                      pkh
                                                                      src_pkh)
                                                                  listings) then
                                                              error
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Public-key-hash `"
                                                                      % string
                                                                    (CamlinternalFormatBasics.Alpha
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "` from account `"
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.String
                                                                          CamlinternalFormatBasics.No_padding
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "` does not appear to have voting rights."
                                                                              %
                                                                              string
                                                                            CamlinternalFormatBasics.End_of_format)))))
                                                                  "Public-key-hash `%a` from account `%s` does not appear to have voting rights."
                                                                    % string)
                                                                Signature.Public_key_hash.pp
                                                                src_pkh src_name
                                                            else
                                                              tt in
                                                          if
                                                            nequiv_decb
                                                              (Stdlib.op_exclamation
                                                                errors) [] then
                                                            op_gtgteq
                                                              ((* ❌ Sending method message is not handled *)
                                                              send
                                                                (CamlinternalFormatBasics.Format
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "There " %
                                                                      string
                                                                    (CamlinternalFormatBasics.String
                                                                      CamlinternalFormatBasics.No_padding
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        " with the submission:"
                                                                          %
                                                                          string
                                                                        (CamlinternalFormatBasics.Theta
                                                                          CamlinternalFormatBasics.End_of_format))))
                                                                  "There %s with the submission:%t"
                                                                    % string)
                                                                (if
                                                                  equiv_decb
                                                                    (List.length
                                                                      (Stdlib.op_exclamation
                                                                        errors))
                                                                    1 then
                                                                  "is an issue"
                                                                    % string
                                                                else
                                                                  "are issues" %
                                                                    string)
                                                                (fun ppf =>
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    pp_print_cut
                                                                      ppf tt in
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    pp_open_vbox
                                                                      ppf 0 in
                                                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                  let _ :=
                                                                    List.iter
                                                                      (fun msg
                                                                        =>
                                                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                        let _ :=
                                                                          pp_open_hovbox
                                                                            ppf
                                                                            2 in
                                                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                        let _ :=
                                                                          pp_print_string
                                                                            ppf
                                                                            "* "
                                                                              %
                                                                              string
                                                                          in
                                                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                        let _ :=
                                                                          pp_print_text
                                                                            ppf
                                                                            msg
                                                                          in
                                                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                                        let _ :=
                                                                          pp_close_box
                                                                            ppf
                                                                            tt
                                                                          in
                                                                        pp_print_cut
                                                                          ppf tt)
                                                                      (Stdlib.op_exclamation
                                                                        errors)
                                                                    in
                                                                  pp_close_box
                                                                    ppf tt))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                return_false)
                                                          else
                                                            return_true in
                                                        op_gtgteqquestion
                                                          (check_proposals
                                                            proposals)
                                                          (fun all_valid =>
                                                            op_gtgteq
                                                              (if all_valid then
                                                                (* ❌ Sending method message is not handled *)
                                                                send
                                                                  (CamlinternalFormatBasics.Format
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "All proposals are valid."
                                                                        % string
                                                                      CamlinternalFormatBasics.End_of_format)
                                                                    "All proposals are valid."
                                                                      % string)
                                                              else
                                                                if force then
                                                                  (* ❌ Sending method message is not handled *)
                                                                  send
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Some proposals are not valid, but `--force` was used."
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)
                                                                      "Some proposals are not valid, but `--force` was used."
                                                                        % string)
                                                                else
                                                                  (* ❌ Sending method message is not handled *)
                                                                  send
                                                                    (CamlinternalFormatBasics.Format
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        "Submission failed because of invalid proposals."
                                                                          %
                                                                          string
                                                                        CamlinternalFormatBasics.End_of_format)
                                                                      "Submission failed because of invalid proposals."
                                                                        % string))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                op_gtgteq
                                                                  (submit_proposals
                                                                    (Some
                                                                      dry_run)
                                                                    (Some
                                                                      verbose_signing)
                                                                    cctxt
                                                                    (* ❌ Sending method message is not handled *)
                                                                    send
                                                                    (* ❌ Sending method message is not handled *)
                                                                    send None
                                                                    src_sk
                                                                    src_pkh
                                                                    proposals)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      Stdlib.Ok
                                                                        _res =>
                                                                      return_unit
                                                                    |
                                                                      Stdlib.Error
                                                                        errs =>
                                                                      op_gtgteq
                                                                        match
                                                                          errs
                                                                          with
                                                                        |
                                                                          cons
                                                                            (Tezos_base__TzPervasives.Unregistred_error
                                                                              (O
                                                                                (cons
                                                                                  ("kind"
                                                                                    %
                                                                                    string,
                                                                                    String
                                                                                      "generic"
                                                                                        %
                                                                                        string)
                                                                                  (cons
                                                                                    ("error"
                                                                                      %
                                                                                      string,
                                                                                      String
                                                                                        msg)
                                                                                    []))))
                                                                            []
                                                                          =>
                                                                          (* ❌ Sending method message is not handled *)
                                                                          send
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "Error:"
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Formatting_gen
                                                                                  (CamlinternalFormatBasics.Open_box
                                                                                    (CamlinternalFormatBasics.Format
                                                                                      (CamlinternalFormatBasics.String_literal
                                                                                        "<hov>"
                                                                                          %
                                                                                          string
                                                                                        CamlinternalFormatBasics.End_of_format)
                                                                                      "<hov>"
                                                                                        %
                                                                                        string))
                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                    CamlinternalFormatBasics.Flush_newline
                                                                                    (CamlinternalFormatBasics.Alpha
                                                                                      (CamlinternalFormatBasics.Formatting_lit
                                                                                        CamlinternalFormatBasics.Close_box
                                                                                        CamlinternalFormatBasics.End_of_format)))))
                                                                              "Error:@[<hov>@.%a@]"
                                                                                %
                                                                                string)
                                                                            Format.pp_print_text
                                                                            (OCaml.Stdlib.reverse_apply
                                                                              (OCaml.Stdlib.reverse_apply
                                                                                (OCaml.Stdlib.reverse_apply
                                                                                  (String.split_on_char
                                                                                    " "
                                                                                      %
                                                                                      char
                                                                                    msg)
                                                                                  (List.filter
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        ""
                                                                                          %
                                                                                          string
                                                                                          |
                                                                                          "
"
                                                                                            %
                                                                                            string
                                                                                        =>
                                                                                        false
                                                                                      |
                                                                                        _
                                                                                        =>
                                                                                        true
                                                                                      end)))
                                                                                (String.concat
                                                                                  " "
                                                                                    %
                                                                                    string))
                                                                              (String.map
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  match
                                                                                    function_parameter
                                                                                    with
                                                                                  |
                                                                                    "010"
                                                                                      %
                                                                                      char
                                                                                      |
                                                                                      "009"
                                                                                        %
                                                                                        char
                                                                                    =>
                                                                                    " "
                                                                                      %
                                                                                      char
                                                                                  |
                                                                                    c
                                                                                    =>
                                                                                    c
                                                                                  end)))
                                                                        | el =>
                                                                          (* ❌ Sending method message is not handled *)
                                                                          send
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "Error:"
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                                  (CamlinternalFormatBasics.Break
                                                                                    "@ "
                                                                                      %
                                                                                      string
                                                                                    1
                                                                                    0)
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    CamlinternalFormatBasics.End_of_format)))
                                                                              "Error:@ %a"
                                                                                %
                                                                                string)
                                                                            pp_print_error
                                                                            el
                                                                        end
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          failwith
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "Failed to submit proposals"
                                                                                  %
                                                                                  string
                                                                                CamlinternalFormatBasics.End_of_format)
                                                                              "Failed to submit proposals"
                                                                                %
                                                                                string))
                                                                    end))))))))))))
                  (cons
                    (command (Some group) "Submit a ballot" % string
                      (args2 verbose_signing_switch dry_run_switch)
                      (apply
                        (prefixes
                          (cons "submit" % string
                            (cons "ballot" % string (cons "for" % string []))))
                        (apply
                          (Client_keys.Secret_key.alias_param
                            (Some "delegate" % string)
                            (Some "the delegate who votes" % string))
                          (apply
                            (param "proposal" % string
                              "the protocol hash proposal to vote for" % string
                              (parameter None
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  fun x =>
                                    match Protocol_hash.of_b58check_opt x with
                                    | None =>
                                      failwith
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Invalid proposal hash: '" % string
                                            (CamlinternalFormatBasics.String
                                              CamlinternalFormatBasics.No_padding
                                              (CamlinternalFormatBasics.Char_literal
                                                "'" % char
                                                CamlinternalFormatBasics.End_of_format)))
                                          "Invalid proposal hash: '%s'" % string)
                                        x
                                    | Some hash => _return hash
                                    end)))
                            (apply
                              (param "ballot" % string
                                "the ballot value (yea/yay, nay, or pass)" %
                                  string
                                (parameter
                                  (Some
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      _return
                                        (cons "yea" % string
                                          (cons "nay" % string
                                            (cons "pass" % string [])))))
                                  (fun function_parameter =>
                                    let '_ := function_parameter in
                                    fun s =>
                                      match String.lowercase_ascii s with
                                      | "yay" % string | "yea" % string =>
                                        _return
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay
                                      | "nay" % string =>
                                        _return
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Nay
                                      | "pass" % string =>
                                        _return
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Pass
                                      | s =>
                                        failwith
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Invalid ballot: '" % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.Char_literal
                                                  "'" % char
                                                  CamlinternalFormatBasics.End_of_format)))
                                            "Invalid ballot: '%s'" % string) s
                                      end))) stop))))
                      (fun function_parameter =>
                        let '(verbose_signing, dry_run) := function_parameter in
                        fun function_parameter =>
                          let '(_, src_sk) := function_parameter in
                          fun proposal =>
                            fun ballot =>
                              fun cctxt =>
                                op_gtgteqquestion (Client_keys.neuterize src_sk)
                                  (fun src_pk =>
                                    op_gtgteqquestion
                                      (Client_keys.public_key_hash src_pk)
                                      (fun function_parameter =>
                                        let '(src_pkh, _) := function_parameter
                                          in
                                        op_gtgteqquestion
                                          (get_period_info cctxt
                                            (* ❌ Sending method message is not handled *)
                                            send
                                            (* ❌ Sending method message is not handled *)
                                            send)
                                          (fun info =>
                                            op_gtgteqquestion
                                              match current_period_kind info
                                                with
                                              |
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Testing_vote
                                                  |
                                                  Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Promotion_vote
                                                => return_unit
                                              | _ =>
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Not in a Testing_vote or Promotion_vote period"
                                                        % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "Not in a Testing_vote or Promotion_vote period"
                                                      % string)
                                              end
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                op_gtgteqquestion
                                                  (submit_ballot (Some dry_run)
                                                    (Some verbose_signing) cctxt
                                                    (* ❌ Sending method message is not handled *)
                                                    send
                                                    (* ❌ Sending method message is not handled *)
                                                    send None src_sk src_pkh
                                                    proposal ballot)
                                                  (fun _res => return_unit)))))))
                    (cons
                      (command (Some group)
                        "Summarize the current voting period" % string
                        no_options
                        (fixed
                          (cons "show" % string
                            (cons "voting" % string (cons "period" % string []))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          fun cctxt =>
                            op_gtgteqquestion
                              (get_period_info cctxt
                                (* ❌ Sending method message is not handled *)
                                send
                                (* ❌ Sending method message is not handled *)
                                send)
                              (fun info =>
                                op_gtgteq
                                  ((* ❌ Sending method message is not handled *)
                                  send
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Current period: " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            "
Blocks remaining until end of period: "
                                              % string
                                            (CamlinternalFormatBasics.Int32
                                              CamlinternalFormatBasics.Int_d
                                              CamlinternalFormatBasics.No_padding
                                              CamlinternalFormatBasics.No_precision
                                              CamlinternalFormatBasics.End_of_format))))
                                      "Current period: %a
Blocks remaining until end of period: %ld"
                                        % string) Data_encoding.Json.pp
                                    (Data_encoding.Json.construct
                                      Alpha_context.Voting_period.kind_encoding
                                      (current_period_kind info))
                                    (remaining info))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (Shell_services.Protocol.list cctxt)
                                      (fun known_protos =>
                                        op_gtgteqquestion
                                          (get_proposals cctxt
                                            (* ❌ Sending method message is not handled *)
                                            send
                                            (* ❌ Sending method message is not handled *)
                                            send)
                                          (fun props =>
                                            let ranks :=
                                              OCaml.Stdlib.reverse_apply
                                                (Environment.Protocol_hash.Map.bindings
                                                  props)
                                                (List.sort
                                                  (fun function_parameter =>
                                                    let '(_, v1) :=
                                                      function_parameter in
                                                    fun function_parameter =>
                                                      let '(_, v2) :=
                                                        function_parameter in
                                                      compare v2 v1)) in
                                            let print_proposal
                                              (function_parameter :
                                              option
                                                Tezos_base__TzPervasives.Protocol_hash.t)
                                              : Lwt.t unit :=
                                              match function_parameter with
                                              | None =>
                                                (* ❌ Assert instruction is not handled. *)
                                                assert false
                                              | Some proposal =>
                                                (* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Current proposal: " %
                                                        string
                                                      (CamlinternalFormatBasics.Alpha
                                                        CamlinternalFormatBasics.End_of_format))
                                                    "Current proposal: %a" %
                                                      string) Protocol_hash.pp
                                                  proposal
                                              end in
                                            match current_period_kind info with
                                            |
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Proposal
                                              =>
                                              op_gtgteq
                                                ((* ❌ Sending method message is not handled *)
                                                send
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "Current proposals:" %
                                                        string
                                                      (CamlinternalFormatBasics.Theta
                                                        CamlinternalFormatBasics.End_of_format))
                                                    "Current proposals:%t" %
                                                      string)
                                                  (fun ppf =>
                                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                    let _ := pp_print_cut ppf tt
                                                      in
                                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                    let _ := pp_open_vbox ppf 0
                                                      in
                                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                    let _ :=
                                                      List.iter
                                                        (fun function_parameter
                                                          =>
                                                          let '(p, w) :=
                                                            function_parameter
                                                            in
                                                          fprintf ppf
                                                            (CamlinternalFormatBasics.Format
                                                              (CamlinternalFormatBasics.String_literal
                                                                "* " % string
                                                                (CamlinternalFormatBasics.Alpha
                                                                  (CamlinternalFormatBasics.Char_literal
                                                                    " " % char
                                                                    (CamlinternalFormatBasics.Int32
                                                                      CamlinternalFormatBasics.Int_d
                                                                      CamlinternalFormatBasics.No_padding
                                                                      CamlinternalFormatBasics.No_precision
                                                                      (CamlinternalFormatBasics.String_literal
                                                                        " (" %
                                                                          string
                                                                        (CamlinternalFormatBasics.String
                                                                          CamlinternalFormatBasics.No_padding
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "known by the node)"
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Formatting_lit
                                                                              CamlinternalFormatBasics.Flush_newline
                                                                              CamlinternalFormatBasics.End_of_format))))))))
                                                              "* %a %ld (%sknown by the node)@."
                                                                % string)
                                                            Protocol_hash.pp p w
                                                            (if
                                                              List.mem p
                                                                known_protos
                                                              then
                                                              "" % string
                                                            else
                                                              "not " % string))
                                                        ranks in
                                                    pp_close_box ppf tt))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  return_unit)
                                            |
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Testing_vote
                                                |
                                                Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Promotion_vote
                                              =>
                                              op_gtgteq
                                                (print_proposal
                                                  (current_proposal info))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteqquestion
                                                    (get_ballots_info cctxt
                                                      (* ❌ Sending method message is not handled *)
                                                      send
                                                      (* ❌ Sending method message is not handled *)
                                                      send)
                                                    (fun ballots_info =>
                                                      op_gtgteq
                                                        ((* ❌ Sending method message is not handled *)
                                                        send
                                                          (CamlinternalFormatBasics.Format
                                                            (CamlinternalFormatBasics.String_literal
                                                              "Ballots: " %
                                                                string
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  (CamlinternalFormatBasics.Break
                                                                    "@," %
                                                                      string 0 0)
                                                                  (CamlinternalFormatBasics.String_literal
                                                                    "Current participation "
                                                                      % string
                                                                    (CamlinternalFormatBasics.Float
                                                                      CamlinternalFormatBasics.Float_f
                                                                      CamlinternalFormatBasics.No_padding
                                                                      (CamlinternalFormatBasics.Lit_precision
                                                                        2)
                                                                      (CamlinternalFormatBasics.Char_literal
                                                                        "%" %
                                                                          char
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          ", necessary quorum "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Float
                                                                            CamlinternalFormatBasics.Float_f
                                                                            CamlinternalFormatBasics.No_padding
                                                                            (CamlinternalFormatBasics.Lit_precision
                                                                              2)
                                                                            (CamlinternalFormatBasics.Char_literal
                                                                              "%"
                                                                                %
                                                                                char
                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                (CamlinternalFormatBasics.Break
                                                                                  "@,"
                                                                                    %
                                                                                    string
                                                                                  0
                                                                                  0)
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Current in favor "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Int32
                                                                                    CamlinternalFormatBasics.Int_d
                                                                                    CamlinternalFormatBasics.No_padding
                                                                                    CamlinternalFormatBasics.No_precision
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      ", needed supermajority "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Int32
                                                                                        CamlinternalFormatBasics.Int_d
                                                                                        CamlinternalFormatBasics.No_padding
                                                                                        CamlinternalFormatBasics.No_precision
                                                                                        CamlinternalFormatBasics.End_of_format))))))))))))))
                                                            "Ballots: %a@,Current participation %.2f%%, necessary quorum %.2f%%@,Current in favor %ld, needed supermajority %ld"
                                                              % string)
                                                          Data_encoding.Json.pp
                                                          (Data_encoding.Json.construct
                                                            Vote.ballots_encoding
                                                            (ballots
                                                              ballots_info))
                                                          (Stdlib.op_divpoint
                                                            (Int32.to_float
                                                              (participation
                                                                ballots_info))
                                                            (* ❌ Float constant 100. is approximated by the integer 100 *)
                                                            100)
                                                          (Stdlib.op_divpoint
                                                            (Int32.to_float
                                                              (current_quorum
                                                                ballots_info))
                                                            (* ❌ Float constant 100. is approximated by the integer 100 *)
                                                            100)
                                                          (yay
                                                            (ballots
                                                              ballots_info))
                                                          (supermajority
                                                            ballots_info))
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          return_unit)))
                                            |
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Voting_period.Testing
                                              =>
                                              op_gtgteq
                                                (print_proposal
                                                  (current_proposal info))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  return_unit)
                                            end)))))) []))))))))).

src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Client_proto_contracts

let group =
  {
    Clic.name = "contracts";
    title = "Commands for managing the record of known contracts";
  }

let commands () =
  let open Clic in
  [ command
      ~group
      ~desc:"Add a contract to the wallet."
      (args1 (RawContractAlias.force_switch ()))
      ( prefixes ["remember"; "contract"]
      @@ RawContractAlias.fresh_alias_param @@ RawContractAlias.source_param
      @@ stop )
      (fun force name hash cctxt ->
        RawContractAlias.of_fresh cctxt force name
        >>=? fun name -> RawContractAlias.add ~force cctxt name hash);
    command
      ~group
      ~desc:"Remove a contract from the wallet."
      no_options
      (prefixes ["forget"; "contract"] @@ RawContractAlias.alias_param @@ stop)
      (fun () (name, _) cctxt -> RawContractAlias.del cctxt name);
    command
      ~group
      ~desc:"Lists all known contracts in the wallet."
      no_options
      (fixed ["list"; "known"; "contracts"])
      (fun () (cctxt : Protocol_client_context.full) ->
        list_contracts cctxt
        >>=? fun contracts ->
        iter_s
          (fun (prefix, alias, contract) ->
            cctxt#message
              "%s%s: %s"
              prefix
              alias
              (Contract.to_b58check contract)
            >>= return)
          contracts);
    command
      ~group
      ~desc:"Forget the entire wallet of known contracts."
      (args1 (RawContractAlias.force_switch ()))
      (fixed ["forget"; "all"; "contracts"])
      (fun force cctxt ->
        fail_unless force (failure "this can only used with option -force")
        >>=? fun () -> RawContractAlias.set cctxt []);
    command
      ~group
      ~desc:"Display a contract from the wallet."
      no_options
      ( prefixes ["show"; "known"; "contract"]
      @@ RawContractAlias.alias_param @@ stop )
      (fun () (_, contract) (cctxt : Protocol_client_context.full) ->
        cctxt#message "%a\n%!" Contract.pp contract >>= fun () -> return_unit)
  ]
src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Client_proto_contracts.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "contracts" % string;
    Clic.title := "Commands for managing the record of known contracts" % string
    |}.

Definition commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  cons
    (command (Some group) "Add a contract to the wallet." % string
      (args1 (RawContractAlias.force_switch tt))
      (apply (prefixes (cons "remember" % string (cons "contract" % string [])))
        (apply
          (let arg := RawContractAlias.fresh_alias_param in
          fun eta => arg None None eta)
          (apply
            (let arg := RawContractAlias.source_param in
            fun eta => arg None None eta) stop)))
      (fun force =>
        fun name =>
          fun hash =>
            fun cctxt =>
              op_gtgteqquestion (RawContractAlias.of_fresh cctxt force name)
                (fun name => RawContractAlias.add force cctxt name hash)))
    (cons
      (command (Some group) "Remove a contract from the wallet." % string
        no_options
        (apply (prefixes (cons "forget" % string (cons "contract" % string [])))
          (apply
            (let arg := RawContractAlias.alias_param in
            fun eta => arg None None eta) stop))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let '(name, _) := function_parameter in
            fun cctxt => RawContractAlias.del cctxt name))
      (cons
        (command (Some group)
          "Lists all known contracts in the wallet." % string no_options
          (fixed
            (cons "list" % string
              (cons "known" % string (cons "contracts" % string []))))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun cctxt =>
              op_gtgteqquestion (list_contracts cctxt)
                (fun contracts =>
                  iter_s
                    (fun function_parameter =>
                      let '(prefix, alias, contract) := function_parameter in
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  ": " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.End_of_format))))
                            "%s%s: %s" % string) prefix alias
                          (Contract.to_b58check contract)) _return) contracts)))
        (cons
          (command (Some group)
            "Forget the entire wallet of known contracts." % string
            (args1 (RawContractAlias.force_switch tt))
            (fixed
              (cons "forget" % string
                (cons "all" % string (cons "contracts" % string []))))
            (fun force =>
              fun cctxt =>
                op_gtgteqquestion
                  (fail_unless force
                    (failure
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "this can only used with option -force" % string
                          CamlinternalFormatBasics.End_of_format)
                        "this can only used with option -force" % string)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    RawContractAlias.set cctxt [])))
          (cons
            (command (Some group) "Display a contract from the wallet." % string
              no_options
              (apply
                (prefixes
                  (cons "show" % string
                    (cons "known" % string (cons "contract" % string []))))
                (apply
                  (let arg := RawContractAlias.alias_param in
                  fun eta => arg None None eta) stop))
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun function_parameter =>
                  let '(_, contract) := function_parameter in
                  fun cctxt =>
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.Char_literal "010" % char
                              (CamlinternalFormatBasics.Flush
                                CamlinternalFormatBasics.End_of_format)))
                          "%a
%!" % string) Contract.pp contract)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit))) [])))).

src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml 185 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let group =
  {
    Clic.name = "multisig";
    title = "Commands for managing a multisig smart contract";
  }

let threshold_param () =
  Clic.param
    ~name:"threshold"
    ~desc:"Number of required signatures"
    Client_proto_args.int_parameter

let public_key_param () =
  Client_keys.Public_key.source_param
    ~name:"key"
    ~desc:"Each signer of the multisig contract"

let secret_key_param () =
  Client_keys.Secret_key.source_param
    ~name:"key"
    ~desc:
      "Secret key corresponding to one of the public keys stored on the \
       multisig contract"

let signature_param () =
  Clic.param
    ~name:"signature"
    ~desc:"Each signer of the multisig contract"
    Client_proto_args.signature_parameter

let bytes_only_switch =
  Clic.switch
    ~long:"bytes-only"
    ~doc:"return only the byte sequence to be signed"
    ()

let bytes_param ~name ~desc =
  Clic.param ~name ~desc Client_proto_args.bytes_parameter

let transfer_options =
  Clic.args12
    Client_proto_args.fee_arg
    Client_proto_context_commands.dry_run_switch
    Client_proto_args.gas_limit_arg
    Client_proto_args.storage_limit_arg
    Client_proto_args.counter_arg
    Client_proto_args.no_print_source_flag
    Client_proto_args.minimal_fees_arg
    Client_proto_args.minimal_nanotez_per_byte_arg
    Client_proto_args.minimal_nanotez_per_gas_unit_arg
    Client_proto_args.force_low_fee_arg
    Client_proto_args.fee_cap_arg
    Client_proto_args.burn_cap_arg

let commands () : #Protocol_client_context.full Clic.command list =
  Clic.
    [ command
        ~group
        ~desc:"Originate a new multisig contract."
        (args13
           Client_proto_args.fee_arg
           Client_proto_context_commands.dry_run_switch
           Client_proto_args.gas_limit_arg
           Client_proto_args.storage_limit_arg
           Client_proto_args.delegate_arg
           (Client_keys.force_switch ())
           Client_proto_args.no_print_source_flag
           Client_proto_args.minimal_fees_arg
           Client_proto_args.minimal_nanotez_per_byte_arg
           Client_proto_args.minimal_nanotez_per_gas_unit_arg
           Client_proto_args.force_low_fee_arg
           Client_proto_args.fee_cap_arg
           Client_proto_args.burn_cap_arg)
        ( prefixes ["deploy"; "multisig"]
        @@ Client_proto_contracts.RawContractAlias.fresh_alias_param
             ~name:"new_multisig"
             ~desc:"name of the new multisig contract"
        @@ prefix "transferring"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from source"
        @@ prefix "from"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"name of the source contract"
        @@ prefixes ["with"; "threshold"]
        @@ threshold_param ()
        @@ prefixes ["on"; "public"; "keys"]
        @@ seq_of_param (public_key_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               delegate,
               force,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             alias_name
             balance
             (_, source)
             threshold
             keys
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_contracts.RawContractAlias.of_fresh
            cctxt
            force
            alias_name
          >>=? fun alias_name ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of an origination"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) keys
              >>=? fun keys ->
              Client_proto_multisig.originate_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ?fee
                ?gas_limit
                ?storage_limit
                ~delegate
                ~threshold:(Z.of_int threshold)
                ~keys
                ~balance
                ~source
                ~src_pk
                ~src_sk
                ~fee_parameter
                ()
              >>= fun errors ->
              Client_proto_context_commands.report_michelson_errors
                ~no_print_source
                ~msg:"multisig origination simulation failed"
                cctxt
                errors
              >>= function
              | None ->
                  return_unit
              | Some (_res, contract) ->
                  if dry_run then return_unit
                  else
                    Client_proto_context.save_contract
                      ~force
                      cctxt
                      alias_name
                      contract
                    >>=? fun () -> return_unit ));
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned transfer."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefix "transferring"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from source"
        @@ prefix "to"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"dst"
             ~desc:"name/literal of the destination contract"
        @@ stop )
        (fun bytes_only
             (_, multisig_contract)
             amount
             (_, destination)
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Transfer (amount, destination))
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned delegate change."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["setting"; "delegate"; "to"]
        @@ Client_keys.Public_key_hash.source_param
             ~name:"dlgt"
             ~desc:"new delegate of the new multisig contract"
        @@ stop )
        (fun bytes_only
             (_, multisig_contract)
             new_delegate
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate (Some new_delegate))
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned delegate withdraw."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["withdrawing"; "delegate"]
        @@ stop )
        (fun bytes_only
             (_, multisig_contract)
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate None)
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:
          "Display the threshold, public keys, and byte sequence to sign for \
           a multisigned change of keys and threshold."
        (args1 bytes_only_switch)
        ( prefixes ["prepare"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["setting"; "threshold"; "to"]
        @@ threshold_param ()
        @@ prefixes ["and"; "public"; "keys"; "to"]
        @@ seq_of_param (public_key_param ()) )
        (fun bytes_only
             (_, multisig_contract)
             new_threshold
             new_keys
             (cctxt : #Protocol_client_context.full) ->
          map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys
          >>=? fun keys ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:
              (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys))
            ()
          >>=? fun prepared_command ->
          return
          @@
          if bytes_only then
            Format.printf
              "0x%a@."
              Hex.pp
              (Hex.of_bytes prepared_command.Client_proto_multisig.bytes)
          else
            Format.printf
              "%a@.%a@.%a@."
              (fun ppf x ->
                Format.fprintf
                  ppf
                  "Bytes to sign: '0x%a'"
                  Hex.pp
                  (Hex.of_bytes x))
              prepared_command.Client_proto_multisig.bytes
              (fun ppf z ->
                Format.fprintf
                  ppf
                  "Threshold (number of signatures required): %s"
                  (Z.to_string z))
              prepared_command.Client_proto_multisig.threshold
              (fun ppf ->
                Format.fprintf
                  ppf
                  "@[<2>Public keys of the signers:@ %a@]"
                  (Format.pp_print_list
                     ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
                     Signature.Public_key.pp))
              prepared_command.Client_proto_multisig.keys);
      command
        ~group
        ~desc:"Sign a transaction for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefix "transferring"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from source"
        @@ prefix "to"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"dst"
             ~desc:"name/literal of the destination contract"
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param () @@ stop )
        (fun ()
             (_, multisig_contract)
             amount
             (_, destination)
             sk
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Transfer (amount, destination))
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:"Sign a delegate change for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["setting"; "delegate"; "to"]
        @@ Client_keys.Public_key_hash.source_param
             ~name:"dlgt"
             ~desc:"new delegate of the new multisig contract"
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param () @@ stop )
        (fun ()
             (_, multisig_contract)
             delegate
             sk
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate (Some delegate))
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:"Sign a delegate withdraw for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["withdrawing"; "delegate"]
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param () @@ stop )
        (fun ()
             (_, multisig_contract)
             sk
             (cctxt : #Protocol_client_context.full) ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:(Client_proto_multisig.Change_delegate None)
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:
          "Sign a change of public keys and threshold for a multisig contract."
        no_options
        ( prefixes ["sign"; "multisig"; "transaction"; "on"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["using"; "secret"; "key"]
        @@ secret_key_param ()
        @@ prefixes ["setting"; "threshold"; "to"]
        @@ threshold_param ()
        @@ prefixes ["and"; "public"; "keys"; "to"]
        @@ seq_of_param (public_key_param ()) )
        (fun ()
             (_, multisig_contract)
             sk
             new_threshold
             new_keys
             (cctxt : #Protocol_client_context.full) ->
          map_s (fun (pk_uri, _) -> Client_keys.public_key pk_uri) new_keys
          >>=? fun keys ->
          Client_proto_multisig.prepare_multisig_transaction
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~multisig_contract
            ~action:
              (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys))
            ()
          >>=? fun prepared_command ->
          Client_keys.sign cctxt sk prepared_command.bytes
          >>=? fun signature ->
          return @@ Format.printf "%a@." Signature.pp signature);
      command
        ~group
        ~desc:"Transfer tokens using a multisig contract."
        transfer_options
        ( prefixes ["from"; "multisig"; "contract"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"multisig"
             ~desc:"name/literal of the multisig contract"
        @@ prefix "transfer"
        @@ Client_proto_args.tez_param
             ~name:"qty"
             ~desc:"amount taken from the multisig contract"
        @@ prefix "to"
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"dst"
             ~desc:"name/literal of the destination contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             (_, multisig_contract)
             amount
             (_, destination)
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~action:(Client_proto_multisig.Transfer (amount, destination))
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      command
        ~group
        ~desc:"Change the delegate of a multisig contract."
        transfer_options
        ( prefixes ["set"; "delegate"; "of"; "multisig"; "contract"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefix "to"
        @@ Client_keys.Public_key_hash.source_param
             ~name:"dlgt"
             ~desc:"new delegate of the new multisig contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             (_, multisig_contract)
             delegate
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~action:(Client_proto_multisig.Change_delegate (Some delegate))
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      command
        ~group
        ~desc:"Withdrow the delegate of a multisig contract."
        transfer_options
        ( prefixes ["withdraw"; "delegate"; "of"; "multisig"; "contract"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             (_, multisig_contract)
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~action:(Client_proto_multisig.Change_delegate None)
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      (* Unfortunately, Clic does not support non terminal lists of
       parameters so we cannot pass both a list of public keys and a
       list of signatures on the command line. This would permit a
       command for running the Change_keys action.

       However, we can run any action by deserialising the sequence of
       bytes built using the "prepare multisig transaction" commands *)
      command
        ~group
        ~desc:
          "Run a transaction described by a sequence of bytes on a multisig \
           contract."
        transfer_options
        ( prefixes ["run"; "transaction"]
        @@ bytes_param
             ~name:"bytes"
             ~desc:
               "the sequence of bytes to deserialize as a multisig action, \
                can be obtained by one of the \"prepare multisig \
                transaction\" commands"
        @@ prefixes ["on"; "multisig"; "contract"]
        @@ Client_proto_contracts.RawContractAlias.alias_param
             ~name:"multisig"
             ~desc:"name of the originated multisig contract"
        @@ prefixes ["on"; "behalf"; "of"]
        @@ Client_proto_contracts.ContractAlias.destination_param
             ~name:"src"
             ~desc:"source calling the multisig contract"
        @@ prefixes ["with"; "signatures"]
        @@ seq_of_param (signature_param ()) )
        (fun ( fee,
               dry_run,
               gas_limit,
               storage_limit,
               counter,
               no_print_source,
               minimal_fees,
               minimal_nanotez_per_byte,
               minimal_nanotez_per_gas_unit,
               force_low_fee,
               fee_cap,
               burn_cap )
             bytes
             (_, multisig_contract)
             (_, source)
             signatures
             (cctxt : #Protocol_client_context.full) ->
          match Contract.is_implicit source with
          | None ->
              failwith
                "only implicit accounts can be the source of a contract call"
          | Some source -> (
              Client_keys.get_key cctxt source
              >>=? fun (_, src_pk, src_sk) ->
              let fee_parameter =
                {
                  Injection.minimal_fees;
                  minimal_nanotez_per_byte;
                  minimal_nanotez_per_gas_unit;
                  force_low_fee;
                  fee_cap;
                  burn_cap;
                }
              in
              Client_proto_multisig.call_multisig_on_bytes
                cctxt
                ~chain:cctxt#chain
                ~block:cctxt#block
                ?confirmations:cctxt#confirmations
                ~dry_run
                ~fee_parameter
                ~source
                ?fee
                ~src_pk
                ~src_sk
                ~multisig_contract
                ~bytes
                ~signatures
                ~amount:Tez.zero
                ?gas_limit
                ?storage_limit
                ?counter
                ()
              >>= Client_proto_context_commands.report_michelson_errors
                    ~no_print_source
                    ~msg:"transfer simulation failed"
                    cctxt
              >>= function
              | None -> return_unit | Some (_res, _contracts) -> return_unit ));
      command
        ~group
        ~desc:"Show the hashes of the supported multisig contracts."
        no_options
        (fixed ["show"; "supported"; "multisig"; "hashes"])
        (fun () _cctxt ->
          Lwt.return Client_proto_multisig.known_multisig_hashes
          >>=? fun l ->
          Format.printf "Hashes of supported multisig contracts:@." ;
          List.iter
            (fun h ->
              Format.printf
                "  0x%a@."
                Hex.pp
                (Script_expr_hash.to_bytes h |> Hex.of_bytes))
            l ;
          return_unit) ]
src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "multisig" % string;
    Clic.title := "Commands for managing a multisig smart contract" % string |}.

Definition threshold_param {A : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    Tezos_client_alpha.Protocol_client_context.full) ->
    Tezos_base__TzPervasives.Clic.params (Z -> A)
      Tezos_client_alpha.Protocol_client_context.full :=
  let 'tt := function_parameter in
  Clic.param "threshold" % string "Number of required signatures" % string
    Client_proto_args.int_parameter.

Definition public_key_param {A C a : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
      * C)) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_client_base.Client_keys.Public_key.t -> A)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
        * C) :=
  let 'tt := function_parameter in
  Client_keys.Public_key.source_param (Some "key" % string)
    (Some "Each signer of the multisig contract" % string).

Definition secret_key_param {A C a : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    (((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
      * C)) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_client_base.Client_keys.Secret_key.t -> A)
      (((option (Lwt_stream.t string)) *
        ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
          ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * C)))))
        * C) :=
  let 'tt := function_parameter in
  Client_keys.Secret_key.source_param (Some "key" % string)
    (Some
      "Secret key corresponding to one of the public keys stored on the multisig contract"
        % string).

Definition signature_param {A : Type} (function_parameter : unit)
  : (Tezos_base__TzPervasives.Clic.params A
    Tezos_client_alpha.Protocol_client_context.full) ->
    Tezos_base__TzPervasives.Clic.params
      (Tezos_base__TzPervasives.Signature.t -> A)
      Tezos_client_alpha.Protocol_client_context.full :=
  let 'tt := function_parameter in
  Clic.param "signature" % string
    "Each signer of the multisig contract" % string
    Client_proto_args.signature_parameter.

Definition bytes_only_switch
  : Tezos_base__TzPervasives.Clic.arg bool
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.switch "return only the byte sequence to be signed" % string None
    "bytes-only" % string tt.

Definition bytes_param {A : Type} (name : string) (desc : string)
  : (Tezos_base__TzPervasives.Clic.params A
    Tezos_client_alpha.Protocol_client_context.full) ->
    Tezos_base__TzPervasives.Clic.params (Stdlib.Bytes.t -> A)
      Tezos_client_alpha.Protocol_client_context.full :=
  Clic.param name desc Client_proto_args.bytes_parameter.

Definition transfer_options
  : Tezos_base__TzPervasives.Clic.options
    ((option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) * bool *
      (option Z.t) * (option Z.t) * (option Z.t) * bool *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t * Z.t * bool *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t *
      Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.args12 Client_proto_args.fee_arg
    Client_proto_context_commands.dry_run_switch Client_proto_args.gas_limit_arg
    Client_proto_args.storage_limit_arg Client_proto_args.counter_arg
    Client_proto_args.no_print_source_flag Client_proto_args.minimal_fees_arg
    Client_proto_args.minimal_nanotez_per_byte_arg
    Client_proto_args.minimal_nanotez_per_gas_unit_arg
    Client_proto_args.force_low_fee_arg Client_proto_args.fee_cap_arg
    Client_proto_args.burn_cap_arg.

Definition commands {D F H J L M a b c i o p q : Type}
  (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((Z -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        nil)))))))))))))))))))))))))
        * nil)) :=
  let 'tt := function_parameter in
  cons
    (command (Some group) "Originate a new multisig contract." % string
      (args13 Client_proto_args.fee_arg
        Client_proto_context_commands.dry_run_switch
        Client_proto_args.gas_limit_arg Client_proto_args.storage_limit_arg
        Client_proto_args.delegate_arg (Client_keys.force_switch tt)
        Client_proto_args.no_print_source_flag
        Client_proto_args.minimal_fees_arg
        Client_proto_args.minimal_nanotez_per_byte_arg
        Client_proto_args.minimal_nanotez_per_gas_unit_arg
        Client_proto_args.force_low_fee_arg Client_proto_args.fee_cap_arg
        Client_proto_args.burn_cap_arg)
      (apply (prefixes (cons "deploy" % string (cons "multisig" % string [])))
        (apply
          (Client_proto_contracts.RawContractAlias.fresh_alias_param
            (Some "new_multisig" % string)
            (Some "name of the new multisig contract" % string))
          (apply (prefix "transferring" % string)
            (apply
              (Client_proto_args.tez_param "qty" % string
                "amount taken from source" % string)
              (apply (prefix "from" % string)
                (apply
                  (Client_proto_contracts.ContractAlias.destination_param
                    (Some "src" % string)
                    (Some "name of the source contract" % string))
                  (apply
                    (prefixes
                      (cons "with" % string (cons "threshold" % string [])))
                    (apply (threshold_param tt)
                      (apply
                        (prefixes
                          (cons "on" % string
                            (cons "public" % string (cons "keys" % string []))))
                        (seq_of_param (public_key_param tt)))))))))))
      (fun function_parameter =>
        let
          '(fee, dry_run, gas_limit, storage_limit, delegate, force,
            no_print_source, minimal_fees, minimal_nanotez_per_byte,
            minimal_nanotez_per_gas_unit, force_low_fee, fee_cap, burn_cap) :=
          function_parameter in
        fun alias_name =>
          fun balance =>
            fun function_parameter =>
              let '(_, source) := function_parameter in
              fun threshold =>
                fun keys =>
                  fun cctxt =>
                    op_gtgteqquestion
                      (Client_proto_contracts.RawContractAlias.of_fresh cctxt
                        force alias_name)
                      (fun alias_name =>
                        match Contract.is_implicit source with
                        | None =>
                          failwith
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "only implicit accounts can be the source of an origination"
                                  % string
                                CamlinternalFormatBasics.End_of_format)
                              "only implicit accounts can be the source of an origination"
                                % string)
                        | Some source =>
                          op_gtgteqquestion (Client_keys.get_key cctxt source)
                            (fun function_parameter =>
                              let '(_, src_pk, src_sk) := function_parameter in
                              let fee_parameter :=
                                {| Injection.minimal_fees := minimal_fees;
                                  Injection.minimal_nanotez_per_byte :=
                                    minimal_nanotez_per_byte;
                                  Injection.minimal_nanotez_per_gas_unit :=
                                    minimal_nanotez_per_gas_unit;
                                  Injection.force_low_fee := force_low_fee;
                                  Injection.fee_cap := fee_cap;
                                  Injection.burn_cap := burn_cap |} in
                              op_gtgteqquestion
                                (map_s
                                  (fun function_parameter =>
                                    let '(pk_uri, _) := function_parameter in
                                    Client_keys.public_key pk_uri) keys)
                                (fun keys =>
                                  op_gtgteq
                                    (Client_proto_multisig.originate_multisig
                                      cctxt
                                      (* ❌ Sending method message is not handled *)
                                      send
                                      (* ❌ Sending method message is not handled *)
                                      send
                                      (* ❌ Sending method message is not handled *)
                                      send (Some dry_run) None fee gas_limit
                                      storage_limit delegate
                                      (Z.of_int threshold) keys balance source
                                      src_pk src_sk fee_parameter tt)
                                    (fun errors =>
                                      op_gtgteq
                                        (Client_proto_context_commands.report_michelson_errors
                                          (Some no_print_source)
                                          "multisig origination simulation failed"
                                            % string cctxt errors)
                                        (fun function_parameter =>
                                          match function_parameter with
                                          | None => return_unit
                                          | Some (_res, contract) =>
                                            if dry_run then
                                              return_unit
                                            else
                                              op_gtgteqquestion
                                                (Client_proto_context.save_contract
                                                  force cctxt alias_name
                                                  contract)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  return_unit)
                                          end))))
                        end)))
    (cons
      (command (Some group)
        "Display the threshold, public keys, and byte sequence to sign for a multisigned transfer."
          % string (args1 bytes_only_switch)
        (apply
          (prefixes
            (cons "prepare" % string
              (cons "multisig" % string
                (cons "transaction" % string (cons "on" % string [])))))
          (apply
            (Client_proto_contracts.RawContractAlias.alias_param
              (Some "multisig" % string)
              (Some "name of the originated multisig contract" % string))
            (apply (prefix "transferring" % string)
              (apply
                (Client_proto_args.tez_param "qty" % string
                  "amount taken from source" % string)
                (apply (prefix "to" % string)
                  (apply
                    (Client_proto_contracts.ContractAlias.destination_param
                      (Some "dst" % string)
                      (Some "name/literal of the destination contract" % string))
                    stop))))))
        (fun bytes_only =>
          fun function_parameter =>
            let '(_, multisig_contract) := function_parameter in
            fun amount =>
              fun function_parameter =>
                let '(_, destination) := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion
                    (Client_proto_multisig.prepare_multisig_transaction cctxt
                      (* ❌ Sending method message is not handled *)
                      send
                      (* ❌ Sending method message is not handled *)
                      send multisig_contract
                      (Tezos_client_alpha.Client_proto_multisig.Transfer amount
                        destination) tt)
                    (fun prepared_command =>
                      apply _return
                        (if bytes_only then
                          Format.printf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "0x" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))
                              "0x%a@." % string) Hex.pp
                            (Hex.of_bytes None
                              (Client_proto_multisig.bytes prepared_command))
                        else
                          Format.printf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          CamlinternalFormatBasics.End_of_format))))))
                              "%a@.%a@.%a@." % string)
                            (fun ppf =>
                              fun x =>
                                Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Bytes to sign: '0x" % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "'" % char
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Bytes to sign: '0x%a'" % string) Hex.pp
                                  (Hex.of_bytes None x))
                            (Client_proto_multisig.bytes prepared_command)
                            (fun ppf =>
                              fun z =>
                                Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Threshold (number of signatures required): "
                                        % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "Threshold (number of signatures required): %s"
                                      % string) (Z.to_string z))
                            (Client_proto_multisig.threshold prepared_command)
                            (fun ppf =>
                              Format.fprintf ppf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<2>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<2>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Public keys of the signers:" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "@[<2>Public keys of the signers:@ %a@]" %
                                    string)
                                (Format.pp_print_list
                                  (Some
                                    (fun ppf =>
                                      fun function_parameter =>
                                        let 'tt := function_parameter in
                                        Format.fprintf ppf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              CamlinternalFormatBasics.End_of_format)
                                            "@ " % string)))
                                  Signature.Public_key.pp))
                            (Client_proto_multisig.keys prepared_command)))))
      (cons
        (command (Some group)
          "Display the threshold, public keys, and byte sequence to sign for a multisigned delegate change."
            % string (args1 bytes_only_switch)
          (apply
            (prefixes
              (cons "prepare" % string
                (cons "multisig" % string
                  (cons "transaction" % string (cons "on" % string [])))))
            (apply
              (Client_proto_contracts.RawContractAlias.alias_param
                (Some "multisig" % string)
                (Some "name of the originated multisig contract" % string))
              (apply
                (prefixes
                  (cons "setting" % string
                    (cons "delegate" % string (cons "to" % string []))))
                (apply
                  (Client_keys.Public_key_hash.source_param
                    (Some "dlgt" % string)
                    (Some "new delegate of the new multisig contract" % string))
                  stop))))
          (fun bytes_only =>
            fun function_parameter =>
              let '(_, multisig_contract) := function_parameter in
              fun new_delegate =>
                fun cctxt =>
                  op_gtgteqquestion
                    (Client_proto_multisig.prepare_multisig_transaction cctxt
                      (* ❌ Sending method message is not handled *)
                      send
                      (* ❌ Sending method message is not handled *)
                      send multisig_contract
                      (Tezos_client_alpha.Client_proto_multisig.Change_delegate
                        (Some new_delegate)) tt)
                    (fun prepared_command =>
                      apply _return
                        (if bytes_only then
                          Format.printf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "0x" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))
                              "0x%a@." % string) Hex.pp
                            (Hex.of_bytes None
                              (Client_proto_multisig.bytes prepared_command))
                        else
                          Format.printf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          CamlinternalFormatBasics.End_of_format))))))
                              "%a@.%a@.%a@." % string)
                            (fun ppf =>
                              fun x =>
                                Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Bytes to sign: '0x" % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "'" % char
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Bytes to sign: '0x%a'" % string) Hex.pp
                                  (Hex.of_bytes None x))
                            (Client_proto_multisig.bytes prepared_command)
                            (fun ppf =>
                              fun z =>
                                Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Threshold (number of signatures required): "
                                        % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "Threshold (number of signatures required): %s"
                                      % string) (Z.to_string z))
                            (Client_proto_multisig.threshold prepared_command)
                            (fun ppf =>
                              Format.fprintf ppf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<2>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<2>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Public keys of the signers:" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "@[<2>Public keys of the signers:@ %a@]" %
                                    string)
                                (Format.pp_print_list
                                  (Some
                                    (fun ppf =>
                                      fun function_parameter =>
                                        let 'tt := function_parameter in
                                        Format.fprintf ppf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              CamlinternalFormatBasics.End_of_format)
                                            "@ " % string)))
                                  Signature.Public_key.pp))
                            (Client_proto_multisig.keys prepared_command)))))
        (cons
          (command (Some group)
            "Display the threshold, public keys, and byte sequence to sign for a multisigned delegate withdraw."
              % string (args1 bytes_only_switch)
            (apply
              (prefixes
                (cons "prepare" % string
                  (cons "multisig" % string
                    (cons "transaction" % string (cons "on" % string [])))))
              (apply
                (Client_proto_contracts.RawContractAlias.alias_param
                  (Some "multisig" % string)
                  (Some "name of the originated multisig contract" % string))
                (apply
                  (prefixes
                    (cons "withdrawing" % string (cons "delegate" % string [])))
                  stop)))
            (fun bytes_only =>
              fun function_parameter =>
                let '(_, multisig_contract) := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion
                    (Client_proto_multisig.prepare_multisig_transaction cctxt
                      (* ❌ Sending method message is not handled *)
                      send
                      (* ❌ Sending method message is not handled *)
                      send multisig_contract
                      (Tezos_client_alpha.Client_proto_multisig.Change_delegate
                        None) tt)
                    (fun prepared_command =>
                      apply _return
                        (if bytes_only then
                          Format.printf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "0x" % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Flush_newline
                                    CamlinternalFormatBasics.End_of_format)))
                              "0x%a@." % string) Hex.pp
                            (Hex.of_bytes None
                              (Client_proto_multisig.bytes prepared_command))
                        else
                          Format.printf
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Flush_newline
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Flush_newline
                                          CamlinternalFormatBasics.End_of_format))))))
                              "%a@.%a@.%a@." % string)
                            (fun ppf =>
                              fun x =>
                                Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Bytes to sign: '0x" % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Char_literal
                                          "'" % char
                                          CamlinternalFormatBasics.End_of_format)))
                                    "Bytes to sign: '0x%a'" % string) Hex.pp
                                  (Hex.of_bytes None x))
                            (Client_proto_multisig.bytes prepared_command)
                            (fun ppf =>
                              fun z =>
                                Format.fprintf ppf
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Threshold (number of signatures required): "
                                        % string
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))
                                    "Threshold (number of signatures required): %s"
                                      % string) (Z.to_string z))
                            (Client_proto_multisig.threshold prepared_command)
                            (fun ppf =>
                              Format.fprintf ppf
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<2>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<2>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Public keys of the signers:" % string
                                      (CamlinternalFormatBasics.Formatting_lit
                                        (CamlinternalFormatBasics.Break
                                          "@ " % string 1 0)
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Close_box
                                            CamlinternalFormatBasics.End_of_format)))))
                                  "@[<2>Public keys of the signers:@ %a@]" %
                                    string)
                                (Format.pp_print_list
                                  (Some
                                    (fun ppf =>
                                      fun function_parameter =>
                                        let 'tt := function_parameter in
                                        Format.fprintf ppf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_lit
                                              (CamlinternalFormatBasics.Break
                                                "@ " % string 1 0)
                                              CamlinternalFormatBasics.End_of_format)
                                            "@ " % string)))
                                  Signature.Public_key.pp))
                            (Client_proto_multisig.keys prepared_command)))))
          (cons
            (command (Some group)
              "Display the threshold, public keys, and byte sequence to sign for a multisigned change of keys and threshold."
                % string (args1 bytes_only_switch)
              (apply
                (prefixes
                  (cons "prepare" % string
                    (cons "multisig" % string
                      (cons "transaction" % string (cons "on" % string [])))))
                (apply
                  (Client_proto_contracts.RawContractAlias.alias_param
                    (Some "multisig" % string)
                    (Some "name of the originated multisig contract" % string))
                  (apply
                    (prefixes
                      (cons "setting" % string
                        (cons "threshold" % string (cons "to" % string []))))
                    (apply (threshold_param tt)
                      (apply
                        (prefixes
                          (cons "and" % string
                            (cons "public" % string
                              (cons "keys" % string (cons "to" % string [])))))
                        (seq_of_param (public_key_param tt)))))))
              (fun bytes_only =>
                fun function_parameter =>
                  let '(_, multisig_contract) := function_parameter in
                  fun new_threshold =>
                    fun new_keys =>
                      fun cctxt =>
                        op_gtgteqquestion
                          (map_s
                            (fun function_parameter =>
                              let '(pk_uri, _) := function_parameter in
                              Client_keys.public_key pk_uri) new_keys)
                          (fun keys =>
                            op_gtgteqquestion
                              (Client_proto_multisig.prepare_multisig_transaction
                                cctxt
                                (* ❌ Sending method message is not handled *)
                                send
                                (* ❌ Sending method message is not handled *)
                                send multisig_contract
                                (Tezos_client_alpha.Client_proto_multisig.Change_keys
                                  (Z.of_int new_threshold) keys) tt)
                              (fun prepared_command =>
                                apply _return
                                  (if bytes_only then
                                    Format.printf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "0x" % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format)))
                                        "0x%a@." % string) Hex.pp
                                      (Hex.of_bytes None
                                        (Client_proto_multisig.bytes
                                          prepared_command))
                                  else
                                    Format.printf
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Flush_newline
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Flush_newline
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Flush_newline
                                                    CamlinternalFormatBasics.End_of_format))))))
                                        "%a@.%a@.%a@." % string)
                                      (fun ppf =>
                                        fun x =>
                                          Format.fprintf ppf
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Bytes to sign: '0x" % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.Char_literal
                                                    "'" % char
                                                    CamlinternalFormatBasics.End_of_format)))
                                              "Bytes to sign: '0x%a'" % string)
                                            Hex.pp (Hex.of_bytes None x))
                                      (Client_proto_multisig.bytes
                                        prepared_command)
                                      (fun ppf =>
                                        fun z =>
                                          Format.fprintf ppf
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Threshold (number of signatures required): "
                                                  % string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  CamlinternalFormatBasics.End_of_format))
                                              "Threshold (number of signatures required): %s"
                                                % string) (Z.to_string z))
                                      (Client_proto_multisig.threshold
                                        prepared_command)
                                      (fun ppf =>
                                        Format.fprintf ppf
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_box
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "<2>" % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "<2>" % string))
                                              (CamlinternalFormatBasics.String_literal
                                                "Public keys of the signers:" %
                                                  string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@ " % string 1 0)
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format)))))
                                            "@[<2>Public keys of the signers:@ %a@]"
                                              % string)
                                          (Format.pp_print_list
                                            (Some
                                              (fun ppf =>
                                                fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  Format.fprintf ppf
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@ " % string 1 0)
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "@ " % string)))
                                            Signature.Public_key.pp))
                                      (Client_proto_multisig.keys
                                        prepared_command))))))
            (cons
              (command (Some group)
                "Sign a transaction for a multisig contract." % string
                no_options
                (apply
                  (prefixes
                    (cons "sign" % string
                      (cons "multisig" % string
                        (cons "transaction" % string (cons "on" % string [])))))
                  (apply
                    (Client_proto_contracts.RawContractAlias.alias_param
                      (Some "multisig" % string)
                      (Some "name of the originated multisig contract" % string))
                    (apply (prefix "transferring" % string)
                      (apply
                        (Client_proto_args.tez_param "qty" % string
                          "amount taken from source" % string)
                        (apply (prefix "to" % string)
                          (apply
                            (Client_proto_contracts.ContractAlias.destination_param
                              (Some "dst" % string)
                              (Some
                                "name/literal of the destination contract" %
                                  string))
                            (apply
                              (prefixes
                                (cons "using" % string
                                  (cons "secret" % string
                                    (cons "key" % string []))))
                              (apply (secret_key_param tt) stop))))))))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  fun function_parameter =>
                    let '(_, multisig_contract) := function_parameter in
                    fun amount =>
                      fun function_parameter =>
                        let '(_, destination) := function_parameter in
                        fun sk =>
                          fun cctxt =>
                            op_gtgteqquestion
                              (Client_proto_multisig.prepare_multisig_transaction
                                cctxt
                                (* ❌ Sending method message is not handled *)
                                send
                                (* ❌ Sending method message is not handled *)
                                send multisig_contract
                                (Tezos_client_alpha.Client_proto_multisig.Transfer
                                  amount destination) tt)
                              (fun prepared_command =>
                                op_gtgteqquestion
                                  (Client_keys.sign cctxt None sk
                                    (bytes prepared_command))
                                  (fun signature =>
                                    apply _return
                                      (Format.printf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format))
                                          "%a@." % string) Signature.pp
                                        signature)))))
              (cons
                (command (Some group)
                  "Sign a delegate change for a multisig contract." % string
                  no_options
                  (apply
                    (prefixes
                      (cons "sign" % string
                        (cons "multisig" % string
                          (cons "transaction" % string (cons "on" % string [])))))
                    (apply
                      (Client_proto_contracts.RawContractAlias.alias_param
                        (Some "multisig" % string)
                        (Some
                          "name of the originated multisig contract" % string))
                      (apply
                        (prefixes
                          (cons "setting" % string
                            (cons "delegate" % string (cons "to" % string []))))
                        (apply
                          (Client_keys.Public_key_hash.source_param
                            (Some "dlgt" % string)
                            (Some
                              "new delegate of the new multisig contract" %
                                string))
                          (apply
                            (prefixes
                              (cons "using" % string
                                (cons "secret" % string (cons "key" % string []))))
                            (apply (secret_key_param tt) stop))))))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    fun function_parameter =>
                      let '(_, multisig_contract) := function_parameter in
                      fun delegate =>
                        fun sk =>
                          fun cctxt =>
                            op_gtgteqquestion
                              (Client_proto_multisig.prepare_multisig_transaction
                                cctxt
                                (* ❌ Sending method message is not handled *)
                                send
                                (* ❌ Sending method message is not handled *)
                                send multisig_contract
                                (Tezos_client_alpha.Client_proto_multisig.Change_delegate
                                  (Some delegate)) tt)
                              (fun prepared_command =>
                                op_gtgteqquestion
                                  (Client_keys.sign cctxt None sk
                                    (bytes prepared_command))
                                  (fun signature =>
                                    apply _return
                                      (Format.printf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format))
                                          "%a@." % string) Signature.pp
                                        signature)))))
                (cons
                  (command (Some group)
                    "Sign a delegate withdraw for a multisig contract." % string
                    no_options
                    (apply
                      (prefixes
                        (cons "sign" % string
                          (cons "multisig" % string
                            (cons "transaction" % string (cons "on" % string [])))))
                      (apply
                        (Client_proto_contracts.RawContractAlias.alias_param
                          (Some "multisig" % string)
                          (Some
                            "name of the originated multisig contract" % string))
                        (apply
                          (prefixes
                            (cons "withdrawing" % string
                              (cons "delegate" % string [])))
                          (apply
                            (prefixes
                              (cons "using" % string
                                (cons "secret" % string (cons "key" % string []))))
                            (apply (secret_key_param tt) stop)))))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      fun function_parameter =>
                        let '(_, multisig_contract) := function_parameter in
                        fun sk =>
                          fun cctxt =>
                            op_gtgteqquestion
                              (Client_proto_multisig.prepare_multisig_transaction
                                cctxt
                                (* ❌ Sending method message is not handled *)
                                send
                                (* ❌ Sending method message is not handled *)
                                send multisig_contract
                                (Tezos_client_alpha.Client_proto_multisig.Change_delegate
                                  None) tt)
                              (fun prepared_command =>
                                op_gtgteqquestion
                                  (Client_keys.sign cctxt None sk
                                    (bytes prepared_command))
                                  (fun signature =>
                                    apply _return
                                      (Format.printf
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Flush_newline
                                              CamlinternalFormatBasics.End_of_format))
                                          "%a@." % string) Signature.pp
                                        signature)))))
                  (cons
                    (command (Some group)
                      "Sign a change of public keys and threshold for a multisig contract."
                        % string no_options
                      (apply
                        (prefixes
                          (cons "sign" % string
                            (cons "multisig" % string
                              (cons "transaction" % string
                                (cons "on" % string [])))))
                        (apply
                          (Client_proto_contracts.RawContractAlias.alias_param
                            (Some "multisig" % string)
                            (Some
                              "name of the originated multisig contract" %
                                string))
                          (apply
                            (prefixes
                              (cons "using" % string
                                (cons "secret" % string (cons "key" % string []))))
                            (apply (secret_key_param tt)
                              (apply
                                (prefixes
                                  (cons "setting" % string
                                    (cons "threshold" % string
                                      (cons "to" % string []))))
                                (apply (threshold_param tt)
                                  (apply
                                    (prefixes
                                      (cons "and" % string
                                        (cons "public" % string
                                          (cons "keys" % string
                                            (cons "to" % string [])))))
                                    (seq_of_param (public_key_param tt)))))))))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        fun function_parameter =>
                          let '(_, multisig_contract) := function_parameter in
                          fun sk =>
                            fun new_threshold =>
                              fun new_keys =>
                                fun cctxt =>
                                  op_gtgteqquestion
                                    (map_s
                                      (fun function_parameter =>
                                        let '(pk_uri, _) := function_parameter
                                          in
                                        Client_keys.public_key pk_uri) new_keys)
                                    (fun keys =>
                                      op_gtgteqquestion
                                        (Client_proto_multisig.prepare_multisig_transaction
                                          cctxt
                                          (* ❌ Sending method message is not handled *)
                                          send
                                          (* ❌ Sending method message is not handled *)
                                          send multisig_contract
                                          (Tezos_client_alpha.Client_proto_multisig.Change_keys
                                            (Z.of_int new_threshold) keys) tt)
                                        (fun prepared_command =>
                                          op_gtgteqquestion
                                            (Client_keys.sign cctxt None sk
                                              (bytes prepared_command))
                                            (fun signature =>
                                              apply _return
                                                (Format.printf
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Flush_newline
                                                        CamlinternalFormatBasics.End_of_format))
                                                    "%a@." % string)
                                                  Signature.pp signature))))))
                    (cons
                      (command (Some group)
                        "Transfer tokens using a multisig contract." % string
                        transfer_options
                        (apply
                          (prefixes
                            (cons "from" % string
                              (cons "multisig" % string
                                (cons "contract" % string []))))
                          (apply
                            (Client_proto_contracts.ContractAlias.destination_param
                              (Some "multisig" % string)
                              (Some
                                "name/literal of the multisig contract" % string))
                            (apply (prefix "transfer" % string)
                              (apply
                                (Client_proto_args.tez_param "qty" % string
                                  "amount taken from the multisig contract" %
                                    string)
                                (apply (prefix "to" % string)
                                  (apply
                                    (Client_proto_contracts.ContractAlias.destination_param
                                      (Some "dst" % string)
                                      (Some
                                        "name/literal of the destination contract"
                                          % string))
                                    (apply
                                      (prefixes
                                        (cons "on" % string
                                          (cons "behalf" % string
                                            (cons "of" % string []))))
                                      (apply
                                        (Client_proto_contracts.ContractAlias.destination_param
                                          (Some "src" % string)
                                          (Some
                                            "source calling the multisig contract"
                                              % string))
                                        (apply
                                          (prefixes
                                            (cons "with" % string
                                              (cons "signatures" % string [])))
                                          (seq_of_param (signature_param tt)))))))))))
                        (fun function_parameter =>
                          let
                            '(fee, dry_run, gas_limit, storage_limit, counter,
                              no_print_source, minimal_fees,
                              minimal_nanotez_per_byte,
                              minimal_nanotez_per_gas_unit, force_low_fee,
                              fee_cap, burn_cap) := function_parameter in
                          fun function_parameter =>
                            let '(_, multisig_contract) := function_parameter in
                            fun amount =>
                              fun function_parameter =>
                                let '(_, destination) := function_parameter in
                                fun function_parameter =>
                                  let '(_, source) := function_parameter in
                                  fun signatures =>
                                    fun cctxt =>
                                      match Contract.is_implicit source with
                                      | None =>
                                        failwith
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "only implicit accounts can be the source of a contract call"
                                                % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "only implicit accounts can be the source of a contract call"
                                              % string)
                                      | Some source =>
                                        op_gtgteqquestion
                                          (Client_keys.get_key cctxt source)
                                          (fun function_parameter =>
                                            let '(_, src_pk, src_sk) :=
                                              function_parameter in
                                            let fee_parameter :=
                                              {|
                                                Injection.minimal_fees :=
                                                  minimal_fees;
                                                Injection.minimal_nanotez_per_byte :=
                                                  minimal_nanotez_per_byte;
                                                Injection.minimal_nanotez_per_gas_unit :=
                                                  minimal_nanotez_per_gas_unit;
                                                Injection.force_low_fee :=
                                                  force_low_fee;
                                                Injection.fee_cap := fee_cap;
                                                Injection.burn_cap := burn_cap
                                                |} in
                                            op_gtgteq
                                              (op_gtgteq
                                                (Client_proto_multisig.call_multisig
                                                  cctxt
                                                  (* ❌ Sending method message is not handled *)
                                                  send
                                                  (* ❌ Sending method message is not handled *)
                                                  send
                                                  (* ❌ Sending method message is not handled *)
                                                  send (Some dry_run) None
                                                  source src_pk src_sk
                                                  multisig_contract
                                                  (Tezos_client_alpha.Client_proto_multisig.Transfer
                                                    amount destination)
                                                  signatures Tez.zero fee
                                                  gas_limit storage_limit
                                                  counter fee_parameter tt)
                                                (Client_proto_context_commands.report_michelson_errors
                                                  (Some no_print_source)
                                                  "transfer simulation failed" %
                                                    string cctxt))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | None => return_unit
                                                | Some (_res, _contracts) =>
                                                  return_unit
                                                end))
                                      end))
                      (cons
                        (command (Some group)
                          "Change the delegate of a multisig contract." % string
                          transfer_options
                          (apply
                            (prefixes
                              (cons "set" % string
                                (cons "delegate" % string
                                  (cons "of" % string
                                    (cons "multisig" % string
                                      (cons "contract" % string []))))))
                            (apply
                              (Client_proto_contracts.RawContractAlias.alias_param
                                (Some "multisig" % string)
                                (Some
                                  "name of the originated multisig contract" %
                                    string))
                              (apply (prefix "to" % string)
                                (apply
                                  (Client_keys.Public_key_hash.source_param
                                    (Some "dlgt" % string)
                                    (Some
                                      "new delegate of the new multisig contract"
                                        % string))
                                  (apply
                                    (prefixes
                                      (cons "on" % string
                                        (cons "behalf" % string
                                          (cons "of" % string []))))
                                    (apply
                                      (Client_proto_contracts.ContractAlias.destination_param
                                        (Some "src" % string)
                                        (Some
                                          "source calling the multisig contract"
                                            % string))
                                      (apply
                                        (prefixes
                                          (cons "with" % string
                                            (cons "signatures" % string [])))
                                        (seq_of_param (signature_param tt)))))))))
                          (fun function_parameter =>
                            let
                              '(fee, dry_run, gas_limit, storage_limit, counter,
                                no_print_source, minimal_fees,
                                minimal_nanotez_per_byte,
                                minimal_nanotez_per_gas_unit, force_low_fee,
                                fee_cap, burn_cap) := function_parameter in
                            fun function_parameter =>
                              let '(_, multisig_contract) := function_parameter
                                in
                              fun delegate =>
                                fun function_parameter =>
                                  let '(_, source) := function_parameter in
                                  fun signatures =>
                                    fun cctxt =>
                                      match Contract.is_implicit source with
                                      | None =>
                                        failwith
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "only implicit accounts can be the source of a contract call"
                                                % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "only implicit accounts can be the source of a contract call"
                                              % string)
                                      | Some source =>
                                        op_gtgteqquestion
                                          (Client_keys.get_key cctxt source)
                                          (fun function_parameter =>
                                            let '(_, src_pk, src_sk) :=
                                              function_parameter in
                                            let fee_parameter :=
                                              {|
                                                Injection.minimal_fees :=
                                                  minimal_fees;
                                                Injection.minimal_nanotez_per_byte :=
                                                  minimal_nanotez_per_byte;
                                                Injection.minimal_nanotez_per_gas_unit :=
                                                  minimal_nanotez_per_gas_unit;
                                                Injection.force_low_fee :=
                                                  force_low_fee;
                                                Injection.fee_cap := fee_cap;
                                                Injection.burn_cap := burn_cap
                                                |} in
                                            op_gtgteq
                                              (op_gtgteq
                                                (Client_proto_multisig.call_multisig
                                                  cctxt
                                                  (* ❌ Sending method message is not handled *)
                                                  send
                                                  (* ❌ Sending method message is not handled *)
                                                  send
                                                  (* ❌ Sending method message is not handled *)
                                                  send (Some dry_run) None
                                                  source src_pk src_sk
                                                  multisig_contract
                                                  (Tezos_client_alpha.Client_proto_multisig.Change_delegate
                                                    (Some delegate)) signatures
                                                  Tez.zero fee gas_limit
                                                  storage_limit counter
                                                  fee_parameter tt)
                                                (Client_proto_context_commands.report_michelson_errors
                                                  (Some no_print_source)
                                                  "transfer simulation failed" %
                                                    string cctxt))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | None => return_unit
                                                | Some (_res, _contracts) =>
                                                  return_unit
                                                end))
                                      end))
                        (cons
                          (command (Some group)
                            "Withdrow the delegate of a multisig contract." %
                              string transfer_options
                            (apply
                              (prefixes
                                (cons "withdraw" % string
                                  (cons "delegate" % string
                                    (cons "of" % string
                                      (cons "multisig" % string
                                        (cons "contract" % string []))))))
                              (apply
                                (Client_proto_contracts.RawContractAlias.alias_param
                                  (Some "multisig" % string)
                                  (Some
                                    "name of the originated multisig contract" %
                                      string))
                                (apply
                                  (prefixes
                                    (cons "on" % string
                                      (cons "behalf" % string
                                        (cons "of" % string []))))
                                  (apply
                                    (Client_proto_contracts.ContractAlias.destination_param
                                      (Some "src" % string)
                                      (Some
                                        "source calling the multisig contract" %
                                          string))
                                    (apply
                                      (prefixes
                                        (cons "with" % string
                                          (cons "signatures" % string [])))
                                      (seq_of_param (signature_param tt)))))))
                            (fun function_parameter =>
                              let
                                '(fee, dry_run, gas_limit, storage_limit,
                                  counter, no_print_source, minimal_fees,
                                  minimal_nanotez_per_byte,
                                  minimal_nanotez_per_gas_unit, force_low_fee,
                                  fee_cap, burn_cap) := function_parameter in
                              fun function_parameter =>
                                let '(_, multisig_contract) :=
                                  function_parameter in
                                fun function_parameter =>
                                  let '(_, source) := function_parameter in
                                  fun signatures =>
                                    fun cctxt =>
                                      match Contract.is_implicit source with
                                      | None =>
                                        failwith
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "only implicit accounts can be the source of a contract call"
                                                % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "only implicit accounts can be the source of a contract call"
                                              % string)
                                      | Some source =>
                                        op_gtgteqquestion
                                          (Client_keys.get_key cctxt source)
                                          (fun function_parameter =>
                                            let '(_, src_pk, src_sk) :=
                                              function_parameter in
                                            let fee_parameter :=
                                              {|
                                                Injection.minimal_fees :=
                                                  minimal_fees;
                                                Injection.minimal_nanotez_per_byte :=
                                                  minimal_nanotez_per_byte;
                                                Injection.minimal_nanotez_per_gas_unit :=
                                                  minimal_nanotez_per_gas_unit;
                                                Injection.force_low_fee :=
                                                  force_low_fee;
                                                Injection.fee_cap := fee_cap;
                                                Injection.burn_cap := burn_cap
                                                |} in
                                            op_gtgteq
                                              (op_gtgteq
                                                (Client_proto_multisig.call_multisig
                                                  cctxt
                                                  (* ❌ Sending method message is not handled *)
                                                  send
                                                  (* ❌ Sending method message is not handled *)
                                                  send
                                                  (* ❌ Sending method message is not handled *)
                                                  send (Some dry_run) None
                                                  source src_pk src_sk
                                                  multisig_contract
                                                  (Tezos_client_alpha.Client_proto_multisig.Change_delegate
                                                    None) signatures Tez.zero
                                                  fee gas_limit storage_limit
                                                  counter fee_parameter tt)
                                                (Client_proto_context_commands.report_michelson_errors
                                                  (Some no_print_source)
                                                  "transfer simulation failed" %
                                                    string cctxt))
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | None => return_unit
                                                | Some (_res, _contracts) =>
                                                  return_unit
                                                end))
                                      end))
                          (cons
                            (command (Some group)
                              "Run a transaction described by a sequence of bytes on a multisig contract."
                                % string transfer_options
                              (apply
                                (prefixes
                                  (cons "run" % string
                                    (cons "transaction" % string [])))
                                (apply
                                  (bytes_param "bytes" % string
                                    "the sequence of bytes to deserialize as a multisig action, can be obtained by one of the ""prepare multisig transaction"" commands"
                                      % string)
                                  (apply
                                    (prefixes
                                      (cons "on" % string
                                        (cons "multisig" % string
                                          (cons "contract" % string []))))
                                    (apply
                                      (Client_proto_contracts.RawContractAlias.alias_param
                                        (Some "multisig" % string)
                                        (Some
                                          "name of the originated multisig contract"
                                            % string))
                                      (apply
                                        (prefixes
                                          (cons "on" % string
                                            (cons "behalf" % string
                                              (cons "of" % string []))))
                                        (apply
                                          (Client_proto_contracts.ContractAlias.destination_param
                                            (Some "src" % string)
                                            (Some
                                              "source calling the multisig contract"
                                                % string))
                                          (apply
                                            (prefixes
                                              (cons "with" % string
                                                (cons "signatures" % string [])))
                                            (seq_of_param (signature_param tt)))))))))
                              (fun function_parameter =>
                                let
                                  '(fee, dry_run, gas_limit, storage_limit,
                                    counter, no_print_source, minimal_fees,
                                    minimal_nanotez_per_byte,
                                    minimal_nanotez_per_gas_unit, force_low_fee,
                                    fee_cap, burn_cap) := function_parameter in
                                fun bytes =>
                                  fun function_parameter =>
                                    let '(_, multisig_contract) :=
                                      function_parameter in
                                    fun function_parameter =>
                                      let '(_, source) := function_parameter in
                                      fun signatures =>
                                        fun cctxt =>
                                          match Contract.is_implicit source with
                                          | None =>
                                            failwith
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "only implicit accounts can be the source of a contract call"
                                                    % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "only implicit accounts can be the source of a contract call"
                                                  % string)
                                          | Some source =>
                                            op_gtgteqquestion
                                              (Client_keys.get_key cctxt source)
                                              (fun function_parameter =>
                                                let '(_, src_pk, src_sk) :=
                                                  function_parameter in
                                                let fee_parameter :=
                                                  {|
                                                    Injection.minimal_fees :=
                                                      minimal_fees;
                                                    Injection.minimal_nanotez_per_byte :=
                                                      minimal_nanotez_per_byte;
                                                    Injection.minimal_nanotez_per_gas_unit :=
                                                      minimal_nanotez_per_gas_unit;
                                                    Injection.force_low_fee :=
                                                      force_low_fee;
                                                    Injection.fee_cap := fee_cap;
                                                    Injection.burn_cap :=
                                                      burn_cap |} in
                                                op_gtgteq
                                                  (op_gtgteq
                                                    (Client_proto_multisig.call_multisig_on_bytes
                                                      cctxt
                                                      (* ❌ Sending method message is not handled *)
                                                      send
                                                      (* ❌ Sending method message is not handled *)
                                                      send
                                                      (* ❌ Sending method message is not handled *)
                                                      send (Some dry_run) None
                                                      source src_pk src_sk
                                                      multisig_contract string
                                                      signatures Tez.zero fee
                                                      gas_limit storage_limit
                                                      counter fee_parameter tt)
                                                    (Client_proto_context_commands.report_michelson_errors
                                                      (Some no_print_source)
                                                      "transfer simulation failed"
                                                        % string cctxt))
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    | None => return_unit
                                                    | Some (_res, _contracts) =>
                                                      return_unit
                                                    end))
                                          end))
                            (cons
                              (command (Some group)
                                "Show the hashes of the supported multisig contracts."
                                  % string no_options
                                (fixed
                                  (cons "show" % string
                                    (cons "supported" % string
                                      (cons "multisig" % string
                                        (cons "hashes" % string [])))))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  fun _cctxt =>
                                    op_gtgteqquestion
                                      (Lwt._return
                                        Client_proto_multisig.known_multisig_hashes)
                                      (fun l =>
                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                        let _ :=
                                          Format.printf
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Hashes of supported multisig contracts:"
                                                  % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Flush_newline
                                                  CamlinternalFormatBasics.End_of_format))
                                              "Hashes of supported multisig contracts:@."
                                                % string) in
                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                        let _ :=
                                          List.iter
                                            (fun h =>
                                              Format.printf
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "  0x" % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Flush_newline
                                                        CamlinternalFormatBasics.End_of_format)))
                                                  "  0x%a@." % string) Hex.pp
                                                (OCaml.Stdlib.reverse_apply
                                                  (Script_expr_hash.to_bytes h)
                                                  (let arg := Hex.of_bytes in
                                                  fun eta => arg None eta))) l
                                          in
                                        return_unit))) []))))))))))))).

src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml 93 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let group =
  {
    Clic.name = "scripts";
    title = "Commands for managing the library of known scripts";
  }

open Tezos_micheline
open Client_proto_programs
open Client_proto_args
open Client_proto_contracts

let commands () =
  let open Clic in
  let show_types_switch =
    switch
      ~long:"details"
      ~short:'v'
      ~doc:"show the types of each instruction"
      ()
  in
  let emacs_mode_switch =
    switch
      ~long:"emacs"
      ?short:None
      ~doc:"output in `michelson-mode.el` compatible format"
      ()
  in
  let trace_stack_switch =
    switch ~long:"trace-stack" ~doc:"show the stack after each step" ()
  in
  let amount_arg =
    Client_proto_args.tez_arg
      ~parameter:"amount"
      ~doc:"amount of the transfer in \xEA\x9C\xA9"
      ~default:"0.05"
  in
  let source_arg =
    ContractAlias.destination_arg
      ~name:"source"
      ~doc:"name of the source (i.e. SENDER) contract for the transaction"
      ()
  in
  let payer_arg =
    ContractAlias.destination_arg
      ~name:"payer"
      ~doc:"name of the payer (i.e. SOURCE) contract for the transaction"
      ()
  in
  let custom_gas_flag =
    arg
      ~long:"gas"
      ~short:'G'
      ~doc:"Initial quantity of gas for typechecking and execution"
      ~placeholder:"gas"
      (parameter (fun _ctx str ->
           try
             let v = Z.of_string str in
             assert (Compare.Z.(v >= Z.zero)) ;
             return v
           with _ -> failwith "invalid gas limit (must be a positive number)"))
  in
  let resolve_max_gas cctxt block = function
    | None ->
        Alpha_services.Constants.all cctxt (cctxt#chain, block)
        >>=? fun {parametric = {hard_gas_limit_per_operation; _}; _} ->
        return hard_gas_limit_per_operation
    | Some gas ->
        return gas
  in
  let data_parameter =
    Clic.parameter (fun _ data ->
        Lwt.return
          ( Micheline_parser.no_parsing_error
          @@ Michelson_v1_parser.parse_expression data ))
  in
  let bytes_parameter ~name ~desc =
    Clic.param ~name ~desc Client_proto_args.bytes_parameter
  in
  let signature_parameter =
    Clic.parameter (fun _cctxt s ->
        match Signature.of_b58check_opt s with
        | Some s ->
            return s
        | None ->
            failwith "Not given a valid signature")
  in
  [ command
      ~group
      ~desc:"Lists all scripts in the library."
      no_options
      (fixed ["list"; "known"; "scripts"])
      (fun () (cctxt : Protocol_client_context.full) ->
        Program.load cctxt
        >>=? fun list ->
        Lwt_list.iter_s (fun (n, _) -> cctxt#message "%s" n) list
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Add a script to the library."
      (args1 (Program.force_switch ()))
      ( prefixes ["remember"; "script"]
      @@ Program.fresh_alias_param @@ Program.source_param @@ stop )
      (fun force name hash cctxt ->
        Program.of_fresh cctxt force name
        >>=? fun name -> Program.add ~force cctxt name hash);
    command
      ~group
      ~desc:"Remove a script from the library."
      no_options
      (prefixes ["forget"; "script"] @@ Program.alias_param @@ stop)
      (fun () (name, _) cctxt -> Program.del cctxt name);
    command
      ~group
      ~desc:"Display a script from the library."
      no_options
      (prefixes ["show"; "known"; "script"] @@ Program.alias_param @@ stop)
      (fun () (_, program) (cctxt : Protocol_client_context.full) ->
        Program.to_source program
        >>=? fun source ->
        cctxt#message "%s\n" source >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Ask the node to run a script."
      (args7
         trace_stack_switch
         amount_arg
         source_arg
         payer_arg
         no_print_source_flag
         custom_gas_flag
         entrypoint_arg)
      ( prefixes ["run"; "script"]
      @@ Program.source_param
      @@ prefixes ["on"; "storage"]
      @@ Clic.param ~name:"storage" ~desc:"the storage data" data_parameter
      @@ prefixes ["and"; "input"]
      @@ Clic.param ~name:"input" ~desc:"the input data" data_parameter
      @@ stop )
      (fun (trace_exec, amount, source, payer, no_print_source, gas, entrypoint)
           program
           storage
           input
           cctxt ->
        let source = Option.map ~f:snd source in
        let payer = Option.map ~f:snd payer in
        Lwt.return @@ Micheline_parser.no_parsing_error program
        >>=? fun program ->
        let show_source = not no_print_source in
        if trace_exec then
          trace
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~amount
            ~program
            ~storage
            ~input
            ?source
            ?payer
            ?gas
            ?entrypoint
            ()
          >>= fun res ->
          print_trace_result cctxt ~show_source ~parsed:program res
        else
          run
            cctxt
            ~chain:cctxt#chain
            ~block:cctxt#block
            ~amount
            ~program
            ~storage
            ~input
            ?source
            ?payer
            ?gas
            ?entrypoint
            ()
          >>= fun res ->
          print_run_result cctxt ~show_source ~parsed:program res);
    command
      ~group
      ~desc:"Ask the node to typecheck a script."
      (args4
         show_types_switch
         emacs_mode_switch
         no_print_source_flag
         custom_gas_flag)
      (prefixes ["typecheck"; "script"] @@ Program.source_param @@ stop)
      (fun (show_types, emacs_mode, no_print_source, original_gas)
           program
           cctxt ->
        match program with
        | (program, []) ->
            resolve_max_gas cctxt cctxt#block original_gas
            >>=? fun original_gas ->
            typecheck_program
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              ~gas:original_gas
              program
            >>= fun res ->
            print_typecheck_result
              ~emacs:emacs_mode
              ~show_types
              ~print_source_on_error:(not no_print_source)
              program
              res
              cctxt
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(types . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program");
    command
      ~group
      ~desc:"Ask the node to typecheck a data expression."
      (args2 no_print_source_flag custom_gas_flag)
      ( prefixes ["typecheck"; "data"]
      @@ Clic.param ~name:"data" ~desc:"the data to typecheck" data_parameter
      @@ prefixes ["against"; "type"]
      @@ Clic.param ~name:"type" ~desc:"the expected type" data_parameter
      @@ stop )
      (fun (no_print_source, custom_gas) data ty cctxt ->
        resolve_max_gas cctxt cctxt#block custom_gas
        >>=? fun original_gas ->
        Client_proto_programs.typecheck_data
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          ~gas:original_gas
          ~data
          ~ty
          ()
        >>= function
        | Ok gas ->
            cctxt#message
              "@[<v 0>Well typed@,Gas remaining: %a@]"
              Alpha_context.Gas.pp
              gas
            >>= fun () -> return_unit
        | Error errs ->
            cctxt#warning
              "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
                 ~show_source:(not no_print_source)
                 ?parsed:None)
              errs
            >>= fun () -> cctxt#error "ill-typed data");
    command
      ~group
      ~desc:
        "Ask the node to pack a data expression.\n\
         The returned hash is the same as what Michelson instruction `PACK` \
         would have produced.\n\
         Also displays the result of hashing this packed data with `BLAKE2B`, \
         `SHA256` or `SHA512` instruction."
      (args1 custom_gas_flag)
      ( prefixes ["hash"; "data"]
      @@ Clic.param ~name:"data" ~desc:"the data to hash" data_parameter
      @@ prefixes ["of"; "type"]
      @@ Clic.param ~name:"type" ~desc:"type of the data" data_parameter
      @@ stop )
      (fun custom_gas data typ cctxt ->
        resolve_max_gas cctxt cctxt#block custom_gas
        >>=? fun original_gas ->
        Alpha_services.Helpers.Scripts.pack_data
          cctxt
          (cctxt#chain, cctxt#block)
          (data.expanded, typ.expanded, Some original_gas)
        >>= function
        | Ok (bytes, remaining_gas) ->
            let hash = Script_expr_hash.hash_bytes [bytes] in
            cctxt#message
              "Raw packed data: 0x%a@,\
               Script-expression-ID-Hash: %a@,\
               Raw Script-expression-ID-Hash: 0x%a@,\
               Ledger Blake2b hash: %s@,\
               Raw Sha256 hash: 0x%a@,\
               Raw Sha512 hash: 0x%a@,\
               Gas remaining: %a"
              Hex.pp
              (Hex.of_bytes bytes)
              Script_expr_hash.pp
              hash
              Hex.pp
              (Hex.of_bytes (Script_expr_hash.to_bytes hash))
              (Base58.raw_encode Blake2B.(hash_bytes [bytes] |> to_string))
              Hex.pp
              (Hex.of_bytes (Environment.Raw_hashes.sha256 bytes))
              Hex.pp
              (Hex.of_bytes (Environment.Raw_hashes.sha512 bytes))
              Alpha_context.Gas.pp
              remaining_gas
            >>= fun () -> return_unit
        | Error errs ->
            cctxt#warning
              "%a"
              (Michelson_v1_error_reporter.report_errors
                 ~details:false
                 ~show_source:false
                 ?parsed:None)
              errs
            >>= fun () -> cctxt#error "ill-formed data");
    command
      ~group
      ~desc:
        "Parse a byte sequence (in hexadecimal notation) as a data \
         expression, as per Michelson instruction `UNPACK`."
      Clic.no_options
      ( prefixes ["unpack"; "michelson"; "data"]
      @@ bytes_parameter ~name:"bytes" ~desc:"the packed data to parse"
      @@ stop )
      (fun () bytes cctxt ->
        ( if Bytes.get bytes 0 != '\005' then
          failwith
            "Not a piece of packed Michelson data (must start with `0x05`)"
        else return_unit )
        >>=? fun () ->
        (* Remove first byte *)
        let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in
        match
          Data_encoding.Binary.of_bytes
            Alpha_context.Script.expr_encoding
            bytes
        with
        | None ->
            failwith "Could not decode bytes"
        | Some expr ->
            cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr
            >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Sign a raw sequence of bytes and display it using the format \
         expected by Michelson instruction `CHECK_SIGNATURE`."
      no_options
      ( prefixes ["sign"; "bytes"]
      @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign"
      @@ prefixes ["for"]
      @@ Client_keys.Secret_key.source_param @@ stop )
      (fun () bytes sk cctxt ->
        Client_keys.sign cctxt sk bytes
        >>=? fun signature ->
        cctxt#message "Signature: %a" Signature.pp signature
        >>= fun () -> return_unit);
    command
      ~group
      ~desc:
        "Check the signature of a byte sequence as per Michelson instruction \
         `CHECK_SIGNATURE`."
      (args1 (switch ~doc:"Use only exit codes" ~short:'q' ~long:"quiet" ()))
      ( prefixes ["check"; "that"]
      @@ bytes_parameter ~name:"bytes" ~desc:"the signed data"
      @@ prefixes ["was"; "signed"; "by"]
      @@ Client_keys.Public_key.alias_param ~name:"key"
      @@ prefixes ["to"; "produce"]
      @@ Clic.param
           ~name:"signature"
           ~desc:"the signature to check"
           signature_parameter
      @@ stop )
      (fun quiet
           bytes
           (_, (key_locator, _))
           signature
           (cctxt : #Protocol_client_context.full) ->
        Client_keys.check key_locator signature bytes
        >>=? function
        | false ->
            cctxt#error "invalid signature"
        | true ->
            if quiet then return_unit
            else
              cctxt#message "Signature check successfull."
              >>= fun () -> return_unit);
    command
      ~group
      ~desc:"Ask the type of an entrypoint of a script."
      (args2 emacs_mode_switch no_print_source_flag)
      ( prefixes ["get"; "script"; "entrypoint"; "type"; "of"]
      @@ Clic.string ~name:"entrypoint" ~desc:"the entrypoint to describe"
      @@ prefixes ["for"]
      @@ Program.source_param @@ stop )
      (fun (emacs_mode, no_print_source) entrypoint program cctxt ->
        match program with
        | (program, []) ->
            entrypoint_type
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              program
              ~entrypoint
            >>= fun entrypoint_type ->
            print_entrypoint_type
              ~emacs:emacs_mode
              ~show_source:(not no_print_source)
              ~parsed:program
              ~entrypoint
              cctxt
              entrypoint_type
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(entrypoint . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program");
    command
      ~group
      ~desc:"Ask the node to list the entrypoints of a script."
      (args2 emacs_mode_switch no_print_source_flag)
      ( prefixes ["get"; "script"; "entrypoints"; "for"]
      @@ Program.source_param @@ stop )
      (fun (emacs_mode, no_print_source) program cctxt ->
        match program with
        | (program, []) ->
            list_entrypoints
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              program
            >>= fun entrypoints ->
            print_entrypoints_list
              ~emacs:emacs_mode
              ~show_source:(not no_print_source)
              ~parsed:program
              cctxt
              entrypoints
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program");
    command
      ~group
      ~desc:
        "Ask the node to list the unreachable pathsin a script's parameter \
         type."
      (args2 emacs_mode_switch no_print_source_flag)
      ( prefixes ["get"; "script"; "unreachable"; "paths"; "for"]
      @@ Program.source_param @@ stop )
      (fun (emacs_mode, no_print_source) program cctxt ->
        match program with
        | (program, []) ->
            list_unreachables
              cctxt
              ~chain:cctxt#chain
              ~block:cctxt#block
              program
            >>= fun entrypoints ->
            print_unreachables
              ~emacs:emacs_mode
              ~show_source:(not no_print_source)
              ~parsed:program
              cctxt
              entrypoints
        | res_with_errors when emacs_mode ->
            cctxt#message
              "(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
              Michelson_v1_emacs.report_errors
              res_with_errors
            >>= fun () -> return_unit
        | (parsed, errors) ->
            cctxt#message
              "%a"
              (fun ppf () ->
                Michelson_v1_error_reporter.report_errors
                  ~details:(not no_print_source)
                  ~parsed
                  ~show_source:(not no_print_source)
                  ppf
                  errors)
              ()
            >>= fun () -> cctxt#error "syntax error in program") ]
src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "scripts" % string;
    Clic.title := "Commands for managing the library of known scripts" % string
    |}.

Import Tezos_micheline.

Import Client_proto_programs.

Import Client_proto_args.

Import Client_proto_contracts.

Definition commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  let show_types_switch :=
    switch "show the types of each instruction" % string (Some "v" % char)
      "details" % string tt in
  let emacs_mode_switch :=
    switch "output in `michelson-mode.el` compatible format" % string None
      "emacs" % string tt in
  let trace_stack_switch :=
    switch "show the stack after each step" % string None "trace-stack" % string
      tt in
  let amount_arg :=
    Client_proto_args.tez_arg "0.05" % string "amount" % string
      "amount of the transfer in ꜩ" % string in
  let source_arg :=
    ContractAlias.destination_arg (Some "source" % string)
      (Some
        "name of the source (i.e. SENDER) contract for the transaction" % string)
      tt in
  let payer_arg :=
    ContractAlias.destination_arg (Some "payer" % string)
      (Some
        "name of the payer (i.e. SOURCE) contract for the transaction" % string)
      tt in
  let custom_gas_flag :=
    arg "Initial quantity of gas for typechecking and execution" % string
      (Some "G" % char) "gas" % string "gas" % string
      (parameter None
        (fun _ctx =>
          fun str =>
            (* ❌ Try-with are not handled *)
            try
              (let v := Z.of_string str in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ :=
                (* ❌ Assert instruction is not handled. *)
                assert (op_gteq v Z.zero) in
              _return v))) in
  let resolve_max_gas {D E F H J L M a b c i o q : Type}
    (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * (D * M))))) *
      (D * M) * (D * E)) (block : E) (function_parameter :
    option Tezos_protocol_environment_alpha__Environment.Z.t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_environment_alpha__Environment.Z.t) :=
    match function_parameter with
    | None =>
      op_gtgteqquestion
        (Alpha_services.Constants.all cctxt
          ((* ❌ Sending method message is not handled *)
          send, block))
        (fun function_parameter =>
          let '{|
            parametric := {|
              hard_gas_limit_per_operation := hard_gas_limit_per_operation
                |}
              |} := function_parameter in
          _return hard_gas_limit_per_operation)
    | Some gas => _return gas
    end in
  let data_parameter :=
    Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun data =>
          Lwt._return
            (apply Micheline_parser.no_parsing_error
              (Michelson_v1_parser.parse_expression None data))) in
  let bytes_parameter {A : Type} (name : string) (desc : string)
    : (Tezos_base__TzPervasives.Clic.params A
      Tezos_client_alpha.Protocol_client_context.full) ->
      Tezos_base__TzPervasives.Clic.params (Stdlib.Bytes.t -> A)
        Tezos_client_alpha.Protocol_client_context.full :=
    Clic.param name desc Client_proto_args.bytes_parameter in
  let signature_parameter :=
    Clic.parameter None
      (fun _cctxt =>
        fun s =>
          match Signature.of_b58check_opt s with
          | Some s => _return s
          | None =>
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Not given a valid signature" % string
                  CamlinternalFormatBasics.End_of_format)
                "Not given a valid signature" % string)
          end) in
  cons
    (command (Some group) "Lists all scripts in the library." % string
      no_options
      (fixed
        (cons "list" % string
          (cons "known" % string (cons "scripts" % string []))))
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun cctxt =>
          op_gtgteqquestion (Program.load cctxt)
            (fun list =>
              op_gtgteq
                (Lwt_list.iter_s
                  (fun function_parameter =>
                    let '(n, _) := function_parameter in
                    (* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          CamlinternalFormatBasics.End_of_format) "%s" % string)
                      n) list)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit))))
    (cons
      (command (Some group) "Add a script to the library." % string
        (args1 (Program.force_switch tt))
        (apply (prefixes (cons "remember" % string (cons "script" % string [])))
          (apply
            (let arg := Program.fresh_alias_param in
            fun eta => arg None None eta)
            (apply
              (let arg := Program.source_param in
              fun eta => arg None None eta) stop)))
        (fun force =>
          fun name =>
            fun hash =>
              fun cctxt =>
                op_gtgteqquestion (Program.of_fresh cctxt force name)
                  (fun name => Program.add force cctxt name hash)))
      (cons
        (command (Some group) "Remove a script from the library." % string
          no_options
          (apply (prefixes (cons "forget" % string (cons "script" % string [])))
            (apply
              (let arg := Program.alias_param in
              fun eta => arg None None eta) stop))
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(name, _) := function_parameter in
              fun cctxt => Program.del cctxt name))
        (cons
          (command (Some group) "Display a script from the library." % string
            no_options
            (apply
              (prefixes
                (cons "show" % string
                  (cons "known" % string (cons "script" % string []))))
              (apply
                (let arg := Program.alias_param in
                fun eta => arg None None eta) stop))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let '(_, program) := function_parameter in
                fun cctxt =>
                  op_gtgteqquestion (Program.to_source program)
                    (fun source =>
                      op_gtgteq
                        ((* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.Char_literal
                                "010" % char
                                CamlinternalFormatBasics.End_of_format))
                            "%s
" % string) source)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit))))
          (cons
            (command (Some group) "Ask the node to run a script." % string
              (args7 trace_stack_switch amount_arg source_arg payer_arg
                no_print_source_flag custom_gas_flag entrypoint_arg)
              (apply
                (prefixes (cons "run" % string (cons "script" % string [])))
                (apply
                  (let arg := Program.source_param in
                  fun eta => arg None None eta)
                  (apply
                    (prefixes (cons "on" % string (cons "storage" % string [])))
                    (apply
                      (Clic.param "storage" % string "the storage data" % string
                        data_parameter)
                      (apply
                        (prefixes
                          (cons "and" % string (cons "input" % string [])))
                        (apply
                          (Clic.param "input" % string "the input data" % string
                            data_parameter) stop))))))
              (fun function_parameter =>
                let
                  '(trace_exec, amount, source, payer, no_print_source, gas,
                    entrypoint) := function_parameter in
                fun program =>
                  fun storage =>
                    fun input =>
                      fun cctxt =>
                        let source := Option.map snd source in
                        let payer := Option.map snd payer in
                        op_gtgteqquestion
                          (apply Lwt._return
                            (Micheline_parser.no_parsing_error program))
                          (fun program =>
                            let show_source := negb no_print_source in
                            if trace_exec then
                              op_gtgteq
                                (trace cctxt
                                  (* ❌ Sending method message is not handled *)
                                  send
                                  (* ❌ Sending method message is not handled *)
                                  send (Some amount) program storage input
                                  source payer gas entrypoint tt)
                                (fun res =>
                                  print_trace_result cctxt show_source program
                                    res)
                            else
                              op_gtgteq
                                (run cctxt
                                  (* ❌ Sending method message is not handled *)
                                  send
                                  (* ❌ Sending method message is not handled *)
                                  send (Some amount) program storage input
                                  source payer gas entrypoint tt)
                                (fun res =>
                                  print_run_result cctxt show_source program res))))
            (cons
              (command (Some group)
                "Ask the node to typecheck a script." % string
                (args4 show_types_switch emacs_mode_switch no_print_source_flag
                  custom_gas_flag)
                (apply
                  (prefixes
                    (cons "typecheck" % string (cons "script" % string [])))
                  (apply
                    (let arg := Program.source_param in
                    fun eta => arg None None eta) stop))
                (fun function_parameter =>
                  let
                    '(show_types, emacs_mode, no_print_source, original_gas) :=
                    function_parameter in
                  fun program =>
                    fun cctxt =>
                      match program with
                      | (program, []) =>
                        op_gtgteqquestion
                          (resolve_max_gas cctxt
                            (* ❌ Sending method message is not handled *)
                            send original_gas)
                          (fun original_gas =>
                            op_gtgteq
                              (typecheck_program cctxt
                                (* ❌ Sending method message is not handled *)
                                send
                                (* ❌ Sending method message is not handled *)
                                send (Some original_gas) program)
                              (fun res =>
                                print_typecheck_result emacs_mode show_types
                                  (negb no_print_source) program res cctxt))
                      | res_with_errors =>
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Char_literal "(" % char
                                (CamlinternalFormatBasics.Formatting_gen
                                  (CamlinternalFormatBasics.Open_box
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "<v 0>" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "<v 0>" % string))
                                  (CamlinternalFormatBasics.String_literal
                                    "(types . ())" % string
                                    (CamlinternalFormatBasics.Formatting_lit
                                      (CamlinternalFormatBasics.Break
                                        "@ " % string 1 0)
                                      (CamlinternalFormatBasics.String_literal
                                        "(errors . " % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.Char_literal
                                            ")" % char
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Close_box
                                              (CamlinternalFormatBasics.Char_literal
                                                ")" % char
                                                CamlinternalFormatBasics.End_of_format)))))))))
                              "(@[<v 0>(types . ())@ (errors . %a)@])" % string)
                            Michelson_v1_emacs.report_errors res_with_errors)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)
                      | (parsed, errors) =>
                        op_gtgteq
                          ((* ❌ Sending method message is not handled *)
                          send
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.Alpha
                                CamlinternalFormatBasics.End_of_format)
                              "%a" % string)
                            (fun ppf =>
                              fun function_parameter =>
                                let 'tt := function_parameter in
                                Michelson_v1_error_reporter.report_errors
                                  (negb no_print_source) (negb no_print_source)
                                  (Some parsed) ppf errors) tt)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            (* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "syntax error in program" % string
                                  CamlinternalFormatBasics.End_of_format)
                                "syntax error in program" % string))
                      end))
              (cons
                (command (Some group)
                  "Ask the node to typecheck a data expression." % string
                  (args2 no_print_source_flag custom_gas_flag)
                  (apply
                    (prefixes
                      (cons "typecheck" % string (cons "data" % string [])))
                    (apply
                      (Clic.param "data" % string
                        "the data to typecheck" % string data_parameter)
                      (apply
                        (prefixes
                          (cons "against" % string (cons "type" % string [])))
                        (apply
                          (Clic.param "type" % string
                            "the expected type" % string data_parameter) stop))))
                  (fun function_parameter =>
                    let '(no_print_source, custom_gas) := function_parameter in
                    fun data =>
                      fun ty =>
                        fun cctxt =>
                          op_gtgteqquestion
                            (resolve_max_gas cctxt
                              (* ❌ Sending method message is not handled *)
                              send custom_gas)
                            (fun original_gas =>
                              op_gtgteq
                                (Client_proto_programs.typecheck_data cctxt
                                  (* ❌ Sending method message is not handled *)
                                  send
                                  (* ❌ Sending method message is not handled *)
                                  send (Some original_gas) data ty tt)
                                (fun function_parameter =>
                                  match function_parameter with
                                  | Stdlib.Ok gas =>
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Formatting_gen
                                            (CamlinternalFormatBasics.Open_box
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "<v 0>" % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "<v 0>" % string))
                                            (CamlinternalFormatBasics.String_literal
                                              "Well typed" % string
                                              (CamlinternalFormatBasics.Formatting_lit
                                                (CamlinternalFormatBasics.Break
                                                  "@," % string 0 0)
                                                (CamlinternalFormatBasics.String_literal
                                                  "Gas remaining: " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Close_box
                                                      CamlinternalFormatBasics.End_of_format))))))
                                          "@[<v 0>Well typed@,Gas remaining: %a@]"
                                            % string) Alpha_context.Gas.pp gas)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        return_unit)
                                  | Stdlib.Error errs =>
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format)
                                          "%a" % string)
                                        (Michelson_v1_error_reporter.report_errors
                                          false (negb no_print_source) None)
                                        errs)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        (* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "ill-typed data" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "ill-typed data" % string))
                                  end))))
                (cons
                  (command (Some group)
                    "Ask the node to pack a data expression.
The returned hash is the same as what Michelson instruction `PACK` would have produced.
Also displays the result of hashing this packed data with `BLAKE2B`, `SHA256` or `SHA512` instruction."
                      % string (args1 custom_gas_flag)
                    (apply
                      (prefixes (cons "hash" % string (cons "data" % string [])))
                      (apply
                        (Clic.param "data" % string "the data to hash" % string
                          data_parameter)
                        (apply
                          (prefixes
                            (cons "of" % string (cons "type" % string [])))
                          (apply
                            (Clic.param "type" % string
                              "type of the data" % string data_parameter) stop))))
                    (fun custom_gas =>
                      fun data =>
                        fun typ =>
                          fun cctxt =>
                            op_gtgteqquestion
                              (resolve_max_gas cctxt
                                (* ❌ Sending method message is not handled *)
                                send custom_gas)
                              (fun original_gas =>
                                op_gtgteq
                                  (Alpha_services.Helpers.Scripts.pack_data
                                    cctxt
                                    ((* ❌ Sending method message is not handled *)
                                    send,
                                      (* ❌ Sending method message is not handled *)
                                      send)
                                    ((expanded data), (expanded typ),
                                      (Some original_gas)))
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | Stdlib.Ok (bytes, remaining_gas) =>
                                      let hash :=
                                        Script_expr_hash.hash_bytes None
                                          (cons string []) in
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Raw packed data: 0x" % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  (CamlinternalFormatBasics.Break
                                                    "@," % string 0 0)
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Script-expression-ID-Hash: "
                                                      % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        (CamlinternalFormatBasics.Break
                                                          "@," % string 0 0)
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Raw Script-expression-ID-Hash: 0x"
                                                            % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              (CamlinternalFormatBasics.Break
                                                                "@," % string 0
                                                                0)
                                                              (CamlinternalFormatBasics.String_literal
                                                                "Ledger Blake2b hash: "
                                                                  % string
                                                                (CamlinternalFormatBasics.String
                                                                  CamlinternalFormatBasics.No_padding
                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                    (CamlinternalFormatBasics.Break
                                                                      "@," %
                                                                        string 0
                                                                      0)
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      "Raw Sha256 hash: 0x"
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                          (CamlinternalFormatBasics.Break
                                                                            "@,"
                                                                              %
                                                                              string
                                                                            0 0)
                                                                          (CamlinternalFormatBasics.String_literal
                                                                            "Raw Sha512 hash: 0x"
                                                                              %
                                                                              string
                                                                            (CamlinternalFormatBasics.Alpha
                                                                              (CamlinternalFormatBasics.Formatting_lit
                                                                                (CamlinternalFormatBasics.Break
                                                                                  "@,"
                                                                                    %
                                                                                    string
                                                                                  0
                                                                                  0)
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  "Gas remaining: "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    CamlinternalFormatBasics.End_of_format))))))))))))))))))))
                                            "Raw packed data: 0x%a@,Script-expression-ID-Hash: %a@,Raw Script-expression-ID-Hash: 0x%a@,Ledger Blake2b hash: %s@,Raw Sha256 hash: 0x%a@,Raw Sha512 hash: 0x%a@,Gas remaining: %a"
                                              % string) Hex.pp
                                          (Hex.of_bytes None string)
                                          Script_expr_hash.pp hash Hex.pp
                                          (Hex.of_bytes None
                                            (Script_expr_hash.to_bytes hash))
                                          (Base58.raw_encode None
                                            (OCaml.Stdlib.reverse_apply
                                              (hash_bytes None (cons string []))
                                              to_string)) Hex.pp
                                          (Hex.of_bytes None
                                            (Environment.Raw_hashes.sha256
                                              string)) Hex.pp
                                          (Hex.of_bytes None
                                            (Environment.Raw_hashes.sha512
                                              string)) Alpha_context.Gas.pp
                                          remaining_gas)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          return_unit)
                                    | Stdlib.Error errs =>
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format)
                                            "%a" % string)
                                          (Michelson_v1_error_reporter.report_errors
                                            false false None) errs)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          (* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "ill-formed data" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "ill-formed data" % string))
                                    end))))
                  (cons
                    (command (Some group)
                      "Parse a byte sequence (in hexadecimal notation) as a data expression, as per Michelson instruction `UNPACK`."
                        % string Clic.no_options
                      (apply
                        (prefixes
                          (cons "unpack" % string
                            (cons "michelson" % string (cons "data" % string []))))
                        (apply
                          (bytes_parameter "bytes" % string
                            "the packed data to parse" % string) stop))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        fun bytes =>
                          fun cctxt =>
                            op_gtgteqquestion
                              (if
                                Stdlib.op_exclamationeq
                                  (Stdlib.Bytes.get string 0) "005" % char then
                                failwith
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Not a piece of packed Michelson data (must start with `0x05`)"
                                        % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Not a piece of packed Michelson data (must start with `0x05`)"
                                      % string)
                              else
                                return_unit)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                let bytes :=
                                  String.sub string 1
                                    (Z.sub (String.length string) 1) in
                                match
                                  Data_encoding.Binary.of_bytes
                                    Alpha_context.Script.expr_encoding string
                                  with
                                | None =>
                                  failwith
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Could not decode bytes" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "Could not decode bytes" % string)
                                | Some expr =>
                                  op_gtgteq
                                    ((* ❌ Sending method message is not handled *)
                                    send
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.Alpha
                                          CamlinternalFormatBasics.End_of_format)
                                        "%a" % string)
                                      Michelson_v1_printer.print_expr_unwrapped
                                      expr)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      return_unit)
                                end)))
                    (cons
                      (command (Some group)
                        "Sign a raw sequence of bytes and display it using the format expected by Michelson instruction `CHECK_SIGNATURE`."
                          % string no_options
                        (apply
                          (prefixes
                            (cons "sign" % string (cons "bytes" % string [])))
                          (apply
                            (bytes_parameter "data" % string
                              "the raw data to sign" % string)
                            (apply (prefixes (cons "for" % string []))
                              (apply
                                (let arg := Client_keys.Secret_key.source_param
                                  in
                                fun eta => arg None None eta) stop))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          fun bytes =>
                            fun sk =>
                              fun cctxt =>
                                op_gtgteqquestion
                                  (Client_keys.sign cctxt None sk string)
                                  (fun signature =>
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Signature: " % string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "Signature: %a" % string) Signature.pp
                                        signature)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        return_unit))))
                      (cons
                        (command (Some group)
                          "Check the signature of a byte sequence as per Michelson instruction `CHECK_SIGNATURE`."
                            % string
                          (args1
                            (switch "Use only exit codes" % string
                              (Some "q" % char) "quiet" % string tt))
                          (apply
                            (prefixes
                              (cons "check" % string (cons "that" % string [])))
                            (apply
                              (bytes_parameter "bytes" % string
                                "the signed data" % string)
                              (apply
                                (prefixes
                                  (cons "was" % string
                                    (cons "signed" % string
                                      (cons "by" % string []))))
                                (apply
                                  (let arg :=
                                    Client_keys.Public_key.alias_param
                                      (Some "key" % string) in
                                  fun eta => arg None eta)
                                  (apply
                                    (prefixes
                                      (cons "to" % string
                                        (cons "produce" % string [])))
                                    (apply
                                      (Clic.param "signature" % string
                                        "the signature to check" % string
                                        signature_parameter) stop))))))
                          (fun quiet =>
                            fun bytes =>
                              fun function_parameter =>
                                let '(_, (key_locator, _)) := function_parameter
                                  in
                                fun signature =>
                                  fun cctxt =>
                                    op_gtgteqquestion
                                      (Client_keys.check None key_locator
                                        signature string)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | false =>
                                          (* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "invalid signature" % string
                                                CamlinternalFormatBasics.End_of_format)
                                              "invalid signature" % string)
                                        | true =>
                                          if quiet then
                                            return_unit
                                          else
                                            op_gtgteq
                                              ((* ❌ Sending method message is not handled *)
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Signature check successfull."
                                                      % string
                                                    CamlinternalFormatBasics.End_of_format)
                                                  "Signature check successfull."
                                                    % string))
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                return_unit)
                                        end)))
                        (cons
                          (command (Some group)
                            "Ask the type of an entrypoint of a script." %
                              string
                            (args2 emacs_mode_switch no_print_source_flag)
                            (apply
                              (prefixes
                                (cons "get" % string
                                  (cons "script" % string
                                    (cons "entrypoint" % string
                                      (cons "type" % string
                                        (cons "of" % string []))))))
                              (apply
                                (Clic.string "entrypoint" % string
                                  "the entrypoint to describe" % string)
                                (apply (prefixes (cons "for" % string []))
                                  (apply
                                    (let arg := Program.source_param in
                                    fun eta => arg None None eta) stop))))
                            (fun function_parameter =>
                              let '(emacs_mode, no_print_source) :=
                                function_parameter in
                              fun entrypoint =>
                                fun program =>
                                  fun cctxt =>
                                    match program with
                                    | (program, []) =>
                                      op_gtgteq
                                        (entrypoint_type cctxt
                                          (* ❌ Sending method message is not handled *)
                                          send
                                          (* ❌ Sending method message is not handled *)
                                          send program entrypoint)
                                        (fun entrypoint_type =>
                                          print_entrypoint_type cctxt emacs_mode
                                            None (negb no_print_source) program
                                            entrypoint entrypoint_type)
                                    | res_with_errors =>
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Char_literal
                                              "(" % char
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_box
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<v 0>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<v 0>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "(entrypoint . ())" % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "(errors . " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          ")" % char
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            (CamlinternalFormatBasics.Char_literal
                                                              ")" % char
                                                              CamlinternalFormatBasics.End_of_format)))))))))
                                            "(@[<v 0>(entrypoint . ())@ (errors . %a)@])"
                                              % string)
                                          Michelson_v1_emacs.report_errors
                                          res_with_errors)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          return_unit)
                                    | (parsed, errors) =>
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format)
                                            "%a" % string)
                                          (fun ppf =>
                                            fun function_parameter =>
                                              let 'tt := function_parameter in
                                              Michelson_v1_error_reporter.report_errors
                                                (negb no_print_source)
                                                (negb no_print_source)
                                                (Some parsed) ppf errors) tt)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          (* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "syntax error in program" %
                                                  string
                                                CamlinternalFormatBasics.End_of_format)
                                              "syntax error in program" % string))
                                    end))
                          (cons
                            (command (Some group)
                              "Ask the node to list the entrypoints of a script."
                                % string
                              (args2 emacs_mode_switch no_print_source_flag)
                              (apply
                                (prefixes
                                  (cons "get" % string
                                    (cons "script" % string
                                      (cons "entrypoints" % string
                                        (cons "for" % string [])))))
                                (apply
                                  (let arg := Program.source_param in
                                  fun eta => arg None None eta) stop))
                              (fun function_parameter =>
                                let '(emacs_mode, no_print_source) :=
                                  function_parameter in
                                fun program =>
                                  fun cctxt =>
                                    match program with
                                    | (program, []) =>
                                      op_gtgteq
                                        (list_entrypoints cctxt
                                          (* ❌ Sending method message is not handled *)
                                          send
                                          (* ❌ Sending method message is not handled *)
                                          send program)
                                        (fun entrypoints =>
                                          print_entrypoints_list cctxt
                                            emacs_mode None
                                            (negb no_print_source) program
                                            entrypoints)
                                    | res_with_errors =>
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Char_literal
                                              "(" % char
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_box
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<v 0>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<v 0>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "(entrypoints . ())" % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    (CamlinternalFormatBasics.String_literal
                                                      "(errors . " % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          ")" % char
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            (CamlinternalFormatBasics.Char_literal
                                                              ")" % char
                                                              CamlinternalFormatBasics.End_of_format)))))))))
                                            "(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
                                              % string)
                                          Michelson_v1_emacs.report_errors
                                          res_with_errors)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          return_unit)
                                    | (parsed, errors) =>
                                      op_gtgteq
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format)
                                            "%a" % string)
                                          (fun ppf =>
                                            fun function_parameter =>
                                              let 'tt := function_parameter in
                                              Michelson_v1_error_reporter.report_errors
                                                (negb no_print_source)
                                                (negb no_print_source)
                                                (Some parsed) ppf errors) tt)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          (* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "syntax error in program" %
                                                  string
                                                CamlinternalFormatBasics.End_of_format)
                                              "syntax error in program" % string))
                                    end))
                            (cons
                              (command (Some group)
                                "Ask the node to list the unreachable pathsin a script's parameter type."
                                  % string
                                (args2 emacs_mode_switch no_print_source_flag)
                                (apply
                                  (prefixes
                                    (cons "get" % string
                                      (cons "script" % string
                                        (cons "unreachable" % string
                                          (cons "paths" % string
                                            (cons "for" % string []))))))
                                  (apply
                                    (let arg := Program.source_param in
                                    fun eta => arg None None eta) stop))
                                (fun function_parameter =>
                                  let '(emacs_mode, no_print_source) :=
                                    function_parameter in
                                  fun program =>
                                    fun cctxt =>
                                      match program with
                                      | (program, []) =>
                                        op_gtgteq
                                          (list_unreachables cctxt
                                            (* ❌ Sending method message is not handled *)
                                            send
                                            (* ❌ Sending method message is not handled *)
                                            send program)
                                          (fun entrypoints =>
                                            print_unreachables cctxt emacs_mode
                                              None (negb no_print_source)
                                              program entrypoints)
                                      | res_with_errors =>
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Char_literal
                                                "(" % char
                                                (CamlinternalFormatBasics.Formatting_gen
                                                  (CamlinternalFormatBasics.Open_box
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "<v 0>" % string
                                                        CamlinternalFormatBasics.End_of_format)
                                                      "<v 0>" % string))
                                                  (CamlinternalFormatBasics.String_literal
                                                    "(entrypoints . ())" %
                                                      string
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      (CamlinternalFormatBasics.Break
                                                        "@ " % string 1 0)
                                                      (CamlinternalFormatBasics.String_literal
                                                        "(errors . " % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Char_literal
                                                            ")" % char
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              CamlinternalFormatBasics.Close_box
                                                              (CamlinternalFormatBasics.Char_literal
                                                                ")" % char
                                                                CamlinternalFormatBasics.End_of_format)))))))))
                                              "(@[<v 0>(entrypoints . ())@ (errors . %a)@])"
                                                % string)
                                            Michelson_v1_emacs.report_errors
                                            res_with_errors)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            return_unit)
                                      | (parsed, errors) =>
                                        op_gtgteq
                                          ((* ❌ Sending method message is not handled *)
                                          send
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Alpha
                                                CamlinternalFormatBasics.End_of_format)
                                              "%a" % string)
                                            (fun ppf =>
                                              fun function_parameter =>
                                                let 'tt := function_parameter in
                                                Michelson_v1_error_reporter.report_errors
                                                  (negb no_print_source)
                                                  (negb no_print_source)
                                                  (Some parsed) ppf errors) tt)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            (* ❌ Sending method message is not handled *)
                                            send
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "syntax error in program" %
                                                    string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "syntax error in program" %
                                                  string))
                                      end)) []))))))))))))).

src/proto_alpha/lib_delegate/client_baking_blocks.ml 90 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type block_info = {
  hash : Block_hash.t;
  chain_id : Chain_id.t;
  predecessor : Block_hash.t;
  fitness : Bytes.t list;
  timestamp : Time.Protocol.t;
  protocol : Protocol_hash.t;
  next_protocol : Protocol_hash.t;
  proto_level : int;
  level : Raw_level.t;
  context : Context_hash.t;
}

let raw_info cctxt ?(chain = `Main) hash shell_header =
  let block = `Hash (hash, 0) in
  Shell_services.Chain.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Shell_services.Blocks.protocols cctxt ~chain ~block ()
  >>=? fun {current_protocol = protocol; next_protocol} ->
  let { Tezos_base.Block_header.predecessor;
        fitness;
        timestamp;
        level;
        context;
        proto_level;
        _ } =
    shell_header
  in
  match Raw_level.of_int32 level with
  | Ok level ->
      return
        {
          hash;
          chain_id;
          predecessor;
          fitness;
          timestamp;
          protocol;
          next_protocol;
          proto_level;
          level;
          context;
        }
  | Error _ ->
      failwith "Cannot convert level into int32"

let info cctxt ?(chain = `Main) block =
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
  >>=? fun shell_header -> raw_info cctxt ~chain hash shell_header

module Block_seen_event = struct
  type t = {
    hash : Block_hash.t;
    header : Tezos_base.Block_header.t;
    occurrence : [`Valid_blocks of Chain_id.t | `Heads];
  }

  let make hash header occurrence () = {hash; header; occurrence}

  module Definition = struct
    let name = "block-seen-" ^ Protocol.name

    type nonrec t = t

    let encoding =
      let open Data_encoding in
      let v0_encoding =
        conv
          (function {hash; header; occurrence} -> (hash, occurrence, header))
          (fun (b, o, h) -> make b h o ())
          (obj3
             (req "hash" Block_hash.encoding)
             (* Occurrence has to come before header, because:
                (Invalid_argument
                   "Cannot merge two objects when the left element is of
                    variable length and the right one of dynamic
                    length. You should use the reverse order, or wrap the
                    second one with Data_encoding.dynamic_size.") *)
             (req
                "occurrence"
                (union
                   [ case
                       ~title:"heads"
                       (Tag 0)
                       (obj1 (req "occurrence-kind" (constant "heads")))
                       (function `Heads -> Some () | _ -> None)
                       (fun () -> `Heads);
                     case
                       ~title:"valid-blocks"
                       (Tag 1)
                       (obj2
                          (req "occurrence-kind" (constant "valid-blocks"))
                          (req "chain-id" Chain_id.encoding))
                       (function
                         | `Valid_blocks ch -> Some ((), ch) | _ -> None)
                       (fun ((), ch) -> `Valid_blocks ch) ]))
             (req "header" Tezos_base.Block_header.encoding))
      in
      With_version.(encoding ~name (first_version v0_encoding))

    let pp ppf {hash; _} =
      Format.fprintf ppf "Saw block %a" Block_hash.pp_short hash

    let doc = "Block observed while monitoring a blockchain."

    include Internal_event.Event_defaults
  end

  module Event = Internal_event.Make (Definition)
end

let monitor_valid_blocks cctxt ?chains ?protocols ~next_protocols () =
  Monitor_services.valid_blocks cctxt ?chains ?protocols ?next_protocols ()
  >>=? fun (block_stream, _stop) ->
  return
    (Lwt_stream.map_s
       (fun ((chain, block), header) ->
         Block_seen_event.(
           Event.emit (make block header (`Valid_blocks chain)))
         >>=? fun () ->
         raw_info
           cctxt
           ~chain:(`Hash chain)
           block
           header.Tezos_base.Block_header.shell)
       block_stream)

let monitor_heads cctxt ~next_protocols chain =
  Monitor_services.heads cctxt ?next_protocols chain
  >>=? fun (block_stream, _stop) ->
  return
    (Lwt_stream.map_s
       (fun (block, ({Tezos_base.Block_header.shell; _} as header)) ->
         Block_seen_event.(Event.emit (make block header `Heads))
         >>=? fun () -> raw_info cctxt ~chain block shell)
       block_stream)

let blocks_from_current_cycle cctxt ?(chain = `Main) block ?(offset = 0l) () =
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
  >>=? fun {level; _} ->
  Alpha_services.Helpers.levels_in_current_cycle cctxt ~offset (chain, block)
  >>= function
  | Error (RPC_context.Not_found _ :: _) ->
      return_nil
  | Error _ as err ->
      Lwt.return err
  | Ok (first, last) ->
      let length = Int32.to_int (Int32.sub level (Raw_level.to_int32 first)) in
      Shell_services.Blocks.list cctxt ~chain ~heads:[hash] ~length ()
      >>=? fun blocks ->
      let blocks =
        List.remove
          (length - Int32.to_int (Raw_level.diff last first))
          (List.hd blocks)
      in
      if Int32.equal level (Raw_level.to_int32 last) then
        return (hash :: blocks)
      else return blocks
src/proto_alpha/lib_delegate/client_baking_blocks.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Record block_info := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  chain_id : Tezos_base__TzPervasives.Chain_id.t;
  predecessor : Tezos_base__TzPervasives.Block_hash.t;
  fitness : list Stdlib.Bytes.t;
  timestamp : Tezos_base__TzPervasives.Time.Protocol.t;
  protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  next_protocol : Tezos_base__TzPervasives.Protocol_hash.t;
  proto_level : Z;
  level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t;
  context : Tezos_base__TzPervasives.Context_hash.t }.

Definition raw_info {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (op_staroptstar : option Tezos_shell_services.Shell_services.Chain.chain)
  : Tezos_base__TzPervasives.Block_hash.t ->
    Tezos_base.Block_header.shell_header ->
      Lwt.t (Tezos_base__TzPervasives.tzresult block_info) :=
  let chain :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun hash =>
    fun shell_header =>
      let block :=
        (* ❌ Variants not supported *)
        variant in
      op_gtgteqquestion (Shell_services.Chain.chain_id cctxt (Some chain) tt)
        (fun chain_id =>
          op_gtgteqquestion
            (Shell_services.Blocks.protocols cctxt (Some chain) (Some block) tt)
            (fun function_parameter =>
              let '{|
                current_protocol := protocol;
                  next_protocol := next_protocol
                  |} := function_parameter in
              let '{|
                Tezos_base.Block_header.level := level;
                  Tezos_base.Block_header.proto_level := proto_level;
                  Tezos_base.Block_header.predecessor := predecessor;
                  Tezos_base.Block_header.timestamp := timestamp;
                  Tezos_base.Block_header.fitness := fitness;
                  Tezos_base.Block_header.context := context
                  |} := shell_header in
              match Raw_level.of_int32 level with
              | Stdlib.Ok level =>
                _return
                  {| hash := hash; chain_id := chain_id;
                    predecessor := predecessor; fitness := fitness;
                    timestamp := timestamp; protocol := protocol;
                    next_protocol := next_protocol; proto_level := proto_level;
                    level := level; context := context |}
              | Stdlib.Error _ =>
                failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Cannot convert level into int32" % string
                      CamlinternalFormatBasics.End_of_format)
                    "Cannot convert level into int32" % string)
              end)).

Definition info {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (op_staroptstar : option Tezos_shell_services__Block_services.chain)
  : Tezos_shell_services__Block_services.block ->
    Lwt.t (Tezos_base__TzPervasives.tzresult block_info) :=
  let chain :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun block =>
    op_gtgteqquestion
      (Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
      (fun hash =>
        op_gtgteqquestion
          (Shell_services.Blocks.Header.shell_header cctxt (Some chain)
            (Some block) tt)
          (fun shell_header => raw_info cctxt (Some chain) hash shell_header)).

Module Block_seen_event.
  Record t := {
    hash : Tezos_base__TzPervasives.Block_hash.t;
    header : Tezos_base.Block_header.t;
    occurrence : variant }.
  
  Definition make
    (hash : Tezos_base__TzPervasives.Block_hash.t)
    (header : Tezos_base.Block_header.t) (occurrence : variant)
    (function_parameter : unit) : t :=
    let 'tt := function_parameter in
    {| hash := hash; header := header; occurrence := occurrence |}.
  
  Module Definition.
    Definition name : string :=
      String.append "block-seen-" % string Protocol.name.
    
    Definition t := t.
    
    Definition encoding : Tezos_data_encoding__Data_encoding.encoding t :=
      let v0_encoding :=
        conv
          (fun function_parameter =>
            let '{|
              hash := hash; header := header; occurrence := occurrence |} :=
              function_parameter in
            (hash, occurrence, header))
          (fun function_parameter =>
            let '(b, o, h) := function_parameter in
            make b h o tt) None
          (obj3 (req None None "hash" % string Block_hash.encoding)
            (req None None "occurrence" % string
              (union None
                (cons
                  (case "heads" % string None
                    (Tezos_base__TzPervasives.Data_encoding.Tag 0)
                    (obj1
                      (req None None "occurrence-kind" % string
                        (constant "heads" % string)))
                    (fun function_parameter =>
                      match function_parameter with
                      | Heads => Some tt
                      | _ => None
                      end)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      (* ❌ Variants not supported *)
                      variant))
                  (cons
                    (case "valid-blocks" % string None
                      (Tezos_base__TzPervasives.Data_encoding.Tag 1)
                      (obj2
                        (req None None "occurrence-kind" % string
                          (constant "valid-blocks" % string))
                        (req None None "chain-id" % string Chain_id.encoding))
                      (fun function_parameter =>
                        match function_parameter with
                        | Valid_blocks ch => Some (tt, ch)
                        | _ => None
                        end)
                      (fun function_parameter =>
                        let '(tt, ch) := function_parameter in
                        (* ❌ Variants not supported *)
                        variant)) []))))
            (req None None "header" % string Tezos_base.Block_header.encoding))
        in
      encoding name (first_version v0_encoding).
    
    Definition pp (ppf : Stdlib.Format.formatter) (function_parameter : t)
      : unit :=
      let '{| hash := hash |} := function_parameter in
      Format.fprintf ppf
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal "Saw block " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format)) "Saw block %a" % string)
        Block_hash.pp_short hash.
    
    Definition doc : string :=
      "Block observed while monitoring a blockchain." % string.
    
    (* ❌ Structure item `include` not handled. *)
    include
  End Definition.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Block_seen_event.

Definition monitor_valid_blocks {E F G i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G))
  (chains : option (list Tezos_shell_services.Chain_services.chain))
  (protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  (next_protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    (Monitor_services.valid_blocks cctxt chains protocols next_protocols tt)
    (fun function_parameter =>
      let '(block_stream, _stop) := function_parameter in
      _return
        (Lwt_stream.map_s
          (fun function_parameter =>
            let '((chain, block), header) := function_parameter in
            op_gtgteqquestion
              (Event.emit None
                (make block header
                  (* ❌ Variants not supported *)
                  variant))
              (fun function_parameter =>
                let 'tt := function_parameter in
                raw_info cctxt
                  (Some
                    (* ❌ Variants not supported *)
                    variant) block (Tezos_base.Block_header.shell header)))
          block_stream)).

Definition monitor_heads {E F G i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      (o -> unit) ->
        (unit -> unit) ->
          p ->
            q ->
              i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult (unit -> unit)))
      * (E * p * q * i * o)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G)) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (F * p * q * i * o)) * G))
  (next_protocols : option (list Tezos_base__TzPervasives.Protocol_hash.t))
  (chain : Tezos_shell_services.Chain_services.chain)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Lwt_stream.t (Tezos_base__TzPervasives.tzresult block_info))) :=
  op_gtgteqquestion (Monitor_services.heads cctxt next_protocols chain)
    (fun function_parameter =>
      let '(block_stream, _stop) := function_parameter in
      _return
        (Lwt_stream.map_s
          (fun function_parameter =>
            let
              '(block, {| Tezos_base.Block_header.shell := shell |} as header) :=
              function_parameter in
            op_gtgteqquestion
              (Event.emit None
                (make block header
                  (* ❌ Variants not supported *)
                  variant))
              (fun function_parameter =>
                let 'tt := function_parameter in
                raw_info cctxt (Some chain) block shell)) block_stream)).

Definition blocks_from_current_cycle {D F H J L M a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (variant * Tezos_shell_services__Block_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (variant * Tezos_shell_services__Block_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (variant * Tezos_shell_services__Block_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (variant * Tezos_shell_services__Block_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (L * p * q * i * o)) * M))))) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (variant * Tezos_shell_services__Block_services.block) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (variant * Tezos_shell_services__Block_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (variant * Tezos_shell_services__Block_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (variant * Tezos_shell_services__Block_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) * M)))))
  (op_staroptstar : option variant)
  : Tezos_shell_services__Block_services.block ->
    (option int32) ->
      unit ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (list Tezos_base__TzPervasives.Block_hash.t)) :=
  let chain :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Variants not supported *)
      variant
    end in
  fun block =>
    fun op_staroptstar =>
      let offset :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None =>
          (* ❌ Constant of type int32 is converted to int *)
          0
        end in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
          (fun hash =>
            op_gtgteqquestion
              (Shell_services.Blocks.Header.shell_header cctxt (Some chain)
                (Some block) tt)
              (fun function_parameter =>
                let '{| level := level |} := function_parameter in
                op_gtgteq
                  (Alpha_services.Helpers.levels_in_current_cycle cctxt
                    (Some offset) (chain, block))
                  (fun function_parameter =>
                    match function_parameter with
                    |
                      Stdlib.Error
                        (cons (Tezos_error_monad.Error_monad.Not_found _) _) =>
                      return_nil
                    | (Stdlib.Error _) as err => Lwt._return err
                    | Stdlib.Ok (first, last) =>
                      let length :=
                        Int32.to_int
                          (Int32.sub level (Raw_level.to_int32 first)) in
                      op_gtgteqquestion
                        (Shell_services.Blocks.list cctxt (Some chain)
                          (Some (cons hash [])) (Some length) None tt)
                        (fun blocks =>
                          let blocks :=
                            List.remove
                              (Z.sub length
                                (Int32.to_int (Raw_level.diff last first)))
                              (List.hd blocks) in
                          if Int32.equal level (Raw_level.to_int32 last) then
                            _return (cons hash blocks)
                          else
                            _return blocks)
                    end))).

src/proto_alpha/lib_delegate/client_baking_denunciation.ml 449 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.denunciation"
end)

open Protocol
open Alpha_context
open Protocol_client_context
open Client_baking_blocks
open Logging

module HLevel = Hashtbl.Make (struct
  type t = Chain_id.t * Raw_level.t

  let equal (c, l) (c', l') = Chain_id.equal c c' && Raw_level.equal l l'

  let hash (c, lvl) = Hashtbl.hash (c, lvl)
end)

module Delegate_Map = Map.Make (Signature.Public_key_hash)

type state = {
  (* Endorsements seen so far *)
  endorsements_table : Kind.endorsement operation Delegate_Map.t HLevel.t;
  (* Blocks received so far *)
  blocks_table : Block_hash.t Delegate_Map.t HLevel.t;
  (* Maximum delta of level to register *)
  preserved_levels : int;
  (* Highest level seen in a block *)
  mutable highest_level_encountered : Raw_level.t;
}

let create_state ~preserved_levels =
  Lwt.return
    {
      endorsements_table = HLevel.create preserved_levels;
      blocks_table = HLevel.create preserved_levels;
      preserved_levels;
      highest_level_encountered = Raw_level.root (* 0l *);
    }

(* We choose a previous offset (5 blocks from head) to ensure that the
   injected operation is branched from a valid predecessor. *)
let get_block_offset level =
  match Environment.wrap_error (Raw_level.of_int32 5l) with
  | Ok min_level ->
      Lwt.return (if Raw_level.(level < min_level) then `Head 0 else `Head 5)
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Invalid level conversion : %a"
            -% t event "invalid_level_conversion"
            -% a errs_tag errs)
      >>= fun () -> Lwt.return (`Head 0)

let process_endorsements (cctxt : #Protocol_client_context.full) state
    (endorsements : Alpha_block_services.operation list) level =
  iter_s
    (fun {Alpha_block_services.shell; chain_id; receipt; hash; protocol_data; _}
         ->
      let chain = `Hash chain_id in
      match (protocol_data, receipt) with
      | ( Operation_data
            ({contents = Single (Endorsement _); _} as protocol_data),
          Apply_results.(
            Operation_metadata
              {contents = Single_result (Endorsement_result {delegate; _})}) )
        -> (
          let new_endorsement : Kind.endorsement Alpha_context.operation =
            {shell; protocol_data}
          in
          let map =
            match
              HLevel.find_opt state.endorsements_table (chain_id, level)
            with
            | None ->
                Delegate_Map.empty
            | Some x ->
                x
          in
          (* If a previous endorsement made by this pkh is found for
             the same level we inject a double_endorsement *)
          match Delegate_Map.find_opt delegate map with
          | None ->
              return
              @@ HLevel.add
                   state.endorsements_table
                   (chain_id, level)
                   (Delegate_Map.add delegate new_endorsement map)
          | Some existing_endorsement
            when Block_hash.(
                   existing_endorsement.shell.branch
                   <> new_endorsement.shell.branch) ->
              get_block_offset level
              >>= fun block ->
              Alpha_block_services.hash cctxt ~chain ~block ()
              >>=? fun block_hash ->
              Alpha_services.Forge.double_endorsement_evidence
                cctxt
                (`Hash chain_id, block)
                ~branch:block_hash
                ~op1:existing_endorsement
                ~op2:new_endorsement
                ()
              >>=? fun bytes ->
              let bytes = Signature.concat bytes Signature.zero in
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "Double endorsement detected"
                    -% t event "double_endorsement_detected"
                    -% t
                         conflicting_endorsements_tag
                         (existing_endorsement, new_endorsement))
              >>= fun () ->
              (* A denunciation may have already occured *)
              Shell_services.Injection.operation cctxt ~chain bytes
              >>=? fun op_hash ->
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "Double endorsement evidence injected %a"
                    -% t event "double_endorsement_denounced"
                    -% t signed_operation_tag bytes
                    -% a Operation_hash.Logging.tag op_hash)
              >>= fun () ->
              return
              @@ HLevel.replace
                   state.endorsements_table
                   (chain_id, level)
                   (Delegate_Map.add delegate new_endorsement map)
          | Some _ ->
              (* This endorsement is already present in another
                   block but endorse the same predecessor *)
              return_unit )
      | _ ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f "Inconsistent endorsement found %a"
                -% t event "inconsistent_endorsement"
                -% a Operation_hash.Logging.tag hash)
          >>= fun () -> return_unit)
    endorsements
  >>=? fun () -> return_unit

let process_block (cctxt : #Protocol_client_context.full) state
    (header : Alpha_block_services.block_info) =
  let { Alpha_block_services.chain_id;
        hash;
        metadata = {protocol_data = {baker; level = {level; _}; _}; _};
        _ } =
    header
  in
  let chain = `Hash chain_id in
  let map =
    match HLevel.find_opt state.blocks_table (chain_id, level) with
    | None ->
        Delegate_Map.empty
    | Some x ->
        x
  in
  match Delegate_Map.find_opt baker map with
  | None ->
      return
      @@ HLevel.add
           state.blocks_table
           (chain_id, level)
           (Delegate_Map.add baker hash map)
  | Some existing_hash when Block_hash.( = ) existing_hash hash ->
      (* This case should never happen *)
      lwt_debug
        Tag.DSL.(
          fun f ->
            f
              "Double baking detected but block hashes are equivalent. \
               Skipping..."
            -% t event "double_baking_but_not")
      >>= fun () ->
      return
      @@ HLevel.replace
           state.blocks_table
           (chain_id, level)
           (Delegate_Map.add baker hash map)
  | Some existing_hash ->
      (* If a previous endorsement made by this pkh is found for
           the same level we inject a double_endorsement *)
      Alpha_block_services.header
        cctxt
        ~chain
        ~block:(`Hash (existing_hash, 0))
        ()
      >>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) ->
      let bh1 = {Alpha_context.Block_header.shell; protocol_data} in
      Alpha_block_services.header cctxt ~chain ~block:(`Hash (hash, 0)) ()
      >>=? fun ({shell; protocol_data; _} : Alpha_block_services.block_header) ->
      let bh2 = {Alpha_context.Block_header.shell; protocol_data} in
      (* If the blocks are on different chains then skip it *)
      get_block_offset level
      >>= fun block ->
      Alpha_block_services.hash cctxt ~chain ~block ()
      >>=? fun block_hash ->
      Alpha_services.Forge.double_baking_evidence
        cctxt
        (chain, block)
        ~branch:block_hash
        ~bh1
        ~bh2
        ()
      >>=? fun bytes ->
      let bytes = Signature.concat bytes Signature.zero in
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Double baking detected" -% t event "double_baking_detected")
      >>= fun () ->
      (* A denunciation may have already occured *)
      Shell_services.Injection.operation cctxt ~chain bytes
      >>=? fun op_hash ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Double baking evidence injected %a"
            -% t event "double_baking_denounced"
            -% t signed_operation_tag bytes
            -% a Operation_hash.Logging.tag op_hash)
      >>= fun () ->
      return
      @@ HLevel.replace
           state.blocks_table
           (chain_id, level)
           (Delegate_Map.add baker hash map)

(* Remove levels that are lower than the [highest_level_encountered] minus [preserved_levels] *)
let cleanup_old_operations state =
  let highest_level_encountered =
    Int32.to_int (Raw_level.to_int32 state.highest_level_encountered)
  in
  let diff = highest_level_encountered - state.preserved_levels in
  let threshold =
    if diff < 0 then Raw_level.root
    else
      Raw_level.of_int32 (Int32.of_int diff)
      |> function Ok threshold -> threshold | Error _ -> Raw_level.root
  in
  let filter hmap =
    HLevel.filter_map_inplace
      (fun (_, level) x ->
        if Raw_level.(level < threshold) then None else Some x)
      hmap
  in
  filter state.endorsements_table ;
  filter state.blocks_table ;
  ()

let endorsements_index = 0

(* Each new block is processed :
   - Checking that every endorser operated only once at this level
   - Checking that every baker injected only once at this level
*)
let process_new_block (cctxt : #Protocol_client_context.full) state
    {hash; chain_id; level; protocol; next_protocol; _} =
  if Protocol_hash.(protocol <> next_protocol) then
    lwt_log_error
      Tag.DSL.(
        fun f ->
          f "Protocol changing detected. Skipping the block."
          -% t event "protocol_change_detected"
        (* TODO which protocols -- in tag *))
    >>= fun () -> return_unit
  else
    lwt_debug
      Tag.DSL.(
        fun f ->
          f "Block level : %a"
          -% t event "accuser_saw_block"
          -% a level_tag level
          -% t Block_hash.Logging.tag hash)
    >>= fun () ->
    let chain = `Hash chain_id in
    let block = `Hash (hash, 0) in
    state.highest_level_encountered <-
      Raw_level.max level state.highest_level_encountered ;
    (* Processing blocks *)
    Alpha_block_services.info cctxt ~chain ~block ()
    >>= (function
          | Ok block_info ->
              process_block cctxt state block_info
          | Error errs ->
              lwt_log_error
                Tag.DSL.(
                  fun f ->
                    f "Error while fetching operations in block %a@\n%a"
                    -% t event "fetch_operations_error"
                    -% a Block_hash.Logging.tag hash
                    -% a errs_tag errs)
              >>= fun () -> return_unit)
    >>=? fun () ->
    (* Processing endorsements *)
    Alpha_block_services.Operations.operations cctxt ~chain ~block ()
    >>= (function
          | Ok operations ->
              if List.length operations > endorsements_index then
                let endorsements = List.nth operations endorsements_index in
                process_endorsements cctxt state endorsements level
              else return_unit
          | Error errs ->
              lwt_log_error
                Tag.DSL.(
                  fun f ->
                    f "Error while fetching operations in block %a@\n%a"
                    -% t event "fetch_operations_error"
                    -% a Block_hash.Logging.tag hash
                    -% a errs_tag errs)
              >>= fun () -> return_unit)
    >>=? fun () ->
    cleanup_old_operations state ;
    return_unit

let create (cctxt : #Protocol_client_context.full) ~preserved_levels
    valid_blocks_stream =
  let process_block cctxt state bi =
    process_new_block cctxt state bi
    >>= function
    | Ok () ->
        lwt_log_notice
          Tag.DSL.(
            fun f ->
              f "Block %a registered"
              -% t event "accuser_processed_block"
              -% a Block_hash.Logging.tag bi.Client_baking_blocks.hash)
        >>= return
    | Error errs ->
        lwt_log_error
          Tag.DSL.(
            fun f ->
              f "Error while processing block %a@\n%a"
              -% t event "accuser_block_error"
              -% a Block_hash.Logging.tag bi.hash
              -% a errs_tag errs)
        >>= return
  in
  let state_maker _ = create_state ~preserved_levels >>= return in
  Client_baking_scheduling.main
    ~name:"accuser"
    ~cctxt
    ~stream:valid_blocks_stream
    ~state_maker
    ~pre_loop:(fun _ _ _ -> return_unit)
    ~compute_timeout:(fun _ -> Lwt_utils.never_ending ())
    ~timeout_k:(fun _ _ () -> return_unit)
    ~event_k:process_block
src/proto_alpha/lib_delegate/client_baking_denunciation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Import Protocol.

Import Alpha_context.

Import Protocol_client_context.

Import Client_baking_blocks.

Import Logging.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Record state := {
  endorsements_table :
    HLevel.t
      (Delegate_Map.(Stdlib__map.S.t)
        (Tezos_protocol_alpha.Protocol.Alpha_context.operation
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement));
  blocks_table :
    HLevel.t
      (Delegate_Map.(Stdlib__map.S.t) Tezos_base__TzPervasives.Block_hash.t);
  preserved_levels : Z;
  highest_level_encountered :
    Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t }.

Definition create_state (preserved_levels : Z) : Lwt.t state :=
  Lwt._return
    {| endorsements_table := HLevel.create preserved_levels;
      blocks_table := HLevel.create preserved_levels;
      preserved_levels := preserved_levels;
      highest_level_encountered := Raw_level.root |}.

Definition get_block_offset
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t variant :=
  match
    Environment.wrap_error
      (Raw_level.of_int32
        (* ❌ Constant of type int32 is converted to int *)
        5) with
  | Stdlib.Ok min_level =>
    Lwt._return
      (if op_lt level min_level then
        (* ❌ Variants not supported *)
        variant
      else
        (* ❌ Variants not supported *)
        variant)
  | Stdlib.Error errs =>
    op_gtgteq
      (lwt_log_error
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (f
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal
                    "Invalid level conversion : " % string
                    (CamlinternalFormatBasics.Alpha
                      CamlinternalFormatBasics.End_of_format))
                  "Invalid level conversion : %a" % string))
              (t event "invalid_level_conversion" % string)) (a errs_tag errs)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        Lwt._return
          (* ❌ Variants not supported *)
          variant)
  end.

Definition process_endorsements {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (endorsements :
    list
      Tezos_client_alpha.Protocol_client_context.Alpha_block_services.operation)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (iter_s
      (fun function_parameter =>
        let '{|
          Alpha_block_services.chain_id := chain_id;
            Alpha_block_services.hash := hash;
            Alpha_block_services.shell := shell;
            Alpha_block_services.protocol_data := protocol_data;
            Alpha_block_services.receipt := receipt
            |} := function_parameter in
        let chain :=
          (* ❌ Variants not supported *)
          variant in
        match (protocol_data, receipt) with
        |
          (Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
            ({|
              contents :=
                Tezos_protocol_alpha.Protocol.Alpha_context.Single
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
                    _)
                |} as protocol_data),
            Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata {|
              contents :=
                Tezos_protocol_alpha.Protocol.Apply_results.Single_result
                  (Tezos_protocol_alpha.Protocol.Apply_results.Endorsement_result
                    {| delegate := delegate |})
                |}) =>
          let new_endorsement :=
            {| shell := shell; protocol_data := protocol_data |} in
          let map :=
            match HLevel.find_opt (endorsements_table state) (chain_id, level)
              with
            | None => Delegate_Map.(Stdlib__map.S.empty)
            | Some x => x
            end in
          match Delegate_Map.(Stdlib__map.S.find_opt) delegate map with
          | None =>
            apply _return
              (HLevel.add (endorsements_table state) (chain_id, level)
                (Delegate_Map.(Stdlib__map.S.add) delegate new_endorsement map))
          | Some existing_endorsement =>
            op_gtgteq (get_block_offset level)
              (fun block =>
                op_gtgteqquestion
                  (Alpha_block_services.hash cctxt (Some chain) (Some block) tt)
                  (fun block_hash =>
                    op_gtgteqquestion
                      (Alpha_services.Forge.double_endorsement_evidence cctxt
                        ((* ❌ Variants not supported *)
                        variant, block) block_hash existing_endorsement
                        new_endorsement tt)
                      (fun bytes =>
                        let bytes := Signature.concat string Signature.zero in
                        op_gtgteq
                          (lwt_log_notice
                            (fun f =>
                              op_minuspercent
                                (op_minuspercent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Double endorsement detected" % string
                                        CamlinternalFormatBasics.End_of_format)
                                      "Double endorsement detected" % string))
                                  (t event
                                    "double_endorsement_detected" % string))
                                (t conflicting_endorsements_tag
                                  (existing_endorsement, new_endorsement))))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Shell_services.Injection.operation cctxt None
                                (Some chain) string)
                              (fun op_hash =>
                                op_gtgteq
                                  (lwt_log_notice
                                    (fun f =>
                                      op_minuspercent
                                        (op_minuspercent
                                          (op_minuspercent
                                            (f
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Double endorsement evidence injected "
                                                    % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    CamlinternalFormatBasics.End_of_format))
                                                "Double endorsement evidence injected %a"
                                                  % string))
                                            (t event
                                              "double_endorsement_denounced" %
                                                string))
                                          (t signed_operation_tag string))
                                        (a Operation_hash.Logging.tag op_hash)))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    apply _return
                                      (HLevel.replace (endorsements_table state)
                                        (chain_id, level)
                                        (Delegate_Map.(Stdlib__map.S.add)
                                          delegate new_endorsement map))))))))
          | Some _ => return_unit
          end
        | _ =>
          op_gtgteq
            (lwt_log_error
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Inconsistent endorsement found " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "Inconsistent endorsement found %a" % string))
                    (t event "inconsistent_endorsement" % string))
                  (a Operation_hash.Logging.tag hash)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        end) endorsements)
    (fun function_parameter =>
      let 'tt := function_parameter in
      return_unit).

Definition process_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (header :
    Tezos_client_alpha.Protocol_client_context.Alpha_block_services.block_info)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    Alpha_block_services.chain_id := chain_id;
      Alpha_block_services.hash := hash;
      Alpha_block_services.metadata := {|
        protocol_data := {| baker := baker; level := {| level := level |} |}
          |}
      |} := header in
  let chain :=
    (* ❌ Variants not supported *)
    variant in
  let map :=
    match HLevel.find_opt (blocks_table state) (chain_id, level) with
    | None => Delegate_Map.(Stdlib__map.S.empty)
    | Some x => x
    end in
  match Delegate_Map.(Stdlib__map.S.find_opt) baker map with
  | None =>
    apply _return
      (HLevel.add (blocks_table state) (chain_id, level)
        (Delegate_Map.(Stdlib__map.S.add) baker hash map))
  | Some existing_hash =>
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Double baking detected but block hashes are equivalent. Skipping..."
                    % string CamlinternalFormatBasics.End_of_format)
                "Double baking detected but block hashes are equivalent. Skipping..."
                  % string)) (t event "double_baking_but_not" % string)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        apply _return
          (HLevel.replace (blocks_table state) (chain_id, level)
            (Delegate_Map.(Stdlib__map.S.add) baker hash map)))
  | Some existing_hash =>
    op_gtgteqquestion
      (Alpha_block_services.header cctxt (Some chain)
        (Some
          (* ❌ Variants not supported *)
          variant) tt)
      (fun function_parameter =>
        let '{| shell := shell; protocol_data := protocol_data |} :=
          function_parameter in
        let bh1 :=
          {| Alpha_context.Block_header.shell := shell;
            Alpha_context.Block_header.protocol_data := protocol_data |} in
        op_gtgteqquestion
          (Alpha_block_services.header cctxt (Some chain)
            (Some
              (* ❌ Variants not supported *)
              variant) tt)
          (fun function_parameter =>
            let '{| shell := shell; protocol_data := protocol_data |} :=
              function_parameter in
            let bh2 :=
              {| Alpha_context.Block_header.shell := shell;
                Alpha_context.Block_header.protocol_data := protocol_data |} in
            op_gtgteq (get_block_offset level)
              (fun block =>
                op_gtgteqquestion
                  (Alpha_block_services.hash cctxt (Some chain) (Some block) tt)
                  (fun block_hash =>
                    op_gtgteqquestion
                      (Alpha_services.Forge.double_baking_evidence cctxt
                        (chain, block) block_hash bh1 bh2 tt)
                      (fun bytes =>
                        let bytes := Signature.concat string Signature.zero in
                        op_gtgteq
                          (lwt_log_notice
                            (fun f =>
                              op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Double baking detected" % string
                                      CamlinternalFormatBasics.End_of_format)
                                    "Double baking detected" % string))
                                (t event "double_baking_detected" % string)))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Shell_services.Injection.operation cctxt None
                                (Some chain) string)
                              (fun op_hash =>
                                op_gtgteq
                                  (lwt_log_notice
                                    (fun f =>
                                      op_minuspercent
                                        (op_minuspercent
                                          (op_minuspercent
                                            (f
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Double baking evidence injected "
                                                    % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    CamlinternalFormatBasics.End_of_format))
                                                "Double baking evidence injected %a"
                                                  % string))
                                            (t event
                                              "double_baking_denounced" % string))
                                          (t signed_operation_tag string))
                                        (a Operation_hash.Logging.tag op_hash)))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    apply _return
                                      (HLevel.replace (blocks_table state)
                                        (chain_id, level)
                                        (Delegate_Map.(Stdlib__map.S.add) baker
                                          hash map))))))))))
  end.

Definition cleanup_old_operations (state : state) : unit :=
  let highest_level_encountered :=
    Int32.to_int (Raw_level.to_int32 (highest_level_encountered state)) in
  let diff := Z.sub highest_level_encountered (preserved_levels state) in
  let threshold :=
    if OCaml.Stdlib.lt diff 0 then
      Raw_level.root
    else
      OCaml.Stdlib.reverse_apply (Raw_level.of_int32 (Int32.of_int diff))
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Ok threshold => threshold
          | Stdlib.Error _ => Raw_level.root
          end) in
  let filter {A : Type} (hmap : HLevel.t A) : unit :=
    HLevel.filter_map_inplace
      (fun function_parameter =>
        let '(_, level) := function_parameter in
        fun x =>
          if op_lt level threshold then
            None
          else
            Some x) hmap in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := filter (endorsements_table state) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := filter (blocks_table state) in
  tt.

Definition endorsements_index : Z := 0.

Definition process_new_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (function_parameter : Tezos_baking_alpha.Client_baking_blocks.block_info)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    hash := hash;
      chain_id := chain_id;
      protocol := protocol;
      next_protocol := next_protocol;
      level := level
      |} := function_parameter in
  if op_ltgt protocol next_protocol then
    op_gtgteq
      (lwt_log_error
        (fun f =>
          op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Protocol changing detected. Skipping the block." % string
                  CamlinternalFormatBasics.End_of_format)
                "Protocol changing detected. Skipping the block." % string))
            (t event "protocol_change_detected" % string)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        return_unit)
  else
    op_gtgteq
      (lwt_debug
        (fun f =>
          op_minuspercent
            (op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Block level : " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "Block level : %a" % string))
                (t event "accuser_saw_block" % string)) (a level_tag level))
            (t Block_hash.Logging.tag hash)))
      (fun function_parameter =>
        let 'tt := function_parameter in
        let chain :=
          (* ❌ Variants not supported *)
          variant in
        let block :=
          (* ❌ Variants not supported *)
          variant in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field state "highest_level_encountered" % string
            (Raw_level.max level (highest_level_encountered state)) in
        op_gtgteqquestion
          (op_gtgteq
            (Alpha_block_services.info cctxt (Some chain) (Some block) tt)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Ok block_info => process_block cctxt state block_info
              | Stdlib.Error errs =>
                op_gtgteq
                  (lwt_log_error
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Error while fetching operations in block " %
                                    string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Force_newline
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))))
                                "Error while fetching operations in block %a@
%a"
                                  % string))
                            (t event "fetch_operations_error" % string))
                          (a Block_hash.Logging.tag hash)) (a errs_tag errs)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)
              end))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (op_gtgteq
                (Alpha_block_services.Operations.operations cctxt (Some chain)
                  (Some block) tt)
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok operations =>
                    if
                      OCaml.Stdlib.gt (List.length operations)
                        endorsements_index then
                      let endorsements := List.nth operations endorsements_index
                        in
                      process_endorsements cctxt state endorsements level
                    else
                      return_unit
                  | Stdlib.Error errs =>
                    op_gtgteq
                      (lwt_log_error
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Error while fetching operations in block "
                                        % string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Force_newline
                                          (CamlinternalFormatBasics.Alpha
                                            CamlinternalFormatBasics.End_of_format))))
                                    "Error while fetching operations in block %a@
%a"
                                      % string))
                                (t event "fetch_operations_error" % string))
                              (a Block_hash.Logging.tag hash)) (a errs_tag errs)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)
                  end))
              (fun function_parameter =>
                let 'tt := function_parameter in
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ := cleanup_old_operations state in
                return_unit))).

Definition create {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (preserved_levels : Z)
  (valid_blocks_stream :
    Lwt_stream.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_baking_alpha.Client_baking_blocks.block_info))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let process_block {O P Q R S T U : Type}
    (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (O * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (P * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Q * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (R * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (S * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (T * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * U)))))))))))))))))))))))))
      * U) (state : state) (bi :
    Tezos_baking_alpha.Client_baking_blocks.block_info)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq (process_new_block cctxt state bi)
      (fun function_parameter =>
        match function_parameter with
        | Stdlib.Ok tt =>
          op_gtgteq
            (lwt_log_notice
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " registered" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Block %a registered" % string))
                    (t event "accuser_processed_block" % string))
                  (a Block_hash.Logging.tag (Client_baking_blocks.hash bi))))
            _return
        | Stdlib.Error errs =>
          op_gtgteq
            (lwt_log_error
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error while processing block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Force_newline
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))))
                          "Error while processing block %a@
%a" % string))
                      (t event "accuser_block_error" % string))
                    (a Block_hash.Logging.tag (hash bi))) (a errs_tag errs)))
            _return
        end) in
  let state_maker {O : Type} (function_parameter : O)
    : Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
    let '_ := function_parameter in
    op_gtgteq (create_state preserved_levels) _return in
  Client_baking_scheduling.main "accuser" % string cctxt valid_blocks_stream
    state_maker
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          return_unit)
    (fun function_parameter =>
      let '_ := function_parameter in
      Lwt_utils.never_ending tt)
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          return_unit) process_block.

src/proto_alpha/lib_delegate/client_baking_endorsement.ml 860 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

[@@@ocaml.warning "-30"]

open Protocol
open Alpha_context
open Protocol_client_context

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.endorsement"
end)

open Logging

let get_signing_slots cctxt ~chain ~block delegate level =
  Alpha_services.Delegate.Endorsing_rights.get
    cctxt
    ~levels:[level]
    ~delegates:[delegate]
    (chain, block)
  >>=? function [{slots; _}] -> return_some slots | _ -> return_none

let inject_endorsement (cctxt : #Protocol_client_context.full) ?async ~chain
    ~block hash level delegate_sk delegate_pkh =
  Alpha_services.Forge.endorsement cctxt (chain, block) ~branch:hash ~level ()
  >>=? fun bytes ->
  let wallet = (cctxt :> Client_context.wallet) in
  (* Double-check the right to inject an endorsement *)
  let open Client_baking_highwatermarks in
  wallet#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Endorsement
      >>=? fun endorsement_location ->
      may_inject_endorsement
        cctxt
        endorsement_location
        ~delegate:delegate_pkh
        level
      >>=? function
      | true ->
          record_endorsement
            cctxt
            endorsement_location
            ~delegate:delegate_pkh
            level
          >>=? fun () -> return_true
      | false ->
          return_false)
  >>=? fun is_allowed_to_endorse ->
  if is_allowed_to_endorse then
    Chain_services.chain_id cctxt ~chain ()
    >>=? fun chain_id ->
    Client_keys.append
      cctxt
      delegate_sk
      ~watermark:(Endorsement chain_id)
      bytes
    >>=? fun signed_bytes ->
    Shell_services.Injection.operation cctxt ?async ~chain signed_bytes
    >>=? fun oph -> return oph
  else
    lwt_log_error
      Tag.DSL.(
        fun f ->
          f "Level %a : previously endorsed."
          -% t event "double_endorsement_near_miss"
          -% a level_tag level)
    >>= fun () -> fail (Level_previously_endorsed level)

let forge_endorsement (cctxt : #Protocol_client_context.full) ?async ~chain
    ~block ~src_sk src_pk =
  let src_pkh = Signature.Public_key.hash src_pk in
  Alpha_block_services.metadata cctxt ~chain ~block ()
  >>=? fun {protocol_data = {level = {level; _}; _}; _} ->
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  inject_endorsement cctxt ?async ~chain ~block hash level src_sk src_pkh
  >>=? fun oph ->
  Client_keys.get_key cctxt src_pkh
  >>=? fun (name, _pk, _sk) ->
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
        -% t event "injected_endorsement"
        -% a Block_hash.Logging.tag hash
        -% a level_tag level
        -% s Client_keys.Logging.tag name
        -% t Signature.Public_key_hash.Logging.tag src_pkh
        -% a Operation_hash.Logging.tag oph)
  >>= fun () -> return oph

(** Worker *)

type state = {
  delegates : public_key_hash list;
  delay : int64;
  mutable pending : endorsements option;
}

and endorsements = {
  time : Time.Protocol.t;
  delegates : public_key_hash list;
  block : Client_baking_blocks.block_info;
}

let create_state delegates delay = {delegates; delay; pending = None}

let get_delegates cctxt state =
  match state.delegates with
  | [] ->
      Client_keys.get_keys cctxt
      >>=? fun keys ->
      let delegates = List.map (fun (_, pkh, _, _) -> pkh) keys in
      return Signature.Public_key_hash.Set.(delegates |> of_list |> elements)
  | _ :: _ as delegates ->
      return delegates

let endorse_for_delegate cctxt block delegate_pkh =
  let {Client_baking_blocks.hash; level; chain_id; _} = block in
  Client_keys.get_key cctxt delegate_pkh
  >>=? fun (name, _pk, delegate_sk) ->
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "Endorsing %a for %s (level %a)!"
        -% t event "endorsing"
        -% a Block_hash.Logging.tag hash
        -% s Client_keys.Logging.tag name
        -% a level_tag level)
  >>= fun () ->
  let chain = `Hash chain_id in
  let block = `Hash (hash, 0) in
  inject_endorsement cctxt ~chain ~block hash level delegate_sk delegate_pkh
  >>=? fun oph ->
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
        -% t event "injected_endorsement"
        -% a Block_hash.Logging.tag hash
        -% a level_tag level
        -% s Client_keys.Logging.tag name
        -% t Signature.Public_key_hash.Logging.tag delegate_pkh
        -% a Operation_hash.Logging.tag oph)
  >>= fun () -> return_unit

let allowed_to_endorse cctxt bi delegate =
  Client_keys.Public_key_hash.name cctxt delegate
  >>=? fun name ->
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "Checking if allowed to endorse block %a for %s"
        -% t event "check_endorsement_ok"
        -% a Block_hash.Logging.tag bi.Client_baking_blocks.hash
        -% s Client_keys.Logging.tag name)
  >>= fun () ->
  let chain = `Hash bi.chain_id in
  let block = `Hash (bi.hash, 0) in
  let level = bi.level in
  get_signing_slots cctxt ~chain ~block delegate level
  >>=? function
  | None | Some [] ->
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "No slot found for %a/%s"
            -% t event "endorsement_no_slots_found"
            -% a Block_hash.Logging.tag bi.hash
            -% s Client_keys.Logging.tag name)
      >>= fun () -> return_false
  | Some (_ :: _ as slots) -> (
      lwt_debug
        Tag.DSL.(
          fun f ->
            f "Found slots for %a/%s (%a)"
            -% t event "endorsement_slots_found"
            -% a Block_hash.Logging.tag bi.hash
            -% s Client_keys.Logging.tag name
            -% a endorsement_slots_tag slots)
      >>= fun () ->
      cctxt#with_lock (fun () ->
          Client_baking_files.resolve_location cctxt ~chain `Endorsement
          >>=? fun endorsement_location ->
          Client_baking_highwatermarks.may_inject_endorsement
            cctxt
            endorsement_location
            ~delegate
            level)
      >>=? function
      | false ->
          lwt_debug
            Tag.DSL.(
              fun f ->
                f "Level %a (or higher) previously endorsed: do not endorse."
                -% t event "previously_endorsed"
                -% a level_tag level)
          >>= fun () -> return_false
      | true ->
          return_true )

let prepare_endorsement ~(max_past : int64) ()
    (cctxt : #Protocol_client_context.full) state bi =
  let past =
    Time.Protocol.diff
      (Time.System.to_protocol (Systime_os.now ()))
      bi.Client_baking_blocks.timestamp
  in
  if past > max_past then
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "Ignore block %a: forged too far the past"
          -% t event "endorsement_stale_block"
          -% a Block_hash.Logging.tag bi.hash)
    >>= fun () -> return_unit
  else
    lwt_log_info
      Tag.DSL.(
        fun f ->
          f "Received new block %a"
          -% t event "endorsement_got_block"
          -% a Block_hash.Logging.tag bi.hash)
    >>= fun () ->
    let time =
      Time.Protocol.add
        (Time.System.to_protocol (Systime_os.now ()))
        state.delay
    in
    get_delegates cctxt state
    >>=? fun delegates ->
    filter_p (allowed_to_endorse cctxt bi) delegates
    >>=? fun delegates ->
    state.pending <- Some {time; block = bi; delegates} ;
    return_unit

let compute_timeout state =
  match state.pending with
  | None ->
      Lwt_utils.never_ending ()
  | Some {time; block; delegates} -> (
    match Client_baking_scheduling.sleep_until time with
    | None ->
        Lwt.return (block, delegates)
    | Some timeout ->
        let timespan =
          let timespan =
            Ptime.diff (Time.System.of_protocol_exn time) (Systime_os.now ())
          in
          if Ptime.Span.compare timespan Ptime.Span.zero > 0 then timespan
          else Ptime.Span.zero
        in
        lwt_log_info
          Tag.DSL.(
            fun f ->
              f "Waiting until %a (%a) to inject endorsements"
              -% t event "wait_before_injecting"
              -% a timestamp_tag (Time.System.of_protocol_exn time)
              -% a timespan_tag timespan)
        >>= fun () -> timeout >>= fun () -> Lwt.return (block, delegates) )

let create (cctxt : #Protocol_client_context.full) ?(max_past = 110L) ~delay
    delegates block_stream =
  let state_maker _ =
    let state = create_state delegates (Int64.of_int delay) in
    return state
  in
  let timeout_k cctxt state (block, delegates) =
    state.pending <- None ;
    iter_s
      (fun delegate ->
        endorse_for_delegate cctxt block delegate
        >>= function
        | Ok () ->
            return_unit
        | Error errs ->
            lwt_log_error
              Tag.DSL.(
                fun f ->
                  f
                    "@[<v 2>Error while injecting endorsement for delegate %a \
                     : @[%a@]@]@."
                  -% t event "error_while_endorsing"
                  -% a Signature.Public_key_hash.Logging.tag delegate
                  -% a errs_tag errs)
            >>= fun () ->
            (* We continue anyway *)
            return_unit)
      delegates
  in
  let event_k cctxt state bi =
    state.pending <- None ;
    prepare_endorsement ~max_past () cctxt state bi
  in
  Client_baking_scheduling.main
    ~name:"endorser"
    ~cctxt
    ~stream:block_stream
    ~state_maker
    ~pre_loop:(prepare_endorsement ~max_past ())
    ~compute_timeout
    ~timeout_k
    ~event_k
src/proto_alpha/lib_delegate/client_baking_endorsement.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Protocol_client_context.

(* ❌ Structure item `include` not handled. *)
include

Import Logging.

Definition get_signing_slots {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (option (list Z))) :=
  op_gtgteqquestion
    (Alpha_services.Delegate.Endorsing_rights.get cctxt (Some (cons level []))
      None (Some (cons delegate [])) (chain, block))
    (fun function_parameter =>
      match function_parameter with
      | cons {| slots := slots |} [] => return_some slots
      | _ => return_none
      end).

Definition inject_endorsement {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (async : option bool)
  (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Shell_services.block)
  (hash :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
  (delegate_sk : Tezos_client_base.Client_keys.sk_uri)
  (delegate_pkh : Tezos_base__TzPervasives.Signature.public_key_hash)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Operation_hash.t) :=
  op_gtgteqquestion
    (Alpha_services.Forge.endorsement cctxt (chain, block) hash level tt)
    (fun bytes =>
      let wallet := cctxt in
      op_gtgteqquestion
        ((* ❌ Sending method message is not handled *)
        send
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Client_baking_files.resolve_location cctxt chain
                (* ❌ Variants not supported *)
                variant)
              (fun endorsement_location =>
                op_gtgteqquestion
                  (may_inject_endorsement cctxt endorsement_location
                    delegate_pkh level)
                  (fun function_parameter =>
                    match function_parameter with
                    | true =>
                      op_gtgteqquestion
                        (record_endorsement cctxt endorsement_location
                          delegate_pkh level)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_true)
                    | false => return_false
                    end))))
        (fun is_allowed_to_endorse =>
          if is_allowed_to_endorse then
            op_gtgteqquestion (Chain_services.chain_id cctxt (Some chain) tt)
              (fun chain_id =>
                op_gtgteqquestion
                  (Client_keys.append cctxt
                    (Some
                      (Tezos_base__TzPervasives.Signature.Endorsement chain_id))
                    delegate_sk string)
                  (fun signed_bytes =>
                    op_gtgteqquestion
                      (Shell_services.Injection.operation cctxt async
                        (Some chain) signed_bytes) (fun oph => _return oph)))
          else
            op_gtgteq
              (lwt_log_error
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Level " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " : previously endorsed." % string
                                CamlinternalFormatBasics.End_of_format)))
                          "Level %a : previously endorsed." % string))
                      (t event "double_endorsement_near_miss" % string))
                    (a level_tag level)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                fail (Tezos_base__TzPervasives.Level_previously_endorsed level)))).

Definition forge_endorsement {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (async : option bool)
  (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  (src_sk : Tezos_client_base.Client_keys.sk_uri)
  (src_pk : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Operation_hash.t) :=
  let src_pkh := Signature.Public_key.hash src_pk in
  op_gtgteqquestion
    (Alpha_block_services.metadata cctxt (Some chain) (Some block) tt)
    (fun function_parameter =>
      let '{| protocol_data := {| level := {| level := level |} |} |} :=
        function_parameter in
      op_gtgteqquestion
        (Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
        (fun hash =>
          op_gtgteqquestion
            (inject_endorsement cctxt async chain block hash level src_sk
              src_pkh)
            (fun oph =>
              op_gtgteqquestion (Client_keys.get_key cctxt src_pkh)
                (fun function_parameter =>
                  let '(name, _pk, _sk) := function_parameter in
                  op_gtgteq
                    (lwt_log_notice
                      (fun f =>
                        op_minuspercent
                          (op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (op_minuspercent
                                  (op_minuspercent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Injected endorsement for block '" %
                                            string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              "' (level " % string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  ", contract " % string
                                                  (CamlinternalFormatBasics.String
                                                    CamlinternalFormatBasics.No_padding
                                                    (CamlinternalFormatBasics.String_literal
                                                      ") '" % string
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.Char_literal
                                                          "'" % char
                                                          CamlinternalFormatBasics.End_of_format)))))))))
                                        "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
                                          % string))
                                    (t event "injected_endorsement" % string))
                                  (a Block_hash.Logging.tag hash))
                                (a level_tag level))
                              (s Client_keys.Logging.tag name))
                            (t Signature.Public_key_hash.Logging.tag src_pkh))
                          (a Operation_hash.Logging.tag oph)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return oph))))).

.

Definition create_state
  (delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (delay : int64) : state :=
  {| delegates := delegates; delay := delay; pending := None |}.

Definition get_delegates {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (state : state)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_base__TzPervasives.Signature.Public_key_hash.Set.elt)) :=
  match delegates state with
  | [] =>
    op_gtgteqquestion (Client_keys.get_keys cctxt)
      (fun keys =>
        let delegates :=
          List.map
            (fun function_parameter =>
              let '(_, pkh, _, _) := function_parameter in
              pkh) keys in
        _return
          (OCaml.Stdlib.reverse_apply
            (OCaml.Stdlib.reverse_apply delegates of_list) elements))
  | (cons _ _) as delegates => _return delegates
  end.

Definition endorse_for_delegate {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q
                      i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (E * q * i * o)) *
                      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                        variant
                        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          * a) q i o) ->
                        (Tezos_shell_services.Shell_services.chain *
                          Tezos_shell_services.Shell_services.block) ->
                          a ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (F * a * q * i * o)) *
                        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                          variant
                          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            * a) * b) q i o) ->
                          (Tezos_shell_services.Shell_services.chain *
                            Tezos_shell_services.Shell_services.block) ->
                            a ->
                              b ->
                                q ->
                                  i ->
                                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                        o)) * (H * a * b * q * i * o)) *
                          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                            variant
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                              * a) * b) * c) q i o) ->
                            (Tezos_shell_services.Shell_services.chain *
                              Tezos_shell_services.Shell_services.block) ->
                              a ->
                                b ->
                                  c ->
                                    q ->
                                      i ->
                                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                            o)) * (J * a * b * c * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((Z -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        (Uri.t *
          (Tezos_shell_services.Shell_services.block *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (E * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q
                i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (F * a * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        q ->
                          i ->
                            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                o)) * (H * a * b * q * i * o)) *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                      a) * b) * c) q i o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      a ->
                        b ->
                          c ->
                            q ->
                              i ->
                                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                    o)) * (J * a * b * c * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((Z -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) * N)))))))))))))))))))))
  (block : Tezos_baking_alpha.Client_baking_blocks.block_info)
  (delegate_pkh : Tezos_client_base.Client_keys.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    Client_baking_blocks.hash := hash;
      Client_baking_blocks.chain_id := chain_id;
      Client_baking_blocks.level := level
      |} := block in
  op_gtgteqquestion (Client_keys.get_key cctxt delegate_pkh)
    (fun function_parameter =>
      let '(name, _pk, delegate_sk) := function_parameter in
      op_gtgteq
        (lwt_debug
          (fun f =>
            op_minuspercent
              (op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Endorsing " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " for " % string
                              (CamlinternalFormatBasics.String
                                CamlinternalFormatBasics.No_padding
                                (CamlinternalFormatBasics.String_literal
                                  " (level " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.String_literal
                                      ")!" % string
                                      CamlinternalFormatBasics.End_of_format)))))))
                        "Endorsing %a for %s (level %a)!" % string))
                    (t event "endorsing" % string))
                  (a Block_hash.Logging.tag hash))
                (s Client_keys.Logging.tag name)) (a level_tag level)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          let chain :=
            (* ❌ Variants not supported *)
            variant in
          let block :=
            (* ❌ Variants not supported *)
            variant in
          op_gtgteqquestion
            (inject_endorsement cctxt None chain block hash level delegate_sk
              delegate_pkh)
            (fun oph =>
              op_gtgteq
                (lwt_log_notice
                  (fun f =>
                    op_minuspercent
                      (op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Injected endorsement for block '" %
                                        string
                                      (CamlinternalFormatBasics.Alpha
                                        (CamlinternalFormatBasics.String_literal
                                          "' (level " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              ", contract " % string
                                              (CamlinternalFormatBasics.String
                                                CamlinternalFormatBasics.No_padding
                                                (CamlinternalFormatBasics.String_literal
                                                  ") '" % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "'" % char
                                                      CamlinternalFormatBasics.End_of_format)))))))))
                                    "Injected endorsement for block '%a' (level %a, contract %s) '%a'"
                                      % string))
                                (t event "injected_endorsement" % string))
                              (a Block_hash.Logging.tag hash))
                            (a level_tag level))
                          (s Client_keys.Logging.tag name))
                        (t Signature.Public_key_hash.Logging.tag delegate_pkh))
                      (a Operation_hash.Logging.tag oph)))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)))).

Definition allowed_to_endorse {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                Tezos_protocol_environment_alpha__Environment.RPC_context.t q i
                o) ->
                (variant * variant) ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (E * q * i * o)) *
                ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                  variant
                  Tezos_protocol_environment_alpha__Environment.RPC_context.t
                  (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                    a) q i o) ->
                  (variant * variant) ->
                    a ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (F * a * q * i * o)) *
                  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                    variant
                    Tezos_protocol_environment_alpha__Environment.RPC_context.t
                    ((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      * a) * b) q i o) ->
                    (variant * variant) ->
                      a ->
                        b ->
                          q ->
                            i ->
                              Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                  o)) * (H * a * b * q * i * o)) *
                    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                      variant
                      Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      (((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                        * a) * b) * c) q i o) ->
                      (variant * variant) ->
                        a ->
                          b ->
                            c ->
                              q ->
                                i ->
                                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                      o)) * (J * a * b * c * q * i * o)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) *
                        (Uri.t *
                          (Tezos_shell_services.Shell_services.block *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((Z -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (variant * variant) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (variant * variant) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (variant * variant) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (variant * variant) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((Z -> Lwt.t unit) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a unit) -> a) * (a)) * N)))))))))))))))))))))
  (bi : Tezos_baking_alpha.Client_baking_blocks.block_info)
  (delegate : Tezos_client_base.Client_keys.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
    (fun name =>
      op_gtgteq
        (lwt_debug
          (fun f =>
            op_minuspercent
              (op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Checking if allowed to endorse block " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " for " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              CamlinternalFormatBasics.End_of_format))))
                      "Checking if allowed to endorse block %a for %s" % string))
                  (t event "check_endorsement_ok" % string))
                (a Block_hash.Logging.tag (Client_baking_blocks.hash bi)))
              (s Client_keys.Logging.tag name)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          let chain :=
            (* ❌ Variants not supported *)
            variant in
          let block :=
            (* ❌ Variants not supported *)
            variant in
          let level := level bi in
          op_gtgteqquestion (get_signing_slots cctxt chain block delegate level)
            (fun function_parameter =>
              match function_parameter with
              | None | Some [] =>
                op_gtgteq
                  (lwt_debug
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "No slot found for " % string
                                  (CamlinternalFormatBasics.Alpha
                                    (CamlinternalFormatBasics.Char_literal
                                      "/" % char
                                      (CamlinternalFormatBasics.String
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.End_of_format))))
                                "No slot found for %a/%s" % string))
                            (t event "endorsement_no_slots_found" % string))
                          (a Block_hash.Logging.tag (hash bi)))
                        (s Client_keys.Logging.tag name)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_false)
              | Some ((cons _ _) as slots) =>
                op_gtgteq
                  (lwt_debug
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (op_minuspercent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Found slots for " % string
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Char_literal
                                        "/" % char
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          (CamlinternalFormatBasics.String_literal
                                            " (" % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                ")" % char
                                                CamlinternalFormatBasics.End_of_format)))))))
                                  "Found slots for %a/%s (%a)" % string))
                              (t event "endorsement_slots_found" % string))
                            (a Block_hash.Logging.tag (hash bi)))
                          (s Client_keys.Logging.tag name))
                        (a endorsement_slots_tag slots)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion
                      ((* ❌ Sending method message is not handled *)
                      send
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (Client_baking_files.resolve_location cctxt chain
                              (* ❌ Variants not supported *)
                              variant)
                            (fun endorsement_location =>
                              Client_baking_highwatermarks.may_inject_endorsement
                                cctxt endorsement_location delegate level)))
                      (fun function_parameter =>
                        match function_parameter with
                        | false =>
                          op_gtgteq
                            (lwt_debug
                              (fun f =>
                                op_minuspercent
                                  (op_minuspercent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Level " % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              " (or higher) previously endorsed: do not endorse."
                                                % string
                                              CamlinternalFormatBasics.End_of_format)))
                                        "Level %a (or higher) previously endorsed: do not endorse."
                                          % string))
                                    (t event "previously_endorsed" % string))
                                  (a level_tag level)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_false)
                        | true => return_true
                        end))
              end))).

Definition prepare_endorsement {D F H J L M N a b c i o p q : Type}
  (max_past : int64) (function_parameter : unit)
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((Z -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    state ->
      Tezos_baking_alpha.Client_baking_blocks.block_info ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let 'tt := function_parameter in
  fun cctxt =>
    fun state =>
      fun bi =>
        let past :=
          Time.Protocol.diff (Time.System.to_protocol (Systime_os.now tt))
            (Client_baking_blocks.timestamp bi) in
        if OCaml.Stdlib.gt past max_past then
          op_gtgteq
            (lwt_log_info
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Ignore block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              ": forged too far the past" % string
                              CamlinternalFormatBasics.End_of_format)))
                        "Ignore block %a: forged too far the past" % string))
                    (t event "endorsement_stale_block" % string))
                  (a Block_hash.Logging.tag (hash bi))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              return_unit)
        else
          op_gtgteq
            (lwt_log_info
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Received new block " % string
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format))
                        "Received new block %a" % string))
                    (t event "endorsement_got_block" % string))
                  (a Block_hash.Logging.tag (hash bi))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              let time :=
                Time.Protocol.add (Time.System.to_protocol (Systime_os.now tt))
                  (delay state) in
              op_gtgteqquestion (get_delegates cctxt state)
                (fun delegates =>
                  op_gtgteqquestion
                    (filter_p (allowed_to_endorse cctxt bi) delegates)
                    (fun delegates =>
                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                      let _ :=
                        (* ❌ Set record field not handled. *)
                        set_record_field state "pending" % string
                          (Some
                            {| time := time; delegates := delegates; block := bi
                              |}) in
                      return_unit))).

Definition compute_timeout (state : state)
  : Lwt.t
    (Tezos_baking_alpha.Client_baking_blocks.block_info *
      (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)) :=
  match pending state with
  | None => Lwt_utils.never_ending tt
  | Some {| time := time; delegates := delegates; block := block |} =>
    match Client_baking_scheduling.sleep_until time with
    | None => Lwt._return (block, delegates)
    | Some timeout =>
      let timespan :=
        let timespan :=
          Ptime.diff (Time.System.of_protocol_exn time) (Systime_os.now tt) in
        if OCaml.Stdlib.gt (Ptime.Span.compare timespan Ptime.Span.zero) 0 then
          timespan
        else
          Ptime.Span.zero in
      op_gtgteq
        (lwt_log_info
          (fun f =>
            op_minuspercent
              (op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Waiting until " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal " (" % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ") to inject endorsements" % string
                                CamlinternalFormatBasics.End_of_format)))))
                      "Waiting until %a (%a) to inject endorsements" % string))
                  (t event "wait_before_injecting" % string))
                (a timestamp_tag (Time.System.of_protocol_exn time)))
              (a timespan_tag timespan)))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq timeout
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt._return (block, delegates)))
    end
  end.

Definition create {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (op_staroptstar : option int64)
  : Z ->
    (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash) ->
      (Lwt_stream.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_baking_alpha.Client_baking_blocks.block_info)) ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let max_past :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int64 is converted to int *)
      110
    end in
  fun delay =>
    fun delegates =>
      fun block_stream =>
        let state_maker {O : Type} (function_parameter : O)
          : Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
          let '_ := function_parameter in
          let state := create_state delegates (Int64.of_int delay) in
          _return state in
        let timeout_k {O P Q R S T U : Type}
          (cctxt :
          ((option (Lwt_stream.t string)) *
            ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
              ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
                (((string ->
                  a ->
                    (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                      Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
                  (((string ->
                    a ->
                      (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                        Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                    ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                      * (a)) *
                      (Uri.t *
                        (Tezos_shell_services.Shell_services.block *
                          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                            variant
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            q i o) ->
                            (Tezos_shell_services.Shell_services.chain *
                              Tezos_shell_services.Shell_services.block) ->
                              q ->
                                i ->
                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                      o)) * (O * q * i * o)) *
                            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                              variant
                              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                              (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                * a) q i o) ->
                              (Tezos_shell_services.Shell_services.chain *
                                Tezos_shell_services.Shell_services.block) ->
                                a ->
                                  q ->
                                    i ->
                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                          o)) * (P * a * q * i * o)) *
                              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                variant
                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                  * a) * b) q i o) ->
                                (Tezos_shell_services.Shell_services.chain *
                                  Tezos_shell_services.Shell_services.block) ->
                                  a ->
                                    b ->
                                      q ->
                                        i ->
                                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                              o)) * (Q * a * b * q * i * o)) *
                                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                  variant
                                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                  (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                    * a) * b) * c) q i o) ->
                                  (Tezos_shell_services.Shell_services.chain *
                                    Tezos_shell_services.Shell_services.block)
                                    ->
                                    a ->
                                      b ->
                                        c ->
                                          q ->
                                            i ->
                                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                  o)) *
                                  (R * a * b * c * q * i * o)) *
                                  ((((Tezos_rpc.RPC_service.t variant unit p q i
                                    o) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              o)) * (S * p * q * i * o)) *
                                    ((((Tezos_rpc.RPC_service.t variant unit p q
                                      i o) ->
                                      (o -> unit) ->
                                        (unit -> unit) ->
                                          p ->
                                            q ->
                                              i ->
                                                Lwt.t
                                                  (Tezos_error_monad.Error_monad.tzresult
                                                    (unit -> unit))) *
                                      (T * p * q * i * o)) *
                                      (Tezos_shell_services.Shell_services.chain
                                        *
                                        ((option Z) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a b) -> a) * (a * b)) *
                                            ((Tezos_rpc.RPC_service.meth ->
                                              (option
                                                Tezos_data_encoding.Data_encoding.json)
                                                ->
                                                Uri.t ->
                                                  Lwt.t
                                                    (Tezos_rpc.RPC_context.rest_result
                                                      Tezos_data_encoding.Data_encoding.json
                                                      (option
                                                        Tezos_data_encoding.Data_encoding.json)))
                                              *
                                              (((string ->
                                                (Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((unit -> Ptime.t) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a
                                                      (Tezos_base__TzPervasives.tzresult
                                                        string)) -> a) * (a)) *
                                                      ((((Tezos_client_base.Client_context.lwt_format
                                                        a
                                                        (Tezos_base__TzPervasives.tzresult
                                                          Bigstring.t)) -> a) *
                                                        (a)) *
                                                        ((Z -> Lwt.t unit) *
                                                          ((((Tezos_client_base.Client_context.lwt_format
                                                            a unit) -> a) * (a))
                                                            * U)))))))))))))))))))))))))
            *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                    variant
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i
                    o) ->
                    (Tezos_shell_services.Shell_services.chain *
                      Tezos_shell_services.Shell_services.block) ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (O * q * i * o)) *
                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                      variant
                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t *
                        a) q i o) ->
                      (Tezos_shell_services.Shell_services.chain *
                        Tezos_shell_services.Shell_services.block) ->
                        a ->
                          q ->
                            i ->
                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                  o)) * (P * a * q * i * o)) *
                      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                        variant
                        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          * a) * b) q i o) ->
                        (Tezos_shell_services.Shell_services.chain *
                          Tezos_shell_services.Shell_services.block) ->
                          a ->
                            b ->
                              q ->
                                i ->
                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                      o)) * (Q * a * b * q * i * o)) *
                        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                          variant
                          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                            * a) * b) * c) q i o) ->
                          (Tezos_shell_services.Shell_services.chain *
                            Tezos_shell_services.Shell_services.block) ->
                            a ->
                              b ->
                                c ->
                                  q ->
                                    i ->
                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                          o)) * (R * a * b * c * q * i * o)) *
                          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult o))
                            * (S * p * q * i * o)) *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              (o -> unit) ->
                                (unit -> unit) ->
                                  p ->
                                    q ->
                                      i ->
                                        Lwt.t
                                          (Tezos_error_monad.Error_monad.tzresult
                                            (unit -> unit))) *
                              (T * p * q * i * o)) *
                              (Tezos_shell_services.Shell_services.chain *
                                ((option Z) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a b) -> a) * (a * b)) *
                                    ((Tezos_rpc.RPC_service.meth ->
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)
                                        ->
                                        Uri.t ->
                                          Lwt.t
                                            (Tezos_rpc.RPC_context.rest_result
                                              Tezos_data_encoding.Data_encoding.json
                                              (option
                                                Tezos_data_encoding.Data_encoding.json)))
                                      *
                                      (((string ->
                                        (Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((unit -> Ptime.t) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) -> a) * (a)) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  Bigstring.t)) -> a) * (a)) *
                                                ((Z -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) * U)))))))))))))))))))))
          (state : state) (function_parameter :
          Tezos_baking_alpha.Client_baking_blocks.block_info *
            (list Tezos_client_base.Client_keys.Public_key_hash.t))
          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
          let '(block, delegates) := function_parameter in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field state "pending" % string None in
          iter_s
            (fun delegate =>
              op_gtgteq (endorse_for_delegate cctxt block delegate)
                (fun function_parameter =>
                  match function_parameter with
                  | Stdlib.Ok tt => return_unit
                  | Stdlib.Error errs =>
                    op_gtgteq
                      (lwt_log_error
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.Formatting_gen
                                      (CamlinternalFormatBasics.Open_box
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "<v 2>" % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "<v 2>" % string))
                                      (CamlinternalFormatBasics.String_literal
                                        "Error while injecting endorsement for delegate "
                                          % string
                                        (CamlinternalFormatBasics.Alpha
                                          (CamlinternalFormatBasics.String_literal
                                            " : " % string
                                            (CamlinternalFormatBasics.Formatting_gen
                                              (CamlinternalFormatBasics.Open_box
                                                (CamlinternalFormatBasics.Format
                                                  CamlinternalFormatBasics.End_of_format
                                                  "" % string))
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    CamlinternalFormatBasics.Close_box
                                                    (CamlinternalFormatBasics.Formatting_lit
                                                      CamlinternalFormatBasics.Flush_newline
                                                      CamlinternalFormatBasics.End_of_format)))))))))
                                    "@[<v 2>Error while injecting endorsement for delegate %a : @[%a@]@]@."
                                      % string))
                                (t event "error_while_endorsing" % string))
                              (a Signature.Public_key_hash.Logging.tag delegate))
                            (a errs_tag errs)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)
                  end)) delegates in
        let event_k {O P Q R S T U : Type}
          (cctxt :
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (O * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i
              o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (P * a * q * i * o)) *
              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                  b) q i o) ->
                (Tezos_shell_services.Shell_services.chain *
                  Tezos_shell_services.Shell_services.block) ->
                  a ->
                    b ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (Q * a * b * q * i * o)) *
                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                  variant
                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                  (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a)
                    * b) * c) q i o) ->
                  (Tezos_shell_services.Shell_services.chain *
                    Tezos_shell_services.Shell_services.block) ->
                    a ->
                      b ->
                        c ->
                          q ->
                            i ->
                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                  o)) * (R * a * b * c * q * i * o)) *
                  ((((Tezos_client_base.Client_context.lwt_format a unit) -> a)
                    * (a)) *
                    (Uri.t *
                      (Tezos_shell_services.Shell_services.block *
                        ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                          * (S * p * q * i * o)) *
                          ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                            (o -> unit) ->
                              (unit -> unit) ->
                                p ->
                                  q ->
                                    i ->
                                      Lwt.t
                                        (Tezos_error_monad.Error_monad.tzresult
                                          (unit -> unit))) * (T * p * q * i * o))
                            *
                            (Tezos_shell_services.Shell_services.chain *
                              ((option Z) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a b) -> a) * (a * b)) *
                                  ((Tezos_rpc.RPC_service.meth ->
                                    (option
                                      Tezos_data_encoding.Data_encoding.json) ->
                                      Uri.t ->
                                        Lwt.t
                                          (Tezos_rpc.RPC_context.rest_result
                                            Tezos_data_encoding.Data_encoding.json
                                            (option
                                              Tezos_data_encoding.Data_encoding.json)))
                                    *
                                    (((string ->
                                      a ->
                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                          a) ->
                                          Lwt.t
                                            (Tezos_base__TzPervasives.tzresult a))
                                      * (a)) *
                                      ((option (Lwt_stream.t string)) *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((string ->
                                                    Lwt.t
                                                      (Tezos_base__TzPervasives.tzresult
                                                        string)) *
                                                    ((Z -> Lwt.t unit) *
                                                      ((((Tezos_client_base.Client_context.lwt_format
                                                        a unit) -> a) * (a)) *
                                                        ((((unit -> Lwt.t a) ->
                                                          Lwt.t a) * (a)) *
                                                          (((string ->
                                                            a ->
                                                              (Tezos_base__TzPervasives.Data_encoding.encoding
                                                                a) ->
                                                                Lwt.t
                                                                  (Tezos_base__TzPervasives.tzresult
                                                                    unit)) * (a))
                                                            * U)))))))))))))))))))))))))
            * U) (state : state) (bi :
          Tezos_baking_alpha.Client_baking_blocks.block_info)
          : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            (* ❌ Set record field not handled. *)
            set_record_field state "pending" % string None in
          prepare_endorsement max_past tt cctxt state bi in
        Client_baking_scheduling.main "endorser" % string cctxt block_stream
          state_maker (prepare_endorsement max_past tt) compute_timeout
          timeout_k event_k.

src/proto_alpha/lib_delegate/client_baking_files.ml 46 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type _ location = {filename : string; chain : Chain_services.chain}

let resolve_location (cctxt : #Client_context.full) ~chain (kind : 'a) :
    'a location tzresult Lwt.t =
  let basename =
    match kind with
    | `Block ->
        "block"
    | `Endorsement ->
        "endorsement"
    | `Nonce ->
        "nonce"
  in
  let test_filename chain_id =
    Format.kasprintf return "test_%a_%s" Chain_id.pp_short chain_id basename
  in
  ( match chain with
  | `Main ->
      return basename
  | `Test ->
      Chain_services.chain_id cctxt ~chain:`Test ()
      >>=? fun chain_id -> test_filename chain_id
  | `Hash chain_id ->
      Chain_services.chain_id cctxt ~chain:`Main ()
      >>=? fun main_chain_id ->
      if Chain_id.(chain_id = main_chain_id) then return basename
      else test_filename chain_id )
  >>=? fun filename -> return {filename; chain}

let filename {filename; _} = filename

let chain {chain; _} = chain
src/proto_alpha/lib_delegate/client_baking_files.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record location {_ : Type} := {
  filename : string;
  chain : Tezos_shell_services.Chain_services.chain }.
Arguments location : clear implicits.

Definition resolve_location {F G I a b i o p q : Type}
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) * I)))))))))))))))))))))
      * I) (chain : Tezos_shell_services.Chain_services.chain) (kind : variant)
  : Lwt.t (Tezos_base__TzPervasives.tzresult (location variant)) :=
  let basename :=
    match kind with
    | Block => "block" % string
    | Endorsement => "endorsement" % string
    | Nonce => "nonce" % string
    end in
  let test_filename (chain_id : Tezos_base__TzPervasives.Chain_id.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult string) :=
    Format.kasprintf _return
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "test_" % string
          (CamlinternalFormatBasics.Alpha
            (CamlinternalFormatBasics.Char_literal "_" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format)))) "test_%a_%s" % string)
      Chain_id.pp_short chain_id basename in
  op_gtgteqquestion
    match chain with
    | Main => _return basename
    | Test =>
      op_gtgteqquestion
        (Chain_services.chain_id cctxt
          (Some
            (* ❌ Variants not supported *)
            variant) tt) (fun chain_id => test_filename chain_id)
    | Hash chain_id =>
      op_gtgteqquestion
        (Chain_services.chain_id cctxt
          (Some
            (* ❌ Variants not supported *)
            variant) tt)
        (fun main_chain_id =>
          if op_eq chain_id main_chain_id then
            _return basename
          else
            test_filename chain_id)
    end (fun filename => _return {| filename := filename; chain := chain |}).

Definition filename {A : Type} (function_parameter : location A) : string :=
  let '{| filename := filename |} := function_parameter in
  filename.

Definition chain {A : Type} (function_parameter : location A)
  : Tezos_shell_services.Chain_services.chain :=
  let '{| chain := chain |} := function_parameter in
  chain.

src/proto_alpha/lib_delegate/client_baking_forge.ml 1402 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Protocol_client_context

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.forge"
end)

open Logging

(* Just proving a point *)
let[@warning "-32"] time_protocol__is__protocol_time :
    Alpha_context.Timestamp.t -> Time.Protocol.t =
 fun x -> x

(* The index of the different components of the protocol's validation passes *)
(* TODO: ideally, we would like this to be more abstract and possibly part of
   the protocol, while retaining the generality of lists *)
(* Hypothesis : we suppose [List.length Protocol.Main.validation_passes = 4] *)
let endorsements_index = 0

let votes_index = 1

let anonymous_index = 2

let managers_index = 3

let default_max_priority = 64

let default_minimal_fees =
  match Tez.of_mutez 100L with None -> assert false | Some t -> t

let default_minimal_nanotez_per_gas_unit = Z.of_int 100

let default_minimal_nanotez_per_byte = Z.of_int 1000

type slot =
  Time.Protocol.t * (Client_baking_blocks.block_info * int * public_key_hash)

type state = {
  context_path : string;
  mutable index : Context.index;
  (* Nonces file location *)
  nonces_location : [`Nonce] Client_baking_files.location;
  (* see [get_delegates] below to find delegates when the list is empty *)
  delegates : public_key_hash list;
  (* lazy-initialisation with retry-on-error *)
  constants : Constants.t;
  (* Minimal operation fee required to include an operation in a block *)
  minimal_fees : Tez.t;
  (* Minimal operation fee per gas required to include an operation in a block *)
  minimal_nanotez_per_gas_unit : Z.t;
  (* Minimal operation fee per byte required to include an operation in a block *)
  minimal_nanotez_per_byte : Z.t;
  (* truly mutable *)
  mutable best_slot : slot option;
}

let create_state ?(minimal_fees = default_minimal_fees)
    ?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit)
    ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) context_path
    index nonces_location delegates constants =
  {
    context_path;
    index;
    nonces_location;
    delegates;
    constants;
    minimal_fees;
    minimal_nanotez_per_gas_unit;
    minimal_nanotez_per_byte;
    best_slot = None;
  }

let get_delegates cctxt state =
  match state.delegates with
  | [] ->
      Client_keys.get_keys cctxt
      >>=? fun keys -> return (List.map (fun (_, pkh, _, _) -> pkh) keys)
  | _ ->
      return state.delegates

let generate_seed_nonce () =
  match Nonce.of_bytes (Rand.generate Constants.nonce_length) with
  | Error _errs ->
      assert false
  | Ok nonce ->
      nonce

let forge_block_header (cctxt : #Protocol_client_context.full) ~chain block
    delegate_sk shell priority seed_nonce_hash =
  Client_baking_pow.mine cctxt chain block shell (fun proof_of_work_nonce ->
      {Block_header.priority; seed_nonce_hash; proof_of_work_nonce})
  >>=? fun contents ->
  let unsigned_header =
    Data_encoding.Binary.to_bytes_exn
      Alpha_context.Block_header.unsigned_encoding
      (shell, contents)
  in
  Shell_services.Chain.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  Client_keys.append
    cctxt
    delegate_sk
    ~watermark:(Block_header chain_id)
    unsigned_header

let forge_faked_protocol_data ~priority ~seed_nonce_hash =
  Alpha_context.Block_header.
    {
      contents =
        {
          priority;
          seed_nonce_hash;
          proof_of_work_nonce = Client_baking_pow.empty_proof_of_work_nonce;
        };
      signature = Signature.zero;
    }

let assert_valid_operations_hash shell_header operations =
  let operations_hash =
    Operation_list_list_hash.compute
      (List.map
         Operation_list_hash.compute
         (List.map (List.map Tezos_base.Operation.hash) operations))
  in
  fail_unless
    (Operation_list_list_hash.equal
       operations_hash
       shell_header.Tezos_base.Block_header.operations_hash)
    (failure "Client_baking_forge.inject_block: inconsistent header.")

let compute_endorsing_power cctxt ~chain ~block operations =
  Shell_services.Chain.chain_id cctxt ~chain ()
  >>=? fun chain_id ->
  fold_left_s
    (fun sum -> function
      | { Alpha_context.protocol_data =
            Operation_data {contents = Single (Endorsement _); _};
          _ } as op ->
          Delegate_services.Endorsing_power.get
            cctxt
            (chain, block)
            op
            chain_id
          >>=? fun power -> return (sum + power) | _ -> return sum)
    0
    operations

let inject_block cctxt ?(force = false) ?seed_nonce_hash ~chain ~shell_header
    ~priority ~delegate_pkh ~delegate_sk ~level operations =
  assert_valid_operations_hash shell_header operations
  >>=? fun () ->
  let block = `Hash (shell_header.Tezos_base.Block_header.predecessor, 0) in
  forge_block_header
    cctxt
    ~chain
    block
    delegate_sk
    shell_header
    priority
    seed_nonce_hash
  >>=? fun signed_header ->
  (* Record baked blocks to prevent double baking  *)
  let open Client_baking_highwatermarks in
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Block
      >>=? fun block_location ->
      may_inject_block cctxt block_location ~delegate:delegate_pkh level
      >>=? function
      | true ->
          record_block cctxt block_location ~delegate:delegate_pkh level
          >>=? fun () -> return_true
      | false ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f "Level %a : previously baked"
                -% t event "double_bake_near_miss"
                -% a level_tag level)
          >>= fun () -> return force)
  >>=? function
  | false ->
      fail (Level_previously_baked level)
  | true ->
      Shell_services.Injection.block
        cctxt
        ~force
        ~chain
        signed_header
        operations
      >>=? fun block_hash ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Client_baking_forge.inject_block: inject %a"
            -% t event "inject_baked_block"
            -% a Block_hash.Logging.tag block_hash
            -% t signed_header_tag signed_header
            -% t operations_tag operations)
      >>= fun () -> return block_hash

type error += Failed_to_preapply of Tezos_base.Operation.t * error list

type error += Forking_test_chain

let () =
  register_error_kind
    `Permanent
    ~id:"Client_baking_forge.failed_to_preapply"
    ~title:"Fail to preapply an operation"
    ~description:""
    ~pp:(fun ppf (op, err) ->
      let h = Tezos_base.Operation.hash op in
      Format.fprintf
        ppf
        "@[Failed to preapply %a:@ @[<v 4>%a@]@]"
        Operation_hash.pp_short
        h
        pp_print_error
        err)
    Data_encoding.(
      obj2
        (req "operation" (dynamic_size Tezos_base.Operation.encoding))
        (req "error" RPC_error.encoding))
    (function Failed_to_preapply (hash, err) -> Some (hash, err) | _ -> None)
    (fun (hash, err) -> Failed_to_preapply (hash, err))

let get_manager_operation_gas_and_fee op =
  let {protocol_data = Operation_data {contents; _}; _} = op in
  let open Operation in
  let l = to_list (Contents_list contents) in
  fold_left_s
    (fun ((total_fee, total_gas) as acc) -> function
      | Contents (Manager_operation {fee; gas_limit; _}) ->
          (Lwt.return @@ Environment.wrap_error @@ Tez.(total_fee +? fee))
          >>=? fun total_fee -> return (total_fee, Z.add total_gas gas_limit)
      | _ -> return acc)
    (Tez.zero, Z.zero)
    l

(* Sort operation consisdering potential gas and storage usage.
   Weight = fee / (max ( (size/size_total), (gas/gas_total))) *)
let sort_manager_operations ~max_size ~hard_gas_limit_per_block ~minimal_fees
    ~minimal_nanotez_per_gas_unit ~minimal_nanotez_per_byte
    (operations : packed_operation list) =
  let compute_weight op (fee, gas) =
    let size = Data_encoding.Binary.length Operation.encoding op in
    let size_f = Q.of_int size in
    let gas_f = Q.of_bigint gas in
    let fee_f = Q.of_int64 (Tez.to_mutez fee) in
    let size_ratio = Q.(size_f / Q.of_int max_size) in
    let gas_ratio = Q.(gas_f / Q.of_bigint hard_gas_limit_per_block) in
    (size, gas, Q.(fee_f / max size_ratio gas_ratio))
  in
  filter_map_s
    (fun op ->
      get_manager_operation_gas_and_fee op
      >>=? fun (fee, gas) ->
      if Tez.(fee < minimal_fees) then return_none
      else
        let ((size, gas, _ratio) as weight) = compute_weight op (fee, gas) in
        let open Environment in
        let fees_in_nanotez =
          Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
        in
        let enough_fees_for_gas =
          let minimal_fees_in_nanotez =
            Z.mul minimal_nanotez_per_gas_unit gas
          in
          Z.compare minimal_fees_in_nanotez fees_in_nanotez <= 0
        in
        let enough_fees_for_size =
          let minimal_fees_in_nanotez =
            Z.mul minimal_nanotez_per_byte (Z.of_int size)
          in
          Z.compare minimal_fees_in_nanotez fees_in_nanotez <= 0
        in
        if enough_fees_for_size && enough_fees_for_gas then
          return_some (op, weight)
        else return_none)
    operations
  >>=? fun operations ->
  (* We sort by the biggest weight *)
  return
    (List.sort
       (fun (_, (_, _, w)) (_, (_, _, w')) -> Q.compare w' w)
       operations)

let retain_operations_up_to_quota operations quota =
  let {Tezos_protocol_environment.max_op; max_size} = quota in
  let operations =
    match max_op with Some n -> List.sub operations n | None -> operations
  in
  let exception Full of packed_operation list in
  let operations =
    try
      List.fold_left
        (fun (ops, size) op ->
          let operation_size =
            Data_encoding.Binary.length Alpha_context.Operation.encoding op
          in
          let new_size = size + operation_size in
          if new_size > max_size then raise (Full ops)
          else (op :: ops, new_size))
        ([], 0)
        operations
      |> fst
    with Full ops -> ops
  in
  List.rev operations

let trim_manager_operations ~max_size ~hard_gas_limit_per_block
    manager_operations =
  map_s
    (fun op ->
      get_manager_operation_gas_and_fee op
      >>=? fun (_fee, gas) ->
      let size = Data_encoding.Binary.length Operation.encoding op in
      return (op, (size, gas)))
    manager_operations
  >>=? fun manager_operations ->
  List.fold_left
    (fun (total_size, total_gas, (good_ops, bad_ops)) (op, (size, gas)) ->
      let new_size = total_size + size in
      let new_gas = Z.(total_gas + gas) in
      if new_size > max_size || Z.gt new_gas hard_gas_limit_per_block then
        (new_size, new_gas, (good_ops, op :: bad_ops))
      else (new_size, new_gas, (op :: good_ops, bad_ops)))
    (0, Z.zero, ([], []))
    manager_operations
  |> fun (_, _, (good_ops, bad_ops)) ->
  (* We keep the overflowing operations, it may be used for client-side validation *)
  return (List.rev good_ops, List.rev bad_ops)

(* We classify operations, sort managers operation by interest and add bad ones at the end *)
(* Hypothesis : we suppose that the received manager operations have a valid gas_limit *)

(** [classify_operations] classify the operation in 4 lists indexed as such :
    - 0 -> Endorsements
    - 1 -> Votes and proposals
    - 2 -> Anonymous operations
    - 3 -> High-priority manager operations.
    Returns two list :
    - A desired set of operations to be included
    - Potentially overflowing operations *)
let classify_operations (cctxt : #Protocol_client_context.full) ~chain ~block
    ~hard_gas_limit_per_block ~minimal_fees ~minimal_nanotez_per_gas_unit
    ~minimal_nanotez_per_byte (ops : packed_operation list) =
  Alpha_block_services.live_blocks cctxt ~chain ~block ()
  >>=? fun live_blocks ->
  (* Remove operations that are too old *)
  let ops =
    List.filter
      (fun {shell = {branch; _}; _} -> Block_hash.Set.mem branch live_blocks)
      ops
  in
  let validation_passes_len = List.length Main.validation_passes in
  let t = Array.make validation_passes_len [] in
  List.iter
    (fun (op : packed_operation) ->
      List.iter
        (fun pass -> t.(pass) <- op :: t.(pass))
        (Main.acceptable_passes op))
    ops ;
  let t = Array.map List.rev t in
  (* Retrieve the optimist maximum paying manager operations *)
  let manager_operations = t.(managers_index) in
  let {Environment.Updater.max_size; _} =
    List.nth Main.validation_passes managers_index
  in
  sort_manager_operations
    ~max_size
    ~hard_gas_limit_per_block
    ~minimal_fees
    ~minimal_nanotez_per_gas_unit
    ~minimal_nanotez_per_byte
    manager_operations
  >>=? fun ordered_operations ->
  (* Greedy heuristic *)
  trim_manager_operations
    ~max_size
    ~hard_gas_limit_per_block
    (List.map fst ordered_operations)
  >>=? fun (desired_manager_operations, overflowing_manager_operations) ->
  t.(managers_index) <- desired_manager_operations ;
  return (Array.to_list t, overflowing_manager_operations)

let forge (op : Operation.packed) : Operation.raw =
  {
    shell = op.shell;
    proto =
      Data_encoding.Binary.to_bytes_exn
        Alpha_context.Operation.protocol_data_encoding
        op.protocol_data;
  }

let ops_of_mempool (ops : Alpha_block_services.Mempool.t) =
  (* We only retain the applied, unprocessed and delayed operations *)
  List.rev
    ( Operation_hash.Map.fold (fun _ op acc -> op :: acc) ops.unprocessed
    @@ Operation_hash.Map.fold
         (fun _ (op, _) acc -> op :: acc)
         ops.branch_delayed
    @@ List.rev_map (fun (_, op) -> op) ops.applied )

let unopt_operations cctxt chain mempool = function
  | None -> (
    match mempool with
    | None ->
        Alpha_block_services.Mempool.pending_operations cctxt ~chain ()
        >>=? fun mpool ->
        let ops = ops_of_mempool mpool in
        return ops
    | Some file ->
        Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file
        >>=? fun json ->
        let mpool =
          Data_encoding.Json.destruct
            Alpha_block_services.S.Mempool.encoding
            json
        in
        let ops = ops_of_mempool mpool in
        return ops )
  | Some operations ->
      return operations

let all_ops_valid (results : error Preapply_result.t list) =
  let open Operation_hash.Map in
  List.for_all
    (fun (result : error Preapply_result.t) ->
      is_empty result.refused
      && is_empty result.branch_refused
      && is_empty result.branch_delayed)
    results

let decode_priority cctxt chain block ~priority ~endorsing_power =
  match priority with
  | `Set priority ->
      Alpha_services.Delegate.Minimal_valid_time.get
        cctxt
        (chain, block)
        priority
        endorsing_power
      >>=? fun minimal_timestamp -> return (priority, minimal_timestamp)
  | `Auto (src_pkh, max_priority) -> (
      Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
      >>=? fun {level; _} ->
      Alpha_services.Delegate.Baking_rights.get
        cctxt
        ?max_priority
        ~levels:[level]
        ~delegates:[src_pkh]
        (chain, block)
      >>=? fun possibilities ->
      try
        let {Alpha_services.Delegate.Baking_rights.priority = prio; _} =
          List.find
            (fun p -> p.Alpha_services.Delegate.Baking_rights.level = level)
            possibilities
        in
        Alpha_services.Delegate.Minimal_valid_time.get
          cctxt
          (chain, block)
          prio
          endorsing_power
        >>=? fun minimal_timestamp -> return (prio, minimal_timestamp)
      with Not_found ->
        failwith "No slot found at level %a" Raw_level.pp level )

let unopt_timestamp ?(force = false) timestamp minimal_timestamp =
  let timestamp =
    match timestamp with
    | None ->
        minimal_timestamp
    | Some timestamp ->
        timestamp
  in
  if (not force) && timestamp < minimal_timestamp then
    failwith
      "Proposed timestamp %a is earlier than minimal timestamp %a"
      Time.Protocol.pp_hum
      timestamp
      Time.Protocol.pp_hum
      minimal_timestamp
  else return timestamp

let merge_preapps (old : error Preapply_result.t)
    (neu : error Preapply_result.t) =
  let merge _ a b =
    (* merge ops *)
    match (a, b) with
    | (None, None) ->
        None
    | (Some x, None) ->
        Some x
    | (_, Some y) ->
        Some y
  in
  let merge = Operation_hash.Map.merge merge in
  (* merge op maps *)
  (* merge preapplies *)
  {
    Preapply_result.applied = [];
    refused = merge old.refused neu.refused;
    branch_refused = merge old.branch_refused neu.branch_refused;
    branch_delayed = merge old.branch_delayed neu.branch_delayed;
  }

let error_of_op (result : error Preapply_result.t) op =
  let op = forge op in
  let h = Tezos_base.Operation.hash op in
  try
    Some
      (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.refused))
  with Not_found -> (
    try
      Some
        (Failed_to_preapply
           (op, snd @@ Operation_hash.Map.find h result.branch_refused))
    with Not_found -> (
      try
        Some
          (Failed_to_preapply
             (op, snd @@ Operation_hash.Map.find h result.branch_delayed))
      with Not_found -> None ) )

let filter_and_apply_operations cctxt state ~chain ~block block_info ~priority
    ?protocol_data
    ((operations : packed_operation list list), overflowing_operations) =
  (* Retrieve the minimal valid time for when the block can be baked with 0 endorsements *)
  Delegate_services.Minimal_valid_time.get cctxt (chain, block) priority 0
  >>=? fun min_valid_timestamp ->
  let open Client_baking_simulator in
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "starting client-side validation after %a"
        -% t event "baking_local_validation_start"
        -% a Block_hash.Logging.tag block_info.Client_baking_blocks.hash)
  >>= fun () ->
  begin_construction
    ~timestamp:min_valid_timestamp
    ?protocol_data
    state.index
    block_info
  >>= (function
        | Ok inc ->
            return inc
        | Error errs ->
            lwt_log_error
              Tag.DSL.(
                fun f ->
                  f "Error while fetching current context : %a"
                  -% t event "context_fetch_error"
                  -% a errs_tag errs)
            >>= fun () ->
            lwt_log_notice
              Tag.DSL.(
                fun f ->
                  f "Retrying to open the context" -% t event "reopen_context")
            >>= fun () ->
            Client_baking_simulator.load_context
              ~context_path:state.context_path
            >>= fun index ->
            begin_construction
              ~timestamp:min_valid_timestamp
              ?protocol_data
              index
              block_info
            >>=? fun inc ->
            state.index <- index ;
            return inc)
  >>=? fun initial_inc ->
  let endorsements = List.nth operations endorsements_index in
  let votes = List.nth operations votes_index in
  let anonymous = List.nth operations anonymous_index in
  let managers = List.nth operations managers_index in
  let validate_operation inc op =
    add_operation inc op
    >>= function
    | Error errs ->
        lwt_debug
          Tag.DSL.(
            fun f ->
              f
                "@[<v 4>Client-side validation: invalid operation filtered %a@\n\
                 %a@]"
              -% t event "baking_rejected_invalid_operation"
              -% a Operation_hash.Logging.tag (Operation.hash_packed op)
              -% a errs_tag errs)
        >>= fun () -> Lwt.return_none
    | Ok (resulting_state, _receipt) ->
        Lwt.return_some resulting_state
  in
  let filter_valid_operations inc ops =
    Lwt_list.fold_left_s
      (fun (inc, acc) op ->
        validate_operation inc op
        >>= function
        | None ->
            Lwt.return (inc, acc)
        | Some inc' ->
            Lwt.return (inc', op :: acc))
      (inc, [])
      ops
  in
  (* First pass : we filter out invalid operations by applying them in the correct order *)
  filter_valid_operations initial_inc endorsements
  >>= fun (inc, endorsements) ->
  filter_valid_operations inc votes
  >>= fun (inc, votes) ->
  filter_valid_operations inc anonymous
  >>= fun (manager_inc, anonymous) ->
  (* Retrieve the correct index order *)
  let managers = List.sort Protocol.compare_operations managers in
  let overflowing_operations =
    List.sort Protocol.compare_operations overflowing_operations
  in
  filter_valid_operations manager_inc (managers @ overflowing_operations)
  >>= fun (inc, managers) ->
  finalize_construction inc
  >>=? fun _ ->
  let quota : Environment.Updater.quota list = Main.validation_passes in
  let {Constants.hard_gas_limit_per_block; _} = state.constants.parametric in
  let votes =
    retain_operations_up_to_quota (List.rev votes) (List.nth quota votes_index)
  in
  let anonymous =
    retain_operations_up_to_quota
      (List.rev anonymous)
      (List.nth quota anonymous_index)
  in
  trim_manager_operations
    ~max_size:(List.nth quota managers_index).max_size
    ~hard_gas_limit_per_block
    managers
  >>=? fun (accepted_managers, _overflowing_managers) ->
  (* Retrieve the correct index order *)
  let accepted_managers =
    List.sort Protocol.compare_operations accepted_managers
  in
  (* Second pass : make sure we only keep valid operations *)
  filter_valid_operations manager_inc accepted_managers
  >>= fun (_, accepted_managers) ->
  (* Put the operations back in order *)
  let operations =
    List.map List.rev [endorsements; votes; anonymous; accepted_managers]
  in
  (* Construct a context with the valid operations and a correct timestamp *)
  compute_endorsing_power cctxt ~chain ~block endorsements
  >>=? fun current_endorsing_power ->
  Delegate_services.Minimal_valid_time.get
    cctxt
    (chain, block)
    priority
    current_endorsing_power
  >>=? fun expected_validity ->
  (* Finally, we construct a block with the minimal possible timestamp
     given the endorsing power *)
  begin_construction
    ~timestamp:expected_validity
    ?protocol_data
    state.index
    block_info
  >>=? fun inc ->
  fold_left_s
    (fun inc op -> add_operation inc op >>=? fun (inc, _receipt) -> return inc)
    inc
    (List.flatten operations)
  >>=? fun final_inc ->
  finalize_construction final_inc
  >>=? fun (validation_result, metadata) ->
  return
    (final_inc, (validation_result, metadata), operations, expected_validity)

(* Build the block header : mimics node prevalidation *)
let finalize_block_header shell_header ~timestamp validation_result operations
    =
  let {Tezos_protocol_environment.context; fitness; message; _} =
    validation_result
  in
  let validation_passes = List.length Main.validation_passes in
  let operations_hash : Operation_list_list_hash.t =
    Operation_list_list_hash.compute
      (List.map
         (fun sl ->
           Operation_list_hash.compute (List.map Operation.hash_packed sl))
         operations)
  in
  let context = Shell_context.unwrap_disk_context context in
  Context.get_test_chain context
  >>= (function
        | Not_running ->
            return context
        | Running {expiration; _} ->
            if Time.Protocol.(expiration <= timestamp) then
              Context.set_test_chain context Not_running
              >>= fun context -> return context
            else return context
        | Forking _ ->
            fail Forking_test_chain)
  >>=? fun context ->
  let context = Context.hash ~time:timestamp ?message context in
  let header =
    Tezos_base.Block_header.
      {
        shell_header with
        level = Int32.succ shell_header.level;
        validation_passes;
        operations_hash;
        fitness;
        context;
      }
  in
  return header

let forge_block cctxt ?force ?operations ?(best_effort = operations = None)
    ?(sort = best_effort) ?(minimal_fees = default_minimal_fees)
    ?(minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit)
    ?(minimal_nanotez_per_byte = default_minimal_nanotez_per_byte) ?timestamp
    ?mempool ?context_path ?seed_nonce_hash ~chain ~priority ~delegate_pkh
    ~delegate_sk block =
  (* making the arguments usable *)
  unopt_operations cctxt chain mempool operations
  >>=? fun operations_arg ->
  compute_endorsing_power cctxt ~chain ~block operations_arg
  >>=? fun endorsing_power ->
  decode_priority cctxt chain block ~priority ~endorsing_power
  >>=? fun (priority, minimal_timestamp) ->
  unopt_timestamp ?force timestamp minimal_timestamp
  >>=? fun timestamp ->
  (* get basic building blocks *)
  let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun Constants.
             { parametric = {hard_gas_limit_per_block; endorsers_per_block; _};
               _ } ->
  classify_operations
    cctxt
    ~chain
    ~hard_gas_limit_per_block
    ~block
    ~minimal_fees
    ~minimal_nanotez_per_gas_unit
    ~minimal_nanotez_per_byte
    operations_arg
  >>=? fun (operations, overflowing_ops) ->
  (* Ensure that we retain operations up to the quota *)
  let quota : Environment.Updater.quota list = Main.validation_passes in
  let endorsements =
    List.sub (List.nth operations endorsements_index) endorsers_per_block
  in
  let votes =
    retain_operations_up_to_quota
      (List.nth operations votes_index)
      (List.nth quota votes_index)
  in
  let anonymous =
    retain_operations_up_to_quota
      (List.nth operations anonymous_index)
      (List.nth quota anonymous_index)
  in
  (* Size/Gas check already occured in classify operations *)
  let managers = List.nth operations managers_index in
  let operations = [endorsements; votes; anonymous; managers] in
  ( match context_path with
  | None ->
      Alpha_block_services.Helpers.Preapply.block
        cctxt
        ~chain
        ~block
        ~timestamp
        ~sort
        ~protocol_data
        operations
      >>=? fun (shell_header, result) ->
      let operations =
        List.map (fun l -> List.map snd l.Preapply_result.applied) result
      in
      (* everything went well (or we don't care about errors): GO! *)
      if best_effort || all_ops_valid result then
        return (shell_header, operations)
        (* some errors (and we care about them) *)
      else
        let result =
          List.fold_left merge_preapps Preapply_result.empty result
        in
        Lwt.return_error @@ List.filter_map (error_of_op result) operations_arg
  | Some context_path ->
      assert sort ;
      assert best_effort ;
      Context.init ~readonly:true context_path
      >>= fun index ->
      Client_baking_blocks.info cctxt ~chain block
      >>=? fun bi ->
      Alpha_services.Constants.all cctxt (chain, `Head 0)
      >>=? fun constants ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      let state =
        {
          context_path;
          index;
          nonces_location;
          constants;
          delegates = [];
          best_slot = None;
          minimal_fees = default_minimal_fees;
          minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
          minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
        }
      in
      filter_and_apply_operations
        cctxt
        state
        ~chain
        ~block
        ~priority
        ~protocol_data
        bi
        (operations, overflowing_ops)
      >>=? fun ( final_context,
                 (validation_result, _),
                 operations,
                 min_valid_timestamp ) ->
      let current_protocol = bi.next_protocol in
      let context =
        Shell_context.unwrap_disk_context validation_result.context
      in
      Context.get_protocol context
      >>= fun next_protocol ->
      if Protocol_hash.equal current_protocol next_protocol then
        finalize_block_header
          final_context.header
          ~timestamp:min_valid_timestamp
          validation_result
          operations
        >>= function
        | Error (Forking_test_chain :: _) ->
            Alpha_block_services.Helpers.Preapply.block
              cctxt
              ~chain
              ~block
              ~timestamp:min_valid_timestamp
              ~sort
              ~protocol_data
              operations
            >>=? fun (shell_header, _result) ->
            return (shell_header, List.map (List.map forge) operations)
        | Error _ as errs ->
            Lwt.return errs
        | Ok shell_header ->
            return (shell_header, List.map (List.map forge) operations)
      else
        lwt_log_notice
          Tag.DSL.(
            fun f ->
              f "New protocol detected: using shell validation"
              -% t event "shell_prevalidation_notice")
        >>= fun () ->
        Alpha_block_services.Helpers.Preapply.block
          cctxt
          ~chain
          ~block
          ~timestamp:min_valid_timestamp
          ~sort
          ~protocol_data
          operations
        >>=? fun (shell_header, _result) ->
        return (shell_header, List.map (List.map forge) operations) )
  >>=? fun (shell_header, operations) ->
  (* Now for some logging *)
  let total_op_count = List.length operations_arg in
  let valid_op_count = List.length (List.concat operations) in
  lwt_log_notice
    Tag.DSL.(
      fun f ->
        f
          "found %d valid operations (%d refused) for timestamp %a (fitness %a)"
        -% t event "found_valid_operations"
        -% s valid_ops valid_op_count
        -% s refused_ops (total_op_count - valid_op_count)
        -% a timestamp_tag (Time.System.of_protocol_exn timestamp)
        -% a fitness_tag shell_header.fitness)
  >>= fun () ->
  ( match Environment.wrap_error (Raw_level.of_int32 shell_header.level) with
  | Ok level ->
      return level
  | Error errs as err ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Error on raw_level conversion : %a"
            -% t event "block_injection_failed"
            -% a errs_tag errs)
      >>= fun () -> Lwt.return err )
  >>=? fun level ->
  inject_block
    cctxt
    ?force
    ~chain
    ~shell_header
    ~priority
    ?seed_nonce_hash
    ~delegate_pkh
    ~delegate_sk
    ~level
    operations
  >>= function
  | Ok hash ->
      return hash
  | Error errs as error ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f
              "@[<v 4>Error while injecting block@ @[Included operations : \
               %a@]@ %a@]"
            -% t event "block_injection_failed"
            -% a raw_operations_tag (List.concat operations)
            -% a errs_tag errs)
      >>= fun () -> Lwt.return error

let shell_prevalidation (cctxt : #Protocol_client_context.full) ~chain ~block
    ~timestamp seed_nonce_hash operations
    ((_, (bi, priority, delegate)) as _slot) =
  let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in
  Alpha_block_services.Helpers.Preapply.block
    cctxt
    ~chain
    ~block
    ~timestamp
    ~sort:true
    ~protocol_data
    operations
  >>= function
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f
              "Shell-side validation: error while prevalidating operations:@\n\
               %a"
            -% t event "built_invalid_block_error"
            -% a errs_tag errs)
      >>= fun () -> return_none
  | Ok (shell_header, operations) ->
      let raw_ops =
        List.map (fun l -> List.map snd l.Preapply_result.applied) operations
      in
      return_some
        (bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash)

let filter_outdated_endorsements expected_level ops =
  List.filter
    (function
      | { Alpha_context.protocol_data =
            Operation_data {contents = Single (Endorsement {level; _}); _};
          _ } ->
          Raw_level.equal expected_level level
      | _ ->
          true)
    ops

(** [fetch_operations] retrieve the operations present in the
    mempool. If no endorsements are present in the initial set, it
    waits until it's able to build a valid block. *)
let fetch_operations (cctxt : #Protocol_client_context.full) ~chain
    (_, (head, priority, _delegate)) =
  Alpha_block_services.Mempool.monitor_operations
    cctxt
    ~chain
    ~applied:true
    ~branch_delayed:true
    ~refused:false
    ~branch_refused:false
    ()
  >>=? fun (operation_stream, _stop) ->
  (* Hypothesis : the first call to the stream returns instantly, even if the mempool is empty. *)
  Lwt_stream.get operation_stream
  >>= function
  | None ->
      (* New head received : aborting block construction *)
      return_none
  | Some current_mempool ->
      let block = `Hash (head.Client_baking_blocks.hash, 0) in
      let operations =
        ref (filter_outdated_endorsements head.level current_mempool)
      in
      (* Actively request our peers' for missing operations *)
      Shell_services.Mempool.request_operations cctxt ~chain ()
      >>=? fun () ->
      let compute_minimal_valid_time () =
        compute_endorsing_power cctxt ~chain ~block !operations
        >>=? fun current_endorsing_power ->
        Delegate_services.Minimal_valid_time.get
          cctxt
          (chain, block)
          priority
          current_endorsing_power
      in
      let compute_timeout () =
        compute_minimal_valid_time ()
        >>=? fun expected_validity ->
        match Client_baking_scheduling.sleep_until expected_validity with
        | None ->
            return_unit
        | Some timeout ->
            timeout >>= fun () -> return_unit
      in
      let last_get_event = ref None in
      let get_event () =
        match !last_get_event with
        | None ->
            let t = Lwt_stream.get operation_stream in
            last_get_event := Some t ;
            t
        | Some t ->
            t
      in
      let rec loop () =
        Lwt.choose
          [ (compute_timeout () >|= fun _ -> `Timeout);
            (get_event () >|= fun e -> `Event e) ]
        >>= function
        | `Event (Some op_list) ->
            last_get_event := None ;
            let op_list = filter_outdated_endorsements head.level op_list in
            operations := op_list @ !operations ;
            loop ()
        | `Timeout ->
            (* Retrieve the remaining operations present in the stream
               before block construction *)
            let remaining_operations =
              filter_outdated_endorsements
                head.level
                (List.flatten (Lwt_stream.get_available operation_stream))
            in
            operations := remaining_operations @ !operations ;
            compute_minimal_valid_time ()
            >>=? fun expected_validity ->
            return_some (!operations, expected_validity)
        | `Event None ->
            (* Got new head while waiting:
               - not enough endorsements received ;
               - late at baking *)
            return_none
      in
      loop ()

(** Given a delegate baking slot [build_block] constructs a full block
    with consistent operations that went through the client-side
    validation *)
let build_block cctxt state seed_nonce_hash
    ((slot_timestamp, (bi, priority, delegate)) as slot) =
  let chain = `Hash bi.Client_baking_blocks.chain_id in
  let block = `Hash (bi.hash, 0) in
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, block)
  >>=? fun next_level ->
  let seed_nonce_hash =
    if next_level.Level.expected_commitment then Some seed_nonce_hash else None
  in
  Client_keys.Public_key_hash.name cctxt delegate
  >>=? fun name ->
  lwt_debug
    Tag.DSL.(
      fun f ->
        f "Try baking after %a (slot %d) for %s (%a)"
        -% t event "try_baking"
        -% a Block_hash.Logging.tag bi.hash
        -% s bake_priority_tag priority
        -% s Client_keys.Logging.tag name
        -% a timestamp_tag (Time.System.of_protocol_exn slot_timestamp))
  >>= fun () ->
  fetch_operations cctxt ~chain slot
  >>=? function
  | None ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f
              "Received a new head while waiting for operations. Aborting \
               this block."
            -% t event "new_head_received")
      >>= fun () -> return_none
  | Some (operations, timestamp) -> (
      let hard_gas_limit_per_block =
        state.constants.parametric.hard_gas_limit_per_block
      in
      classify_operations
        cctxt
        ~chain
        ~hard_gas_limit_per_block
        ~minimal_fees:state.minimal_fees
        ~minimal_nanotez_per_gas_unit:state.minimal_nanotez_per_gas_unit
        ~minimal_nanotez_per_byte:state.minimal_nanotez_per_byte
        ~block
        operations
      >>=? fun (operations, overflowing_ops) ->
      let next_version =
        match
          Tezos_base.Block_header.get_forced_protocol_upgrade
            ~level:(Raw_level.to_int32 next_level.Level.level)
        with
        | None ->
            bi.next_protocol
        | Some hash ->
            hash
      in
      if Protocol_hash.(Protocol.hash <> next_version) then
        (* Let the shell validate this *)
        shell_prevalidation
          cctxt
          ~chain
          ~block
          ~timestamp
          seed_nonce_hash
          operations
          slot
      else
        let protocol_data =
          forge_faked_protocol_data ~priority ~seed_nonce_hash
        in
        filter_and_apply_operations
          cctxt
          state
          ~chain
          ~block
          ~priority
          ~protocol_data
          bi
          (operations, overflowing_ops)
        >>= function
        | Error errs ->
            lwt_log_error
              Tag.DSL.(
                fun f ->
                  f
                    "Client-side validation: error while filtering invalid \
                     operations :@\n\
                     @[<v 4>%a@]"
                  -% t event "client_side_validation_error"
                  -% a errs_tag errs)
            >>= fun () ->
            lwt_log_notice
              Tag.DSL.(
                fun f ->
                  f "Building a block using shell validation"
                  -% t event "shell_prevalidation_notice")
            >>= fun () ->
            shell_prevalidation
              cctxt
              ~chain
              ~block
              ~timestamp
              seed_nonce_hash
              operations
              slot
        | Ok
            (final_context, (validation_result, _), operations, valid_timestamp)
          ->
            ( if
              Time.System.(Systime_os.now () < of_protocol_exn valid_timestamp)
            then
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "[%a] not ready to inject yet, waiting until %a"
                    -% a timestamp_tag (Systime_os.now ())
                    -% a
                         timestamp_tag
                         (Time.System.of_protocol_exn valid_timestamp)
                    -% t event "waiting_before_injection")
              >>= fun () ->
              match Client_baking_scheduling.sleep_until valid_timestamp with
              | None ->
                  Lwt.return_unit
              | Some timeout ->
                  timeout
            else Lwt.return_unit )
            >>= fun () ->
            lwt_debug
              Tag.DSL.(
                fun f ->
                  f
                    "Try forging locally the block header for %a (slot %d) \
                     for %s (%a)"
                  -% t event "try_forging"
                  -% a Block_hash.Logging.tag bi.hash
                  -% s bake_priority_tag priority
                  -% s Client_keys.Logging.tag name
                  -% a timestamp_tag (Time.System.of_protocol_exn timestamp))
            >>= fun () ->
            let current_protocol = bi.next_protocol in
            let context =
              Shell_context.unwrap_disk_context validation_result.context
            in
            Context.get_protocol context
            >>= fun next_protocol ->
            if Protocol_hash.equal current_protocol next_protocol then
              finalize_block_header
                final_context.header
                ~timestamp:valid_timestamp
                validation_result
                operations
              >>= function
              | Error (Forking_test_chain :: _) ->
                  shell_prevalidation
                    cctxt
                    ~chain
                    ~block
                    ~timestamp
                    seed_nonce_hash
                    operations
                    slot
              | Error _ as errs ->
                  Lwt.return errs
              | Ok shell_header ->
                  let raw_ops = List.map (List.map forge) operations in
                  return_some
                    ( bi,
                      priority,
                      shell_header,
                      raw_ops,
                      delegate,
                      seed_nonce_hash )
            else
              lwt_log_notice
                Tag.DSL.(
                  fun f ->
                    f "New protocol detected: using shell validation"
                    -% t event "shell_prevalidation_notice")
              >>= fun () ->
              shell_prevalidation
                cctxt
                ~chain
                ~block
                ~timestamp
                seed_nonce_hash
                operations
                slot )

(** [bake cctxt state] create a single block when woken up to do
    so. All the necessary information is available in the
    [state.best_slot]. *)
let bake (cctxt : #Protocol_client_context.full) ~chain state =
  ( match state.best_slot with
  | None ->
      assert false (* unreachable *)
  | Some slot ->
      return slot )
  >>=? fun slot ->
  let seed_nonce = generate_seed_nonce () in
  let seed_nonce_hash = Nonce.hash seed_nonce in
  build_block cctxt state seed_nonce_hash slot
  >>=? function
  | Some (head, priority, shell_header, operations, delegate, seed_nonce_hash)
    -> (
      let level = Raw_level.succ head.level in
      Client_keys.Public_key_hash.name cctxt delegate
      >>=? fun name ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Injecting block (priority %d, fitness %a) for %s after %a..."
            -% t event "start_injecting_block"
            -% s bake_priority_tag priority
            -% a fitness_tag shell_header.fitness
            -% s Client_keys.Logging.tag name
            -% a Block_hash.Logging.predecessor_tag shell_header.predecessor
            -% t Signature.Public_key_hash.Logging.tag delegate)
      >>= fun () ->
      Client_keys.get_key cctxt delegate
      >>=? fun (_, _, delegate_sk) ->
      inject_block
        cctxt
        ~chain
        ~force:false
        ~shell_header
        ~priority
        ?seed_nonce_hash
        ~delegate_pkh:delegate
        ~delegate_sk
        ~level
        operations
      >>= function
      | Error errs ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f
                  "@[<v 4>Error while injecting block@ @[Included operations \
                   : %a@]@ %a@]"
                -% t event "block_injection_failed"
                -% a raw_operations_tag (List.concat operations)
                -% a errs_tag errs)
          >>= fun () -> return_unit
      | Ok block_hash ->
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f
                  "Injected block %a for %s after %a (level %a, priority %d, \
                   fitness %a, operations %a)."
                -% t event "injected_block"
                -% a Block_hash.Logging.tag block_hash
                -% s Client_keys.Logging.tag name
                -% a Block_hash.Logging.tag shell_header.predecessor
                -% a level_tag level
                -% s bake_priority_tag priority
                -% a fitness_tag shell_header.fitness
                -% a operations_tag operations)
          >>= fun () ->
          ( if seed_nonce_hash <> None then
            cctxt#with_lock (fun () ->
                let open Client_baking_nonces in
                load cctxt state.nonces_location
                >>=? fun nonces ->
                let nonces = add nonces block_hash seed_nonce in
                save cctxt state.nonces_location nonces)
            |> trace_exn (Failure "Error while recording nonce")
          else return_unit )
          >>=? fun () -> return_unit )
  | None ->
      return_unit

(** [get_baking_slots] calls the node via RPC to retrieve the potential
    slots for the given delegates within a given range of priority *)
let get_baking_slots cctxt ?(max_priority = default_max_priority) new_head
    delegates =
  let chain = `Hash new_head.Client_baking_blocks.chain_id in
  let block = `Hash (new_head.hash, 0) in
  let level = Raw_level.succ new_head.level in
  Alpha_services.Delegate.Baking_rights.get
    cctxt
    ~max_priority
    ~levels:[level]
    ~delegates
    (chain, block)
  >>= function
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Error while fetching baking possibilities:\n%a"
            -% t event "baking_slot_fetch_errors"
            -% a errs_tag errs)
      >>= fun () -> Lwt.return_nil
  | Ok [] ->
      Lwt.return_nil
  | Ok slots ->
      let slots =
        List.filter_map
          (function
            | {Alpha_services.Delegate.Baking_rights.timestamp = None; _} ->
                None
            | {timestamp = Some timestamp; priority; delegate; _} ->
                Some (timestamp, (new_head, priority, delegate)))
          slots
      in
      Lwt.return slots

(** [compute_best_slot_on_current_level] retrieves, among the given
    delegates, the highest priority slot for the current level. Then,
    it registers this slot in the state so the timeout knows when to
    wake up. *)
let compute_best_slot_on_current_level ?max_priority
    (cctxt : #Protocol_client_context.full) state new_head =
  get_delegates cctxt state
  >>=? fun delegates ->
  let level = Raw_level.succ new_head.Client_baking_blocks.level in
  get_baking_slots cctxt ?max_priority new_head delegates
  >>= function
  | [] ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            let max_priority =
              Option.unopt ~default:default_max_priority max_priority
            in
            f "No slot found at level %a (max_priority = %d)"
            -% t event "no_slot_found" -% a level_tag level
            -% s bake_priority_tag max_priority)
      >>= fun () -> return_none
      (* No slot found *)
  | h :: t ->
      (* One or more slot found, fetching the best (lowest) priority.
         We do not suppose that the received slots are sorted. *)
      let ((timestamp, (_, priority, delegate)) as best_slot) =
        List.fold_left
          (fun ((_, (_, priority, _)) as acc) ((_, (_, priority', _)) as slot) ->
            if priority < priority' then acc else slot)
          h
          t
      in
      Client_keys.Public_key_hash.name cctxt delegate
      >>=? fun name ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f
              "New baking slot found (level %a, priority %d) at %a for %s \
               after %a."
            -% t event "have_baking_slot" -% a level_tag level
            -% s bake_priority_tag priority
            -% a timestamp_tag (Time.System.of_protocol_exn timestamp)
            -% s Client_keys.Logging.tag name
            -% a Block_hash.Logging.tag new_head.hash
            -% t Signature.Public_key_hash.Logging.tag delegate)
      >>= fun () ->
      (* Found at least a slot *)
      return_some best_slot

(** [reveal_potential_nonces] reveal registered nonces *)
let reveal_potential_nonces (cctxt : #Client_context.full) constants ~chain
    ~block =
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      Client_baking_nonces.load cctxt nonces_location
      >>= function
      | Error err ->
          lwt_log_error
            Tag.DSL.(
              fun f ->
                f "Cannot read nonces: %a" -% t event "read_nonce_fail"
                -% a errs_tag err)
          >>= fun () -> return_unit
      | Ok nonces -> (
          Client_baking_nonces.get_unrevealed_nonces
            cctxt
            nonces_location
            nonces
          >>= function
          | Error err ->
              lwt_log_error
                Tag.DSL.(
                  fun f ->
                    f "Cannot retrieve unrevealed nonces: %a"
                    -% t event "nonce_retrieval_fail"
                    -% a errs_tag err)
              >>= fun () -> return_unit
          | Ok [] ->
              return_unit
          | Ok nonces_to_reveal -> (
              Client_baking_revelation.inject_seed_nonce_revelation
                cctxt
                ~chain
                ~block
                nonces_to_reveal
              >>= function
              | Error err ->
                  lwt_log_error
                    Tag.DSL.(
                      fun f ->
                        f "Cannot inject nonces: %a"
                        -% t event "nonce_injection_fail"
                        -% a errs_tag err)
                  >>= fun () -> return_unit
              | Ok () ->
                  (* If some nonces are to be revealed it means:
                   - We entered a new cycle and we can clear old nonces ;
                   - A revelation was not included yet in the cycle beggining.
                   So, it is safe to only filter outdated_nonces there *)
                  Client_baking_nonces.filter_outdated_nonces
                    cctxt
                    ~constants
                    nonces_location
                    nonces
                  >>=? fun live_nonces ->
                  Client_baking_nonces.save cctxt nonces_location live_nonces
                  >>=? fun () -> return_unit ) ))

(** [create] starts the main loop of the baker. The loop monitors new blocks and
    starts individual baking operations when baking-slots are available to any of
    the [delegates] *)
let create (cctxt : #Protocol_client_context.full) ?minimal_fees
    ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority
    ~chain ~context_path delegates block_stream =
  let state_maker bi =
    Alpha_services.Constants.all cctxt (chain, `Head 0)
    >>=? fun constants ->
    Client_baking_simulator.load_context ~context_path
    >>= fun index ->
    Client_baking_simulator.check_context_consistency
      index
      bi.Client_baking_blocks.context
    >>=? fun () ->
    Client_baking_files.resolve_location cctxt ~chain `Nonce
    >>=? fun nonces_location ->
    let state =
      create_state
        ?minimal_fees
        ?minimal_nanotez_per_gas_unit
        ?minimal_nanotez_per_byte
        context_path
        index
        nonces_location
        delegates
        constants
    in
    return state
  in
  let event_k cctxt state new_head =
    reveal_potential_nonces
      cctxt
      state.constants
      ~chain
      ~block:(`Hash (new_head.Client_baking_blocks.hash, 0))
    >>= fun _ignore_nonce_err ->
    compute_best_slot_on_current_level ?max_priority cctxt state new_head
    >>=? fun slot ->
    state.best_slot <- slot ;
    return_unit
  in
  let compute_timeout state =
    match state.best_slot with
    | None ->
        (* No slot, just wait for new blocks which will give more info *)
        Lwt_utils.never_ending ()
    | Some (timestamp, _) -> (
      match Client_baking_scheduling.sleep_until timestamp with
      | None ->
          Lwt.return_unit
      | Some timeout ->
          timeout )
  in
  let timeout_k cctxt state () =
    bake cctxt ~chain state
    >>=? fun () ->
    (* Stopping the timeout and waiting for the next block *)
    state.best_slot <- None ;
    return_unit
  in
  Client_baking_scheduling.main
    ~name:"baker"
    ~cctxt
    ~stream:block_stream
    ~state_maker
    ~pre_loop:event_k
    ~compute_timeout
    ~timeout_k
    ~event_k
src/proto_alpha/lib_delegate/client_baking_forge.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Protocol_client_context.

(* ❌ Structure item `include` not handled. *)
include

Import Logging.

Definition time_protocol__is__protocol_time
  (x : Tezos_protocol_alpha.Protocol.Alpha_context.Timestamp.t)
  : Tezos_base__TzPervasives.Time.Protocol.t := x.

Definition endorsements_index : Z := 0.

Definition votes_index : Z := 1.

Definition anonymous_index : Z := 2.

Definition managers_index : Z := 3.

Definition default_max_priority : Z := 64.

Definition default_minimal_fees
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  match
    Tez.of_mutez
      (* ❌ Constant of type int64 is converted to int *)
      100 with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some t => t
  end.

Definition default_minimal_nanotez_per_gas_unit : Z.t := Z.of_int 100.

Definition default_minimal_nanotez_per_byte : Z.t := Z.of_int 1000.

Definition slot :=
  Tezos_base__TzPervasives.Time.Protocol.t *
    (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
      Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash).

Record state := {
  context_path : string;
  index : Tezos_storage.Context.index;
  nonces_location : Tezos_baking_alpha.Client_baking_files.location variant;
  delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
  constants : Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t;
  minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
  minimal_nanotez_per_gas_unit : Z.t;
  minimal_nanotez_per_byte : Z.t;
  best_slot : option slot }.

Definition create_state
  (op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : (option Z.t) ->
    (option Z.t) ->
      string ->
        Tezos_storage.Context.index ->
          (Tezos_baking_alpha.Client_baking_files.location variant) ->
            (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
              ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t -> state :=
  let minimal_fees :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => default_minimal_fees
    end in
  fun op_staroptstar =>
    let minimal_nanotez_per_gas_unit :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_minimal_nanotez_per_gas_unit
      end in
    fun op_staroptstar =>
      let minimal_nanotez_per_byte :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => default_minimal_nanotez_per_byte
        end in
      fun context_path =>
        fun index =>
          fun nonces_location =>
            fun delegates =>
              fun constants =>
                {| context_path := context_path; index := index;
                  nonces_location := nonces_location; delegates := delegates;
                  constants := constants; minimal_fees := minimal_fees;
                  minimal_nanotez_per_gas_unit := minimal_nanotez_per_gas_unit;
                  minimal_nanotez_per_byte := minimal_nanotez_per_byte;
                  best_slot := None |}.

Definition get_delegates {B a : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (state : state)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_client_base.Client_keys.Public_key_hash.t)) :=
  match delegates state with
  | [] =>
    op_gtgteqquestion (Client_keys.get_keys cctxt)
      (fun keys =>
        _return
          (List.map
            (fun function_parameter =>
              let '(_, pkh, _, _) := function_parameter in
              pkh) keys))
  | _ => _return (delegates state)
  end.

Definition generate_seed_nonce (function_parameter : unit)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  let 'tt := function_parameter in
  match Nonce.of_bytes (Rand.generate Constants.nonce_length) with
  | Stdlib.Error _errs =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Stdlib.Ok nonce => nonce
  end.

Definition forge_block_header {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (delegate_sk : Tezos_client_base.Client_keys.sk_uri)
  (shell : Tezos_base__TzPervasives.Block_header.shell_header) (priority : Z)
  (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Stdlib.Bytes.t) :=
  op_gtgteqquestion
    (Client_baking_pow.mine cctxt chain block shell
      (fun proof_of_work_nonce =>
        {| Block_header.priority := priority;
          Block_header.seed_nonce_hash := seed_nonce_hash;
          Block_header.proof_of_work_nonce := proof_of_work_nonce |}))
    (fun contents =>
      let unsigned_header :=
        Data_encoding.Binary.to_bytes_exn
          Alpha_context.Block_header.unsigned_encoding (shell, contents) in
      op_gtgteqquestion (Shell_services.Chain.chain_id cctxt (Some chain) tt)
        (fun chain_id =>
          Client_keys.append cctxt
            (Some (Tezos_base__TzPervasives.Signature.Block_header chain_id))
            delegate_sk unsigned_header)).

Definition forge_faked_protocol_data
  (priority : Z)
  (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.protocol_data :=
  {|
    contents :=
      {| priority := priority; seed_nonce_hash := seed_nonce_hash;
        proof_of_work_nonce := Client_baking_pow.empty_proof_of_work_nonce |};
    signature := Signature.zero |}.

Definition assert_valid_operations_hash
  (shell_header : Tezos_base.Block_header.shell_header)
  (operations : list (list Tezos_base.Operation.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let operations_hash :=
    Operation_list_list_hash.compute
      (List.map Operation_list_hash.compute
        (List.map (List.map Tezos_base.Operation.hash) operations)) in
  fail_unless
    (Operation_list_list_hash.equal operations_hash
      (Tezos_base.Block_header.operations_hash shell_header))
    (failure
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Client_baking_forge.inject_block: inconsistent header." % string
          CamlinternalFormatBasics.End_of_format)
        "Client_baking_forge.inject_block: inconsistent header." % string)).

Definition compute_endorsing_power {E F G I K M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.Chain.chain * F) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (G * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services.Shell_services.Chain.chain * F) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (I * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services.Shell_services.Chain.chain * F) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.Chain.chain * F) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N))))) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.Chain.chain * F) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (G * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services.Shell_services.Chain.chain * F) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (I * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services.Shell_services.Chain.chain * F) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.Chain.chain * F) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N)))))
  (chain : Tezos_shell_services.Shell_services.Chain.chain) (block : F)
  (operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
  op_gtgteqquestion (Shell_services.Chain.chain_id cctxt (Some chain) tt)
    (fun chain_id =>
      fold_left_s
        (fun sum =>
          fun function_parameter =>
            match function_parameter with
            |
              {|
                Alpha_context.protocol_data :=
                  Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
                    contents :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Single
                        (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
                          _)
                      |}
                  |} as op =>
              op_gtgteqquestion
                (Delegate_services.Endorsing_power.get cctxt (chain, block) op
                  chain_id) (fun power => _return (Z.add sum power))
            | _ => _return sum
            end) 0 operations).

Definition inject_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (op_staroptstar : option bool)
  : (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
    Tezos_shell_services.Shell_services.chain ->
      Tezos_base.Block_header.shell_header ->
        Z ->
          Tezos_base__TzPervasives.Signature.public_key_hash ->
            Tezos_client_base.Client_keys.sk_uri ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
                (list (list Tezos_base.Operation.t)) ->
                  Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      Tezos_base__TzPervasives.Block_hash.t) :=
  let force :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun seed_nonce_hash =>
    fun chain =>
      fun shell_header =>
        fun priority =>
          fun delegate_pkh =>
            fun delegate_sk =>
              fun level =>
                fun operations =>
                  op_gtgteqquestion
                    (assert_valid_operations_hash shell_header operations)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let block :=
                        (* ❌ Variants not supported *)
                        variant in
                      op_gtgteqquestion
                        (forge_block_header cctxt chain block delegate_sk
                          shell_header priority seed_nonce_hash)
                        (fun signed_header =>
                          op_gtgteqquestion
                            ((* ❌ Sending method message is not handled *)
                            send
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion
                                  (Client_baking_files.resolve_location cctxt
                                    chain
                                    (* ❌ Variants not supported *)
                                    variant)
                                  (fun block_location =>
                                    op_gtgteqquestion
                                      (may_inject_block cctxt block_location
                                        delegate_pkh level)
                                      (fun function_parameter =>
                                        match function_parameter with
                                        | true =>
                                          op_gtgteqquestion
                                            (record_block cctxt block_location
                                              delegate_pkh level)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              return_true)
                                        | false =>
                                          op_gtgteq
                                            (lwt_log_error
                                              (fun f =>
                                                op_minuspercent
                                                  (op_minuspercent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Level " % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.String_literal
                                                              " : previously baked"
                                                                % string
                                                              CamlinternalFormatBasics.End_of_format)))
                                                        "Level %a : previously baked"
                                                          % string))
                                                    (t event
                                                      "double_bake_near_miss" %
                                                        string))
                                                  (a level_tag level)))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              _return force)
                                        end))))
                            (fun function_parameter =>
                              match function_parameter with
                              | false =>
                                fail
                                  (Tezos_base__TzPervasives.Level_previously_baked
                                    level)
                              | true =>
                                op_gtgteqquestion
                                  (Shell_services.Injection.block cctxt None
                                    (Some force) (Some chain) signed_header
                                    operations)
                                  (fun block_hash =>
                                    op_gtgteq
                                      (lwt_log_info
                                        (fun f =>
                                          op_minuspercent
                                            (op_minuspercent
                                              (op_minuspercent
                                                (op_minuspercent
                                                  (f
                                                    (CamlinternalFormatBasics.Format
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Client_baking_forge.inject_block: inject "
                                                          % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          CamlinternalFormatBasics.End_of_format))
                                                      "Client_baking_forge.inject_block: inject %a"
                                                        % string))
                                                  (t event
                                                    "inject_baked_block" %
                                                      string))
                                                (a Block_hash.Logging.tag
                                                  block_hash))
                                              (t signed_header_tag signed_header))
                                            (t operations_tag operations)))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        _return block_hash))
                              end))).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition get_manager_operation_gas_and_fee
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)) :=
  let '{|
    protocol_data :=
      Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
        contents := contents |}
      |} := op in
  let l :=
    to_list (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents)
    in
  fold_left_s
    (fun function_parameter =>
      let '(total_fee, total_gas) as acc := function_parameter in
      fun function_parameter =>
        match function_parameter with
        |
          Tezos_protocol_alpha.Protocol.Alpha_context.Contents
            (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
              fee := fee; gas_limit := gas_limit |}) =>
          op_gtgteqquestion
            (apply Lwt._return
              (apply Environment.wrap_error (op_plusquestion total_fee fee)))
            (fun total_fee => _return (total_fee, (Z.add total_gas gas_limit)))
        | _ => _return acc
        end) (Tez.zero, Z.zero) l.

Definition sort_manager_operations
  (max_size : Z) (hard_gas_limit_per_block : Z.t)
  (minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (minimal_nanotez_per_gas_unit : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (minimal_nanotez_per_byte : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation *
          (Z * Tezos_protocol_alpha.Protocol.Environment.Z.t * Q.t)))) :=
  let compute_weight
    (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
    (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez * Z.t)
    : Z * Z.t * Q.t :=
    let '(fee, gas) := function_parameter in
    let size := Data_encoding.Binary.length Operation.encoding op in
    let size_f := Q.of_int size in
    let gas_f := Q.of_bigint gas in
    let fee_f := Q.of_int64 (Tez.to_mutez fee) in
    let size_ratio := op_div size_f (Q.of_int max_size) in
    let gas_ratio := op_div gas_f (Q.of_bigint hard_gas_limit_per_block) in
    (size, gas, (op_div fee_f (max size_ratio gas_ratio))) in
  op_gtgteqquestion
    (filter_map_s
      (fun op =>
        op_gtgteqquestion (get_manager_operation_gas_and_fee op)
          (fun function_parameter =>
            let '(fee, gas) := function_parameter in
            if op_lt fee minimal_fees then
              return_none
            else
              let '(size, gas, _ratio) as weight := compute_weight op (fee, gas)
                in
              let fees_in_nanotez :=
                Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000) in
              let enough_fees_for_gas :=
                let minimal_fees_in_nanotez :=
                  Z.mul minimal_nanotez_per_gas_unit gas in
                OCaml.Stdlib.le
                  (Z.compare minimal_fees_in_nanotez fees_in_nanotez) 0 in
              let enough_fees_for_size :=
                let minimal_fees_in_nanotez :=
                  Z.mul minimal_nanotez_per_byte (Z.of_int size) in
                OCaml.Stdlib.le
                  (Z.compare minimal_fees_in_nanotez fees_in_nanotez) 0 in
              if andb enough_fees_for_size enough_fees_for_gas then
                return_some (op, weight)
              else
                return_none)) operations)
    (fun operations =>
      _return
        (List.sort
          (fun function_parameter =>
            let '(_, (_, _, w)) := function_parameter in
            fun function_parameter =>
              let '(_, (_, _, w')) := function_parameter in
              Q.compare w' w) operations)).

Definition retain_operations_up_to_quota
  (operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  (quota : Tezos_protocol_environment.quota)
  : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation :=
  let '{|
    Tezos_protocol_environment.max_size := max_size;
      Tezos_protocol_environment.max_op := max_op
      |} := quota in
  let operations :=
    match max_op with
    | Some n => List.sub operations n
    | None => operations
    end in
  (* ❌ Let of exception is not handled *)
  let_exception.

Definition trim_manager_operations
  (max_size : Z) (hard_gas_limit_per_block : Z.t)
  (manager_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) *
        (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))) :=
  op_gtgteqquestion
    (map_s
      (fun op =>
        op_gtgteqquestion (get_manager_operation_gas_and_fee op)
          (fun function_parameter =>
            let '(_fee, gas) := function_parameter in
            let size := Data_encoding.Binary.length Operation.encoding op in
            _return (op, (size, gas)))) manager_operations)
    (fun manager_operations =>
      OCaml.Stdlib.reverse_apply
        (List.fold_left
          (fun function_parameter =>
            let '(total_size, total_gas, (good_ops, bad_ops)) :=
              function_parameter in
            fun function_parameter =>
              let '(op, (size, gas)) := function_parameter in
              let new_size := Z.add total_size size in
              let new_gas := op_plus total_gas gas in
              if
                orb (OCaml.Stdlib.gt new_size max_size)
                  (Z.gt new_gas hard_gas_limit_per_block) then
                (new_size, new_gas, (good_ops, (cons op bad_ops)))
              else
                (new_size, new_gas, ((cons op good_ops), bad_ops)))
          (0, Z.zero, ([], [])) manager_operations)
        (fun function_parameter =>
          let '(_, _, (good_ops, bad_ops)) := function_parameter in
          _return ((List.rev good_ops), (List.rev bad_ops)))).

Definition classify_operations {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  (hard_gas_limit_per_block : Z.t)
  (minimal_fees : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (minimal_nanotez_per_gas_unit : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (minimal_nanotez_per_byte : Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (ops : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((list (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))
        * (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))) :=
  op_gtgteqquestion
    (Alpha_block_services.live_blocks cctxt (Some chain) (Some block) tt)
    (fun live_blocks =>
      let ops :=
        List.filter
          (fun function_parameter =>
            let '{| shell := {| branch := branch |} |} := function_parameter in
            Block_hash.Set.mem branch live_blocks) ops in
      let validation_passes_len := List.length Main.validation_passes in
      let t := Array.make validation_passes_len [] in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        List.iter
          (fun op =>
            List.iter
              (fun pass => Array.set t pass (cons op (Array.get t pass)))
              (Main.acceptable_passes op)) ops in
      let t := Array.map List.rev t in
      let manager_operations := Array.get t managers_index in
      let '{| Environment.Updater.max_size := max_size |} :=
        List.nth Main.validation_passes managers_index in
      op_gtgteqquestion
        (sort_manager_operations max_size hard_gas_limit_per_block minimal_fees
          minimal_nanotez_per_gas_unit minimal_nanotez_per_byte
          manager_operations)
        (fun ordered_operations =>
          op_gtgteqquestion
            (trim_manager_operations max_size hard_gas_limit_per_block
              (List.map fst ordered_operations))
            (fun function_parameter =>
              let
                '(desired_manager_operations, overflowing_manager_operations) :=
                function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Array.set t managers_index desired_manager_operations in
              _return ((Array.to_list t), overflowing_manager_operations)))).

Definition forge
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw :=
  {| shell := shell op;
    proto :=
      Data_encoding.Binary.to_bytes_exn
        Alpha_context.Operation.protocol_data_encoding (protocol_data op) |}.

Definition ops_of_mempool
  (ops :
    Tezos_client_alpha.Protocol_client_context.Alpha_block_services.Mempool.t)
  : list Tezos_protocol_alpha.Protocol.operation :=
  List.rev
    (apply
      (Operation_hash.Map.fold
        (fun function_parameter =>
          let '_ := function_parameter in
          fun op => fun acc => cons op acc) (unprocessed ops))
      (apply
        (Operation_hash.Map.fold
          (fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '(op, _) := function_parameter in
              fun acc => cons op acc) (branch_delayed ops))
        (List.rev_map
          (fun function_parameter =>
            let '(_, op) := function_parameter in
            op) (applied ops)))).

Definition unopt_operations {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (chain : Tezos_shell_services__Block_services.chain) (mempool : option string)
  (function_parameter : option (list Tezos_protocol_alpha.Protocol.operation))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list Tezos_protocol_alpha.Protocol.operation)) :=
  match function_parameter with
  | None =>
    match mempool with
    | None =>
      op_gtgteqquestion
        (Alpha_block_services.Mempool.pending_operations cctxt (Some chain) tt)
        (fun mpool =>
          let ops := ops_of_mempool mpool in
          _return ops)
    | Some file =>
      op_gtgteqquestion (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file file)
        (fun json =>
          let mpool :=
            Data_encoding.Json.destruct Alpha_block_services.S.Mempool.encoding
              json in
          let ops := ops_of_mempool mpool in
          _return ops)
    end
  | Some operations => _return operations
  end.

Definition all_ops_valid
  (results :
    list
      (Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error))
  : bool :=
  List.for_all
    (fun result =>
      andb (is_empty (refused result))
        (andb (is_empty (branch_refused result))
          (is_empty (branch_delayed result)))) results.

Definition decode_priority {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E) (priority : variant)
  (endorsing_power : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Z * Tezos_protocol_environment_alpha__Environment.Time.t)) :=
  match priority with
  | Set priority =>
    op_gtgteqquestion
      (Alpha_services.Delegate.Minimal_valid_time.get cctxt (chain, block)
        priority endorsing_power)
      (fun minimal_timestamp => _return (priority, minimal_timestamp))
  | Auto (src_pkh, max_priority) =>
    op_gtgteqquestion
      (Alpha_services.Helpers.current_level cctxt
        (Some
          (* ❌ Constant of type int32 is converted to int *)
          1) (chain, block))
      (fun function_parameter =>
        let '{| level := level |} := function_parameter in
        op_gtgteqquestion
          (Alpha_services.Delegate.Baking_rights.get cctxt
            (Some (cons level [])) None (Some (cons src_pkh [])) None
            max_priority (chain, block))
          (fun possibilities =>
            (* ❌ Try-with are not handled *)
            try
              (let '{|
                Alpha_services.Delegate.Baking_rights.priority := prio |} :=
                List.find
                  (fun p =>
                    equiv_decb (Alpha_services.Delegate.Baking_rights.level p)
                      level) possibilities in
              op_gtgteqquestion
                (Alpha_services.Delegate.Minimal_valid_time.get cctxt
                  (chain, block) prio endorsing_power)
                (fun minimal_timestamp => _return (prio, minimal_timestamp)))))
  end.

Definition unopt_timestamp (op_staroptstar : option bool)
  : (option Tezos_base__TzPervasives.Time.Protocol.t) ->
    Tezos_base__TzPervasives.Time.Protocol.t ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult
          Tezos_base__TzPervasives.Time.Protocol.t) :=
  let force :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun timestamp =>
    fun minimal_timestamp =>
      let timestamp :=
        match timestamp with
        | None => minimal_timestamp
        | Some timestamp => timestamp
        end in
      if andb (negb force) (OCaml.Stdlib.lt timestamp minimal_timestamp) then
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Proposed timestamp " % string
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.String_literal
                  " is earlier than minimal timestamp " % string
                  (CamlinternalFormatBasics.Alpha
                    CamlinternalFormatBasics.End_of_format))))
            "Proposed timestamp %a is earlier than minimal timestamp %a" %
              string) Time.Protocol.pp_hum timestamp Time.Protocol.pp_hum
          minimal_timestamp
      else
        _return timestamp.

Definition merge_preapps
  (old :
    Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
  (neu :
    Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
  : Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error :=
  let merge {A B : Type} (function_parameter : A)
    : (option B) -> (option B) -> option B :=
    let '_ := function_parameter in
    fun a =>
      fun b =>
        match (a, b) with
        | (None, None) => None
        | (Some x, None) => Some x
        | (_, Some y) => Some y
        end in
  let merge := Operation_hash.Map.merge merge in
  {| Preapply_result.applied := [];
    Preapply_result.refused := merge (refused old) (refused neu);
    Preapply_result.branch_refused :=
      merge (branch_refused old) (branch_refused neu);
    Preapply_result.branch_delayed :=
      merge (branch_delayed old) (branch_delayed neu) |}.

Definition error_of_op
  (result :
    Tezos_base__TzPervasives.Preapply_result.t Tezos_base__TzPervasives.error)
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  : option Tezos_base__TzPervasives.error :=
  let op := forge op in
  let h := Tezos_base.Operation.hash op in
  (* ❌ Try-with are not handled *)
  try
    (Some
      (Tezos_base__TzPervasives.Failed_to_preapply op
        (apply snd (Operation_hash.Map.find h (refused result))))).

Definition filter_and_apply_operations {D E G I K M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.Chain.chain * D) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (Tezos_shell_services.Shell_services.Chain.chain * D) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (Tezos_shell_services.Shell_services.Chain.chain * D) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (Tezos_shell_services.Shell_services.Chain.chain * D) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) *
            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
              p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
              (M * p * q * i * o)) * N))))) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (M * p * q * i * o)) * N) *
      (Tezos_shell_services.Shell_services.Chain.chain * D)) (state : state)
  (chain : Tezos_shell_services.Shell_services.Chain.chain) (block : D)
  (block_info : Tezos_baking_alpha.Client_baking_blocks.block_info)
  (priority : Z)
  (protocol_data : option Tezos_protocol_alpha.Protocol.block_header_data)
  (function_parameter :
    (list (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)) *
      (list Tezos_protocol_alpha.Protocol.operation))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_baking_alpha.Client_baking_simulator.incremental *
        (Tezos_protocol_environment.validation_result *
          Tezos_protocol_alpha.Protocol.block_header_metadata) *
        (list
          (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) *
        Tezos_protocol_environment_alpha__Environment.Time.t)) :=
  let '(_ as operations, overflowing_operations) := function_parameter in
  op_gtgteqquestion
    (Delegate_services.Minimal_valid_time.get cctxt (chain, block) priority 0)
    (fun min_valid_timestamp =>
      op_gtgteq
        (lwt_debug
          (fun f =>
            op_minuspercent
              (op_minuspercent
                (f
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "starting client-side validation after " % string
                      (CamlinternalFormatBasics.Alpha
                        CamlinternalFormatBasics.End_of_format))
                    "starting client-side validation after %a" % string))
                (t event "baking_local_validation_start" % string))
              (a Block_hash.Logging.tag (Client_baking_blocks.hash block_info))))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (op_gtgteq
              (begin_construction min_valid_timestamp protocol_data
                (index state) block_info)
              (fun function_parameter =>
                match function_parameter with
                | Stdlib.Ok inc => _return inc
                | Stdlib.Error errs =>
                  op_gtgteq
                    (lwt_log_error
                      (fun f =>
                        op_minuspercent
                          (op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Error while fetching current context : " %
                                    string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Error while fetching current context : %a" %
                                  string))
                            (t event "context_fetch_error" % string))
                          (a errs_tag errs)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq
                        (lwt_log_notice
                          (fun f =>
                            op_minuspercent
                              (f
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Retrying to open the context" % string
                                    CamlinternalFormatBasics.End_of_format)
                                  "Retrying to open the context" % string))
                              (t event "reopen_context" % string)))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteq
                            (Client_baking_simulator.load_context
                              (context_path state))
                            (fun index =>
                              op_gtgteqquestion
                                (begin_construction min_valid_timestamp
                                  protocol_data index block_info)
                                (fun inc =>
                                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                                  let _ :=
                                    (* ❌ Set record field not handled. *)
                                    set_record_field state "index" % string
                                      index in
                                  _return inc))))
                end))
            (fun initial_inc =>
              let endorsements := List.nth operations endorsements_index in
              let votes := List.nth operations votes_index in
              let anonymous := List.nth operations anonymous_index in
              let managers := List.nth operations managers_index in
              let validate_operation
                (inc : Tezos_baking_alpha.Client_baking_simulator.incremental)
                (op :
                Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
                : Lwt.t
                  (option Tezos_baking_alpha.Client_baking_simulator.incremental) :=
                op_gtgteq (add_operation inc op)
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Error errs =>
                      op_gtgteq
                        (lwt_debug
                          (fun f =>
                            op_minuspercent
                              (op_minuspercent
                                (op_minuspercent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.Formatting_gen
                                        (CamlinternalFormatBasics.Open_box
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "<v 4>" % string
                                              CamlinternalFormatBasics.End_of_format)
                                            "<v 4>" % string))
                                        (CamlinternalFormatBasics.String_literal
                                          "Client-side validation: invalid operation filtered "
                                            % string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.Formatting_lit
                                              CamlinternalFormatBasics.Force_newline
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Close_box
                                                  CamlinternalFormatBasics.End_of_format))))))
                                      "@[<v 4>Client-side validation: invalid operation filtered %a@
%a@]"
                                        % string))
                                  (t event
                                    "baking_rejected_invalid_operation" % string))
                                (a Operation_hash.Logging.tag
                                  (Operation.hash_packed op))) (a errs_tag errs)))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          Lwt.return_none)
                    | Stdlib.Ok (resulting_state, _receipt) =>
                      Lwt.return_some resulting_state
                    end) in
              let filter_valid_operations
                (inc : Tezos_baking_alpha.Client_baking_simulator.incremental)
                (ops :
                list
                  Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
                : Lwt.t
                  (Tezos_baking_alpha.Client_baking_simulator.incremental *
                    (list
                      Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)) :=
                Lwt_list.fold_left_s
                  (fun function_parameter =>
                    let '(inc, acc) := function_parameter in
                    fun op =>
                      op_gtgteq (validate_operation inc op)
                        (fun function_parameter =>
                          match function_parameter with
                          | None => Lwt._return (inc, acc)
                          | Some inc' => Lwt._return (inc', (cons op acc))
                          end)) (inc, []) ops in
              op_gtgteq (filter_valid_operations initial_inc endorsements)
                (fun function_parameter =>
                  let '(inc, endorsements) := function_parameter in
                  op_gtgteq (filter_valid_operations inc votes)
                    (fun function_parameter =>
                      let '(inc, votes) := function_parameter in
                      op_gtgteq (filter_valid_operations inc anonymous)
                        (fun function_parameter =>
                          let '(manager_inc, anonymous) := function_parameter in
                          let managers :=
                            List.sort Protocol.compare_operations managers in
                          let overflowing_operations :=
                            List.sort Protocol.compare_operations
                              overflowing_operations in
                          op_gtgteq
                            (filter_valid_operations manager_inc
                              (OCaml.Stdlib.app managers overflowing_operations))
                            (fun function_parameter =>
                              let '(inc, managers) := function_parameter in
                              op_gtgteqquestion (finalize_construction inc)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  let quota := Main.validation_passes in
                                  let '{|
                                    Constants.hard_gas_limit_per_block := hard_gas_limit_per_block
                                      |} := parametric (constants state) in
                                  let votes :=
                                    retain_operations_up_to_quota
                                      (List.rev votes)
                                      (List.nth quota votes_index) in
                                  let anonymous :=
                                    retain_operations_up_to_quota
                                      (List.rev anonymous)
                                      (List.nth quota anonymous_index) in
                                  op_gtgteqquestion
                                    (trim_manager_operations
                                      (max_size (List.nth quota managers_index))
                                      hard_gas_limit_per_block managers)
                                    (fun function_parameter =>
                                      let
                                        '(accepted_managers,
                                          _overflowing_managers) :=
                                        function_parameter in
                                      let accepted_managers :=
                                        List.sort Protocol.compare_operations
                                          accepted_managers in
                                      op_gtgteq
                                        (filter_valid_operations manager_inc
                                          accepted_managers)
                                        (fun function_parameter =>
                                          let '(_, accepted_managers) :=
                                            function_parameter in
                                          let operations :=
                                            List.map List.rev
                                              (cons endorsements
                                                (cons votes
                                                  (cons anonymous
                                                    (cons accepted_managers []))))
                                            in
                                          op_gtgteqquestion
                                            (compute_endorsing_power cctxt chain
                                              block endorsements)
                                            (fun current_endorsing_power =>
                                              op_gtgteqquestion
                                                (Delegate_services.Minimal_valid_time.get
                                                  cctxt (chain, block) priority
                                                  current_endorsing_power)
                                                (fun expected_validity =>
                                                  op_gtgteqquestion
                                                    (begin_construction
                                                      expected_validity
                                                      protocol_data
                                                      (index state) block_info)
                                                    (fun inc =>
                                                      op_gtgteqquestion
                                                        (fold_left_s
                                                          (fun inc =>
                                                            fun op =>
                                                              op_gtgteqquestion
                                                                (add_operation
                                                                  inc op)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let
                                                                    '(inc,
                                                                      _receipt) :=
                                                                    function_parameter
                                                                    in
                                                                  _return inc))
                                                          inc
                                                          (List.flatten
                                                            operations))
                                                        (fun final_inc =>
                                                          op_gtgteqquestion
                                                            (finalize_construction
                                                              final_inc)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let
                                                                '(validation_result,
                                                                  metadata) :=
                                                                function_parameter
                                                                in
                                                              _return
                                                                (final_inc,
                                                                  (validation_result,
                                                                    metadata),
                                                                  operations,
                                                                  expected_validity)))))))))))))))).

Definition finalize_block_header
  (shell_header : Tezos_base.Block_header.shell_header)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (validation_result : Tezos_protocol_environment.validation_result)
  (operations :
    list (list Tezos_raw_protocol_alpha__Alpha_context.packed_operation))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base.Block_header.shell_header) :=
  let '{|
    Tezos_protocol_environment.context := context;
      Tezos_protocol_environment.fitness := fitness;
      Tezos_protocol_environment.message := message
      |} := validation_result in
  let validation_passes := List.length Main.validation_passes in
  let operations_hash :=
    Operation_list_list_hash.compute
      (List.map
        (fun sl =>
          Operation_list_hash.compute (List.map Operation.hash_packed sl))
        operations) in
  let context := Shell_context.unwrap_disk_context context in
  op_gtgteqquestion
    (op_gtgteq (Context.get_test_chain context)
      (fun function_parameter =>
        match function_parameter with
        | Tezos_base__TzPervasives.Test_chain_status.Not_running =>
          _return context
        |
          Tezos_base__TzPervasives.Test_chain_status.Running {|
            expiration := expiration |} =>
          if op_lteq expiration timestamp then
            op_gtgteq
              (Context.set_test_chain context
                Tezos_base__TzPervasives.Test_chain_status.Not_running)
              (fun context => _return context)
          else
            _return context
        | Tezos_base__TzPervasives.Test_chain_status.Forking _ =>
          fail Tezos_base__TzPervasives.Forking_test_chain
        end))
    (fun context =>
      let context := Context.hash timestamp message context in
      let header :=
        (* ❌ Record substitution not handled *)
        record_substitution in
      _return header).

Definition forge_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (force : option bool)
  (operations :
    option (list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation))
  (op_staroptstar : option bool)
  : (option bool) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
      (option Tezos_protocol_alpha.Protocol.Environment.Z.t) ->
        (option Tezos_protocol_alpha.Protocol.Environment.Z.t) ->
          (option Tezos_base__TzPervasives.Time.Protocol.t) ->
            (option string) ->
              (option string) ->
                (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
                  Tezos_shell_services__Block_services.chain ->
                    variant ->
                      Tezos_base__TzPervasives.Signature.public_key_hash ->
                        Tezos_client_base.Client_keys.sk_uri ->
                          Tezos_shell_services.Shell_services.block ->
                            Lwt.t
                              (Tezos_base__TzPervasives.tzresult
                                Tezos_base__TzPervasives.Block_hash.t) :=
  let best_effort :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => equiv_decb operations None
    end in
  fun op_staroptstar =>
    let sort :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => best_effort
      end in
    fun op_staroptstar =>
      let minimal_fees :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => default_minimal_fees
        end in
      fun op_staroptstar =>
        let minimal_nanotez_per_gas_unit :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => default_minimal_nanotez_per_gas_unit
          end in
        fun op_staroptstar =>
          let minimal_nanotez_per_byte :=
            match op_staroptstar with
            | Some op_starsthstar => op_starsthstar
            | None => default_minimal_nanotez_per_byte
            end in
          fun timestamp =>
            fun mempool =>
              fun context_path =>
                fun seed_nonce_hash =>
                  fun chain =>
                    fun priority =>
                      fun delegate_pkh =>
                        fun delegate_sk =>
                          fun block =>
                            op_gtgteqquestion
                              (unopt_operations cctxt chain mempool operations)
                              (fun operations_arg =>
                                op_gtgteqquestion
                                  (compute_endorsing_power cctxt chain block
                                    operations_arg)
                                  (fun endorsing_power =>
                                    op_gtgteqquestion
                                      (decode_priority cctxt chain block
                                        priority endorsing_power)
                                      (fun function_parameter =>
                                        let '(priority, minimal_timestamp) :=
                                          function_parameter in
                                        op_gtgteqquestion
                                          (unopt_timestamp force timestamp
                                            minimal_timestamp)
                                          (fun timestamp =>
                                            let protocol_data :=
                                              forge_faked_protocol_data priority
                                                seed_nonce_hash in
                                            op_gtgteqquestion
                                              (Alpha_services.Constants.all
                                                cctxt (chain, block))
                                              (fun function_parameter =>
                                                let '{|
                                                  parametric := {|
                                                    endorsers_per_block :=
                                                      endorsers_per_block;
                                                      hard_gas_limit_per_block
                                                        :=
                                                        hard_gas_limit_per_block
                                                      |}
                                                    |} := function_parameter in
                                                op_gtgteqquestion
                                                  (classify_operations cctxt
                                                    chain block
                                                    hard_gas_limit_per_block
                                                    minimal_fees
                                                    minimal_nanotez_per_gas_unit
                                                    minimal_nanotez_per_byte
                                                    operations_arg)
                                                  (fun function_parameter =>
                                                    let
                                                      '(operations,
                                                        overflowing_ops) :=
                                                      function_parameter in
                                                    let quota :=
                                                      Main.validation_passes in
                                                    let endorsements :=
                                                      List.sub
                                                        (List.nth operations
                                                          endorsements_index)
                                                        endorsers_per_block in
                                                    let votes :=
                                                      retain_operations_up_to_quota
                                                        (List.nth operations
                                                          votes_index)
                                                        (List.nth quota
                                                          votes_index) in
                                                    let anonymous :=
                                                      retain_operations_up_to_quota
                                                        (List.nth operations
                                                          anonymous_index)
                                                        (List.nth quota
                                                          anonymous_index) in
                                                    let managers :=
                                                      List.nth operations
                                                        managers_index in
                                                    let operations :=
                                                      cons endorsements
                                                        (cons votes
                                                          (cons anonymous
                                                            (cons managers [])))
                                                      in
                                                    op_gtgteqquestion
                                                      match context_path with
                                                      | None =>
                                                        op_gtgteqquestion
                                                          (Alpha_block_services.Helpers.Preapply.block
                                                            cctxt (Some chain)
                                                            (Some block)
                                                            (Some sort)
                                                            (Some timestamp)
                                                            protocol_data
                                                            operations)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let
                                                              '(shell_header,
                                                                result) :=
                                                              function_parameter
                                                              in
                                                            let operations :=
                                                              List.map
                                                                (fun l =>
                                                                  List.map snd
                                                                    (Preapply_result.applied
                                                                      l)) result
                                                              in
                                                            if
                                                              orb best_effort
                                                                (all_ops_valid
                                                                  result) then
                                                              _return
                                                                (shell_header,
                                                                  operations)
                                                            else
                                                              let result :=
                                                                List.fold_left
                                                                  merge_preapps
                                                                  Preapply_result.empty
                                                                  result in
                                                              apply
                                                                Lwt.return_error
                                                                (List.filter_map
                                                                  (error_of_op
                                                                    result)
                                                                  operations_arg))
                                                      | Some context_path =>
                                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                        let _ :=
                                                          (* ❌ Assert instruction is not handled. *)
                                                          assert sort in
                                                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                        let _ :=
                                                          (* ❌ Assert instruction is not handled. *)
                                                          assert best_effort in
                                                        op_gtgteq
                                                          (Context.init None
                                                            None (Some true)
                                                            context_path)
                                                          (fun index =>
                                                            op_gtgteqquestion
                                                              (Client_baking_blocks.info
                                                                cctxt
                                                                (Some chain)
                                                                block)
                                                              (fun bi =>
                                                                op_gtgteqquestion
                                                                  (Alpha_services.Constants.all
                                                                    cctxt
                                                                    (chain,
                                                                      (* ❌ Variants not supported *)
                                                                      variant))
                                                                  (fun constants
                                                                    =>
                                                                    op_gtgteqquestion
                                                                      (Client_baking_files.resolve_location
                                                                        cctxt
                                                                        chain
                                                                        (* ❌ Variants not supported *)
                                                                        variant)
                                                                      (fun
                                                                        nonces_location
                                                                        =>
                                                                        let
                                                                          state :=
                                                                          {|
                                                                            context_path :=
                                                                              context_path;
                                                                            index :=
                                                                              index;
                                                                            nonces_location :=
                                                                              nonces_location;
                                                                            delegates :=
                                                                              [];
                                                                            constants :=
                                                                              constants;
                                                                            minimal_fees :=
                                                                              default_minimal_fees;
                                                                            minimal_nanotez_per_gas_unit :=
                                                                              default_minimal_nanotez_per_gas_unit;
                                                                            minimal_nanotez_per_byte :=
                                                                              default_minimal_nanotez_per_byte;
                                                                            best_slot :=
                                                                              None
                                                                            |}
                                                                          in
                                                                        op_gtgteqquestion
                                                                          (filter_and_apply_operations
                                                                            cctxt
                                                                            state
                                                                            chain
                                                                            block
                                                                            bi
                                                                            priority
                                                                            (Some
                                                                              protocol_data)
                                                                            (operations,
                                                                              overflowing_ops))
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              '(final_context,
                                                                                (validation_result,
                                                                                  _),
                                                                                operations,
                                                                                min_valid_timestamp) :=
                                                                              function_parameter
                                                                              in
                                                                            let
                                                                              current_protocol :=
                                                                              next_protocol
                                                                                bi
                                                                              in
                                                                            let
                                                                              context :=
                                                                              Shell_context.unwrap_disk_context
                                                                                (context
                                                                                  validation_result)
                                                                              in
                                                                            op_gtgteq
                                                                              (Context.get_protocol
                                                                                context)
                                                                              (fun
                                                                                next_protocol
                                                                                =>
                                                                                if
                                                                                  Protocol_hash.equal
                                                                                    current_protocol
                                                                                    next_protocol
                                                                                  then
                                                                                  op_gtgteq
                                                                                    (finalize_block_header
                                                                                      (header
                                                                                        final_context)
                                                                                      min_valid_timestamp
                                                                                      validation_result
                                                                                      operations)
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      match
                                                                                        function_parameter
                                                                                        with
                                                                                      |
                                                                                        Stdlib.Error
                                                                                          (cons
                                                                                            Tezos_base__TzPervasives.Forking_test_chain
                                                                                            _)
                                                                                        =>
                                                                                        op_gtgteqquestion
                                                                                          (Alpha_block_services.Helpers.Preapply.block
                                                                                            cctxt
                                                                                            (Some
                                                                                              chain)
                                                                                            (Some
                                                                                              block)
                                                                                            (Some
                                                                                              sort)
                                                                                            (Some
                                                                                              min_valid_timestamp)
                                                                                            protocol_data
                                                                                            operations)
                                                                                          (fun
                                                                                            function_parameter
                                                                                            =>
                                                                                            let
                                                                                              '(shell_header,
                                                                                                _result) :=
                                                                                              function_parameter
                                                                                              in
                                                                                            _return
                                                                                              (shell_header,
                                                                                                (List.map
                                                                                                  (List.map
                                                                                                    forge)
                                                                                                  operations)))
                                                                                      |
                                                                                        (Stdlib.Error
                                                                                          _)
                                                                                          as
                                                                                          errs
                                                                                        =>
                                                                                        Lwt._return
                                                                                          errs
                                                                                      |
                                                                                        Stdlib.Ok
                                                                                          shell_header
                                                                                        =>
                                                                                        _return
                                                                                          (shell_header,
                                                                                            (List.map
                                                                                              (List.map
                                                                                                forge)
                                                                                              operations))
                                                                                      end)
                                                                                else
                                                                                  op_gtgteq
                                                                                    (lwt_log_notice
                                                                                      (fun
                                                                                        f
                                                                                        =>
                                                                                        op_minuspercent
                                                                                          (f
                                                                                            (CamlinternalFormatBasics.Format
                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                "New protocol detected: using shell validation"
                                                                                                  %
                                                                                                  string
                                                                                                CamlinternalFormatBasics.End_of_format)
                                                                                              "New protocol detected: using shell validation"
                                                                                                %
                                                                                                string))
                                                                                          (t
                                                                                            event
                                                                                            "shell_prevalidation_notice"
                                                                                              %
                                                                                              string)))
                                                                                    (fun
                                                                                      function_parameter
                                                                                      =>
                                                                                      let
                                                                                        'tt :=
                                                                                        function_parameter
                                                                                        in
                                                                                      op_gtgteqquestion
                                                                                        (Alpha_block_services.Helpers.Preapply.block
                                                                                          cctxt
                                                                                          (Some
                                                                                            chain)
                                                                                          (Some
                                                                                            block)
                                                                                          (Some
                                                                                            sort)
                                                                                          (Some
                                                                                            min_valid_timestamp)
                                                                                          protocol_data
                                                                                          operations)
                                                                                        (fun
                                                                                          function_parameter
                                                                                          =>
                                                                                          let
                                                                                            '(shell_header,
                                                                                              _result) :=
                                                                                            function_parameter
                                                                                            in
                                                                                          _return
                                                                                            (shell_header,
                                                                                              (List.map
                                                                                                (List.map
                                                                                                  forge)
                                                                                                operations))))))))))
                                                      end
                                                      (fun function_parameter =>
                                                        let
                                                          '(shell_header,
                                                            operations) :=
                                                          function_parameter in
                                                        let total_op_count :=
                                                          List.length
                                                            operations_arg in
                                                        let valid_op_count :=
                                                          List.length
                                                            (List.concat
                                                              operations) in
                                                        op_gtgteq
                                                          (lwt_log_notice
                                                            (fun f =>
                                                              op_minuspercent
                                                                (op_minuspercent
                                                                  (op_minuspercent
                                                                    (op_minuspercent
                                                                      (op_minuspercent
                                                                        (f
                                                                          (CamlinternalFormatBasics.Format
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              "found "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Int
                                                                                CamlinternalFormatBasics.Int_d
                                                                                CamlinternalFormatBasics.No_padding
                                                                                CamlinternalFormatBasics.No_precision
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  " valid operations ("
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Int
                                                                                    CamlinternalFormatBasics.Int_d
                                                                                    CamlinternalFormatBasics.No_padding
                                                                                    CamlinternalFormatBasics.No_precision
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      " refused) for timestamp "
                                                                                        %
                                                                                        string
                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          " (fitness "
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Alpha
                                                                                            (CamlinternalFormatBasics.Char_literal
                                                                                              ")"
                                                                                                %
                                                                                                char
                                                                                              CamlinternalFormatBasics.End_of_format)))))))))
                                                                            "found %d valid operations (%d refused) for timestamp %a (fitness %a)"
                                                                              %
                                                                              string))
                                                                        (t event
                                                                          "found_valid_operations"
                                                                            %
                                                                            string))
                                                                      (s
                                                                        valid_ops
                                                                        valid_op_count))
                                                                    (s
                                                                      refused_ops
                                                                      (Z.sub
                                                                        total_op_count
                                                                        valid_op_count)))
                                                                  (a
                                                                    timestamp_tag
                                                                    (Time.System.of_protocol_exn
                                                                      timestamp)))
                                                                (a fitness_tag
                                                                  (fitness
                                                                    shell_header))))
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let 'tt :=
                                                              function_parameter
                                                              in
                                                            op_gtgteqquestion
                                                              match
                                                                Environment.wrap_error
                                                                  (Raw_level.of_int32
                                                                    (level
                                                                      shell_header))
                                                                with
                                                              | Stdlib.Ok level
                                                                => _return level
                                                              |
                                                                (Stdlib.Error
                                                                  errs) as err
                                                                =>
                                                                op_gtgteq
                                                                  (lwt_log_error
                                                                    (fun f =>
                                                                      op_minuspercent
                                                                        (op_minuspercent
                                                                          (f
                                                                            (CamlinternalFormatBasics.Format
                                                                              (CamlinternalFormatBasics.String_literal
                                                                                "Error on raw_level conversion : "
                                                                                  %
                                                                                  string
                                                                                (CamlinternalFormatBasics.Alpha
                                                                                  CamlinternalFormatBasics.End_of_format))
                                                                              "Error on raw_level conversion : %a"
                                                                                %
                                                                                string))
                                                                          (t
                                                                            event
                                                                            "block_injection_failed"
                                                                              %
                                                                              string))
                                                                        (a
                                                                          errs_tag
                                                                          errs)))
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let 'tt :=
                                                                      function_parameter
                                                                      in
                                                                    Lwt._return
                                                                      err)
                                                              end
                                                              (fun level =>
                                                                op_gtgteq
                                                                  (inject_block
                                                                    cctxt force
                                                                    seed_nonce_hash
                                                                    chain
                                                                    shell_header
                                                                    priority
                                                                    delegate_pkh
                                                                    delegate_sk
                                                                    level
                                                                    operations)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      Stdlib.Ok
                                                                        hash =>
                                                                      _return
                                                                        hash
                                                                    |
                                                                      (Stdlib.Error
                                                                        errs) as
                                                                        error =>
                                                                      op_gtgteq
                                                                        (lwt_log_error
                                                                          (fun f
                                                                            =>
                                                                            op_minuspercent
                                                                              (op_minuspercent
                                                                                (op_minuspercent
                                                                                  (f
                                                                                    (CamlinternalFormatBasics.Format
                                                                                      (CamlinternalFormatBasics.Formatting_gen
                                                                                        (CamlinternalFormatBasics.Open_box
                                                                                          (CamlinternalFormatBasics.Format
                                                                                            (CamlinternalFormatBasics.String_literal
                                                                                              "<v 4>"
                                                                                                %
                                                                                                string
                                                                                              CamlinternalFormatBasics.End_of_format)
                                                                                            "<v 4>"
                                                                                              %
                                                                                              string))
                                                                                        (CamlinternalFormatBasics.String_literal
                                                                                          "Error while injecting block"
                                                                                            %
                                                                                            string
                                                                                          (CamlinternalFormatBasics.Formatting_lit
                                                                                            (CamlinternalFormatBasics.Break
                                                                                              "@ "
                                                                                                %
                                                                                                string
                                                                                              1
                                                                                              0)
                                                                                            (CamlinternalFormatBasics.Formatting_gen
                                                                                              (CamlinternalFormatBasics.Open_box
                                                                                                (CamlinternalFormatBasics.Format
                                                                                                  CamlinternalFormatBasics.End_of_format
                                                                                                  ""
                                                                                                    %
                                                                                                    string))
                                                                                              (CamlinternalFormatBasics.String_literal
                                                                                                "Included operations : "
                                                                                                  %
                                                                                                  string
                                                                                                (CamlinternalFormatBasics.Alpha
                                                                                                  (CamlinternalFormatBasics.Formatting_lit
                                                                                                    CamlinternalFormatBasics.Close_box
                                                                                                    (CamlinternalFormatBasics.Formatting_lit
                                                                                                      (CamlinternalFormatBasics.Break
                                                                                                        "@ "
                                                                                                          %
                                                                                                          string
                                                                                                        1
                                                                                                        0)
                                                                                                      (CamlinternalFormatBasics.Alpha
                                                                                                        (CamlinternalFormatBasics.Formatting_lit
                                                                                                          CamlinternalFormatBasics.Close_box
                                                                                                          CamlinternalFormatBasics.End_of_format))))))))))
                                                                                      "@[<v 4>Error while injecting block@ @[Included operations : %a@]@ %a@]"
                                                                                        %
                                                                                        string))
                                                                                  (t
                                                                                    event
                                                                                    "block_injection_failed"
                                                                                      %
                                                                                      string))
                                                                                (a
                                                                                  raw_operations_tag
                                                                                  (List.concat
                                                                                    operations)))
                                                                              (a
                                                                                errs_tag
                                                                                errs)))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          Lwt._return
                                                                            error)
                                                                    end)))))))))).

Definition shell_prevalidation {D F H J L M N O P Q a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  (timestamp : Tezos_base__TzPervasives.Time.Protocol.t)
  (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
  (operations : list (list Tezos_protocol_alpha.Protocol.operation))
  (function_parameter : O * (P * Z * Q))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (P * Z * Tezos_base__TzPervasives.Block_header.shell_header *
          (list (list Tezos_base.Operation.t)) * Q *
          (option Tezos_raw_protocol_alpha.Nonce_hash.t)))) :=
  let '(_, (bi, priority, delegate)) as _slot := function_parameter in
  let protocol_data := forge_faked_protocol_data priority seed_nonce_hash in
  op_gtgteq
    (Alpha_block_services.Helpers.Preapply.block cctxt (Some chain) (Some block)
      (Some true) (Some timestamp) protocol_data operations)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Error errs =>
        op_gtgteq
          (lwt_log_error
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Shell-side validation: error while prevalidating operations:"
                          % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)))
                      "Shell-side validation: error while prevalidating operations:@
%a"
                        % string))
                  (t event "built_invalid_block_error" % string))
                (a errs_tag errs)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_none)
      | Stdlib.Ok (shell_header, operations) =>
        let raw_ops :=
          List.map (fun l => List.map snd (Preapply_result.applied l))
            operations in
        return_some
          (bi, priority, shell_header, raw_ops, delegate, seed_nonce_hash)
      end).

Definition filter_outdated_endorsements
  (expected_level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (ops : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation :=
  List.filter
    (fun function_parameter =>
      match function_parameter with
      | {|
        Alpha_context.protocol_data :=
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
            contents :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Single
                (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
                  {|
                  level := level
                    |})
              |}
          |} => Raw_level.equal expected_level level
      | _ => true
      end) ops.

Definition fetch_operations {D F H J L M N O P a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (function_parameter :
    O * (Tezos_baking_alpha.Client_baking_blocks.block_info * Z * P))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        ((list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) *
          Tezos_protocol_environment_alpha__Environment.Time.t))) :=
  let '(_, (head, priority, _delegate)) := function_parameter in
  op_gtgteqquestion
    (Alpha_block_services.Mempool.monitor_operations cctxt (Some chain)
      (Some true) (Some true) (Some false) (Some false) tt)
    (fun function_parameter =>
      let '(operation_stream, _stop) := function_parameter in
      op_gtgteq (Lwt_stream.get operation_stream)
        (fun function_parameter =>
          match function_parameter with
          | None => return_none
          | Some current_mempool =>
            let block :=
              (* ❌ Variants not supported *)
              variant in
            let operations :=
              Stdlib.ref
                (filter_outdated_endorsements (level head) current_mempool) in
            op_gtgteqquestion
              (Shell_services.Mempool.request_operations cctxt (Some chain) tt)
              (fun function_parameter =>
                let 'tt := function_parameter in
                let compute_minimal_valid_time (function_parameter : unit)
                  : Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      Tezos_protocol_environment_alpha__Environment.Time.t) :=
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (compute_endorsing_power cctxt chain block
                      (Stdlib.op_exclamation operations))
                    (fun current_endorsing_power =>
                      Delegate_services.Minimal_valid_time.get cctxt
                        (chain, block) priority current_endorsing_power) in
                let compute_timeout (function_parameter : unit)
                  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                  let 'tt := function_parameter in
                  op_gtgteqquestion (compute_minimal_valid_time tt)
                    (fun expected_validity =>
                      match
                        Client_baking_scheduling.sleep_until expected_validity
                        with
                      | None => return_unit
                      | Some timeout =>
                        op_gtgteq timeout
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            return_unit)
                      end) in
                let last_get_event := Stdlib.ref None in
                let get_event (function_parameter : unit)
                  : Lwt.t
                    (option (list Tezos_protocol_alpha.Protocol.operation)) :=
                  let 'tt := function_parameter in
                  match Stdlib.op_exclamation last_get_event with
                  | None =>
                    let t := Lwt_stream.get operation_stream in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Stdlib.op_coloneq last_get_event (Some t) in
                    t
                  | Some t => t
                  end in
                let fix loop (function_parameter : unit)
                  : Lwt.t
                    (Tezos_base__TzPervasives.tzresult
                      (option
                        ((list
                          Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
                          * Tezos_protocol_environment_alpha__Environment.Time.t))) :=
                  let 'tt := function_parameter in
                  op_gtgteq
                    (Lwt.choose
                      (cons
                        (op_gtpipeeq (compute_timeout tt)
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            (* ❌ Variants not supported *)
                            variant))
                        (cons
                          (op_gtpipeeq (get_event tt)
                            (fun e =>
                              (* ❌ Variants not supported *)
                              variant)) [])))
                    (fun function_parameter =>
                      match function_parameter with
                      | Event (Some op_list) =>
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ := Stdlib.op_coloneq last_get_event None in
                        let op_list :=
                          filter_outdated_endorsements (level head) op_list in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          Stdlib.op_coloneq operations
                            (OCaml.Stdlib.app op_list
                              (Stdlib.op_exclamation operations)) in
                        loop tt
                      | Timeout =>
                        let remaining_operations :=
                          filter_outdated_endorsements (level head)
                            (List.flatten
                              (Lwt_stream.get_available operation_stream)) in
                        (* ❌ Sequences of instructions are not handled (operator ";") *)
                        let _ :=
                          Stdlib.op_coloneq operations
                            (OCaml.Stdlib.app remaining_operations
                              (Stdlib.op_exclamation operations)) in
                        op_gtgteqquestion (compute_minimal_valid_time tt)
                          (fun expected_validity =>
                            return_some
                              ((Stdlib.op_exclamation operations),
                                expected_validity))
                      | Event None => return_none
                      end) in
                loop tt)
          end)).

Definition build_block {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                Tezos_protocol_environment_alpha__Environment.RPC_context.t q i
                o) ->
                (variant * variant) ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (E * q * i * o)) *
                ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                  variant
                  Tezos_protocol_environment_alpha__Environment.RPC_context.t
                  (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                    a) q i o) ->
                  (variant * variant) ->
                    a ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (F * a * q * i * o)) *
                  ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                    variant
                    Tezos_protocol_environment_alpha__Environment.RPC_context.t
                    ((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      * a) * b) q i o) ->
                    (variant * variant) ->
                      a ->
                        b ->
                          q ->
                            i ->
                              Tezos_protocol_environment_alpha__Environment.Lwt.t
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                  o)) * (H * a * b * q * i * o)) *
                    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                      variant
                      Tezos_protocol_environment_alpha__Environment.RPC_context.t
                      (((Tezos_protocol_environment_alpha__Environment.RPC_context.t
                        * a) * b) * c) q i o) ->
                      (variant * variant) ->
                        a ->
                          b ->
                            c ->
                              q ->
                                i ->
                                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                      o)) * (J * a * b * c * q * i * o)) *
                      ((((Tezos_client_base.Client_context.lwt_format a unit) ->
                        a) * (a)) *
                        (Uri.t *
                          (Tezos_shell_services.Shell_services.block *
                            ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult o))
                              * (L * p * q * i * o)) *
                              ((((Tezos_rpc.RPC_service.t variant unit p q i o)
                                ->
                                (o -> unit) ->
                                  (unit -> unit) ->
                                    p ->
                                      q ->
                                        i ->
                                          Lwt.t
                                            (Tezos_error_monad.Error_monad.tzresult
                                              (unit -> unit))) *
                                (M * p * q * i * o)) *
                                (Tezos_shell_services.Shell_services.chain *
                                  ((option Z) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a b) -> a) * (a * b)) *
                                      ((Tezos_rpc.RPC_service.meth ->
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)
                                          ->
                                          Uri.t ->
                                            Lwt.t
                                              (Tezos_rpc.RPC_context.rest_result
                                                Tezos_data_encoding.Data_encoding.json
                                                (option
                                                  Tezos_data_encoding.Data_encoding.json)))
                                        *
                                        (((string ->
                                          (Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a unit) -> a) * (a)) *
                                            ((unit -> Ptime.t) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) -> a) * (a)) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a
                                                  (Tezos_base__TzPervasives.tzresult
                                                    Bigstring.t)) -> a) * (a)) *
                                                  ((Z -> Lwt.t unit) *
                                                    ((((Tezos_client_base.Client_context.lwt_format
                                                      a unit) -> a) * (a)) * N)))))))))))))))))))))))))
      *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) *
                ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                  (a)) *
                  (Uri.t *
                    (Tezos_shell_services.Shell_services.block *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                        * (L * p * q * i * o)) *
                        ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                          (o -> unit) ->
                            (unit -> unit) ->
                              p ->
                                q ->
                                  i ->
                                    Lwt.t
                                      (Tezos_error_monad.Error_monad.tzresult
                                        (unit -> unit))) * (M * p * q * i * o))
                          *
                          (Tezos_shell_services.Shell_services.chain *
                            ((option Z) *
                              ((((Tezos_client_base.Client_context.lwt_format a
                                b) -> a) * (a * b)) *
                                ((Tezos_rpc.RPC_service.meth ->
                                  (option Tezos_data_encoding.Data_encoding.json)
                                    ->
                                    Uri.t ->
                                      Lwt.t
                                        (Tezos_rpc.RPC_context.rest_result
                                          Tezos_data_encoding.Data_encoding.json
                                          (option
                                            Tezos_data_encoding.Data_encoding.json)))
                                  *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((Z -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) * N)))))))))))))))))))))
      * (variant * variant)) (state : state)
  (seed_nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t)
  (function_parameter :
    Tezos_base__Time.Protocol.t *
      (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
        Tezos_client_base.Client_keys.Public_key_hash.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
          Tezos_base__TzPervasives.Block_header.shell_header *
          (list (list Tezos_base.Operation.t)) *
          Tezos_client_base.Client_keys.Public_key_hash.t *
          (option Tezos_raw_protocol_alpha.Nonce_hash.t)))) :=
  let '(slot_timestamp, (bi, priority, delegate)) as slot := function_parameter
    in
  let chain :=
    (* ❌ Variants not supported *)
    variant in
  let block :=
    (* ❌ Variants not supported *)
    variant in
  op_gtgteqquestion
    (Alpha_services.Helpers.current_level cctxt
      (Some
        (* ❌ Constant of type int32 is converted to int *)
        1) (chain, block))
    (fun next_level =>
      let seed_nonce_hash :=
        if Level.expected_commitment next_level then
          Some seed_nonce_hash
        else
          None in
      op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
        (fun name =>
          op_gtgteq
            (lwt_debug
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (op_minuspercent
                      (op_minuspercent
                        (op_minuspercent
                          (f
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Try baking after " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.String_literal
                                    " (slot " % string
                                    (CamlinternalFormatBasics.Int
                                      CamlinternalFormatBasics.Int_d
                                      CamlinternalFormatBasics.No_padding
                                      CamlinternalFormatBasics.No_precision
                                      (CamlinternalFormatBasics.String_literal
                                        ") for " % string
                                        (CamlinternalFormatBasics.String
                                          CamlinternalFormatBasics.No_padding
                                          (CamlinternalFormatBasics.String_literal
                                            " (" % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Char_literal
                                                ")" % char
                                                CamlinternalFormatBasics.End_of_format)))))))))
                              "Try baking after %a (slot %d) for %s (%a)" %
                                string)) (t event "try_baking" % string))
                        (a Block_hash.Logging.tag (hash bi)))
                      (s bake_priority_tag priority))
                    (s Client_keys.Logging.tag name))
                  (a timestamp_tag (Time.System.of_protocol_exn slot_timestamp))))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (fetch_operations cctxt chain slot)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    op_gtgteq
                      (lwt_log_notice
                        (fun f =>
                          op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Received a new head while waiting for operations. Aborting this block."
                                    % string
                                  CamlinternalFormatBasics.End_of_format)
                                "Received a new head while waiting for operations. Aborting this block."
                                  % string))
                            (t event "new_head_received" % string)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_none)
                  | Some (operations, timestamp) =>
                    let hard_gas_limit_per_block :=
                      hard_gas_limit_per_block (parametric (constants state)) in
                    op_gtgteqquestion
                      (classify_operations cctxt chain block
                        hard_gas_limit_per_block (minimal_fees state)
                        (minimal_nanotez_per_gas_unit state)
                        (minimal_nanotez_per_byte state) operations)
                      (fun function_parameter =>
                        let '(operations, overflowing_ops) := function_parameter
                          in
                        let next_version :=
                          match
                            Tezos_base.Block_header.get_forced_protocol_upgrade
                              (Raw_level.to_int32 (Level.level next_level)) with
                          | None => next_protocol bi
                          | Some hash => hash
                          end in
                        if op_ltgt Protocol.hash next_version then
                          shell_prevalidation cctxt chain block timestamp
                            seed_nonce_hash operations slot
                        else
                          let protocol_data :=
                            forge_faked_protocol_data priority seed_nonce_hash
                            in
                          op_gtgteq
                            (filter_and_apply_operations cctxt state chain block
                              bi priority (Some protocol_data)
                              (operations, overflowing_ops))
                            (fun function_parameter =>
                              match function_parameter with
                              | Stdlib.Error errs =>
                                op_gtgteq
                                  (lwt_log_error
                                    (fun f =>
                                      op_minuspercent
                                        (op_minuspercent
                                          (f
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.String_literal
                                                "Client-side validation: error while filtering invalid operations :"
                                                  % string
                                                (CamlinternalFormatBasics.Formatting_lit
                                                  CamlinternalFormatBasics.Force_newline
                                                  (CamlinternalFormatBasics.Formatting_gen
                                                    (CamlinternalFormatBasics.Open_box
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "<v 4>" % string
                                                          CamlinternalFormatBasics.End_of_format)
                                                        "<v 4>" % string))
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.Formatting_lit
                                                        CamlinternalFormatBasics.Close_box
                                                        CamlinternalFormatBasics.End_of_format)))))
                                              "Client-side validation: error while filtering invalid operations :@
@[<v 4>%a@]"
                                                % string))
                                          (t event
                                            "client_side_validation_error" %
                                              string)) (a errs_tag errs)))
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      (lwt_log_notice
                                        (fun f =>
                                          op_minuspercent
                                            (f
                                              (CamlinternalFormatBasics.Format
                                                (CamlinternalFormatBasics.String_literal
                                                  "Building a block using shell validation"
                                                    % string
                                                  CamlinternalFormatBasics.End_of_format)
                                                "Building a block using shell validation"
                                                  % string))
                                            (t event
                                              "shell_prevalidation_notice" %
                                                string)))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        shell_prevalidation cctxt chain block
                                          timestamp seed_nonce_hash operations
                                          slot))
                              |
                                Stdlib.Ok
                                  (final_context, (validation_result, _),
                                    operations, valid_timestamp) =>
                                op_gtgteq
                                  (if
                                    op_lt (Systime_os.now tt)
                                      (of_protocol_exn valid_timestamp) then
                                    op_gtgteq
                                      (lwt_log_notice
                                        (fun f =>
                                          op_minuspercent
                                            (op_minuspercent
                                              (op_minuspercent
                                                (f
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.Char_literal
                                                      "[" % char
                                                      (CamlinternalFormatBasics.Alpha
                                                        (CamlinternalFormatBasics.String_literal
                                                          "] not ready to inject yet, waiting until "
                                                            % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            CamlinternalFormatBasics.End_of_format))))
                                                    "[%a] not ready to inject yet, waiting until %a"
                                                      % string))
                                                (a timestamp_tag
                                                  (Systime_os.now tt)))
                                              (a timestamp_tag
                                                (Time.System.of_protocol_exn
                                                  valid_timestamp)))
                                            (t event
                                              "waiting_before_injection" %
                                                string)))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        match
                                          Client_baking_scheduling.sleep_until
                                            valid_timestamp with
                                        | None => Lwt.return_unit
                                        | Some timeout => timeout
                                        end)
                                  else
                                    Lwt.return_unit)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      (lwt_debug
                                        (fun f =>
                                          op_minuspercent
                                            (op_minuspercent
                                              (op_minuspercent
                                                (op_minuspercent
                                                  (op_minuspercent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Try forging locally the block header for "
                                                            % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.String_literal
                                                              " (slot " % string
                                                              (CamlinternalFormatBasics.Int
                                                                CamlinternalFormatBasics.Int_d
                                                                CamlinternalFormatBasics.No_padding
                                                                CamlinternalFormatBasics.No_precision
                                                                (CamlinternalFormatBasics.String_literal
                                                                  ") for " %
                                                                    string
                                                                  (CamlinternalFormatBasics.String
                                                                    CamlinternalFormatBasics.No_padding
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      " (" %
                                                                        string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.Char_literal
                                                                          ")" %
                                                                            char
                                                                          CamlinternalFormatBasics.End_of_format)))))))))
                                                        "Try forging locally the block header for %a (slot %d) for %s (%a)"
                                                          % string))
                                                    (t event
                                                      "try_forging" % string))
                                                  (a Block_hash.Logging.tag
                                                    (hash bi)))
                                                (s bake_priority_tag priority))
                                              (s Client_keys.Logging.tag name))
                                            (a timestamp_tag
                                              (Time.System.of_protocol_exn
                                                timestamp))))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        let current_protocol := next_protocol bi
                                          in
                                        let context :=
                                          Shell_context.unwrap_disk_context
                                            (context validation_result) in
                                        op_gtgteq (Context.get_protocol context)
                                          (fun next_protocol =>
                                            if
                                              Protocol_hash.equal
                                                current_protocol next_protocol
                                              then
                                              op_gtgteq
                                                (finalize_block_header
                                                  (header final_context)
                                                  valid_timestamp
                                                  validation_result operations)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  |
                                                    Stdlib.Error
                                                      (cons
                                                        Tezos_base__TzPervasives.Forking_test_chain
                                                        _) =>
                                                    shell_prevalidation cctxt
                                                      chain block timestamp
                                                      seed_nonce_hash operations
                                                      slot
                                                  | (Stdlib.Error _) as errs =>
                                                    Lwt._return errs
                                                  | Stdlib.Ok shell_header =>
                                                    let raw_ops :=
                                                      List.map (List.map forge)
                                                        operations in
                                                    return_some
                                                      (bi, priority,
                                                        shell_header, raw_ops,
                                                        delegate,
                                                        seed_nonce_hash)
                                                  end)
                                            else
                                              op_gtgteq
                                                (lwt_log_notice
                                                  (fun f =>
                                                    op_minuspercent
                                                      (f
                                                        (CamlinternalFormatBasics.Format
                                                          (CamlinternalFormatBasics.String_literal
                                                            "New protocol detected: using shell validation"
                                                              % string
                                                            CamlinternalFormatBasics.End_of_format)
                                                          "New protocol detected: using shell validation"
                                                            % string))
                                                      (t event
                                                        "shell_prevalidation_notice"
                                                          % string)))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  shell_prevalidation cctxt
                                                    chain block timestamp
                                                    seed_nonce_hash operations
                                                    slot))))
                              end))
                  end)))).

Definition bake {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Shell_services.chain) (state : state)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    match best_slot state with
    | None =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Some slot => _return slot
    end
    (fun slot =>
      let seed_nonce := generate_seed_nonce tt in
      let seed_nonce_hash := Nonce.hash seed_nonce in
      op_gtgteqquestion (build_block cctxt state seed_nonce_hash slot)
        (fun function_parameter =>
          match function_parameter with
          |
            Some
              (head, priority, shell_header, operations, delegate,
                seed_nonce_hash) =>
            let level := Raw_level.succ (level head) in
            op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
              (fun name =>
                op_gtgteq
                  (lwt_log_info
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (op_minuspercent
                                  (f
                                    (CamlinternalFormatBasics.Format
                                      (CamlinternalFormatBasics.String_literal
                                        "Injecting block (priority " % string
                                        (CamlinternalFormatBasics.Int
                                          CamlinternalFormatBasics.Int_d
                                          CamlinternalFormatBasics.No_padding
                                          CamlinternalFormatBasics.No_precision
                                          (CamlinternalFormatBasics.String_literal
                                            ", fitness " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                ") for " % string
                                                (CamlinternalFormatBasics.String
                                                  CamlinternalFormatBasics.No_padding
                                                  (CamlinternalFormatBasics.String_literal
                                                    " after " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        "..." % string
                                                        CamlinternalFormatBasics.End_of_format)))))))))
                                      "Injecting block (priority %d, fitness %a) for %s after %a..."
                                        % string))
                                  (t event "start_injecting_block" % string))
                                (s bake_priority_tag priority))
                              (a fitness_tag (fitness shell_header)))
                            (s Client_keys.Logging.tag name))
                          (a Block_hash.Logging.predecessor_tag
                            (predecessor shell_header)))
                        (t Signature.Public_key_hash.Logging.tag delegate)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion (Client_keys.get_key cctxt delegate)
                      (fun function_parameter =>
                        let '(_, _, delegate_sk) := function_parameter in
                        op_gtgteq
                          (inject_block cctxt (Some false) seed_nonce_hash chain
                            shell_header priority delegate delegate_sk level
                            operations)
                          (fun function_parameter =>
                            match function_parameter with
                            | Stdlib.Error errs =>
                              op_gtgteq
                                (lwt_log_error
                                  (fun f =>
                                    op_minuspercent
                                      (op_minuspercent
                                        (op_minuspercent
                                          (f
                                            (CamlinternalFormatBasics.Format
                                              (CamlinternalFormatBasics.Formatting_gen
                                                (CamlinternalFormatBasics.Open_box
                                                  (CamlinternalFormatBasics.Format
                                                    (CamlinternalFormatBasics.String_literal
                                                      "<v 4>" % string
                                                      CamlinternalFormatBasics.End_of_format)
                                                    "<v 4>" % string))
                                                (CamlinternalFormatBasics.String_literal
                                                  "Error while injecting block"
                                                    % string
                                                  (CamlinternalFormatBasics.Formatting_lit
                                                    (CamlinternalFormatBasics.Break
                                                      "@ " % string 1 0)
                                                    (CamlinternalFormatBasics.Formatting_gen
                                                      (CamlinternalFormatBasics.Open_box
                                                        (CamlinternalFormatBasics.Format
                                                          CamlinternalFormatBasics.End_of_format
                                                          "" % string))
                                                      (CamlinternalFormatBasics.String_literal
                                                        "Included operations : "
                                                          % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.Formatting_lit
                                                            CamlinternalFormatBasics.Close_box
                                                            (CamlinternalFormatBasics.Formatting_lit
                                                              (CamlinternalFormatBasics.Break
                                                                "@ " % string 1
                                                                0)
                                                              (CamlinternalFormatBasics.Alpha
                                                                (CamlinternalFormatBasics.Formatting_lit
                                                                  CamlinternalFormatBasics.Close_box
                                                                  CamlinternalFormatBasics.End_of_format))))))))))
                                              "@[<v 4>Error while injecting block@ @[Included operations : %a@]@ %a@]"
                                                % string))
                                          (t event
                                            "block_injection_failed" % string))
                                        (a raw_operations_tag
                                          (List.concat operations)))
                                      (a errs_tag errs)))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit)
                            | Stdlib.Ok block_hash =>
                              op_gtgteq
                                (lwt_log_notice
                                  (fun f =>
                                    op_minuspercent
                                      (op_minuspercent
                                        (op_minuspercent
                                          (op_minuspercent
                                            (op_minuspercent
                                              (op_minuspercent
                                                (op_minuspercent
                                                  (op_minuspercent
                                                    (f
                                                      (CamlinternalFormatBasics.Format
                                                        (CamlinternalFormatBasics.String_literal
                                                          "Injected block " %
                                                            string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.String_literal
                                                              " for " % string
                                                              (CamlinternalFormatBasics.String
                                                                CamlinternalFormatBasics.No_padding
                                                                (CamlinternalFormatBasics.String_literal
                                                                  " after " %
                                                                    string
                                                                  (CamlinternalFormatBasics.Alpha
                                                                    (CamlinternalFormatBasics.String_literal
                                                                      " (level "
                                                                        % string
                                                                      (CamlinternalFormatBasics.Alpha
                                                                        (CamlinternalFormatBasics.String_literal
                                                                          ", priority "
                                                                            %
                                                                            string
                                                                          (CamlinternalFormatBasics.Int
                                                                            CamlinternalFormatBasics.Int_d
                                                                            CamlinternalFormatBasics.No_padding
                                                                            CamlinternalFormatBasics.No_precision
                                                                            (CamlinternalFormatBasics.String_literal
                                                                              ", fitness "
                                                                                %
                                                                                string
                                                                              (CamlinternalFormatBasics.Alpha
                                                                                (CamlinternalFormatBasics.String_literal
                                                                                  ", operations "
                                                                                    %
                                                                                    string
                                                                                  (CamlinternalFormatBasics.Alpha
                                                                                    (CamlinternalFormatBasics.String_literal
                                                                                      ")."
                                                                                        %
                                                                                        string
                                                                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
                                                        "Injected block %a for %s after %a (level %a, priority %d, fitness %a, operations %a)."
                                                          % string))
                                                    (t event
                                                      "injected_block" % string))
                                                  (a Block_hash.Logging.tag
                                                    block_hash))
                                                (s Client_keys.Logging.tag name))
                                              (a Block_hash.Logging.tag
                                                (predecessor shell_header)))
                                            (a level_tag level))
                                          (s bake_priority_tag priority))
                                        (a fitness_tag (fitness shell_header)))
                                      (a operations_tag operations)))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (if nequiv_decb seed_nonce_hash None then
                                      OCaml.Stdlib.reverse_apply
                                        ((* ❌ Sending method message is not handled *)
                                        send
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            op_gtgteqquestion
                                              (load cctxt
                                                (nonces_location state))
                                              (fun nonces =>
                                                let nonces :=
                                                  add nonces block_hash
                                                    seed_nonce in
                                                save cctxt
                                                  (nonces_location state) nonces)))
                                        (trace_exn
                                          (OCaml.Failure
                                            "Error while recording nonce" %
                                              string))
                                    else
                                      return_unit)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      return_unit))
                            end))))
          | None => return_unit
          end)).

Definition get_baking_slots {D F H J K a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (variant * variant) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (variant * variant) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (variant * variant) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (variant * variant) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) * K)))) * K *
      (variant * variant)) (op_staroptstar : option Z)
  : Tezos_baking_alpha.Client_baking_blocks.block_info ->
    (list
      Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
      ->
      Lwt.t
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t *
            (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
              Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))) :=
  let max_priority :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => default_max_priority
    end in
  fun new_head =>
    fun delegates =>
      let chain :=
        (* ❌ Variants not supported *)
        variant in
      let block :=
        (* ❌ Variants not supported *)
        variant in
      let level := Raw_level.succ (level new_head) in
      op_gtgteq
        (Alpha_services.Delegate.Baking_rights.get cctxt (Some (cons level []))
          None (Some delegates) None (Some max_priority) (chain, block))
        (fun function_parameter =>
          match function_parameter with
          | Stdlib.Error errs =>
            op_gtgteq
              (lwt_log_error
                (fun f =>
                  op_minuspercent
                    (op_minuspercent
                      (f
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error while fetching baking possibilities:
" %
                              string
                            (CamlinternalFormatBasics.Alpha
                              CamlinternalFormatBasics.End_of_format))
                          "Error while fetching baking possibilities:
%a" %
                            string))
                      (t event "baking_slot_fetch_errors" % string))
                    (a errs_tag errs)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                Lwt.return_nil)
          | Stdlib.Ok [] => Lwt.return_nil
          | Stdlib.Ok slots =>
            let slots :=
              List.filter_map
                (fun function_parameter =>
                  match function_parameter with
                  | {|
                    Alpha_services.Delegate.Baking_rights.timestamp := None
                      |} => None
                  | {|
                    delegate := delegate;
                      priority := priority;
                      timestamp := Some timestamp
                      |} => Some (timestamp, (new_head, priority, delegate))
                  end) slots in
            Lwt._return slots
          end).

Definition compute_best_slot_on_current_level
  {D F H J L M N a b c i o p q : Type}
  (max_priority : option Z)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (state : state)
  (new_head : Tezos_baking_alpha.Client_baking_blocks.block_info)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (option
        (Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t *
          (Tezos_baking_alpha.Client_baking_blocks.block_info * Z *
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)))) :=
  op_gtgteqquestion (get_delegates cctxt state)
    (fun delegates =>
      let level := Raw_level.succ (Client_baking_blocks.level new_head) in
      op_gtgteq (get_baking_slots cctxt max_priority new_head delegates)
        (fun function_parameter =>
          match function_parameter with
          | [] =>
            op_gtgteq
              (lwt_log_notice
                (fun f =>
                  let max_priority :=
                    Option.unopt default_max_priority max_priority in
                  op_minuspercent
                    (op_minuspercent
                      (op_minuspercent
                        (f
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "No slot found at level " % string
                              (CamlinternalFormatBasics.Alpha
                                (CamlinternalFormatBasics.String_literal
                                  " (max_priority = " % string
                                  (CamlinternalFormatBasics.Int
                                    CamlinternalFormatBasics.Int_d
                                    CamlinternalFormatBasics.No_padding
                                    CamlinternalFormatBasics.No_precision
                                    (CamlinternalFormatBasics.Char_literal
                                      ")" % char
                                      CamlinternalFormatBasics.End_of_format)))))
                            "No slot found at level %a (max_priority = %d)" %
                              string)) (t event "no_slot_found" % string))
                      (a level_tag level)) (s bake_priority_tag max_priority)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                return_none)
          | cons h t =>
            let '(timestamp, (_, priority, delegate)) as best_slot :=
              List.fold_left
                (fun function_parameter =>
                  let '(_, (_, priority, _)) as acc := function_parameter in
                  fun function_parameter =>
                    let '(_, (_, priority', _)) as slot := function_parameter in
                    if OCaml.Stdlib.lt priority priority' then
                      acc
                    else
                      slot) h t in
            op_gtgteqquestion (Client_keys.Public_key_hash.name cctxt delegate)
              (fun name =>
                op_gtgteq
                  (lwt_log_notice
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (op_minuspercent
                                  (op_minuspercent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "New baking slot found (level " %
                                            string
                                          (CamlinternalFormatBasics.Alpha
                                            (CamlinternalFormatBasics.String_literal
                                              ", priority " % string
                                              (CamlinternalFormatBasics.Int
                                                CamlinternalFormatBasics.Int_d
                                                CamlinternalFormatBasics.No_padding
                                                CamlinternalFormatBasics.No_precision
                                                (CamlinternalFormatBasics.String_literal
                                                  ") at " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.String_literal
                                                      " for " % string
                                                      (CamlinternalFormatBasics.String
                                                        CamlinternalFormatBasics.No_padding
                                                        (CamlinternalFormatBasics.String_literal
                                                          " after " % string
                                                          (CamlinternalFormatBasics.Alpha
                                                            (CamlinternalFormatBasics.Char_literal
                                                              "." % char
                                                              CamlinternalFormatBasics.End_of_format)))))))))))
                                        "New baking slot found (level %a, priority %d) at %a for %s after %a."
                                          % string))
                                    (t event "have_baking_slot" % string))
                                  (a level_tag level))
                                (s bake_priority_tag priority))
                              (a timestamp_tag
                                (Time.System.of_protocol_exn timestamp)))
                            (s Client_keys.Logging.tag name))
                          (a Block_hash.Logging.tag (hash new_head)))
                        (t Signature.Public_key_hash.Logging.tag delegate)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_some best_slot))
          end)).

Definition reveal_potential_nonces {F G I J K M N a b c i o p q : Type}
  (cctxt :
    ((Z -> Lwt.t unit) *
      ((unit -> Ptime.t) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          (Uri.t *
            (Tezos_shell_services.Shell_services.block *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (F * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (G * p * q * i * o)) *
                  (Tezos_shell_services.Shell_services.chain *
                    ((option Z) *
                      ((((Tezos_client_base.Client_context.lwt_format a b) -> a)
                        * (a * b)) *
                        ((Tezos_rpc.RPC_service.meth ->
                          (option Tezos_data_encoding.Data_encoding.json) ->
                            Uri.t ->
                              Lwt.t
                                (Tezos_rpc.RPC_context.rest_result
                                  Tezos_data_encoding.Data_encoding.json
                                  (option Tezos_data_encoding.Data_encoding.json)))
                          *
                          (((string ->
                            a ->
                              (Tezos_base__TzPervasives.Data_encoding.encoding a)
                                -> Lwt.t (Tezos_base__TzPervasives.tzresult a))
                            * (a)) *
                            ((option (Lwt_stream.t string)) *
                              (((string ->
                                (Tezos_client_base.Client_context.lwt_format a
                                  unit) -> a) * (a)) *
                                ((((Tezos_client_base.Client_context.lwt_format
                                  a unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a (Tezos_base__TzPervasives.tzresult string))
                                    -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a
                                      (Tezos_base__TzPervasives.tzresult
                                        Bigstring.t)) -> a) * (a)) *
                                      ((string ->
                                        Lwt.t
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a unit) -> a) * (a)) *
                                          ((((unit -> Lwt.t a) -> Lwt.t a) * (a))
                                            *
                                            (((string ->
                                              a ->
                                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                                  a) ->
                                                  Lwt.t
                                                    (Tezos_base__TzPervasives.tzresult
                                                      unit)) * (a)) *
                                              ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                variant
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                q i o) ->
                                                (Tezos_shell_services.Shell_services.chain
                                                  *
                                                  Tezos_shell_services.Shell_services.block)
                                                  ->
                                                  q ->
                                                    i ->
                                                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                          o)) * (I * q * i * o))
                                                *
                                                ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                  variant
                                                  Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                  (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    * a) q i o) ->
                                                  (Tezos_shell_services.Shell_services.chain
                                                    *
                                                    Tezos_shell_services.Shell_services.block)
                                                    ->
                                                    a ->
                                                      q ->
                                                        i ->
                                                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                              o)) *
                                                  (J * a * q * i * o)) *
                                                  ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                    variant
                                                    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                    ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      * a) * b) q i o) ->
                                                    (Tezos_shell_services.Shell_services.chain
                                                      *
                                                      Tezos_shell_services.Shell_services.block)
                                                      ->
                                                      a ->
                                                        b ->
                                                          q ->
                                                            i ->
                                                              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                  o)) *
                                                    (K * a * b * q * i * o)) *
                                                    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t
                                                      variant
                                                      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                      (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
                                                        * a) * b) * c) q i o) ->
                                                      (Tezos_shell_services.Shell_services.chain
                                                        *
                                                        Tezos_shell_services.Shell_services.block)
                                                        ->
                                                        a ->
                                                          b ->
                                                            c ->
                                                              q ->
                                                                i ->
                                                                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                                                                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                                                                      o)) *
                                                      (M * a * b * c * q * i * o))
                                                      * N)))))))))))))))))))))))))
      *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (I * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (J * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (K * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (M * a * b * c * q * i * o)) * N)))))
  (constants : Tezos_protocol_alpha.Protocol.Alpha_context.Constants.t)
  (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sending method message is not handled *)
  send
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (Client_baking_files.resolve_location cctxt chain
          (* ❌ Variants not supported *)
          variant)
        (fun nonces_location =>
          op_gtgteq (Client_baking_nonces.load cctxt nonces_location)
            (fun function_parameter =>
              match function_parameter with
              | Stdlib.Error err =>
                op_gtgteq
                  (lwt_log_error
                    (fun f =>
                      op_minuspercent
                        (op_minuspercent
                          (f
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "Cannot read nonces: " % string
                                (CamlinternalFormatBasics.Alpha
                                  CamlinternalFormatBasics.End_of_format))
                              "Cannot read nonces: %a" % string))
                          (t event "read_nonce_fail" % string)) (a errs_tag err)))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    return_unit)
              | Stdlib.Ok nonces =>
                op_gtgteq
                  (Client_baking_nonces.get_unrevealed_nonces cctxt
                    nonces_location nonces)
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Error err =>
                      op_gtgteq
                        (lwt_log_error
                          (fun f =>
                            op_minuspercent
                              (op_minuspercent
                                (f
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Cannot retrieve unrevealed nonces: " %
                                        string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Cannot retrieve unrevealed nonces: %a" %
                                      string))
                                (t event "nonce_retrieval_fail" % string))
                              (a errs_tag err)))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          return_unit)
                    | Stdlib.Ok [] => return_unit
                    | Stdlib.Ok nonces_to_reveal =>
                      op_gtgteq
                        (Client_baking_revelation.inject_seed_nonce_revelation
                          cctxt chain block None nonces_to_reveal)
                        (fun function_parameter =>
                          match function_parameter with
                          | Stdlib.Error err =>
                            op_gtgteq
                              (lwt_log_error
                                (fun f =>
                                  op_minuspercent
                                    (op_minuspercent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Cannot inject nonces: " % string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "Cannot inject nonces: %a" % string))
                                      (t event "nonce_injection_fail" % string))
                                    (a errs_tag err)))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit)
                          | Stdlib.Ok tt =>
                            op_gtgteqquestion
                              (Client_baking_nonces.filter_outdated_nonces cctxt
                                (Some constants) nonces_location nonces)
                              (fun live_nonces =>
                                op_gtgteqquestion
                                  (Client_baking_nonces.save cctxt
                                    nonces_location live_nonces)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    return_unit))
                          end)
                    end)
              end))).

Definition create {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N)
  (minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (minimal_nanotez_per_gas_unit : option Z.t)
  (minimal_nanotez_per_byte : option Z.t) (max_priority : option Z)
  (chain : Tezos_shell_services.Shell_services.chain) (context_path : string)
  (delegates : list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (block_stream :
    Lwt_stream.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_baking_alpha.Client_baking_blocks.block_info))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let state_maker (bi : Tezos_baking_alpha.Client_baking_blocks.block_info)
    : Lwt.t (Tezos_base__TzPervasives.tzresult state) :=
    op_gtgteqquestion
      (Alpha_services.Constants.all cctxt
        (chain,
          (* ❌ Variants not supported *)
          variant))
      (fun constants =>
        op_gtgteq (Client_baking_simulator.load_context context_path)
          (fun index =>
            op_gtgteqquestion
              (Client_baking_simulator.check_context_consistency index
                (Client_baking_blocks.context bi))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (Client_baking_files.resolve_location cctxt chain
                    (* ❌ Variants not supported *)
                    variant)
                  (fun nonces_location =>
                    let state :=
                      create_state minimal_fees minimal_nanotez_per_gas_unit
                        minimal_nanotez_per_byte context_path index
                        nonces_location delegates constants in
                    _return state)))) in
  let event_k {O P Q R S T U : Type}
    (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (O * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (P * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Q * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (R * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (S * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (T * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * U)))))))))))))))))))))))))
      * U) (state : state) (new_head :
    Tezos_baking_alpha.Client_baking_blocks.block_info)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteq
      (reveal_potential_nonces cctxt (constants state) chain
        (* ❌ Variants not supported *)
        variant)
      (fun _ignore_nonce_err =>
        op_gtgteqquestion
          (compute_best_slot_on_current_level max_priority cctxt state new_head)
          (fun slot =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Set record field not handled. *)
              set_record_field state "best_slot" % string slot in
            return_unit)) in
  let compute_timeout (state : state) : Lwt.t unit :=
    match best_slot state with
    | None => Lwt_utils.never_ending tt
    | Some (timestamp, _) =>
      match Client_baking_scheduling.sleep_until timestamp with
      | None => Lwt.return_unit
      | Some timeout => timeout
      end
    end in
  let timeout_k {O P Q R S T U : Type}
    (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (O * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (P * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Q * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (R * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (S * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (T * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * U)))))))))))))))))))))))))
      * U) (state : state) (function_parameter : unit)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    let 'tt := function_parameter in
    op_gtgteqquestion (bake cctxt chain state)
      (fun function_parameter =>
        let 'tt := function_parameter in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Set record field not handled. *)
          set_record_field state "best_slot" % string None in
        return_unit) in
  Client_baking_scheduling.main "baker" % string cctxt block_stream state_maker
    event_k compute_timeout timeout_k event_k.

src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml 637 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context

type error += Level_previously_endorsed of Raw_level.t

type error += Level_previously_baked of Raw_level.t

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"highwatermarks.block_already_baked"
    ~title:"Block already baked"
    ~description:"Trying to bake a block for a level that was previously done"
    ~pp:(fun ppf level ->
      Format.fprintf ppf "Level %a previously baked " Raw_level.pp level)
    (obj1 (req "level" Raw_level.encoding))
    (function Level_previously_baked level -> Some level | _ -> None)
    (fun level -> Level_previously_baked level) ;
  register_error_kind
    `Permanent
    ~id:"highwatermarks.block_already_endorsed"
    ~title:"Fail to preapply an operation"
    ~description:
      "Trying to endorse a block for a level that was previously done"
    ~pp:(fun ppf level ->
      Format.fprintf ppf "Level %a previously endorsed " Raw_level.pp level)
    (obj1 (req "level" Raw_level.encoding))
    (function Level_previously_endorsed level -> Some level | _ -> None)
    (fun level -> Level_previously_endorsed level)

type t = (string * Raw_level.t) list

let encoding =
  let open Data_encoding in
  def "highwatermarks" @@ assoc Raw_level.encoding

let empty = []

(* We do not lock these functions. The caller will be already locked. *)
let load_highwatermarks (cctxt : #Protocol_client_context.full) filename :
    t tzresult Lwt.t =
  cctxt#load filename encoding ~default:empty

let save_highwatermarks (cctxt : #Protocol_client_context.full) filename
    highwatermarks : unit tzresult Lwt.t =
  cctxt#write filename highwatermarks encoding

let retrieve_highwatermark cctxt filename = load_highwatermarks cctxt filename

let may_inject (cctxt : #Protocol_client_context.full) location ~delegate level
    =
  retrieve_highwatermark cctxt (Client_baking_files.filename location)
  >>=? fun highwatermark ->
  let delegate = Signature.Public_key_hash.to_short_b58check delegate in
  List.find_opt
    (fun (delegate', _) -> String.compare delegate delegate' = 0)
    highwatermark
  |> function
  | None ->
      return_true
  | Some (_, past_level) ->
      return Raw_level.(past_level < level)

let may_inject_block = may_inject

let may_inject_endorsement = may_inject

let record (cctxt : #Protocol_client_context.full) location ~delegate level =
  let filename = Client_baking_files.filename location in
  let delegate = Signature.Public_key_hash.to_short_b58check delegate in
  load_highwatermarks cctxt filename
  >>=? fun highwatermarks ->
  let level =
    match List.assoc_opt delegate highwatermarks with
    | None ->
        level
    | Some lower_prev_level when level >= lower_prev_level ->
        level
    | Some higher_prev_level ->
        higher_prev_level
    (* should only happen in `forced` mode *)
  in
  save_highwatermarks
    cctxt
    filename
    ( (delegate, level)
    :: List.filter
         (fun (delegate', _) -> String.compare delegate delegate' <> 0)
         highwatermarks )

let record_block = record

let record_endorsement = record
src/proto_alpha/lib_delegate/client_baking_highwatermarks.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol_client_context.

Import Protocol.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition t :=
  list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t).

Definition encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)) :=
  apply
    (let arg := def "highwatermarks" % string in
    fun eta => arg None None eta) (assoc Raw_level.encoding).

Definition empty {A : Type} : list A := [].

Definition load_highwatermarks {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (filename : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  (* ❌ Sending method message is not handled *)
  send filename empty encoding.

Definition save_highwatermarks {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (filename : string)
  (highwatermarks :
    list (string * Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sending method message is not handled *)
  send filename highwatermarks encoding.

Definition retrieve_highwatermark {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (filename : string) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  load_highwatermarks cctxt filename.

Definition may_inject {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (location : Tezos_baking_alpha.Client_baking_files.location O)
  (delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
  op_gtgteqquestion
    (retrieve_highwatermark cctxt (Client_baking_files.filename location))
    (fun highwatermark =>
      let delegate := Signature.Public_key_hash.to_short_b58check delegate in
      OCaml.Stdlib.reverse_apply
        (List.find_opt
          (fun function_parameter =>
            let '(delegate', _) := function_parameter in
            equiv_decb (String.compare delegate delegate') 0) highwatermark)
        (fun function_parameter =>
          match function_parameter with
          | None => return_true
          | Some (_, past_level) => _return (op_lt past_level level)
          end)).

Definition may_inject_block {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((Z -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult bool) := may_inject.

Definition may_inject_endorsement {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((Z -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult bool) := may_inject.

Definition record {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (location : Tezos_baking_alpha.Client_baking_files.location O)
  (delegate : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let filename := Client_baking_files.filename location in
  let delegate := Signature.Public_key_hash.to_short_b58check delegate in
  op_gtgteqquestion (load_highwatermarks cctxt filename)
    (fun highwatermarks =>
      let level :=
        match List.assoc_opt delegate highwatermarks with
        | None => level
        | Some lower_prev_level => level
        | Some higher_prev_level => higher_prev_level
        end in
      save_highwatermarks cctxt filename
        (cons (delegate, level)
          (List.filter
            (fun function_parameter =>
              let '(delegate', _) := function_parameter in
              nequiv_decb (String.compare delegate delegate') 0) highwatermarks))).

Definition record_block {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((Z -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) := record.

Definition record_endorsement {D F H J L M N O a b c i o p q : Type}
  : (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    (Tezos_shell_services.Shell_services.chain *
      Tezos_shell_services.Shell_services.block) ->
      q ->
        i ->
          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
              o)) * (D * q * i * o)) *
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        a ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (F * a * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            b ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (H * a * b * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                c ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * c * q * i * o)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (Uri.t *
              (Tezos_shell_services.Shell_services.block *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  p ->
                    q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                  * (L * p * q * i * o)) *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    (o -> unit) ->
                      (unit -> unit) ->
                        p ->
                          q ->
                            i ->
                              Lwt.t
                                (Tezos_error_monad.Error_monad.tzresult
                                  (unit -> unit))) * (M * p * q * i * o)) *
                    (Tezos_shell_services.Shell_services.chain *
                      ((option Z) *
                        ((((Tezos_client_base.Client_context.lwt_format a b) ->
                          a) * (a * b)) *
                          ((Tezos_rpc.RPC_service.meth ->
                            (option Tezos_data_encoding.Data_encoding.json) ->
                              Uri.t ->
                                Lwt.t
                                  (Tezos_rpc.RPC_context.rest_result
                                    Tezos_data_encoding.Data_encoding.json
                                    (option
                                      Tezos_data_encoding.Data_encoding.json)))
                            *
                            (((string ->
                              a ->
                                (Tezos_base__TzPervasives.Data_encoding.encoding
                                  a) ->
                                  Lwt.t (Tezos_base__TzPervasives.tzresult a)) *
                              (a)) *
                              ((option (Lwt_stream.t string)) *
                                (((string ->
                                  (Tezos_client_base.Client_context.lwt_format a
                                    unit) -> a) * (a)) *
                                  ((((Tezos_client_base.Client_context.lwt_format
                                    a unit) -> a) * (a)) *
                                    ((unit -> Ptime.t) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a
                                        (Tezos_base__TzPervasives.tzresult
                                          string)) -> a) * (a)) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            Bigstring.t)) -> a) * (a)) *
                                          ((string ->
                                            Lwt.t
                                              (Tezos_base__TzPervasives.tzresult
                                                string)) *
                                            ((Z -> Lwt.t unit) *
                                              ((((Tezos_client_base.Client_context.lwt_format
                                                a unit) -> a) * (a)) *
                                                ((((unit -> Lwt.t a) -> Lwt.t a)
                                                  * (a)) *
                                                  (((string ->
                                                    a ->
                                                      (Tezos_base__TzPervasives.Data_encoding.encoding
                                                        a) ->
                                                        Lwt.t
                                                          (Tezos_base__TzPervasives.tzresult
                                                            unit)) * (a)) * N)))))))))))))))))))))))))
    * N) ->
    (Tezos_baking_alpha.Client_baking_files.location O) ->
      Tezos_base__TzPervasives.Signature.Public_key_hash.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult unit) := record.

src/proto_alpha/lib_delegate/client_baking_lib.ml 380 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let bake_block (cctxt : #Protocol_client_context.full) ?minimal_fees
    ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?force
    ?max_priority ?(minimal_timestamp = false) ?mempool ?context_path ?src_sk
    ~chain ~head delegate =
  ( match src_sk with
  | None ->
      Client_keys.get_key cctxt delegate
      >>=? fun (_, _, src_sk) -> return src_sk
  | Some sk ->
      return sk )
  >>=? fun src_sk ->
  Alpha_services.Helpers.current_level cctxt ~offset:1l (chain, head)
  >>=? fun level ->
  let (seed_nonce, seed_nonce_hash) =
    if level.expected_commitment then
      let seed_nonce = Client_baking_forge.generate_seed_nonce () in
      let seed_nonce_hash = Nonce.hash seed_nonce in
      (Some seed_nonce, Some seed_nonce_hash)
    else (None, None)
  in
  let timestamp =
    if minimal_timestamp then None
    else Some Time.System.(to_protocol (Systime_os.now ()))
  in
  Client_baking_forge.forge_block
    cctxt
    ?force
    ?minimal_fees
    ?minimal_nanotez_per_gas_unit
    ?minimal_nanotez_per_byte
    ?timestamp
    ?seed_nonce_hash
    ?mempool
    ?context_path
    ~chain
    ~priority:(`Auto (delegate, max_priority))
    ~delegate_pkh:delegate
    ~delegate_sk:src_sk
    head
  >>=? fun block_hash ->
  ( match seed_nonce with
  | None ->
      return_unit
  | Some seed_nonce ->
      cctxt#with_lock (fun () ->
          let open Client_baking_nonces in
          Client_baking_files.resolve_location cctxt ~chain `Nonce
          >>=? fun nonces_location ->
          load cctxt nonces_location
          >>=? fun nonces ->
          let nonces = add nonces block_hash seed_nonce in
          save cctxt nonces_location nonces)
      |> trace_exn (Failure "Error while recording block") )
  >>=? fun () ->
  cctxt#message "Injected block %a" Block_hash.pp_short block_hash
  >>= fun () -> return_unit

let endorse_block cctxt ~chain delegate =
  Client_keys.get_key cctxt delegate
  >>=? fun (_src_name, src_pk, src_sk) ->
  Client_baking_endorsement.forge_endorsement
    cctxt
    ~chain
    ~block:cctxt#block
    ~src_sk
    src_pk
  >>=? fun oph ->
  cctxt#answer "Operation successfully injected in the node."
  >>= fun () ->
  cctxt#answer "Operation hash is '%a'." Operation_hash.pp oph
  >>= fun () -> return_unit

let get_predecessor_cycle (cctxt : #Client_context.printer) cycle =
  match Cycle.pred cycle with
  | None ->
      if Cycle.(cycle = root) then
        cctxt#error "No predecessor for the first cycle"
      else
        cctxt#error "Cannot compute the predecessor of cycle %a" Cycle.pp cycle
  | Some cycle ->
      Lwt.return cycle

let do_reveal cctxt ~chain ~block nonces =
  Client_baking_revelation.inject_seed_nonce_revelation
    cctxt
    ~chain
    ~block
    nonces
  >>=? fun () -> return_unit

let reveal_block_nonces (cctxt : #Protocol_client_context.full) ~chain ~block
    block_hashes =
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      Client_baking_nonces.load cctxt nonces_location)
  >>=? fun nonces ->
  Lwt_list.filter_map_p
    (fun hash ->
      Lwt.catch
        (fun () ->
          Client_baking_blocks.info cctxt (`Hash (hash, 0))
          >>= function
          | Ok bi -> Lwt.return_some bi | Error _ -> Lwt.fail Not_found)
        (fun _ ->
          cctxt#warning
            "Cannot find block %a in the chain. (ignoring)@."
            Block_hash.pp_short
            hash
          >>= fun () -> Lwt.return_none))
    block_hashes
  >>= fun block_infos ->
  filter_map_s
    (fun (bi : Client_baking_blocks.block_info) ->
      match Client_baking_nonces.find_opt nonces bi.hash with
      | None ->
          cctxt#warning
            "Cannot find nonces for block %a (ignoring)@."
            Block_hash.pp_short
            bi.hash
          >>= fun () -> return_none
      | Some nonce ->
          return_some (bi.hash, (bi.level, nonce)))
    block_infos
  >>=? fun nonces ->
  let nonces = List.map snd nonces in
  do_reveal cctxt ~chain ~block nonces

let reveal_nonces (cctxt : #Protocol_client_context.full) ~chain ~block () =
  let open Client_baking_nonces in
  cctxt#with_lock (fun () ->
      Client_baking_files.resolve_location cctxt ~chain `Nonce
      >>=? fun nonces_location ->
      load cctxt nonces_location
      >>=? fun nonces ->
      get_unrevealed_nonces cctxt nonces_location nonces
      >>=? fun nonces_to_reveal ->
      do_reveal cctxt ~chain ~block nonces_to_reveal
      >>=? fun () ->
      filter_outdated_nonces cctxt nonces_location nonces
      >>=? fun nonces ->
      save cctxt nonces_location nonces >>=? fun () -> return_unit)
src/proto_alpha/lib_delegate/client_baking_lib.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition bake_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N)
  (minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (minimal_nanotez_per_gas_unit : option Z.t)
  (minimal_nanotez_per_byte : option Z.t) (force : option bool)
  (max_priority : option Z) (op_staroptstar : option bool)
  : (option string) ->
    (option string) ->
      (option Tezos_client_base.Client_keys.sk_uri) ->
        Tezos_shell_services.Shell_services.chain ->
          Tezos_shell_services.Shell_services.block ->
            Tezos_client_base.Client_keys.Public_key_hash.t ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let minimal_timestamp :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun mempool =>
    fun context_path =>
      fun src_sk =>
        fun chain =>
          fun head =>
            fun delegate =>
              op_gtgteqquestion
                match src_sk with
                | None =>
                  op_gtgteqquestion (Client_keys.get_key cctxt delegate)
                    (fun function_parameter =>
                      let '(_, _, src_sk) := function_parameter in
                      _return src_sk)
                | Some sk => _return sk
                end
                (fun src_sk =>
                  op_gtgteqquestion
                    (Alpha_services.Helpers.current_level cctxt
                      (Some
                        (* ❌ Constant of type int32 is converted to int *)
                        1) (chain, head))
                    (fun level =>
                      let '(seed_nonce, seed_nonce_hash) :=
                        if expected_commitment level then
                          let seed_nonce :=
                            Client_baking_forge.generate_seed_nonce tt in
                          let seed_nonce_hash := Nonce.hash seed_nonce in
                          ((Some seed_nonce), (Some seed_nonce_hash))
                        else
                          (None, None) in
                      let timestamp :=
                        if minimal_timestamp then
                          None
                        else
                          Some (to_protocol (Systime_os.now tt)) in
                      op_gtgteqquestion
                        (Client_baking_forge.forge_block cctxt force None None
                          None minimal_fees minimal_nanotez_per_gas_unit
                          minimal_nanotez_per_byte timestamp mempool
                          context_path seed_nonce_hash chain
                          (* ❌ Variants not supported *)
                          variant delegate src_sk head)
                        (fun block_hash =>
                          op_gtgteqquestion
                            match seed_nonce with
                            | None => return_unit
                            | Some seed_nonce =>
                              OCaml.Stdlib.reverse_apply
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (Client_baking_files.resolve_location
                                        cctxt chain
                                        (* ❌ Variants not supported *)
                                        variant)
                                      (fun nonces_location =>
                                        op_gtgteqquestion
                                          (load cctxt nonces_location)
                                          (fun nonces =>
                                            let nonces :=
                                              add nonces block_hash seed_nonce
                                              in
                                            save cctxt nonces_location nonces))))
                                (trace_exn
                                  (OCaml.Failure
                                    "Error while recording block" % string))
                            end
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                ((* ❌ Sending method message is not handled *)
                                send
                                  (CamlinternalFormatBasics.Format
                                    (CamlinternalFormatBasics.String_literal
                                      "Injected block " % string
                                      (CamlinternalFormatBasics.Alpha
                                        CamlinternalFormatBasics.End_of_format))
                                    "Injected block %a" % string)
                                  Block_hash.pp_short block_hash)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  return_unit))))).

Definition endorse_block {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (delegate : Tezos_client_base.Client_keys.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion (Client_keys.get_key cctxt delegate)
    (fun function_parameter =>
      let '(_src_name, src_pk, src_sk) := function_parameter in
      op_gtgteqquestion
        (Client_baking_endorsement.forge_endorsement cctxt None chain
          (* ❌ Sending method message is not handled *)
          send src_sk src_pk)
        (fun oph =>
          op_gtgteq
            ((* ❌ Sending method message is not handled *)
            send
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Operation successfully injected in the node." % string
                  CamlinternalFormatBasics.End_of_format)
                "Operation successfully injected in the node." % string))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Operation hash is '" % string
                      (CamlinternalFormatBasics.Alpha
                        (CamlinternalFormatBasics.String_literal "'." % string
                          CamlinternalFormatBasics.End_of_format)))
                    "Operation hash is '%a'." % string) Operation_hash.pp oph)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)))).

Definition get_predecessor_cycle {C a b : Type}
  (cctxt :
    ((((Tezos_client_base.Client_context.lwt_format a b) -> a) * (a * b)) *
      ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
        ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
          ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a)) *
            (((string ->
              (Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              * C))))) * C)
  (cycle : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle)
  : Lwt.t Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle :=
  match Cycle.pred cycle with
  | None =>
    if op_eq cycle root then
      (* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "No predecessor for the first cycle" % string
            CamlinternalFormatBasics.End_of_format)
          "No predecessor for the first cycle" % string)
    else
      (* ❌ Sending method message is not handled *)
      send
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Cannot compute the predecessor of cycle " % string
            (CamlinternalFormatBasics.Alpha
              CamlinternalFormatBasics.End_of_format))
          "Cannot compute the predecessor of cycle %a" % string) Cycle.pp cycle
  | Some cycle => Lwt._return cycle
  end.

Definition do_reveal {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (nonces :
    list
      (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t *
        Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (Client_baking_revelation.inject_seed_nonce_revelation cctxt chain block
      None nonces)
    (fun function_parameter =>
      let 'tt := function_parameter in
      return_unit).

Definition reveal_block_nonces {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (block_hashes : list Tezos_base__TzPervasives.Block_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    ((* ❌ Sending method message is not handled *)
    send
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (Client_baking_files.resolve_location cctxt chain
            (* ❌ Variants not supported *)
            variant)
          (fun nonces_location =>
            Client_baking_nonces.load cctxt nonces_location)))
    (fun nonces =>
      op_gtgteq
        (Lwt_list.filter_map_p
          (fun hash =>
            Lwt.catch
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq
                  (Client_baking_blocks.info cctxt None
                    (* ❌ Variants not supported *)
                    variant)
                  (fun function_parameter =>
                    match function_parameter with
                    | Stdlib.Ok bi => Lwt.return_some bi
                    | Stdlib.Error _ => Lwt.fail OCaml.Not_found
                    end))
              (fun function_parameter =>
                let '_ := function_parameter in
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Cannot find block " % string
                        (CamlinternalFormatBasics.Alpha
                          (CamlinternalFormatBasics.String_literal
                            " in the chain. (ignoring)" % string
                            (CamlinternalFormatBasics.Formatting_lit
                              CamlinternalFormatBasics.Flush_newline
                              CamlinternalFormatBasics.End_of_format))))
                      "Cannot find block %a in the chain. (ignoring)@." % string)
                    Block_hash.pp_short hash)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Lwt.return_none))) block_hashes)
        (fun block_infos =>
          op_gtgteqquestion
            (filter_map_s
              (fun bi =>
                match Client_baking_nonces.find_opt nonces (hash bi) with
                | None =>
                  op_gtgteq
                    ((* ❌ Sending method message is not handled *)
                    send
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Cannot find nonces for block " % string
                          (CamlinternalFormatBasics.Alpha
                            (CamlinternalFormatBasics.String_literal
                              " (ignoring)" % string
                              (CamlinternalFormatBasics.Formatting_lit
                                CamlinternalFormatBasics.Flush_newline
                                CamlinternalFormatBasics.End_of_format))))
                        "Cannot find nonces for block %a (ignoring)@." % string)
                      Block_hash.pp_short (hash bi))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_none)
                | Some nonce => return_some ((hash bi), ((level bi), nonce))
                end) block_infos)
            (fun nonces =>
              let nonces := List.map snd nonces in
              do_reveal cctxt chain block nonces))).

Definition reveal_nonces {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services.Chain_services.chain)
  (block : Tezos_shell_services.Block_services.block)
  (function_parameter : unit)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let 'tt := function_parameter in
  (* ❌ Sending method message is not handled *)
  send
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (Client_baking_files.resolve_location cctxt chain
          (* ❌ Variants not supported *)
          variant)
        (fun nonces_location =>
          op_gtgteqquestion (load cctxt nonces_location)
            (fun nonces =>
              op_gtgteqquestion
                (get_unrevealed_nonces cctxt nonces_location nonces)
                (fun nonces_to_reveal =>
                  op_gtgteqquestion
                    (do_reveal cctxt chain block nonces_to_reveal)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (filter_outdated_nonces cctxt None nonces_location
                          nonces)
                        (fun nonces =>
                          op_gtgteqquestion (save cctxt nonces_location nonces)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit))))))).

src/proto_alpha/lib_delegate/client_baking_nonces.ml 183 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.nonces"
end)

type t = Nonce.t Block_hash.Map.t

let empty = Block_hash.Map.empty

let encoding =
  let open Data_encoding in
  def "seed_nonce"
  @@ conv
       (fun m ->
         Block_hash.Map.fold (fun hash nonce acc -> (hash, nonce) :: acc) m [])
       (fun l ->
         List.fold_left
           (fun map (hash, nonce) -> Block_hash.Map.add hash nonce map)
           Block_hash.Map.empty
           l)
  @@ list (obj2 (req "block" Block_hash.encoding) (req "nonce" Nonce.encoding))

let load (wallet : #Client_context.wallet) location =
  wallet#load (Client_baking_files.filename location) ~default:empty encoding

let save (wallet : #Client_context.wallet) location nonces =
  wallet#write (Client_baking_files.filename location) nonces encoding

let mem nonces hash = Block_hash.Map.mem hash nonces

let find_opt nonces hash = Block_hash.Map.find_opt hash nonces

let add nonces hash nonce = Block_hash.Map.add hash nonce nonces

let add_all nonces nonces_to_add =
  Block_hash.Map.fold
    (fun hash nonce acc -> add acc hash nonce)
    nonces_to_add
    nonces

let remove nonces hash = Block_hash.Map.remove hash nonces

let remove_all nonces nonces_to_remove =
  Block_hash.Map.fold
    (fun hash _ acc -> remove acc hash)
    nonces_to_remove
    nonces

let get_block_level_opt cctxt ~chain ~block =
  Shell_services.Blocks.Header.shell_header cctxt ~chain ~block ()
  >>= function
  | Ok {level; _} ->
      Lwt.return_some level
  | Error errs ->
      lwt_warn
        Tag.DSL.(
          fun f ->
            f
              "@[<v 2>Cannot retrieve block %a header associated to nonce:@ \
               @[%a@]@]@."
            -% t event "cannot_retrieve_block_header"
            -% a Logging.block_tag block -% a errs_tag errs)
      >>= fun () -> Lwt.return_none

let get_outdated_nonces cctxt ?constants ~chain nonces =
  ( match constants with
  | None ->
      Alpha_services.Constants.all cctxt (chain, `Head 0)
  | Some constants ->
      return constants )
  >>=? fun {Constants.parametric = {blocks_per_cycle; preserved_cycles; _}; _} ->
  get_block_level_opt cctxt ~chain ~block:(`Head 0)
  >>= function
  | None ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Cannot fetch chain's head level. Aborting nonces filtering."
            -% t event "cannot_retrieve_head_level")
      >>= fun () -> return (empty, empty)
  | Some current_level ->
      let current_cycle = Int32.(div current_level blocks_per_cycle) in
      let is_older_than_preserved_cycles block_level =
        let block_cycle = Int32.(div block_level blocks_per_cycle) in
        Int32.sub current_cycle block_cycle > Int32.of_int preserved_cycles
      in
      Block_hash.Map.fold
        (fun hash nonce acc ->
          acc
          >>=? fun (orphans, outdated) ->
          get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0))
          >>= function
          | Some level ->
              if is_older_than_preserved_cycles level then
                return (orphans, add outdated hash nonce)
              else acc
          | None ->
              return (add orphans hash nonce, outdated))
        nonces
        (return (empty, empty))

let filter_outdated_nonces cctxt ?constants location nonces =
  let chain = Client_baking_files.chain location in
  get_outdated_nonces cctxt ?constants ~chain nonces
  >>=? fun (orphans, outdated_nonces) ->
  ( if Block_hash.Map.cardinal orphans >= 50 then
    lwt_warn
      Tag.DSL.(
        fun f ->
          f
            "Found too many nonces associated to blocks unknown by the node \
             in '$TEZOS_CLIENT/%s'. After checking that these blocks were \
             never included in the chain (e.g. via a block explorer), \
             consider using `tezos-client filter orphan nonces` to clear them."
          -% s
               Logging.filename_tag
               (Client_baking_files.filename location ^ "s")
          -% t event "too_many_orphans")
    >>= fun () -> Lwt.return_unit
  else Lwt.return_unit )
  >>= fun () -> return (remove_all nonces outdated_nonces)

let get_unrevealed_nonces cctxt location nonces =
  let chain = Client_baking_files.chain location in
  Client_baking_blocks.blocks_from_current_cycle
    cctxt
    ~chain
    (`Head 0)
    ~offset:(-1l)
    ()
  >>=? fun blocks ->
  filter_map_s
    (fun hash ->
      match find_opt nonces hash with
      | None ->
          return_none
      | Some nonce -> (
          get_block_level_opt cctxt ~chain ~block:(`Hash (hash, 0))
          >>= function
          | Some level -> (
              Lwt.return (Environment.wrap_error (Raw_level.of_int32 level))
              >>=? fun level ->
              Alpha_services.Nonce.get cctxt (chain, `Head 0) level
              >>=? function
              | Missing nonce_hash when Nonce.check_hash nonce nonce_hash ->
                  lwt_log_notice
                    Tag.DSL.(
                      fun f ->
                        f "Found nonce to reveal for %a (level: %a)"
                        -% t event "found_nonce"
                        -% a Block_hash.Logging.tag hash
                        -% a Logging.level_tag level)
                  >>= fun () -> return_some (level, nonce)
              | Missing _nonce_hash ->
                  lwt_log_error
                    Tag.DSL.(
                      fun f ->
                        f "Incoherent nonce for level %a"
                        -% t event "bad_nonce" -% a Logging.level_tag level)
                  >>= fun () -> return_none
              | Forgotten ->
                  return_none
              | Revealed _ ->
                  return_none )
          | None ->
              return_none ))
    blocks
src/proto_alpha/lib_delegate/client_baking_nonces.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

(* ❌ Structure item `include` not handled. *)
include

Definition t :=
  Tezos_base__TzPervasives.Block_hash.Map.t
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t.

Definition empty {A : Type} : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Block_hash.Map.empty.

Definition encoding
  : Tezos_base__TzPervasives.Data_encoding.encoding
    (Tezos_base__TzPervasives.Block_hash.Map.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce) :=
  apply
    (let arg := def "seed_nonce" % string in
    fun eta => arg None None eta)
    (apply
      (let arg :=
        conv
          (fun m =>
            Block_hash.Map.fold
              (fun hash => fun nonce => fun acc => cons (hash, nonce) acc) m [])
          (fun l =>
            List.fold_left
              (fun map =>
                fun function_parameter =>
                  let '(hash, nonce) := function_parameter in
                  Block_hash.Map.add hash nonce map) Block_hash.Map.empty l) in
      fun eta => arg None eta)
      (list None
        (obj2 (req None None "block" % string Block_hash.encoding)
          (req None None "nonce" % string Nonce.encoding)))).

Definition load {B C a : Type}
  (wallet :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (location : Tezos_baking_alpha.Client_baking_files.location C)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.Map.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)) :=
  (* ❌ Sending method message is not handled *)
  send (Client_baking_files.filename location) empty encoding.

Definition save {B C a : Type}
  (wallet :
    ((option (Lwt_stream.t string)) *
      ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
        ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
          (((string ->
            a ->
              (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
            (((string ->
              a ->
                (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                  Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * B)))))
      * B) (location : Tezos_baking_alpha.Client_baking_files.location C)
  (nonces :
    Tezos_base__TzPervasives.Block_hash.Map.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  (* ❌ Sending method message is not handled *)
  send (Client_baking_files.filename location) nonces encoding.

Definition mem {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key) : bool :=
  Block_hash.Map.mem hash nonces.

Definition find_opt {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key) : option A :=
  Block_hash.Map.find_opt hash nonces.

Definition add {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key) (nonce : A)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Block_hash.Map.add hash nonce nonces.

Definition add_all {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (nonces_to_add : Tezos_base__TzPervasives.Block_hash.Map.t A)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Block_hash.Map.fold (fun hash => fun nonce => fun acc => add acc hash nonce)
    nonces_to_add nonces.

Definition remove {A : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (hash : Tezos_base__TzPervasives.Block_hash.Map.key)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Block_hash.Map.remove hash nonces.

Definition remove_all {A B : Type}
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t A)
  (nonces_to_remove : Tezos_base__TzPervasives.Block_hash.Map.t B)
  : Tezos_base__TzPervasives.Block_hash.Map.t A :=
  Block_hash.Map.fold
    (fun hash =>
      fun function_parameter =>
        let '_ := function_parameter in
        fun acc => remove acc hash) nonces_to_remove nonces.

Definition get_block_level_opt {E F i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) * F) * F)
  (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block)
  : Lwt.t (option Stdlib.Int32.t) :=
  op_gtgteq
    (Shell_services.Blocks.Header.shell_header cctxt (Some chain) (Some block)
      tt)
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok {| level := level |} => Lwt.return_some level
      | Stdlib.Error errs =>
        op_gtgteq
          (lwt_warn
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.Formatting_gen
                          (CamlinternalFormatBasics.Open_box
                            (CamlinternalFormatBasics.Format
                              (CamlinternalFormatBasics.String_literal
                                "<v 2>" % string
                                CamlinternalFormatBasics.End_of_format)
                              "<v 2>" % string))
                          (CamlinternalFormatBasics.String_literal
                            "Cannot retrieve block " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " header associated to nonce:" % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  (CamlinternalFormatBasics.Break "@ " % string
                                    1 0)
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        CamlinternalFormatBasics.End_of_format
                                        "" % string))
                                    (CamlinternalFormatBasics.Alpha
                                      (CamlinternalFormatBasics.Formatting_lit
                                        CamlinternalFormatBasics.Close_box
                                        (CamlinternalFormatBasics.Formatting_lit
                                          CamlinternalFormatBasics.Close_box
                                          (CamlinternalFormatBasics.Formatting_lit
                                            CamlinternalFormatBasics.Flush_newline
                                            CamlinternalFormatBasics.End_of_format))))))))))
                        "@[<v 2>Cannot retrieve block %a header associated to nonce:@ @[%a@]@]@."
                          % string))
                    (t event "cannot_retrieve_block_header" % string))
                  (a Logging.block_tag block)) (a errs_tag errs)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            Lwt.return_none)
      end).

Definition get_outdated_nonces {E F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services__Block_services.chain * variant) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (F * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services__Block_services.chain * variant) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (H * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services__Block_services.chain * variant) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services__Block_services.chain * variant) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (L * a * b * c * q * i * o)) * M))))) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * M) *
      (Tezos_shell_services__Block_services.chain * variant))
  (constants : option Tezos_raw_protocol_alpha.Alpha_context.Constants.t)
  (chain : Tezos_shell_services__Block_services.chain)
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t N)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      ((Tezos_base__TzPervasives.Block_hash.Map.t N) *
        (Tezos_base__TzPervasives.Block_hash.Map.t N))) :=
  op_gtgteqquestion
    match constants with
    | None =>
      Alpha_services.Constants.all cctxt
        (chain,
          (* ❌ Variants not supported *)
          variant)
    | Some constants => _return constants
    end
    (fun function_parameter =>
      let '{|
        Constants.parametric := {|
          preserved_cycles := preserved_cycles;
            blocks_per_cycle := blocks_per_cycle
            |}
          |} := function_parameter in
      op_gtgteq
        (get_block_level_opt cctxt chain
          (* ❌ Variants not supported *)
          variant)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            op_gtgteq
              (lwt_log_error
                (fun f =>
                  op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Cannot fetch chain's head level. Aborting nonces filtering."
                            % string CamlinternalFormatBasics.End_of_format)
                        "Cannot fetch chain's head level. Aborting nonces filtering."
                          % string))
                    (t event "cannot_retrieve_head_level" % string)))
              (fun function_parameter =>
                let 'tt := function_parameter in
                _return (empty, empty))
          | Some current_level =>
            let current_cycle := div current_level blocks_per_cycle in
            let is_older_than_preserved_cycles (block_level : int32) : bool :=
              let block_cycle := div block_level blocks_per_cycle in
              OCaml.Stdlib.gt (Int32.sub current_cycle block_cycle)
                (Int32.of_int preserved_cycles) in
            Block_hash.Map.fold
              (fun hash =>
                fun nonce =>
                  fun acc =>
                    op_gtgteqquestion acc
                      (fun function_parameter =>
                        let '(orphans, outdated) := function_parameter in
                        op_gtgteq
                          (get_block_level_opt cctxt chain
                            (* ❌ Variants not supported *)
                            variant)
                          (fun function_parameter =>
                            match function_parameter with
                            | Some level =>
                              if is_older_than_preserved_cycles level then
                                _return (orphans, (add outdated hash nonce))
                              else
                                acc
                            | None =>
                              _return ((add orphans hash nonce), outdated)
                            end))) nonces (_return (empty, empty))
          end)).

Definition filter_outdated_nonces {E F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        (Tezos_shell_services__Block_services.chain * variant) ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (F * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          (Tezos_shell_services__Block_services.chain * variant) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (H * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            (Tezos_shell_services__Block_services.chain * variant) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (J * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              (Tezos_shell_services__Block_services.chain * variant) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (L * a * b * c * q * i * o)) * M))))) *
      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
        p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
        (E * p * q * i * o)) * M) *
      (Tezos_shell_services__Block_services.chain * variant))
  (constants : option Tezos_raw_protocol_alpha.Alpha_context.Constants.t)
  (location : Tezos_baking_alpha.Client_baking_files.location N)
  (nonces : Tezos_base__TzPervasives.Block_hash.Map.t O)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_base__TzPervasives.Block_hash.Map.t O)) :=
  let chain := Client_baking_files.chain location in
  op_gtgteqquestion (get_outdated_nonces cctxt constants chain nonces)
    (fun function_parameter =>
      let '(orphans, outdated_nonces) := function_parameter in
      op_gtgteq
        (if OCaml.Stdlib.ge (Block_hash.Map.cardinal orphans) 50 then
          op_gtgteq
            (lwt_warn
              (fun f =>
                op_minuspercent
                  (op_minuspercent
                    (f
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Found too many nonces associated to blocks unknown by the node in '$TEZOS_CLIENT/"
                            % string
                          (CamlinternalFormatBasics.String
                            CamlinternalFormatBasics.No_padding
                            (CamlinternalFormatBasics.String_literal
                              "'. After checking that these blocks were never included in the chain (e.g. via a block explorer), consider using `tezos-client filter orphan nonces` to clear them."
                                % string CamlinternalFormatBasics.End_of_format)))
                        "Found too many nonces associated to blocks unknown by the node in '$TEZOS_CLIENT/%s'. After checking that these blocks were never included in the chain (e.g. via a block explorer), consider using `tezos-client filter orphan nonces` to clear them."
                          % string))
                    (s Logging.filename_tag
                      (String.append (Client_baking_files.filename location)
                        "s" % string))) (t event "too_many_orphans" % string)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              Lwt.return_unit)
        else
          Lwt.return_unit)
        (fun function_parameter =>
          let 'tt := function_parameter in
          _return (remove_all nonces outdated_nonces))).

Definition get_unrevealed_nonces {D F H J L M N O a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            (Uri.t *
              ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                * (L * p * q * i * o)) *
                ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                  (o -> unit) ->
                    (unit -> unit) ->
                      p ->
                        q ->
                          i ->
                            Lwt.t
                              (Tezos_error_monad.Error_monad.tzresult
                                (unit -> unit))) * (M * p * q * i * o)) *
                  ((Tezos_rpc.RPC_service.meth ->
                    (option Tezos_data_encoding.Data_encoding.json) ->
                      Uri.t ->
                        Lwt.t
                          (Tezos_rpc.RPC_context.rest_result
                            Tezos_data_encoding.Data_encoding.json
                            (option Tezos_data_encoding.Data_encoding.json))) *
                    N)))))))) * N)
  (location : Tezos_baking_alpha.Client_baking_files.location O)
  (nonces :
    Tezos_base__TzPervasives.Block_hash.Map.t
      Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        (Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.raw_level *
          Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce))) :=
  let chain := Client_baking_files.chain location in
  op_gtgteqquestion
    (Client_baking_blocks.blocks_from_current_cycle cctxt (Some chain)
      (* ❌ Variants not supported *)
      variant
      (Some
        (* ❌ Constant of type int32 is converted to int *)
        (-1)) tt)
    (fun blocks =>
      filter_map_s
        (fun hash =>
          match find_opt nonces hash with
          | None => return_none
          | Some nonce =>
            op_gtgteq
              (get_block_level_opt cctxt chain
                (* ❌ Variants not supported *)
                variant)
              (fun function_parameter =>
                match function_parameter with
                | Some level =>
                  op_gtgteqquestion
                    (Lwt._return
                      (Environment.wrap_error (Raw_level.of_int32 level)))
                    (fun level =>
                      op_gtgteqquestion
                        (Alpha_services.Nonce.get cctxt
                          (chain,
                            (* ❌ Variants not supported *)
                            variant) level)
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Missing
                              nonce_hash =>
                            op_gtgteq
                              (lwt_log_notice
                                (fun f =>
                                  op_minuspercent
                                    (op_minuspercent
                                      (op_minuspercent
                                        (f
                                          (CamlinternalFormatBasics.Format
                                            (CamlinternalFormatBasics.String_literal
                                              "Found nonce to reveal for " %
                                                string
                                              (CamlinternalFormatBasics.Alpha
                                                (CamlinternalFormatBasics.String_literal
                                                  " (level: " % string
                                                  (CamlinternalFormatBasics.Alpha
                                                    (CamlinternalFormatBasics.Char_literal
                                                      ")" % char
                                                      CamlinternalFormatBasics.End_of_format)))))
                                            "Found nonce to reveal for %a (level: %a)"
                                              % string))
                                        (t event "found_nonce" % string))
                                      (a Block_hash.Logging.tag hash))
                                    (a Logging.level_tag level)))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_some (level, nonce))
                          |
                            Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Missing
                              _nonce_hash =>
                            op_gtgteq
                              (lwt_log_error
                                (fun f =>
                                  op_minuspercent
                                    (op_minuspercent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Incoherent nonce for level " %
                                              string
                                            (CamlinternalFormatBasics.Alpha
                                              CamlinternalFormatBasics.End_of_format))
                                          "Incoherent nonce for level %a" %
                                            string))
                                      (t event "bad_nonce" % string))
                                    (a Logging.level_tag level)))
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_none)
                          |
                            Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Forgotten
                            => return_none
                          |
                            Tezos_protocol_alpha.Protocol.Alpha_services.Nonce.Revealed
                              _ => return_none
                          end))
                | None => return_none
                end)
          end) blocks).

src/proto_alpha/lib_delegate/client_baking_pow.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let default_constant = "\x00\x00\x00\x05"

let is_updated_constant =
  let commit_hash =
    if TzString.is_hex Tezos_version.Current_git_info.commit_hash then
      Hex.to_string (`Hex Tezos_version.Current_git_info.commit_hash)
    else Tezos_version.Current_git_info.commit_hash
  in
  if String.length commit_hash >= 4 then String.sub commit_hash 0 4
  else default_constant

let is_updated_constant_len = String.length is_updated_constant

(* add a version to the pow *)
let init_proof_of_work_nonce () =
  let buf =
    Bytes.make Alpha_context.Constants.proof_of_work_nonce_size '\000'
  in
  Bytes.blit_string is_updated_constant 0 buf 0 is_updated_constant_len ;
  let max_z_len =
    Alpha_context.Constants.proof_of_work_nonce_size - is_updated_constant_len
  in
  let rec aux z =
    let z_len = (Z.numbits z + 7) / 8 in
    if z_len > max_z_len then Seq.Nil
    else (
      Bytes.blit_string (Z.to_bits z) 0 buf is_updated_constant_len z_len ;
      Seq.Cons (buf, fun () -> aux (Z.succ z)) )
  in
  aux Z.zero

(* This was used before November 2018 *)
(* (\* Random proof of work *\)
 * let generate_proof_of_work_nonce () =
 *   Rand.generate Alpha_context.Constants.proof_of_work_nonce_size *)

let empty_proof_of_work_nonce =
  Bytes.make Constants_repr.proof_of_work_nonce_size '\000'

let mine cctxt chain block shell builder =
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun constants ->
  let threshold = constants.parametric.proof_of_work_threshold in
  let rec loop nonce_seq =
    match nonce_seq with
    | Seq.Nil ->
        failwith
          "Client_baking_pow.mine: couldn't find nonce for required proof of \
           work"
    | Seq.Cons (nonce, seq) ->
        let block = builder nonce in
        if Baking.check_header_proof_of_work_stamp shell block threshold then
          return block
        else loop (seq ())
  in
  loop (init_proof_of_work_nonce ())
src/proto_alpha/lib_delegate/client_baking_pow.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition default_constant : string := "" % string.

Definition is_updated_constant : string :=
  let commit_hash :=
    if TzString.is_hex Tezos_version.Current_git_info.commit_hash then
      Hex.to_string
        (* ❌ Variants not supported *)
        variant
    else
      Tezos_version.Current_git_info.commit_hash in
  if OCaml.Stdlib.ge (String.length commit_hash) 4 then
    String.sub commit_hash 0 4
  else
    default_constant.

Definition is_updated_constant_len : Z := String.length is_updated_constant.

Definition init_proof_of_work_nonce (function_parameter : unit)
  : Stdlib.Seq.node string :=
  let 'tt := function_parameter in
  let buf :=
    Stdlib.Bytes.make Alpha_context.Constants.proof_of_work_nonce_size
      "000" % char in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Stdlib.Bytes.blit_string is_updated_constant 0 buf 0 is_updated_constant_len
    in
  let max_z_len :=
    Z.sub Alpha_context.Constants.proof_of_work_nonce_size
      is_updated_constant_len in
  let fix aux (z : Z.t) : Stdlib.Seq.node string :=
    let z_len := Z.div (Z.add (Z.numbits z) 7) 8 in
    if OCaml.Stdlib.gt z_len max_z_len then
      Stdlib.Seq.Nil
    else
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        Stdlib.Bytes.blit_string (Z.to_bits z) 0 buf is_updated_constant_len
          z_len in
      Stdlib.Seq.Cons buf
        (fun function_parameter =>
          let 'tt := function_parameter in
          aux (Z.succ z)) in
  aux Z.zero.

Definition empty_proof_of_work_nonce : string :=
  Stdlib.Bytes.make Constants_repr.proof_of_work_nonce_size "000" % char.

Definition mine {D E F H J L M a b c i o q : Type}
  (cctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      (D * E) ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (F * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        (D * E) ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (H * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          (D * E) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (J * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            (D * E) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (L * a * b * c * q * i * o)) * M)))) * M *
      (D * E)) (chain : D) (block : E)
  (shell : Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header)
  (builder :
    string -> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents) :=
  op_gtgteqquestion (Alpha_services.Constants.all cctxt (chain, block))
    (fun constants =>
      let threshold := proof_of_work_threshold (parametric constants) in
      let fix loop (nonce_seq : Stdlib.Seq.node string)
        : Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents) :=
        match nonce_seq with
        | Stdlib.Seq.Nil =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Client_baking_pow.mine: couldn't find nonce for required proof of work"
                  % string CamlinternalFormatBasics.End_of_format)
              "Client_baking_pow.mine: couldn't find nonce for required proof of work"
                % string)
        | Stdlib.Seq.Cons nonce seq =>
          let block := builder nonce in
          if Baking.check_header_proof_of_work_stamp shell block threshold then
            _return block
          else
            loop (seq tt)
        end in
      loop (init_proof_of_work_nonce tt)).

src/proto_alpha/lib_delegate/client_baking_revelation.ml 89 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.nonce_revelation"
end)

let inject_seed_nonce_revelation (cctxt : #Protocol_client_context.full) ~chain
    ~block ?async nonces =
  Shell_services.Blocks.hash cctxt ~chain ~block ()
  >>=? fun hash ->
  match nonces with
  | [] ->
      lwt_log_notice
        Tag.DSL.(
          fun f ->
            f "Nothing to reveal for block %a"
            -% t event "no_nonce_reveal"
            -% a Block_hash.Logging.tag hash)
      >>= fun () -> return_unit
  | _ ->
      iter_s
        (fun (level, nonce) ->
          Alpha_services.Forge.seed_nonce_revelation
            cctxt
            (chain, block)
            ~branch:hash
            ~level
            ~nonce
            ()
          >>=? fun bytes ->
          let bytes = Signature.concat bytes Signature.zero in
          Shell_services.Injection.operation cctxt ?async ~chain bytes
          >>=? fun oph ->
          lwt_log_notice
            Tag.DSL.(
              fun f ->
                f
                  "Revealing nonce %a from level %a for chain %a, block %a \
                   with operation %a"
                -% t event "reveal_nonce" -% a Logging.nonce_tag nonce
                -% a Logging.level_tag level -% a Logging.chain_tag chain
                -% a Logging.block_tag block
                -% a Operation_hash.Logging.tag oph)
          >>= fun () -> return_unit)
        nonces
src/proto_alpha/lib_delegate/client_baking_revelation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

(* ❌ Structure item `include` not handled. *)
include

Definition inject_seed_nonce_revelation {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (chain : Tezos_shell_services__Block_services.chain)
  (block : Tezos_shell_services__Block_services.block) (async : option bool)
  (nonces :
    list
      (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
        Tezos_raw_protocol_alpha.Alpha_context.Nonce.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (Shell_services.Blocks.hash cctxt (Some chain) (Some block) tt)
    (fun hash =>
      match nonces with
      | [] =>
        op_gtgteq
          (lwt_log_notice
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Nothing to reveal for block " % string
                        (CamlinternalFormatBasics.Alpha
                          CamlinternalFormatBasics.End_of_format))
                      "Nothing to reveal for block %a" % string))
                  (t event "no_nonce_reveal" % string))
                (a Block_hash.Logging.tag hash)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            return_unit)
      | _ =>
        iter_s
          (fun function_parameter =>
            let '(level, nonce) := function_parameter in
            op_gtgteqquestion
              (Alpha_services.Forge.seed_nonce_revelation cctxt (chain, block)
                hash level nonce tt)
              (fun bytes =>
                let bytes := Signature.concat string Signature.zero in
                op_gtgteqquestion
                  (Shell_services.Injection.operation cctxt async (Some chain)
                    string)
                  (fun oph =>
                    op_gtgteq
                      (lwt_log_notice
                        (fun f =>
                          op_minuspercent
                            (op_minuspercent
                              (op_minuspercent
                                (op_minuspercent
                                  (op_minuspercent
                                    (op_minuspercent
                                      (f
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "Revealing nonce " % string
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.String_literal
                                                " from level " % string
                                                (CamlinternalFormatBasics.Alpha
                                                  (CamlinternalFormatBasics.String_literal
                                                    " for chain " % string
                                                    (CamlinternalFormatBasics.Alpha
                                                      (CamlinternalFormatBasics.String_literal
                                                        ", block " % string
                                                        (CamlinternalFormatBasics.Alpha
                                                          (CamlinternalFormatBasics.String_literal
                                                            " with operation " %
                                                              string
                                                            (CamlinternalFormatBasics.Alpha
                                                              CamlinternalFormatBasics.End_of_format))))))))))
                                          "Revealing nonce %a from level %a for chain %a, block %a with operation %a"
                                            % string))
                                      (t event "reveal_nonce" % string))
                                    (a Logging.nonce_tag nonce))
                                  (a Logging.level_tag level))
                                (a Logging.chain_tag chain))
                              (a Logging.block_tag block))
                            (a Operation_hash.Logging.tag oph)))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        return_unit)))) nonces
      end).

src/proto_alpha/lib_delegate/client_baking_scheduling.ml 310 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Internal_event.Legacy_logging.Make_semantic (struct
  let name = Protocol.name ^ ".baking.scheduling"
end)

open Logging

let sleep_until time =
  (* Sleeping is a system op, baking is a protocol op, this is where we convert *)
  let time = Time.System.of_protocol_exn time in
  let delay = Ptime.diff time (Tezos_stdlib_unix.Systime_os.now ()) in
  if Ptime.Span.compare delay Ptime.Span.zero < 0 then None
  else Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay))

let rec wait_for_first_event ~name stream =
  Lwt_stream.get stream
  >>= function
  | None | Some (Error _) ->
      lwt_log_info
        Tag.DSL.(
          fun f ->
            f "Can't fetch the current event. Waiting for new event."
            -% t event "cannot_fetch_event"
            -% t worker_tag name)
      >>= fun () ->
      (* NOTE: this is not a tight loop because of Lwt_stream.get *)
      wait_for_first_event ~name stream
  | Some (Ok bi) ->
      Lwt.return bi

let log_errors_and_continue ~name p =
  p
  >>= function
  | Ok () ->
      Lwt.return_unit
  | Error errs ->
      lwt_log_error
        Tag.DSL.(
          fun f ->
            f "Error while baking:@\n%a"
            -% t event "daemon_error" -% t worker_tag name -% a errs_tag errs)

let main ~(name : string) ~(cctxt : #Protocol_client_context.full)
    ~(stream : 'event tzresult Lwt_stream.t)
    ~(state_maker : 'event -> 'state tzresult Lwt.t)
    ~(pre_loop :
       #Protocol_client_context.full -> 'state -> 'event -> unit tzresult Lwt.t)
    ~(compute_timeout : 'state -> 'timesup Lwt.t)
    ~(timeout_k :
       #Protocol_client_context.full ->
       'state ->
       'timesup ->
       unit tzresult Lwt.t)
    ~(event_k :
       #Protocol_client_context.full -> 'state -> 'event -> unit tzresult Lwt.t)
    =
  lwt_log_info
    Tag.DSL.(
      fun f ->
        f "Setting up before the %s can start."
        -% t event "daemon_setup" -% s worker_tag name)
  >>= fun () ->
  wait_for_first_event ~name stream
  >>= fun first_event ->
  (* statefulness *)
  let last_get_event = ref None in
  let get_event () =
    match !last_get_event with
    | None ->
        let t = Lwt_stream.get stream in
        last_get_event := Some t ;
        t
    | Some t ->
        t
  in
  state_maker first_event
  >>=? fun state ->
  log_errors_and_continue ~name @@ pre_loop cctxt state first_event
  >>= fun () ->
  (* main loop *)
  let rec worker_loop () =
    (* event construction *)
    let timeout = compute_timeout state in
    Lwt.choose
      [ (Lwt_exit.termination_thread >|= fun _ -> `Termination);
        (timeout >|= fun timesup -> `Timeout timesup);
        (get_event () >|= fun e -> `Event e) ]
    >>= function
    (* event matching *)
    | `Termination ->
        return_unit
    | `Event (None | Some (Error _)) ->
        (* exit when the node is unavailable *)
        last_get_event := None ;
        lwt_log_error
          Tag.DSL.(
            fun f ->
              f "Connection to node lost, %s exiting."
              -% t event "daemon_connection_lost"
              -% s worker_tag name)
        >>= fun () -> return_unit
    | `Event (Some (Ok event)) ->
        (* new event: cancel everything and execute callback *)
        last_get_event := None ;
        (* TODO: pretty-print events (requires passing a pp as argument) *)
        log_errors_and_continue ~name @@ event_k cctxt state event
        >>= fun () -> worker_loop ()
    | `Timeout timesup ->
        (* main event: it's time *)
        lwt_debug
          Tag.DSL.(
            fun f ->
              f "Waking up for %s." -% t event "daemon_wakeup"
              -% s worker_tag name)
        >>= fun () ->
        (* core functionality *)
        log_errors_and_continue ~name @@ timeout_k cctxt state timesup
        >>= fun () -> worker_loop ()
  in
  (* ignition *)
  lwt_log_info
    Tag.DSL.(
      fun f ->
        f "Starting %s daemon" -% t event "daemon_start" -% s worker_tag name)
  >>= fun () -> worker_loop ()
src/proto_alpha/lib_delegate/client_baking_scheduling.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Import Logging.

Definition sleep_until (time : Tezos_base__Time.Protocol.t)
  : option (Lwt.t unit) :=
  let time := Time.System.of_protocol_exn time in
  let delay := Ptime.diff time (Tezos_stdlib_unix.Systime_os.now tt) in
  if OCaml.Stdlib.lt (Ptime.Span.compare delay Ptime.Span.zero) 0 then
    None
  else
    Some (Lwt_unix.sleep (Ptime.Span.to_float_s delay)).

Fixpoint wait_for_first_event {A B : Type}
  (name : string) (stream : Lwt_stream.t (sum A B)) : Lwt.t A :=
  op_gtgteq (Lwt_stream.get stream)
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Stdlib.Error _) =>
        op_gtgteq
          (lwt_log_info
            (fun f =>
              op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Can't fetch the current event. Waiting for new event."
                          % string CamlinternalFormatBasics.End_of_format)
                      "Can't fetch the current event. Waiting for new event." %
                        string)) (t event "cannot_fetch_event" % string))
                (t worker_tag name)))
          (fun function_parameter =>
            let 'tt := function_parameter in
            wait_for_first_event name stream)
      | Some (Stdlib.Ok bi) => Lwt._return bi
      end).

Definition log_errors_and_continue
  (name : string) (p : Lwt.t (sum unit Tezos_base__TzPervasives.trace))
  : Lwt.t unit :=
  op_gtgteq p
    (fun function_parameter =>
      match function_parameter with
      | Stdlib.Ok tt => Lwt.return_unit
      | Stdlib.Error errs =>
        lwt_log_error
          (fun f =>
            op_minuspercent
              (op_minuspercent
                (op_minuspercent
                  (f
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Error while baking:" % string
                        (CamlinternalFormatBasics.Formatting_lit
                          CamlinternalFormatBasics.Force_newline
                          (CamlinternalFormatBasics.Alpha
                            CamlinternalFormatBasics.End_of_format)))
                      "Error while baking:@
%a" % string))
                  (t event "daemon_error" % string)) (t worker_tag name))
              (a errs_tag errs))
      end).

Definition main
  {D F H J L M N Q R S T U V X Y Z [ \ ] _ ` a b c event i o op_caret p q state
  timesup : Type}
  (name : string)
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (stream : Lwt_stream.t (Tezos_base__TzPervasives.tzresult event))
  (state_maker : event -> Lwt.t (Tezos_base__TzPervasives.tzresult state))
  (pre_loop :
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (Q * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (R * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (S * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (T * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (U * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (V * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) -> state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (compute_timeout : state -> Lwt.t timesup)
  (timeout_k :
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (X * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (Y * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (Z * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * ([ * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (\ * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (] * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) -> state -> timesup -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  (event_k :
    (((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (op_caret * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (_ * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (` * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (a * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (b * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (c * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) -> state -> event -> Lwt.t (Tezos_base__TzPervasives.tzresult unit))
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    (lwt_log_info
      (fun f =>
        op_minuspercent
          (op_minuspercent
            (f
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Setting up before the " % string
                  (CamlinternalFormatBasics.String
                    CamlinternalFormatBasics.No_padding
                    (CamlinternalFormatBasics.String_literal
                      " can start." % string
                      CamlinternalFormatBasics.End_of_format)))
                "Setting up before the %s can start." % string))
            (t event "daemon_setup" % string)) (s worker_tag name)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteq (wait_for_first_event name stream)
        (fun first_event =>
          let last_get_event := Stdlib.ref None in
          let get_event (function_parameter : unit)
            : Lwt.t (option (Tezos_base__TzPervasives.tzresult event)) :=
            let 'tt := function_parameter in
            match Stdlib.op_exclamation last_get_event with
            | None =>
              let t := Lwt_stream.get stream in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := Stdlib.op_coloneq last_get_event (Some t) in
              t
            | Some t => t
            end in
          op_gtgteqquestion (state_maker first_event)
            (fun state =>
              op_gtgteq
                (apply (log_errors_and_continue name)
                  (pre_loop cctxt state first_event))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let fix worker_loop (function_parameter : unit)
                    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                    let 'tt := function_parameter in
                    let timeout := compute_timeout state in
                    op_gtgteq
                      (Lwt.choose
                        (cons
                          (op_gtpipeeq Lwt_exit.termination_thread
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              (* ❌ Variants not supported *)
                              variant))
                          (cons
                            (op_gtpipeeq timeout
                              (fun timesup =>
                                (* ❌ Variants not supported *)
                                variant))
                            (cons
                              (op_gtpipeeq (get_event tt)
                                (fun e =>
                                  (* ❌ Variants not supported *)
                                  variant)) []))))
                      (fun function_parameter =>
                        match function_parameter with
                        | Termination => return_unit
                        | Event (None | Some (Stdlib.Error _)) =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ := Stdlib.op_coloneq last_get_event None in
                          op_gtgteq
                            (lwt_log_error
                              (fun f =>
                                op_minuspercent
                                  (op_minuspercent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Connection to node lost, " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.String_literal
                                              " exiting." % string
                                              CamlinternalFormatBasics.End_of_format)))
                                        "Connection to node lost, %s exiting." %
                                          string))
                                    (t event "daemon_connection_lost" % string))
                                  (s worker_tag name)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit)
                        | Event (Some (Stdlib.Ok event)) =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ := Stdlib.op_coloneq last_get_event None in
                          op_gtgteq
                            (apply (log_errors_and_continue name)
                              (event_k cctxt state event))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              worker_loop tt)
                        | Timeout timesup =>
                          op_gtgteq
                            (lwt_debug
                              (fun f =>
                                op_minuspercent
                                  (op_minuspercent
                                    (f
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "Waking up for " % string
                                          (CamlinternalFormatBasics.String
                                            CamlinternalFormatBasics.No_padding
                                            (CamlinternalFormatBasics.Char_literal
                                              "." % char
                                              CamlinternalFormatBasics.End_of_format)))
                                        "Waking up for %s." % string))
                                    (t event "daemon_wakeup" % string))
                                  (s worker_tag name)))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteq
                                (apply (log_errors_and_continue name)
                                  (timeout_k cctxt state timesup))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  worker_loop tt))
                        end) in
                  op_gtgteq
                    (lwt_log_info
                      (fun f =>
                        op_minuspercent
                          (op_minuspercent
                            (f
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Starting " % string
                                  (CamlinternalFormatBasics.String
                                    CamlinternalFormatBasics.No_padding
                                    (CamlinternalFormatBasics.String_literal
                                      " daemon" % string
                                      CamlinternalFormatBasics.End_of_format)))
                                "Starting %s daemon" % string))
                            (t event "daemon_start" % string))
                          (s worker_tag name)))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      worker_loop tt))))).

src/proto_alpha/lib_delegate/client_baking_simulator.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol_client_context
open Protocol
open Alpha_context

type error += Failed_to_checkout_context

type error += Invalid_context

let ( >>=?? ) x k = x >>= fun x -> Lwt.return (Environment.wrap_error x) >>=? k

let () =
  register_error_kind
    `Permanent
    ~id:"Client_baking_simulator.failed_to_checkout_context"
    ~title:"Failed to checkout context"
    ~description:"The given context hash does not exists in the context."
    ~pp:(fun ppf () -> Format.fprintf ppf "Failed to checkout the context")
    Data_encoding.unit
    (function Failed_to_checkout_context -> Some () | _ -> None)
    (fun () -> Failed_to_checkout_context) ;
  register_error_kind
    `Permanent
    ~id:"Client_baking_simulator.invalid_context"
    ~title:"Invalid context"
    ~description:"Occurs when the context is inconsistent."
    ~pp:(fun ppf () -> Format.fprintf ppf "The given context is invalid.")
    Data_encoding.unit
    (function Invalid_context -> Some () | _ -> None)
    (fun () -> Invalid_context)

type incremental = {
  predecessor : Client_baking_blocks.block_info;
  context : Tezos_protocol_environment.Context.t;
  state : Protocol.validation_state;
  rev_operations : Operation.packed list;
  header : Tezos_base.Block_header.shell_header;
}

let load_context ~context_path = Context.init ~readonly:true context_path

let check_context_consistency index context_hash =
  (* Hypothesis : the version key exists *)
  let version_key = ["version"] in
  Context.checkout index context_hash
  >>= function
  | None ->
      fail Failed_to_checkout_context
  | Some context -> (
      Context.mem context version_key
      >>= function true -> return_unit | false -> fail Invalid_context )

let begin_construction ~timestamp ?protocol_data index predecessor =
  let {Client_baking_blocks.context; _} = predecessor in
  Shell_context.checkout index context
  >>= function
  | None ->
      fail Failed_to_checkout_context
  | Some context ->
      let header : Tezos_base.Block_header.shell_header =
        Tezos_base.Block_header.
          {
            predecessor = predecessor.hash;
            proto_level = predecessor.proto_level;
            validation_passes = 0;
            fitness = predecessor.fitness;
            timestamp;
            level = Raw_level.to_int32 predecessor.level;
            context = Context_hash.zero;
            operations_hash = Operation_list_list_hash.zero;
          }
      in
      Protocol.begin_construction
        ~chain_id:predecessor.chain_id
        ~predecessor_context:context
        ~predecessor_timestamp:predecessor.timestamp
        ~predecessor_fitness:predecessor.fitness
        ~predecessor_level:(Raw_level.to_int32 predecessor.level)
        ~predecessor:predecessor.hash
        ?protocol_data
        ~timestamp
        ()
      >>=?? fun state ->
      return {predecessor; context; state; rev_operations = []; header}

let add_operation st (op : Operation.packed) =
  Protocol.apply_operation st.state op
  >>=?? fun (state, receipt) ->
  return ({st with state; rev_operations = op :: st.rev_operations}, receipt)

let finalize_construction inc = Protocol.finalize_block inc.state >>=?? return
src/proto_alpha/lib_delegate/client_baking_simulator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol_client_context.

Import Protocol.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition op_gtgteqquestionquestion {A B : Type}
  (x : Lwt.t (Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult A))
  (k : A -> Lwt.t (Tezos_base__TzPervasives.tzresult B))
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  op_gtgteq x
    (fun x => op_gtgteqquestion (Lwt._return (Environment.wrap_error x)) k).



Record incremental := {
  predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info;
  context : Tezos_protocol_environment.Context.t;
  state : Tezos_protocol_alpha.Protocol.validation_state;
  rev_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  header : Tezos_base.Block_header.shell_header }.

Definition load_context (context_path : string)
  : Lwt.t Tezos_storage.Context.index :=
  Context.init None None (Some true) context_path.

Definition check_context_consistency
  (index : Tezos_storage.Context.index)
  (context_hash : Tezos_base__TzPervasives.Context_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let version_key := cons "version" % string [] in
  op_gtgteq (Context.checkout index context_hash)
    (fun function_parameter =>
      match function_parameter with
      | None => fail Tezos_base__TzPervasives.Failed_to_checkout_context
      | Some context =>
        op_gtgteq (Context.mem context version_key)
          (fun function_parameter =>
            match function_parameter with
            | true => return_unit
            | false => fail Tezos_base__TzPervasives.Invalid_context
            end)
      end).

Definition begin_construction
  (timestamp : Tezos_base.Time.Protocol.t)
  (protocol_data : option Tezos_protocol_alpha.Protocol.block_header_data)
  (index : Tezos_storage.Context.index)
  (predecessor : Tezos_baking_alpha.Client_baking_blocks.block_info)
  : Lwt.t (Tezos_base__TzPervasives.tzresult incremental) :=
  let '{| Client_baking_blocks.context := context |} := predecessor in
  op_gtgteq (Shell_context.checkout index context)
    (fun function_parameter =>
      match function_parameter with
      | None => fail Tezos_base__TzPervasives.Failed_to_checkout_context
      | Some context =>
        let header :=
          {| level := Raw_level.to_int32 (level predecessor);
            proto_level := proto_level predecessor;
            predecessor := hash predecessor; timestamp := timestamp;
            validation_passes := 0;
            operations_hash := Operation_list_list_hash.zero;
            fitness := fitness predecessor; context := Context_hash.zero |} in
        op_gtgteqquestionquestion
          (Protocol.begin_construction (chain_id predecessor) context
            (timestamp predecessor) (Raw_level.to_int32 (level predecessor))
            (fitness predecessor) (hash predecessor) timestamp protocol_data tt)
          (fun state =>
            _return
              {| predecessor := predecessor; context := context; state := state;
                rev_operations := []; header := header |})
      end).

Definition add_operation
  (st : incremental)
  (op : Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (incremental * Tezos_protocol_alpha.Protocol.operation_receipt)) :=
  op_gtgteqquestionquestion (Protocol.apply_operation (state st) op)
    (fun function_parameter =>
      let '(state, receipt) := function_parameter in
      _return
        ((* ❌ Record substitution not handled *)
        record_substitution, receipt)).

Definition finalize_construction (inc : incremental)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Updater.validation_result *
        Tezos_protocol_alpha.Protocol.block_header_metadata)) :=
  op_gtgteqquestionquestion (Protocol.finalize_block (state inc)) _return.

src/proto_alpha/lib_delegate/client_daemon.ml 437 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let rec retry (cctxt : #Protocol_client_context.full) ~delay ~tries f x =
  f x
  >>= function
  | Ok _ as r ->
      Lwt.return r
  | Error
      (RPC_client_errors.Request_failed {error = Connection_failed _; _} :: _)
    as err
    when tries > 0 -> (
      cctxt#message "Connection refused, retrying in %.2f seconds..." delay
      >>= fun () ->
      Lwt.pick
        [ (Lwt_unix.sleep delay >|= fun () -> `Continue);
          (Lwt_exit.termination_thread >|= fun _ -> `Killed) ]
      >>= function
      | `Killed ->
          Lwt.return err
      | `Continue ->
          retry cctxt ~delay:(delay *. 1.5) ~tries:(tries - 1) f x )
  | Error _ as err ->
      Lwt.return err

let await_bootstrapped_node (cctxt : #Protocol_client_context.full) =
  (* Waiting for the node to be synchronized *)
  cctxt#message "Waiting for the node to be synchronized with its peers..."
  >>= fun () ->
  retry cctxt ~tries:5 ~delay:1. Shell_services.Monitor.bootstrapped cctxt
  >>=? fun (block_stream, _stopper) ->
  let rec waiting_loop () =
    Lwt_stream.get block_stream
    >>= function None -> Lwt.return_unit | Some _ -> waiting_loop ()
  in
  waiting_loop ()
  >>= fun () -> cctxt#message "Node synchronized." >>= fun () -> return_unit

let monitor_fork_testchain (cctxt : #Protocol_client_context.full)
    ~cleanup_nonces =
  (* Waiting for the node to be synchronized *)
  cctxt#message "Waiting for the test chain to be forked..."
  >>= fun () ->
  Shell_services.Monitor.active_chains cctxt
  >>=? fun (stream, _) ->
  let rec loop () =
    Lwt_stream.next stream
    >>= fun l ->
    let testchain =
      List.find_opt
        (function Shell_services.Monitor.Active_test _ -> true | _ -> false)
        l
    in
    match testchain with
    | Some (Active_test {protocol; expiration_date; _})
      when Protocol_hash.equal Protocol.hash protocol ->
        let abort_daemon () =
          cctxt#message
            "Test chain's expiration date reached (%a)... Stopping the \
             daemon.@."
            Time.Protocol.pp_hum
            expiration_date
          >>= fun () ->
          if cleanup_nonces then
            (* Clean-up existing nonces *)
            cctxt#with_lock (fun () ->
                Client_baking_files.resolve_location cctxt ~chain:`Test `Nonce
                >>=? fun nonces_location ->
                Client_baking_nonces.(save cctxt nonces_location empty))
          else return_unit >>=? fun () -> exit 0
        in
        let canceler = Lwt_canceler.create () in
        Lwt_canceler.on_cancel canceler (fun () ->
            abort_daemon () >>= function _ -> Lwt.return_unit) ;
        let now = Time.System.(to_protocol (Systime_os.now ())) in
        let delay = Int64.to_int (Time.Protocol.diff expiration_date now) in
        if delay <= 0 then (* Testchain already expired... Retrying. *)
          loop ()
        else
          let timeout =
            Lwt_timeout.create delay (fun () ->
                Lwt_canceler.cancel canceler |> ignore)
          in
          Lwt_timeout.start timeout ; return_unit
    | None ->
        loop ()
    | Some _ ->
        loop ()
    (* Got a testchain for a different protocol, skipping *)
  in
  Lwt.pick
    [ (Lwt_exit.termination_thread >>= fun _ -> failwith "Interrupted...");
      loop () ]
  >>=? fun () -> cctxt#message "Test chain forked." >>= fun () -> return_unit

module Endorser = struct
  let run (cctxt : #Protocol_client_context.full) ~chain ~delay delegates =
    await_bootstrapped_node cctxt
    >>=? fun _ ->
    ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:false
    else return_unit )
    >>=? fun () ->
    Client_baking_blocks.monitor_heads
      ~next_protocols:(Some [Protocol.hash])
      cctxt
      chain
    >>=? fun block_stream ->
    cctxt#message "Endorser started."
    >>= fun () ->
    Client_baking_endorsement.create cctxt ~delay delegates block_stream
end

module Baker = struct
  let run (cctxt : #Protocol_client_context.full) ?minimal_fees
      ?minimal_nanotez_per_gas_unit ?minimal_nanotez_per_byte ?max_priority
      ~chain ~context_path delegates =
    await_bootstrapped_node cctxt
    >>=? fun _ ->
    ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true
    else return_unit )
    >>=? fun () ->
    Client_baking_blocks.monitor_heads
      ~next_protocols:(Some [Protocol.hash])
      cctxt
      chain
    >>=? fun block_stream ->
    cctxt#message "Baker started."
    >>= fun () ->
    Client_baking_forge.create
      cctxt
      ?minimal_fees
      ?minimal_nanotez_per_gas_unit
      ?minimal_nanotez_per_byte
      ?max_priority
      ~chain
      ~context_path
      delegates
      block_stream
end

module Accuser = struct
  let run (cctxt : #Protocol_client_context.full) ~chain ~preserved_levels =
    await_bootstrapped_node cctxt
    >>=? fun _ ->
    ( if chain = `Test then monitor_fork_testchain cctxt ~cleanup_nonces:true
    else return_unit )
    >>=? fun () ->
    Client_baking_blocks.monitor_valid_blocks
      ~next_protocols:(Some [Protocol.hash])
      cctxt
      ~chains:[chain]
      ()
    >>=? fun valid_blocks_stream ->
    cctxt#message "Accuser started."
    >>= fun () ->
    Client_baking_denunciation.create
      cctxt
      ~preserved_levels
      valid_blocks_stream
end
src/proto_alpha/lib_delegate/client_daemon.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Fixpoint retry {D F H J L M N O P a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (delay : Z) (tries : Z)
  (f : O -> Lwt.t (sum P (list Tezos_base__TzPervasives.error))) (x : O)
  : Lwt.t (sum P (list Tezos_base__TzPervasives.error)) :=
  op_gtgteq (f x)
    (fun function_parameter =>
      match function_parameter with
      | (Stdlib.Ok _) as r => Lwt._return r
      |
        (Stdlib.Error
          (cons
            (Tezos_base__TzPervasives.Request_failed {|
              error := Tezos_rpc_http.RPC_client_errors.Connection_failed _
                |}) _)) as err =>
        op_gtgteq
          ((* ❌ Sending method message is not handled *)
          send
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Connection refused, retrying in " % string
                (CamlinternalFormatBasics.Float CamlinternalFormatBasics.Float_f
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Lit_precision 2)
                  (CamlinternalFormatBasics.String_literal
                    " seconds..." % string
                    CamlinternalFormatBasics.End_of_format)))
              "Connection refused, retrying in %.2f seconds..." % string) delay)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq
              (Lwt.pick
                (cons
                  (op_gtpipeeq (Lwt_unix.sleep delay)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      (* ❌ Variants not supported *)
                      variant))
                  (cons
                    (op_gtpipeeq Lwt_exit.termination_thread
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        (* ❌ Variants not supported *)
                        variant)) [])))
              (fun function_parameter =>
                match function_parameter with
                | Killed => Lwt._return err
                | Continue =>
                  retry cctxt
                    (Stdlib.op_starpoint delay
                      (* ❌ Float constant 1.5 is approximated by the integer 1 *)
                      1) (Z.sub tries 1) f x
                end))
      | (Stdlib.Error _) as err => Lwt._return err
      end).

Definition await_bootstrapped_node {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    ((* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Waiting for the node to be synchronized with its peers..." % string
          CamlinternalFormatBasics.End_of_format)
        "Waiting for the node to be synchronized with its peers..." % string))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (retry cctxt
          (* ❌ Float constant 1. is approximated by the integer 1 *)
          1 5 Shell_services.Monitor.bootstrapped cctxt)
        (fun function_parameter =>
          let '(block_stream, _stopper) := function_parameter in
          let fix waiting_loop (function_parameter : unit) : Lwt.t unit :=
            let 'tt := function_parameter in
            op_gtgteq (Lwt_stream.get block_stream)
              (fun function_parameter =>
                match function_parameter with
                | None => Lwt.return_unit
                | Some _ => waiting_loop tt
                end) in
          op_gtgteq (waiting_loop tt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Node synchronized." % string
                      CamlinternalFormatBasics.End_of_format)
                    "Node synchronized." % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)))).

Definition monitor_fork_testchain {D F H J L M N a b c i o p q : Type}
  (cctxt :
    ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
      (Tezos_shell_services.Shell_services.chain *
        Tezos_shell_services.Shell_services.block) ->
        q ->
          i ->
            Tezos_protocol_alpha.Protocol.Environment.Lwt.t
              (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                o)) * (D * q * i * o)) *
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          a ->
            q ->
              i ->
                Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                  (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                    o)) * (F * a * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q
          i o) ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                      (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                        o)) * (H * a * b * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
              * c) q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                          (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                            o)) * (J * a * b * c * q * i * o)) *
            ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) * (a))
              *
              (Uri.t *
                (Tezos_shell_services.Shell_services.block *
                  ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                    p ->
                      q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                    * (L * p * q * i * o)) *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      (o -> unit) ->
                        (unit -> unit) ->
                          p ->
                            q ->
                              i ->
                                Lwt.t
                                  (Tezos_error_monad.Error_monad.tzresult
                                    (unit -> unit))) * (M * p * q * i * o)) *
                      (Tezos_shell_services.Shell_services.chain *
                        ((option Z) *
                          ((((Tezos_client_base.Client_context.lwt_format a b)
                            -> a) * (a * b)) *
                            ((Tezos_rpc.RPC_service.meth ->
                              (option Tezos_data_encoding.Data_encoding.json) ->
                                Uri.t ->
                                  Lwt.t
                                    (Tezos_rpc.RPC_context.rest_result
                                      Tezos_data_encoding.Data_encoding.json
                                      (option
                                        Tezos_data_encoding.Data_encoding.json)))
                              *
                              (((string ->
                                a ->
                                  (Tezos_base__TzPervasives.Data_encoding.encoding
                                    a) ->
                                    Lwt.t (Tezos_base__TzPervasives.tzresult a))
                                * (a)) *
                                ((option (Lwt_stream.t string)) *
                                  (((string ->
                                    (Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                    ((((Tezos_client_base.Client_context.lwt_format
                                      a unit) -> a) * (a)) *
                                      ((unit -> Ptime.t) *
                                        ((((Tezos_client_base.Client_context.lwt_format
                                          a
                                          (Tezos_base__TzPervasives.tzresult
                                            string)) -> a) * (a)) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              Bigstring.t)) -> a) * (a)) *
                                            ((string ->
                                              Lwt.t
                                                (Tezos_base__TzPervasives.tzresult
                                                  string)) *
                                              ((Z -> Lwt.t unit) *
                                                ((((Tezos_client_base.Client_context.lwt_format
                                                  a unit) -> a) * (a)) *
                                                  ((((unit -> Lwt.t a) ->
                                                    Lwt.t a) * (a)) *
                                                    (((string ->
                                                      a ->
                                                        (Tezos_base__TzPervasives.Data_encoding.encoding
                                                          a) ->
                                                          Lwt.t
                                                            (Tezos_base__TzPervasives.tzresult
                                                              unit)) * (a)) * N)))))))))))))))))))))))))
      * N) (cleanup_nonces : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteq
    ((* ❌ Sending method message is not handled *)
    send
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Waiting for the test chain to be forked..." % string
          CamlinternalFormatBasics.End_of_format)
        "Waiting for the test chain to be forked..." % string))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (Shell_services.Monitor.active_chains cctxt)
        (fun function_parameter =>
          let '(stream, _) := function_parameter in
          let fix loop (function_parameter : unit)
            : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
            let 'tt := function_parameter in
            op_gtgteq (Lwt_stream.next stream)
              (fun l =>
                let testchain :=
                  List.find_opt
                    (fun function_parameter =>
                      match function_parameter with
                      |
                        Tezos_shell_services.Shell_services.Monitor.Active_test
                          _ => true
                      | _ => false
                      end) l in
                match testchain with
                |
                  Some
                    (Tezos_shell_services.Shell_services.Monitor.Active_test {|
                      protocol := protocol;
                        expiration_date := expiration_date
                        |}) =>
                  let abort_daemon (function_parameter : unit)
                    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
                    let 'tt := function_parameter in
                    op_gtgteq
                      ((* ❌ Sending method message is not handled *)
                      send
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Test chain's expiration date reached (" % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                ")... Stopping the daemon." % string
                                (CamlinternalFormatBasics.Formatting_lit
                                  CamlinternalFormatBasics.Flush_newline
                                  CamlinternalFormatBasics.End_of_format))))
                          "Test chain's expiration date reached (%a)... Stopping the daemon.@."
                            % string) Time.Protocol.pp_hum expiration_date)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        if cleanup_nonces then
                          (* ❌ Sending method message is not handled *)
                          send
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (Client_baking_files.resolve_location cctxt
                                  (* ❌ Variants not supported *)
                                  variant
                                  (* ❌ Variants not supported *)
                                  variant)
                                (fun nonces_location =>
                                  save cctxt nonces_location empty))
                        else
                          op_gtgteqquestion return_unit
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              Stdlib.exit 0)) in
                  let canceler := Lwt_canceler.create tt in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Lwt_canceler.on_cancel canceler
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (abort_daemon tt)
                          (fun function_parameter =>
                            let '_ := function_parameter in
                            Lwt.return_unit)) in
                  let now := to_protocol (Systime_os.now tt) in
                  let delay :=
                    Int64.to_int (Time.Protocol.diff expiration_date now) in
                  if OCaml.Stdlib.le delay 0 then
                    loop tt
                  else
                    let timeout :=
                      Lwt_timeout.create delay
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          OCaml.Stdlib.reverse_apply
                            (Lwt_canceler.cancel canceler) OCaml.Stdlib.ignore)
                      in
                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                    let _ := Lwt_timeout.start timeout in
                    return_unit
                | None => loop tt
                | Some _ => loop tt
                end) in
          op_gtgteqquestion
            (Lwt.pick
              (cons
                (op_gtgteq Lwt_exit.termination_thread
                  (fun function_parameter =>
                    let '_ := function_parameter in
                    failwith
                      (CamlinternalFormatBasics.Format
                        (CamlinternalFormatBasics.String_literal
                          "Interrupted..." % string
                          CamlinternalFormatBasics.End_of_format)
                        "Interrupted..." % string))) (cons (loop tt) [])))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq
                ((* ❌ Sending method message is not handled *)
                send
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Test chain forked." % string
                      CamlinternalFormatBasics.End_of_format)
                    "Test chain forked." % string))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  return_unit)))).

Module Endorser.
  Definition run {D F H J L M N a b c i o p q : Type}
    (cctxt :
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((Z -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        N)))))))))))))))))))))))))
        * N) (chain : variant) (delay : Z)
    (delegates :
      list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (await_bootstrapped_node cctxt)
      (fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteqquestion
          (if
            equiv_decb chain
              (* ❌ Variants not supported *)
              variant then
            monitor_fork_testchain cctxt false
          else
            return_unit)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Client_baking_blocks.monitor_heads cctxt
                (Some (cons Protocol.hash [])) chain)
              (fun block_stream =>
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Endorser started." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Endorser started." % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Client_baking_endorsement.create cctxt None delay delegates
                      block_stream)))).
End Endorser.

Module Baker.
  Definition run {D F H J L M N a b c i o p q : Type}
    (cctxt :
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((Z -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        N)))))))))))))))))))))))))
        * N)
    (minimal_fees : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
    (minimal_nanotez_per_gas_unit : option Z.t)
    (minimal_nanotez_per_byte : option Z.t) (max_priority : option Z)
    (chain : variant) (context_path : string)
    (delegates :
      list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (await_bootstrapped_node cctxt)
      (fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteqquestion
          (if
            equiv_decb chain
              (* ❌ Variants not supported *)
              variant then
            monitor_fork_testchain cctxt true
          else
            return_unit)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Client_baking_blocks.monitor_heads cctxt
                (Some (cons Protocol.hash [])) chain)
              (fun block_stream =>
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Baker started." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Baker started." % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Client_baking_forge.create cctxt minimal_fees
                      minimal_nanotez_per_gas_unit minimal_nanotez_per_byte
                      max_priority chain context_path delegates block_stream)))).
End Baker.

Module Accuser.
  Definition run {D F H J L M N a b c i o p q : Type}
    (cctxt :
      ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
        (Tezos_shell_services.Shell_services.chain *
          Tezos_shell_services.Shell_services.block) ->
          q ->
            i ->
              Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                  o)) * (D * q * i * o)) *
        ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o)
          ->
          (Tezos_shell_services.Shell_services.chain *
            Tezos_shell_services.Shell_services.block) ->
            a ->
              q ->
                i ->
                  Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                    (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                      o)) * (F * a * q * i * o)) *
          ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
            Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
            ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b)
            q i o) ->
            (Tezos_shell_services.Shell_services.chain *
              Tezos_shell_services.Shell_services.block) ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                        (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                          o)) * (H * a * b * q * i * o)) *
            ((((Tezos_protocol_alpha.Protocol.Environment.RPC_service.t variant
              Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
              (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) *
                b) * c) q i o) ->
              (Tezos_shell_services.Shell_services.chain *
                Tezos_shell_services.Shell_services.block) ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_alpha.Protocol.Environment.Lwt.t
                            (Tezos_protocol_alpha.Protocol.Environment.Error_monad.shell_tzresult
                              o)) * (J * a * b * c * q * i * o)) *
              ((((Tezos_client_base.Client_context.lwt_format a unit) -> a) *
                (a)) *
                (Uri.t *
                  (Tezos_shell_services.Shell_services.block *
                    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                      p ->
                        q ->
                          i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o))
                      * (L * p * q * i * o)) *
                      ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
                        (o -> unit) ->
                          (unit -> unit) ->
                            p ->
                              q ->
                                i ->
                                  Lwt.t
                                    (Tezos_error_monad.Error_monad.tzresult
                                      (unit -> unit))) * (M * p * q * i * o)) *
                        (Tezos_shell_services.Shell_services.chain *
                          ((option Z) *
                            ((((Tezos_client_base.Client_context.lwt_format a b)
                              -> a) * (a * b)) *
                              ((Tezos_rpc.RPC_service.meth ->
                                (option Tezos_data_encoding.Data_encoding.json)
                                  ->
                                  Uri.t ->
                                    Lwt.t
                                      (Tezos_rpc.RPC_context.rest_result
                                        Tezos_data_encoding.Data_encoding.json
                                        (option
                                          Tezos_data_encoding.Data_encoding.json)))
                                *
                                (((string ->
                                  a ->
                                    (Tezos_base__TzPervasives.Data_encoding.encoding
                                      a) ->
                                      Lwt.t
                                        (Tezos_base__TzPervasives.tzresult a)) *
                                  (a)) *
                                  ((option (Lwt_stream.t string)) *
                                    (((string ->
                                      (Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                      ((((Tezos_client_base.Client_context.lwt_format
                                        a unit) -> a) * (a)) *
                                        ((unit -> Ptime.t) *
                                          ((((Tezos_client_base.Client_context.lwt_format
                                            a
                                            (Tezos_base__TzPervasives.tzresult
                                              string)) -> a) * (a)) *
                                            ((((Tezos_client_base.Client_context.lwt_format
                                              a
                                              (Tezos_base__TzPervasives.tzresult
                                                Bigstring.t)) -> a) * (a)) *
                                              ((string ->
                                                Lwt.t
                                                  (Tezos_base__TzPervasives.tzresult
                                                    string)) *
                                                ((Z -> Lwt.t unit) *
                                                  ((((Tezos_client_base.Client_context.lwt_format
                                                    a unit) -> a) * (a)) *
                                                    ((((unit -> Lwt.t a) ->
                                                      Lwt.t a) * (a)) *
                                                      (((string ->
                                                        a ->
                                                          (Tezos_base__TzPervasives.Data_encoding.encoding
                                                            a) ->
                                                            Lwt.t
                                                              (Tezos_base__TzPervasives.tzresult
                                                                unit)) * (a)) *
                                                        N)))))))))))))))))))))))))
        * N) (chain : variant) (preserved_levels : Z)
    : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
    op_gtgteqquestion (await_bootstrapped_node cctxt)
      (fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteqquestion
          (if
            equiv_decb chain
              (* ❌ Variants not supported *)
              variant then
            monitor_fork_testchain cctxt true
          else
            return_unit)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Client_baking_blocks.monitor_valid_blocks cctxt
                (Some (cons chain [])) None (Some (cons Protocol.hash [])) tt)
              (fun valid_blocks_stream =>
                op_gtgteq
                  ((* ❌ Sending method message is not handled *)
                  send
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "Accuser started." % string
                        CamlinternalFormatBasics.End_of_format)
                      "Accuser started." % string))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Client_baking_denunciation.create cctxt preserved_levels
                      valid_blocks_stream)))).
End Accuser.

src/proto_alpha/lib_delegate/delegate_commands.ml 40 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Client_proto_args
open Client_baking_lib

let group =
  {Clic.name = "delegate"; title = "Commands related to delegate operations."}

let directory_parameter =
  Clic.parameter (fun _ p ->
      if not (Sys.file_exists p && Sys.is_directory p) then
        failwith "Directory doesn't exist: '%s'" p
      else return p)

let mempool_arg =
  Clic.arg
    ~long:"mempool"
    ~placeholder:"file"
    ~doc:
      "When used the client will read the mempool in the provided file \
       instead of querying the node through an RPC (useful for debugging \
       only)."
    string_parameter

let context_path_arg =
  Clic.arg
    ~long:"context"
    ~placeholder:"path"
    ~doc:
      "When use the client will read in the local context at the provided \
       path in order to build the block, instead of relying on the 'preapply' \
       RPC."
    string_parameter

let pidfile_arg =
  Clic.arg
    ~doc:"write process id in file"
    ~short:'P'
    ~long:"pidfile"
    ~placeholder:"filename"
    (Clic.parameter (fun _ s -> return s))

let may_lock_pidfile = function
  | None ->
      return_unit
  | Some pidfile ->
      trace (failure "Failed to create the pidfile: %s" pidfile)
      @@ Lwt_lock_file.create ~unlink_on_exit:true pidfile

let block_param t =
  Clic.param
    ~name:"block"
    ~desc:"commitment blocks whose nonce should be revealed"
    (Clic.parameter (fun _ str -> Lwt.return (Block_hash.of_b58check str)))
    t

let delegate_commands () =
  let open Clic in
  [ command
      ~group
      ~desc:"Forge and inject block using the delegate rights."
      (args8
         max_priority_arg
         minimal_fees_arg
         minimal_nanotez_per_gas_unit_arg
         minimal_nanotez_per_byte_arg
         force_switch
         minimal_timestamp_switch
         mempool_arg
         context_path_arg)
      ( prefixes ["bake"; "for"]
      @@ Client_keys.Public_key_hash.source_param
           ~name:"baker"
           ~desc:"name of the delegate owning the baking right"
      @@ stop )
      (fun ( max_priority,
             minimal_fees,
             minimal_nanotez_per_gas_unit,
             minimal_nanotez_per_byte,
             force,
             minimal_timestamp,
             mempool,
             context_path )
           delegate
           cctxt ->
        bake_block
          cctxt
          ~minimal_fees
          ~minimal_nanotez_per_gas_unit
          ~minimal_nanotez_per_byte
          ~force
          ?max_priority
          ~minimal_timestamp
          ?mempool
          ?context_path
          ~chain:cctxt#chain
          ~head:cctxt#block
          delegate);
    command
      ~group
      ~desc:"Forge and inject a seed-nonce revelation operation."
      no_options
      (prefixes ["reveal"; "nonce"; "for"] @@ seq_of_param block_param)
      (fun () block_hashes cctxt ->
        reveal_block_nonces
          cctxt
          ~chain:cctxt#chain
          ~block:cctxt#block
          block_hashes);
    command
      ~group
      ~desc:
        "Forge and inject all the possible seed-nonce revelation operations."
      no_options
      (prefixes ["reveal"; "nonces"] @@ stop)
      (fun () cctxt ->
        reveal_nonces ~chain:cctxt#chain ~block:cctxt#block cctxt ());
    command
      ~group
      ~desc:"Forge and inject an endorsement operation."
      no_options
      ( prefixes ["endorse"; "for"]
      @@ Client_keys.Public_key_hash.source_param
           ~name:"baker"
           ~desc:"name of the delegate owning the endorsement right"
      @@ stop )
      (fun () delegate cctxt ->
        endorse_block cctxt ~chain:cctxt#chain delegate);
    command
      ~group
      ~desc:
        "Clear the nonces file by removing the nonces which blocks cannot be \
         found on the chain."
      no_options
      (prefixes ["filter"; "orphan"; "nonces"] @@ stop)
      (fun () (cctxt : #Protocol_client_context.full) ->
        cctxt#with_lock (fun () ->
            let chain = cctxt#chain in
            Client_baking_files.resolve_location cctxt ~chain `Nonce
            >>=? fun nonces_location ->
            let open Client_baking_nonces in
            (* Filtering orphan nonces *)
            load cctxt nonces_location
            >>=? fun nonces ->
            Block_hash.Map.fold
              (fun block nonce acc ->
                acc
                >>= fun acc ->
                Shell_services.Blocks.Header.shell_header
                  cctxt
                  ~chain
                  ~block:(`Hash (block, 0))
                  ()
                >>= function
                | Ok _ ->
                    Lwt.return acc
                | Error _ ->
                    Lwt.return (Block_hash.Map.add block nonce acc))
              nonces
              (Lwt.return empty)
            >>= fun orphans ->
            if Block_hash.Map.cardinal orphans = 0 then
              cctxt#message "No orphan nonces found." >>= fun () -> return_unit
            else
              (* "Backup-ing" orphan nonces *)
              let orphan_nonces_file = "orphan_nonce" in
              cctxt#load orphan_nonces_file ~default:empty encoding
              >>=? fun orphan_nonces ->
              let orphan_nonces = add_all orphan_nonces orphans in
              cctxt#write orphan_nonces_file orphan_nonces encoding
              >>=? fun () ->
              (* Don't forget the 's'. *)
              let orphan_nonces_file = orphan_nonces_file ^ "s" in
              cctxt#message
                "Successfully filtered %d orphan nonces and moved them to \
                 '$TEZOS_CLIENT/%s'."
                (Block_hash.Map.cardinal orphans)
                orphan_nonces_file
              >>= fun () ->
              let filtered_nonces =
                Client_baking_nonces.remove_all nonces orphans
              in
              save cctxt nonces_location filtered_nonces
              >>=? fun () -> return_unit));
    command
      ~group
      ~desc:"List orphan nonces."
      no_options
      (prefixes ["list"; "orphan"; "nonces"] @@ stop)
      (fun () (cctxt : #Protocol_client_context.full) ->
        cctxt#with_lock (fun () ->
            let open Client_baking_nonces in
            let orphan_nonces_file = "orphan_nonce" in
            cctxt#load orphan_nonces_file ~default:empty encoding
            >>=? fun orphan_nonces ->
            let block_hashes =
              List.map fst (Block_hash.Map.bindings orphan_nonces)
            in
            cctxt#message
              "@[<v 2>Found %d orphan nonces associated to the potentially \
               unknown following blocks:@ %a@]"
              (Block_hash.Map.cardinal orphan_nonces)
              (Format.pp_print_list ~pp_sep:Format.pp_print_cut Block_hash.pp)
              block_hashes
            >>= fun () -> return_unit)) ]

let baker_commands () =
  let open Clic in
  let group =
    {
      Clic.name = "delegate.baker";
      title = "Commands related to the baker daemon.";
    }
  in
  [ command
      ~group
      ~desc:"Launch the baker daemon."
      (args5
         pidfile_arg
         max_priority_arg
         minimal_fees_arg
         minimal_nanotez_per_gas_unit_arg
         minimal_nanotez_per_byte_arg)
      ( prefixes ["run"; "with"; "local"; "node"]
      @@ param
           ~name:"context_path"
           ~desc:"Path to the node data directory (e.g. $HOME/.tezos-node)"
           directory_parameter
      @@ seq_of_param Client_keys.Public_key_hash.alias_param )
      (fun ( pidfile,
             max_priority,
             minimal_fees,
             minimal_nanotez_per_gas_unit,
             minimal_nanotez_per_byte )
           node_path
           delegates
           cctxt ->
        may_lock_pidfile pidfile
        >>=? fun () ->
        Tezos_signer_backends.Encrypted.decrypt_list
          cctxt
          (List.map fst delegates)
        >>=? fun () ->
        Client_daemon.Baker.run
          cctxt
          ~chain:cctxt#chain
          ~minimal_fees
          ~minimal_nanotez_per_gas_unit
          ~minimal_nanotez_per_byte
          ?max_priority
          ~context_path:(Filename.concat node_path "context")
          (List.map snd delegates)) ]

let endorser_commands () =
  let open Clic in
  let group =
    {
      Clic.name = "delegate.endorser";
      title = "Commands related to endorser daemon.";
    }
  in
  [ command
      ~group
      ~desc:"Launch the endorser daemon"
      (args2 pidfile_arg endorsement_delay_arg)
      (prefixes ["run"] @@ seq_of_param Client_keys.Public_key_hash.alias_param)
      (fun (pidfile, endorsement_delay) delegates cctxt ->
        may_lock_pidfile pidfile
        >>=? fun () ->
        Tezos_signer_backends.Encrypted.decrypt_list
          cctxt
          (List.map fst delegates)
        >>=? fun () ->
        let delegates = List.map snd delegates in
        let delegates_no_duplicates =
          Signature.Public_key_hash.Set.(delegates |> of_list |> elements)
        in
        ( if List.length delegates <> List.length delegates_no_duplicates then
          cctxt#message
            "Warning: the list of public key hash aliases contains duplicate \
             hashes, which are ignored"
        else Lwt.return () )
        >>= fun () ->
        Client_daemon.Endorser.run
          cctxt
          ~chain:cctxt#chain
          ~delay:endorsement_delay
          delegates_no_duplicates) ]

let accuser_commands () =
  let open Clic in
  let group =
    {
      Clic.name = "delegate.accuser";
      title = "Commands related to the accuser daemon.";
    }
  in
  [ command
      ~group
      ~desc:"Launch the accuser daemon"
      (args2 pidfile_arg preserved_levels_arg)
      (prefixes ["run"] @@ stop)
      (fun (pidfile, preserved_levels) cctxt ->
        may_lock_pidfile pidfile
        >>=? fun () ->
        Client_daemon.Accuser.run ~chain:cctxt#chain ~preserved_levels cctxt)
  ]
src/proto_alpha/lib_delegate/delegate_commands.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Client_proto_args.

Import Client_baking_lib.

Definition group : Tezos_base__TzPervasives.Clic.group :=
  {| Clic.name := "delegate" % string;
    Clic.title := "Commands related to delegate operations." % string |}.

Definition directory_parameter
  : Tezos_base__TzPervasives.Clic.parameter string
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun p =>
        if negb (andb (Sys.file_exists p) (Sys.is_directory p)) then
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Directory doesn't exist: '" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal "'" % char
                    CamlinternalFormatBasics.End_of_format)))
              "Directory doesn't exist: '%s'" % string) p
        else
          _return p).

Definition mempool_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.arg
    "When used the client will read the mempool in the provided file instead of querying the node through an RPC (useful for debugging only)."
      % string None "mempool" % string "file" % string string_parameter.

Definition context_path_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.arg
    "When use the client will read in the local context at the provided path in order to build the block, instead of relying on the 'preapply' RPC."
      % string None "context" % string "path" % string string_parameter.

Definition pidfile_arg
  : Tezos_base__TzPervasives.Clic.arg (option string)
    Tezos_client_alpha.Protocol_client_context.full :=
  Clic.arg "write process id in file" % string (Some "P" % char)
    "pidfile" % string "filename" % string
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun s => _return s)).

Definition may_lock_pidfile (function_parameter : option string)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match function_parameter with
  | None => return_unit
  | Some pidfile =>
    apply
      (trace
        (failure
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Failed to create the pidfile: " % string
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.End_of_format))
            "Failed to create the pidfile: %s" % string) pidfile))
      (Lwt_lock_file.create None (Some true) pidfile)
  end.

Definition block_param {A B : Type}
  (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Block_hash.t -> A) B :=
  Clic.param "block" % string
    "commitment blocks whose nonce should be revealed" % string
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun str => Lwt._return (Block_hash.of_b58check str))) t.

Definition delegate_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  cons
    (command (Some group)
      "Forge and inject block using the delegate rights." % string
      (args8 max_priority_arg minimal_fees_arg minimal_nanotez_per_gas_unit_arg
        minimal_nanotez_per_byte_arg force_switch minimal_timestamp_switch
        mempool_arg context_path_arg)
      (apply (prefixes (cons "bake" % string (cons "for" % string [])))
        (apply
          (Client_keys.Public_key_hash.source_param (Some "baker" % string)
            (Some "name of the delegate owning the baking right" % string)) stop))
      (fun function_parameter =>
        let
          '(max_priority, minimal_fees, minimal_nanotez_per_gas_unit,
            minimal_nanotez_per_byte, force, minimal_timestamp, mempool,
            context_path) := function_parameter in
        fun delegate =>
          fun cctxt =>
            bake_block cctxt (Some minimal_fees)
              (Some minimal_nanotez_per_gas_unit)
              (Some minimal_nanotez_per_byte) (Some force) max_priority
              (Some minimal_timestamp) mempool context_path None
              (* ❌ Sending method message is not handled *)
              send
              (* ❌ Sending method message is not handled *)
              send delegate))
    (cons
      (command (Some group)
        "Forge and inject a seed-nonce revelation operation." % string
        no_options
        (apply
          (prefixes
            (cons "reveal" % string
              (cons "nonce" % string (cons "for" % string []))))
          (seq_of_param block_param))
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun block_hashes =>
            fun cctxt =>
              reveal_block_nonces cctxt
                (* ❌ Sending method message is not handled *)
                send
                (* ❌ Sending method message is not handled *)
                send block_hashes))
      (cons
        (command (Some group)
          "Forge and inject all the possible seed-nonce revelation operations."
            % string no_options
          (apply (prefixes (cons "reveal" % string (cons "nonces" % string [])))
            stop)
          (fun function_parameter =>
            let 'tt := function_parameter in
            fun cctxt =>
              reveal_nonces cctxt
                (* ❌ Sending method message is not handled *)
                send
                (* ❌ Sending method message is not handled *)
                send tt))
        (cons
          (command (Some group)
            "Forge and inject an endorsement operation." % string no_options
            (apply (prefixes (cons "endorse" % string (cons "for" % string [])))
              (apply
                (Client_keys.Public_key_hash.source_param
                  (Some "baker" % string)
                  (Some
                    "name of the delegate owning the endorsement right" % string))
                stop))
            (fun function_parameter =>
              let 'tt := function_parameter in
              fun delegate =>
                fun cctxt =>
                  endorse_block cctxt
                    (* ❌ Sending method message is not handled *)
                    send delegate))
          (cons
            (command (Some group)
              "Clear the nonces file by removing the nonces which blocks cannot be found on the chain."
                % string no_options
              (apply
                (prefixes
                  (cons "filter" % string
                    (cons "orphan" % string (cons "nonces" % string [])))) stop)
              (fun function_parameter =>
                let 'tt := function_parameter in
                fun cctxt =>
                  (* ❌ Sending method message is not handled *)
                  send
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let chain :=
                        (* ❌ Sending method message is not handled *)
                        send in
                      op_gtgteqquestion
                        (Client_baking_files.resolve_location cctxt chain
                          (* ❌ Variants not supported *)
                          variant)
                        (fun nonces_location =>
                          op_gtgteqquestion (load cctxt nonces_location)
                            (fun nonces =>
                              op_gtgteq
                                (Block_hash.Map.fold
                                  (fun block =>
                                    fun nonce =>
                                      fun acc =>
                                        op_gtgteq acc
                                          (fun acc =>
                                            op_gtgteq
                                              (Shell_services.Blocks.Header.shell_header
                                                cctxt (Some chain)
                                                (Some
                                                  (* ❌ Variants not supported *)
                                                  variant) tt)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | Stdlib.Ok _ => Lwt._return acc
                                                | Stdlib.Error _ =>
                                                  Lwt._return
                                                    (Block_hash.Map.add block
                                                      nonce acc)
                                                end))) nonces
                                  (Lwt._return empty))
                                (fun orphans =>
                                  if
                                    equiv_decb (Block_hash.Map.cardinal orphans)
                                      0 then
                                    op_gtgteq
                                      ((* ❌ Sending method message is not handled *)
                                      send
                                        (CamlinternalFormatBasics.Format
                                          (CamlinternalFormatBasics.String_literal
                                            "No orphan nonces found." % string
                                            CamlinternalFormatBasics.End_of_format)
                                          "No orphan nonces found." % string))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        return_unit)
                                  else
                                    let orphan_nonces_file :=
                                      "orphan_nonce" % string in
                                    op_gtgteqquestion
                                      ((* ❌ Sending method message is not handled *)
                                      send orphan_nonces_file empty encoding)
                                      (fun orphan_nonces =>
                                        let orphan_nonces :=
                                          add_all orphan_nonces orphans in
                                        op_gtgteqquestion
                                          ((* ❌ Sending method message is not handled *)
                                          send orphan_nonces_file orphan_nonces
                                            encoding)
                                          (fun function_parameter =>
                                            let 'tt := function_parameter in
                                            let orphan_nonces_file :=
                                              String.append orphan_nonces_file
                                                "s" % string in
                                            op_gtgteq
                                              ((* ❌ Sending method message is not handled *)
                                              send
                                                (CamlinternalFormatBasics.Format
                                                  (CamlinternalFormatBasics.String_literal
                                                    "Successfully filtered " %
                                                      string
                                                    (CamlinternalFormatBasics.Int
                                                      CamlinternalFormatBasics.Int_d
                                                      CamlinternalFormatBasics.No_padding
                                                      CamlinternalFormatBasics.No_precision
                                                      (CamlinternalFormatBasics.String_literal
                                                        " orphan nonces and moved them to '$TEZOS_CLIENT/"
                                                          % string
                                                        (CamlinternalFormatBasics.String
                                                          CamlinternalFormatBasics.No_padding
                                                          (CamlinternalFormatBasics.String_literal
                                                            "'." % string
                                                            CamlinternalFormatBasics.End_of_format)))))
                                                  "Successfully filtered %d orphan nonces and moved them to '$TEZOS_CLIENT/%s'."
                                                    % string)
                                                (Block_hash.Map.cardinal orphans)
                                                orphan_nonces_file)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                let filtered_nonces :=
                                                  Client_baking_nonces.remove_all
                                                    nonces orphans in
                                                op_gtgteqquestion
                                                  (save cctxt nonces_location
                                                    filtered_nonces)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    return_unit))))))))))
            (cons
              (command (Some group) "List orphan nonces." % string no_options
                (apply
                  (prefixes
                    (cons "list" % string
                      (cons "orphan" % string (cons "nonces" % string []))))
                  stop)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  fun cctxt =>
                    (* ❌ Sending method message is not handled *)
                    send
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        let orphan_nonces_file := "orphan_nonce" % string in
                        op_gtgteqquestion
                          ((* ❌ Sending method message is not handled *)
                          send orphan_nonces_file empty encoding)
                          (fun orphan_nonces =>
                            let block_hashes :=
                              List.map fst
                                (Block_hash.Map.bindings orphan_nonces) in
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.Formatting_gen
                                    (CamlinternalFormatBasics.Open_box
                                      (CamlinternalFormatBasics.Format
                                        (CamlinternalFormatBasics.String_literal
                                          "<v 2>" % string
                                          CamlinternalFormatBasics.End_of_format)
                                        "<v 2>" % string))
                                    (CamlinternalFormatBasics.String_literal
                                      "Found " % string
                                      (CamlinternalFormatBasics.Int
                                        CamlinternalFormatBasics.Int_d
                                        CamlinternalFormatBasics.No_padding
                                        CamlinternalFormatBasics.No_precision
                                        (CamlinternalFormatBasics.String_literal
                                          " orphan nonces associated to the potentially unknown following blocks:"
                                            % string
                                          (CamlinternalFormatBasics.Formatting_lit
                                            (CamlinternalFormatBasics.Break
                                              "@ " % string 1 0)
                                            (CamlinternalFormatBasics.Alpha
                                              (CamlinternalFormatBasics.Formatting_lit
                                                CamlinternalFormatBasics.Close_box
                                                CamlinternalFormatBasics.End_of_format)))))))
                                  "@[<v 2>Found %d orphan nonces associated to the potentially unknown following blocks:@ %a@]"
                                    % string)
                                (Block_hash.Map.cardinal orphan_nonces)
                                (Format.pp_print_list (Some Format.pp_print_cut)
                                  Block_hash.pp) block_hashes)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit))))) []))))).

Definition baker_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  let group :=
    {| Clic.name := "delegate.baker" % string;
      Clic.title := "Commands related to the baker daemon." % string |} in
  cons
    (command (Some group) "Launch the baker daemon." % string
      (args5 pidfile_arg max_priority_arg minimal_fees_arg
        minimal_nanotez_per_gas_unit_arg minimal_nanotez_per_byte_arg)
      (apply
        (prefixes
          (cons "run" % string
            (cons "with" % string
              (cons "local" % string (cons "node" % string [])))))
        (apply
          (param "context_path" % string
            "Path to the node data directory (e.g. $HOME/.tezos-node)" % string
            directory_parameter)
          (seq_of_param
            (let arg := Client_keys.Public_key_hash.alias_param in
            fun eta => arg None None eta))))
      (fun function_parameter =>
        let
          '(pidfile, max_priority, minimal_fees, minimal_nanotez_per_gas_unit,
            minimal_nanotez_per_byte) := function_parameter in
        fun node_path =>
          fun delegates =>
            fun cctxt =>
              op_gtgteqquestion (may_lock_pidfile pidfile)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (Tezos_signer_backends.Encrypted.decrypt_list cctxt
                      (List.map fst delegates))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      Client_daemon.Baker.run cctxt (Some minimal_fees)
                        (Some minimal_nanotez_per_gas_unit)
                        (Some minimal_nanotez_per_byte) max_priority
                        (* ❌ Sending method message is not handled *)
                        send (Filename.concat node_path "context" % string)
                        (List.map snd delegates))))) [].

Definition endorser_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  let group :=
    {| Clic.name := "delegate.endorser" % string;
      Clic.title := "Commands related to endorser daemon." % string |} in
  cons
    (command (Some group) "Launch the endorser daemon" % string
      (args2 pidfile_arg endorsement_delay_arg)
      (apply (prefixes (cons "run" % string []))
        (seq_of_param
          (let arg := Client_keys.Public_key_hash.alias_param in
          fun eta => arg None None eta)))
      (fun function_parameter =>
        let '(pidfile, endorsement_delay) := function_parameter in
        fun delegates =>
          fun cctxt =>
            op_gtgteqquestion (may_lock_pidfile pidfile)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (Tezos_signer_backends.Encrypted.decrypt_list cctxt
                    (List.map fst delegates))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let delegates := List.map snd delegates in
                    let delegates_no_duplicates :=
                      OCaml.Stdlib.reverse_apply
                        (OCaml.Stdlib.reverse_apply delegates of_list) elements
                      in
                    op_gtgteq
                      (if
                        nequiv_decb (List.length delegates)
                          (List.length delegates_no_duplicates) then
                        (* ❌ Sending method message is not handled *)
                        send
                          (CamlinternalFormatBasics.Format
                            (CamlinternalFormatBasics.String_literal
                              "Warning: the list of public key hash aliases contains duplicate hashes, which are ignored"
                                % string CamlinternalFormatBasics.End_of_format)
                            "Warning: the list of public key hash aliases contains duplicate hashes, which are ignored"
                              % string)
                      else
                        Lwt._return tt)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        Client_daemon.Endorser.run cctxt
                          (* ❌ Sending method message is not handled *)
                          send endorsement_delay delegates_no_duplicates))))) [].

Definition accuser_commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command
      Tezos_client_alpha.Protocol_client_context.full) :=
  let 'tt := function_parameter in
  let group :=
    {| Clic.name := "delegate.accuser" % string;
      Clic.title := "Commands related to the accuser daemon." % string |} in
  cons
    (command (Some group) "Launch the accuser daemon" % string
      (args2 pidfile_arg preserved_levels_arg)
      (apply (prefixes (cons "run" % string [])) stop)
      (fun function_parameter =>
        let '(pidfile, preserved_levels) := function_parameter in
        fun cctxt =>
          op_gtgteqquestion (may_lock_pidfile pidfile)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Client_daemon.Accuser.run cctxt
                (* ❌ Sending method message is not handled *)
                send preserved_levels))) [].

src/proto_alpha/lib_delegate/delegate_commands_registration.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Client_commands.register Protocol.hash
  @@ fun _network ->
  List.map (Clic.map_command (new Protocol_client_context.wrap_full))
  @@ Delegate_commands.delegate_commands ()
src/proto_alpha/lib_delegate/delegate_commands_registration.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/proto_alpha/lib_delegate/logging.ml 17 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let timestamp_tag =
  Tag.def ~doc:"Timestamp when event occurred" "timestamp" Time.System.pp_hum

let valid_ops = Tag.def ~doc:"Valid Operations" "valid_ops" Format.pp_print_int

let op_count =
  Tag.def ~doc:"Number of operations" "op_count" Format.pp_print_int

let refused_ops =
  Tag.def ~doc:"Refused Operations" "refused_ops" Format.pp_print_int

let bake_priority_tag =
  Tag.def ~doc:"Baking priority" "bake_priority" Format.pp_print_int

let fitness_tag = Tag.def ~doc:"Fitness" "fitness" Fitness.pp

let current_slots_tag =
  Tag.def
    ~doc:"Number of baking slots that can be baked at this time"
    "current_slots"
    Format.pp_print_int

let future_slots_tag =
  Tag.def
    ~doc:
      "Number of baking slots in the foreseeable future but not yet bakeable"
    "future_slots"
    Format.pp_print_int

let timespan_tag = Tag.def ~doc:"Timespan in seconds" "timespan" Ptime.Span.pp

let filename_tag = Tag.def ~doc:"Filename" "filename" Format.pp_print_text

let signed_header_tag =
  Tag.def ~doc:"Signed header" "signed_header" (fun fmt x ->
      Hex.pp fmt (Hex.of_bytes x))

let signed_operation_tag =
  Tag.def ~doc:"Signed operation" "signed_operation" (fun fmt x ->
      Hex.pp fmt (Hex.of_bytes x))

let operations_tag =
  Tag.def
    ~doc:"Block Operations"
    "operations"
    (Format.pp_print_list
       ~pp_sep:(fun ppf () -> Format.fprintf ppf "+")
       (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations)))

let raw_operations_tag =
  Tag.def ~doc:"Raw operations" "raw_operations" (fun fmt raw_ops ->
      let pp_op fmt op =
        let json = Data_encoding.Json.construct Operation.raw_encoding op in
        Format.fprintf fmt "%a" Data_encoding.Json.pp json
      in
      Format.fprintf
        fmt
        "@[<v>%a@]"
        (Format.pp_print_list ~pp_sep:Format.pp_print_cut pp_op)
        raw_ops)

let bake_op_count_tag =
  Tag.def ~doc:"Bake Operation Count" "operation_count" Format.pp_print_int

let endorsement_slot_tag =
  Tag.def ~doc:"Endorsement Slot" "endorsement_slot" Format.pp_print_int

let endorsement_slots_tag =
  Tag.def
    ~doc:"Endorsement Slots"
    "endorsement_slots"
    Format.(fun ppf v -> pp_print_int ppf (List.length v))

let denounced_endorsements_slots_tag =
  Tag.def
    ~doc:"Endorsement Slots"
    "denounced_endorsement_slots"
    Format.(pp_print_list pp_print_int)

let denouncement_source_tag =
  Tag.def ~doc:"Denounce Source" "source" Format.pp_print_text

let level_tag = Tag.def ~doc:"Level" "level" Raw_level.pp

let nonce_tag =
  Tag.def
    ~doc:"Nonce"
    "nonce"
    Data_encoding.Json.(
      fun ppf nonce -> pp ppf (construct Nonce.encoding nonce))

let chain_tag =
  Tag.def
    ~doc:"Chain selector"
    "chain"
    Format.(
      fun ppf chain ->
        pp_print_string ppf @@ Block_services.chain_to_string chain)

let block_tag =
  Tag.def
    ~doc:"Block selector"
    "block"
    Format.(
      fun ppf block -> pp_print_string ppf @@ Block_services.to_string block)

let worker_tag =
  Tag.def ~doc:"Worker in which event occurred" "worker" Format.pp_print_text

let block_header_tag =
  Tag.def ~doc:"Raw block header" "block_header" (fun ppf _ ->
      Format.fprintf ppf "[raw block header]")

let conflicting_endorsements_tag =
  Tag.def
    ~doc:"Two conflicting endorsements signed by the same key"
    "conflicting_endorsements"
    Format.(
      fun ppf (a, b) ->
        fprintf
          ppf
          "%a / %a"
          Operation_hash.pp
          (Operation.hash a)
          Operation_hash.pp
          (Operation.hash b))
src/proto_alpha/lib_delegate/logging.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition timestamp_tag
  : Tezos_base__TzPervasives.Tag.def Tezos_base__TzPervasives.Time.System.t :=
  Tag.def (Some "Timestamp when event occurred" % string) "timestamp" % string
    Time.System.pp_hum.

Definition valid_ops : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def (Some "Valid Operations" % string) "valid_ops" % string
    Format.pp_print_int.

Definition op_count : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def (Some "Number of operations" % string) "op_count" % string
    Format.pp_print_int.

Definition refused_ops : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def (Some "Refused Operations" % string) "refused_ops" % string
    Format.pp_print_int.

Definition bake_priority_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def (Some "Baking priority" % string) "bake_priority" % string
    Format.pp_print_int.

Definition fitness_tag
  : Tezos_base__TzPervasives.Tag.def
    Tezos_protocol_alpha.Protocol.Alpha_context.Fitness.t :=
  Tag.def (Some "Fitness" % string) "fitness" % string Fitness.pp.

Definition current_slots_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def
    (Some "Number of baking slots that can be baked at this time" % string)
    "current_slots" % string Format.pp_print_int.

Definition future_slots_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def
    (Some
      "Number of baking slots in the foreseeable future but not yet bakeable" %
        string) "future_slots" % string Format.pp_print_int.

Definition timespan_tag : Tezos_base__TzPervasives.Tag.def Ptime.span :=
  Tag.def (Some "Timespan in seconds" % string) "timespan" % string
    Ptime.Span.pp.

Definition filename_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tag.def (Some "Filename" % string) "filename" % string Format.pp_print_text.

Definition signed_header_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tag.def (Some "Signed header" % string) "signed_header" % string
    (fun fmt => fun x => Hex.pp fmt (Hex.of_bytes None x)).

Definition signed_operation_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tag.def (Some "Signed operation" % string) "signed_operation" % string
    (fun fmt => fun x => Hex.pp fmt (Hex.of_bytes None x)).

Definition operations_tag {A : Type}
  : Tezos_base__TzPervasives.Tag.def (list (list A)) :=
  Tag.def (Some "Block Operations" % string) "operations" % string
    (Format.pp_print_list
      (Some
        (fun ppf =>
          fun function_parameter =>
            let 'tt := function_parameter in
            Format.fprintf ppf
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.Char_literal "+" % char
                  CamlinternalFormatBasics.End_of_format) "+" % string)))
      (fun ppf =>
        fun operations =>
          Format.fprintf ppf
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Int CamlinternalFormatBasics.Int_d
                CamlinternalFormatBasics.No_padding
                CamlinternalFormatBasics.No_precision
                CamlinternalFormatBasics.End_of_format) "%d" % string)
            (List.length operations))).

Definition raw_operations_tag
  : Tezos_base__TzPervasives.Tag.def
    (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw) :=
  Tag.def (Some "Raw operations" % string) "raw_operations" % string
    (fun fmt =>
      fun raw_ops =>
        let pp_op
          (fmt : Stdlib.Format.formatter) (op :
          Tezos_protocol_alpha.Protocol.Alpha_context.Operation.raw) : unit :=
          let json := Data_encoding.Json.construct Operation.raw_encoding op in
          Format.fprintf fmt
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.Alpha
                CamlinternalFormatBasics.End_of_format) "%a" % string)
            Data_encoding.Json.pp json in
        Format.fprintf fmt
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Formatting_gen
              (CamlinternalFormatBasics.Open_box
                (CamlinternalFormatBasics.Format
                  (CamlinternalFormatBasics.String_literal "<v>" % string
                    CamlinternalFormatBasics.End_of_format) "<v>" % string))
              (CamlinternalFormatBasics.Alpha
                (CamlinternalFormatBasics.Formatting_lit
                  CamlinternalFormatBasics.Close_box
                  CamlinternalFormatBasics.End_of_format))) "@[<v>%a@]" % string)
          (Format.pp_print_list (Some Format.pp_print_cut) pp_op) raw_ops).

Definition bake_op_count_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def (Some "Bake Operation Count" % string) "operation_count" % string
    Format.pp_print_int.

Definition endorsement_slot_tag : Tezos_base__TzPervasives.Tag.def Z :=
  Tag.def (Some "Endorsement Slot" % string) "endorsement_slot" % string
    Format.pp_print_int.

Definition endorsement_slots_tag {A : Type}
  : Tezos_base__TzPervasives.Tag.def (list A) :=
  Tag.def (Some "Endorsement Slots" % string) "endorsement_slots" % string
    (fun ppf => fun v => pp_print_int ppf (List.length v)).

Definition denounced_endorsements_slots_tag
  : Tezos_base__TzPervasives.Tag.def (list Z) :=
  Tag.def (Some "Endorsement Slots" % string)
    "denounced_endorsement_slots" % string (pp_print_list None pp_print_int).

Definition denouncement_source_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tag.def (Some "Denounce Source" % string) "source" % string
    Format.pp_print_text.

Definition level_tag
  : Tezos_base__TzPervasives.Tag.def
    Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t :=
  Tag.def (Some "Level" % string) "level" % string Raw_level.pp.

Definition nonce_tag
  : Tezos_base__TzPervasives.Tag.def
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  Tag.def (Some "Nonce" % string) "nonce" % string
    (fun ppf => fun nonce => pp ppf (construct Nonce.encoding nonce)).

Definition chain_tag
  : Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.chain :=
  Tag.def (Some "Chain selector" % string) "chain" % string
    (fun ppf =>
      fun chain =>
        apply (pp_print_string ppf) (Block_services.chain_to_string chain)).

Definition block_tag
  : Tezos_base__TzPervasives.Tag.def Tezos_shell_services.Block_services.block :=
  Tag.def (Some "Block selector" % string) "block" % string
    (fun ppf =>
      fun block => apply (pp_print_string ppf) (Block_services.to_string block)).

Definition worker_tag : Tezos_base__TzPervasives.Tag.def string :=
  Tag.def (Some "Worker in which event occurred" % string) "worker" % string
    Format.pp_print_text.

Definition block_header_tag {A : Type} : Tezos_base__TzPervasives.Tag.def A :=
  Tag.def (Some "Raw block header" % string) "block_header" % string
    (fun ppf =>
      fun function_parameter =>
        let '_ := function_parameter in
        Format.fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "[raw block header]" % string
              CamlinternalFormatBasics.End_of_format)
            "[raw block header]" % string)).

Definition conflicting_endorsements_tag {A B : Type}
  : Tezos_base__TzPervasives.Tag.def
    ((Tezos_raw_protocol_alpha__Alpha_context.operation A) *
      (Tezos_raw_protocol_alpha__Alpha_context.operation B)) :=
  Tag.def (Some "Two conflicting endorsements signed by the same key" % string)
    "conflicting_endorsements" % string
    (fun ppf =>
      fun function_parameter =>
        let '(a, b) := function_parameter in
        fprintf ppf
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal " / " % string
                (CamlinternalFormatBasics.Alpha
                  CamlinternalFormatBasics.End_of_format))) "%a / %a" % string)
          Operation_hash.pp (Operation.hash a) Operation_hash.pp
          (Operation.hash b)).

src/proto_alpha/lib_mempool/filter.ml 68 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Development. <contact@tezcore.com>             *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
module Proto = Registerer.Registered

type nanotez = Z.t

let nanotez_enc =
  Data_encoding.def
    "nanotez"
    ~title:"Thousandths of tez"
    ~description:"One thousand nanotez make a tez"
    Data_encoding.z

type config = {
  minimal_fees : Tez.t;
  minimal_nanotez_per_gas_unit : nanotez;
  minimal_nanotez_per_byte : nanotez;
  allow_script_failure : bool;
}

let default_minimal_fees =
  match Tez.of_mutez 100L with None -> assert false | Some t -> t

let default_minimal_nanotez_per_gas_unit = Z.of_int 100

let default_minimal_nanotez_per_byte = Z.of_int 1000

let config_encoding : config Data_encoding.t =
  let open Data_encoding in
  conv
    (fun { minimal_fees;
           minimal_nanotez_per_gas_unit;
           minimal_nanotez_per_byte;
           allow_script_failure } ->
      ( minimal_fees,
        minimal_nanotez_per_gas_unit,
        minimal_nanotez_per_byte,
        allow_script_failure ))
    (fun ( minimal_fees,
           minimal_nanotez_per_gas_unit,
           minimal_nanotez_per_byte,
           allow_script_failure ) ->
      {
        minimal_fees;
        minimal_nanotez_per_gas_unit;
        minimal_nanotez_per_byte;
        allow_script_failure;
      })
    (obj4
       (dft "minimal_fees" Tez.encoding default_minimal_fees)
       (dft
          "minimal_nanotez_per_gas_unit"
          nanotez_enc
          default_minimal_nanotez_per_gas_unit)
       (dft
          "minimal_nanotez_per_byte"
          nanotez_enc
          default_minimal_nanotez_per_byte)
       (dft "allow_script_failure" bool true))

let default_config =
  {
    minimal_fees = default_minimal_fees;
    minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
    minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
    allow_script_failure = true;
  }

let get_manager_operation_gas_and_fee contents =
  let open Operation in
  let l = to_list (Contents_list contents) in
  List.fold_left
    (fun acc -> function
      | Contents (Manager_operation {fee; gas_limit; _}) -> (
        match acc with
        | Error _ as e ->
            e
        | Ok (total_fee, total_gas) -> (
          match Tez.(total_fee +? fee) with
          | Ok total_fee ->
              Ok (total_fee, Z.add total_gas gas_limit)
          | Error _ as e ->
              e ) ) | _ -> acc)
    (Ok (Tez.zero, Z.zero))
    l

let pre_filter_manager :
    type t. config -> t Kind.manager contents_list -> int -> bool =
 fun config op size ->
  match get_manager_operation_gas_and_fee op with
  | Error _ ->
      false
  | Ok (fee, gas) ->
      let fees_in_nanotez =
        Z.mul (Z.of_int64 (Tez.to_mutez fee)) (Z.of_int 1000)
      in
      let minimal_fees_in_nanotez =
        Z.mul (Z.of_int64 (Tez.to_mutez config.minimal_fees)) (Z.of_int 1000)
      in
      let minimal_fees_for_gas_in_nanotez =
        Z.mul config.minimal_nanotez_per_gas_unit gas
      in
      let minimal_fees_for_size_in_nanotez =
        Z.mul config.minimal_nanotez_per_byte (Z.of_int size)
      in
      Z.compare
        fees_in_nanotez
        (Z.add
           minimal_fees_in_nanotez
           (Z.add
              minimal_fees_for_gas_in_nanotez
              minimal_fees_for_size_in_nanotez))
      >= 0

let pre_filter config
    (Operation_data {contents; _} as op : Operation.packed_protocol_data) =
  let bytes =
    Data_encoding.Binary.fixed_length_exn
      Tezos_base.Operation.shell_header_encoding
    + Data_encoding.Binary.length Operation.protocol_data_encoding op
  in
  match contents with
  | Single (Endorsement _) ->
      true
  | Single (Seed_nonce_revelation _) ->
      true
  | Single (Double_endorsement_evidence _) ->
      true
  | Single (Double_baking_evidence _) ->
      true
  | Single (Activate_account _) ->
      true
  | Single (Proposals _) ->
      true
  | Single (Ballot _) ->
      true
  | Single (Manager_operation _) as op ->
      pre_filter_manager config op bytes
  | Cons (Manager_operation _, _) as op ->
      pre_filter_manager config op bytes

open Apply_results

let rec post_filter_manager :
    type t.
    Alpha_context.t ->
    t Kind.manager contents_result_list ->
    config ->
    bool Lwt.t =
 fun ctxt op config ->
  match op with
  | Single_result (Manager_operation_result {operation_result; _}) -> (
    match operation_result with
    | Applied _ ->
        Lwt.return_true
    | Skipped _ | Failed _ | Backtracked _ ->
        Lwt.return config.allow_script_failure )
  | Cons_result (Manager_operation_result res, rest) -> (
      post_filter_manager
        ctxt
        (Single_result (Manager_operation_result res))
        config
      >>= function
      | false ->
          Lwt.return_false
      | true ->
          post_filter_manager ctxt rest config )

let post_filter config ~validation_state_before:_
    ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) =
  match receipt with
  | No_operation_metadata ->
      assert false (* only for multipass validator *)
  | Operation_metadata {contents} -> (
    match contents with
    | Single_result (Endorsement_result _) ->
        Lwt.return_true
    | Single_result (Seed_nonce_revelation_result _) ->
        Lwt.return_true
    | Single_result (Double_endorsement_evidence_result _) ->
        Lwt.return_true
    | Single_result (Double_baking_evidence_result _) ->
        Lwt.return_true
    | Single_result (Activate_account_result _) ->
        Lwt.return_true
    | Single_result Proposals_result ->
        Lwt.return_true
    | Single_result Ballot_result ->
        Lwt.return_true
    | Single_result (Manager_operation_result _) as op ->
        post_filter_manager ctxt op config
    | Cons_result (Manager_operation_result _, _) as op ->
        post_filter_manager ctxt op config )
src/proto_alpha/lib_mempool/filter.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Proto.

End Proto.

Definition nanotez_enc {A : Type} : A :=
  op_startypeminuserrorstar "nanotez" % string "Thousandths of tez" % string
    "One thousand nanotez make a tez" % string op_startypeminuserrorstar.

Definition default_minimal_fees {A : Type} : A :=
  match
    op_startypeminuserrorstar
      (* ❌ Constant of type int64 is converted to int *)
      100 with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some t => t
  end.

Definition default_minimal_nanotez_per_gas_unit {A : Type} : A :=
  op_startypeminuserrorstar 100.

Definition default_minimal_nanotez_per_byte {A : Type} : A :=
  op_startypeminuserrorstar 1000.



Definition default_config {A : Type} : A := op_startypeminuserrorstar.

Definition get_manager_operation_gas_and_fee {A B : Type} (contents : A) : B :=
  op_startypeminuserrorstar.



Definition pre_filter {A B : Type} (config : A) (function_parameter : B)
  : bool :=
  let '_ := function_parameter in
  let bytes :=
    Z.add (op_startypeminuserrorstar op_startypeminuserrorstar)
      (op_startypeminuserrorstar op_startypeminuserrorstar
        op_startypeminuserrorstar) in
  match op_startypeminuserrorstar with
  | _ => true
  | _ => true
  | _ => true
  | _ => true
  | _ => true
  | _ => true
  | _ => true
  | _ => op_startypeminuserrorstar config op_startypeminuserrorstar string
  | _ => op_startypeminuserrorstar config op_startypeminuserrorstar string
  end.

Definition post_filter {A B C D E F : Type}
  (config : A) (function_parameter : B) : C -> (D * E) -> F :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    fun function_parameter =>
      let '(_op, receipt) := function_parameter in
      match receipt with
      | _ =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      | _ =>
        match op_startypeminuserrorstar with
        | _ => op_startypeminuserrorstar
        | _ => op_startypeminuserrorstar
        | _ => op_startypeminuserrorstar
        | _ => op_startypeminuserrorstar
        | _ => op_startypeminuserrorstar
        | _ => op_startypeminuserrorstar
        | _ => op_startypeminuserrorstar
        | _ =>
          op_startypeminuserrorstar op_startypeminuserrorstar
            op_startypeminuserrorstar config
        | _ =>
          op_startypeminuserrorstar op_startypeminuserrorstar
            op_startypeminuserrorstar config
        end
      end.

src/proto_alpha/lib_parameters/default_parameters.ml 23 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let constants_mainnet =
  Constants_repr.
    {
      preserved_cycles = 5;
      blocks_per_cycle = 4096l;
      blocks_per_commitment = 32l;
      blocks_per_roll_snapshot = 256l;
      blocks_per_voting_period = 32768l;
      time_between_blocks = List.map Period_repr.of_seconds_exn [60L; 40L];
      endorsers_per_block = 32;
      hard_gas_limit_per_operation = Z.of_int 800_000;
      hard_gas_limit_per_block = Z.of_int 8_000_000;
      proof_of_work_threshold = Int64.(sub (shift_left 1L 46) 1L);
      tokens_per_roll = Tez_repr.(mul_exn one 8_000);
      michelson_maximum_type_size = 1000;
      seed_nonce_revelation_tip =
        (match Tez_repr.(one /? 8L) with Ok c -> c | Error _ -> assert false);
      origination_size = 257;
      block_security_deposit = Tez_repr.(mul_exn one 512);
      endorsement_security_deposit = Tez_repr.(mul_exn one 64);
      block_reward = Tez_repr.(mul_exn one 16);
      endorsement_reward = Tez_repr.(mul_exn one 2);
      hard_storage_limit_per_operation = Z.of_int 60_000;
      cost_per_byte = Tez_repr.of_mutez_exn 1_000L;
      test_chain_duration = Int64.mul 32768L 60L;
      quorum_min = 20_00l;
      (* quorum is in centile of a percentage *)
      quorum_max = 70_00l;
      min_proposal_quorum = 5_00l;
      initial_endorsers = 24;
      delay_per_missing_endorsement = Period_repr.of_seconds_exn 8L;
    }

let constants_sandbox =
  Constants_repr.
    {
      constants_mainnet with
      preserved_cycles = 2;
      blocks_per_cycle = 8l;
      blocks_per_commitment = 4l;
      blocks_per_roll_snapshot = 4l;
      blocks_per_voting_period = 64l;
      time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
      proof_of_work_threshold = Int64.of_int (-1);
      initial_endorsers = 1;
      delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
    }

let constants_test =
  Constants_repr.
    {
      constants_mainnet with
      blocks_per_cycle = 128l;
      blocks_per_commitment = 4l;
      blocks_per_roll_snapshot = 32l;
      blocks_per_voting_period = 256l;
      time_between_blocks = List.map Period_repr.of_seconds_exn [1L; 0L];
      proof_of_work_threshold = Int64.of_int (-1);
      initial_endorsers = 1;
      delay_per_missing_endorsement = Period_repr.of_seconds_exn 1L;
    }

let bootstrap_accounts_strings =
  [ "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav";
    "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9";
    "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV";
    "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU";
    "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" ]

let boostrap_balance = Tez_repr.of_mutez_exn 4_000_000_000_000L

let bootstrap_accounts =
  List.map
    (fun s ->
      let public_key = Signature.Public_key.of_b58check_exn s in
      let public_key_hash = Signature.Public_key.hash public_key in
      Parameters_repr.
        {
          public_key_hash;
          public_key = Some public_key;
          amount = boostrap_balance;
        })
    bootstrap_accounts_strings

(* TODO this could be generated from OCaml together with the faucet
   for now these are harcoded values in the tests *)
let commitments =
  let json_result =
    Data_encoding.Json.from_string
      {json|
  [
    [ "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ],
    [ "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ],
    [ "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428348" ],
    [ "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ],
    [ "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ],
    [ "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ],
    [ "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ],
    [ "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ],
    [ "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ],
    [ "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ]
  ]|json}
  in
  match json_result with
  | Error err ->
      raise (Failure err)
  | Ok json ->
      Data_encoding.Json.destruct
        (Data_encoding.list Commitment_repr.encoding)
        json

let make_bootstrap_account (pkh, pk, amount) =
  Parameters_repr.{public_key_hash = pkh; public_key = Some pk; amount}

let parameters_of_constants ?(bootstrap_accounts = bootstrap_accounts)
    ?(bootstrap_contracts = []) ?(with_commitments = false) constants =
  let commitments = if with_commitments then commitments else [] in
  Parameters_repr.
    {
      bootstrap_accounts;
      bootstrap_contracts;
      commitments;
      constants;
      security_deposit_ramp_up_cycles = None;
      no_reward_cycles = None;
    }

let json_of_parameters parameters =
  Data_encoding.Json.construct Parameters_repr.encoding parameters
src/proto_alpha/lib_parameters/default_parameters.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition constants_mainnet {A : Type} : A := op_startypeminuserrorstar.

Definition constants_sandbox {A : Type} : A := op_startypeminuserrorstar.

Definition constants_test {A : Type} : A := op_startypeminuserrorstar.

Definition bootstrap_accounts_strings : list string :=
  cons "edpkuBknW28nW72KG6RoHtYW7p12T6GKc7nAbwYX5m8Wd9sDVC9yav" % string
    (cons "edpktzNbDAUjUk697W7gYg2CRuBQjyPxbEg8dLccYYwKSKvkPvjtV9" % string
      (cons "edpkuTXkJDGcFd5nh6VvMz8phXxU3Bi7h6hqgywNFi1vZTfQNnS1RV" % string
        (cons "edpkuFrRoDSEbJYgxRtLx2ps82UdaYc1WwfS9sE11yhauZt5DgCHbU" % string
          (cons
            "edpkv8EUUH68jmo3f7Um5PezmfGrRF24gnfLpH3sVNwJnV5bVCxL2n" % string [])))).

Definition boostrap_balance {A : Type} : A :=
  op_startypeminuserrorstar
    (* ❌ Constant of type int64 is converted to int *)
    4000000000000.

Definition bootstrap_accounts {A : Type} : list A :=
  List.map
    (fun s =>
      let public_key := Signature.Public_key.of_b58check_exn s in
      let public_key_hash := Signature.Public_key.hash public_key in
      op_startypeminuserrorstar) bootstrap_accounts_strings.

Definition commitments {A : Type} : list A :=
  let json_result :=
    Data_encoding.Json.from_string
      "
  [
    [ ""btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa"", ""23932454669343"" ],
    [ ""btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv"", ""72954577464032"" ],
    [ ""btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw"", ""217487035428348"" ],
    [ ""btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy"", ""4092742372031"" ],
    [ ""btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r"", ""17590039016550"" ],
    [ ""btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT"", ""26322312350555"" ],
    [ ""btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP"", ""244951387881443"" ],
    [ ""btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1"", ""80065050465525"" ],
    [ ""btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD"", ""3569618927693"" ],
    [ ""btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy"", ""9034781424478"" ]
  ]"
        % string in
  match json_result with
  | Stdlib.Error err => Stdlib.raise (OCaml.Failure err)
  | Stdlib.Ok json =>
    Data_encoding.Json.destruct
      (Data_encoding.list None op_startypeminuserrorstar) json
  end.

Definition make_bootstrap_account {A B C D : Type}
  (function_parameter : A * B * C) : D :=
  let '(pkh, pk, amount) := function_parameter in
  op_startypeminuserrorstar.

Definition parameters_of_constants {A B C D : Type}
  (op_staroptstar : option (list A))
  : (option (list B)) -> (option bool) -> C -> D :=
  let bootstrap_accounts :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => bootstrap_accounts
    end in
  fun op_staroptstar =>
    let bootstrap_contracts :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun op_staroptstar =>
      let with_commitments :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => false
        end in
      fun constants =>
        let commitments :=
          if with_commitments then
            commitments
          else
            [] in
        op_startypeminuserrorstar.

Definition json_of_parameters {A : Type} (parameters : A)
  : Tezos_base__TzPervasives.Data_encoding.Json.json :=
  Data_encoding.Json.construct op_startypeminuserrorstar parameters.

src/proto_alpha/lib_parameters/gen.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Prints the json encoding of the parametric constants of protocol alpha.
   $ dune utop src/proto_alpha/lib_protocol/test/helpers/ constants.ml
*)

let () =
  let print_usage_and_fail s =
    Printf.eprintf "Usage: %s [ --sandbox | --test | --mainnet ]" Sys.argv.(0) ;
    raise (Invalid_argument s)
  in
  let dump parameters file =
    let str =
      Data_encoding.Json.to_string
        (Default_parameters.json_of_parameters parameters)
    in
    let fd = open_out file in
    output_string fd str ; close_out fd
  in
  if Array.length Sys.argv < 2 then print_usage_and_fail ""
  else
    match Sys.argv.(1) with
    | "--sandbox" ->
        dump
          Default_parameters.(parameters_of_constants constants_sandbox)
          "sandbox-parameters.json"
    | "--test" ->
        dump
          Default_parameters.(
            parameters_of_constants ~with_commitments:true constants_sandbox)
          "test-parameters.json"
    | "--mainnet" ->
        dump
          Default_parameters.(
            parameters_of_constants ~with_commitments:true constants_mainnet)
          "mainnet-parameters.json"
    | s ->
        print_usage_and_fail s
src/proto_alpha/lib_parameters/gen.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/proto_alpha/lib_protocol/alpha_context.ml 70 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Raw_context.t

type context = t

module type BASIC_DATA = sig
  type t

  include Compare.S with type t := t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit
end

module Tez = Tez_repr
module Period = Period_repr

module Timestamp = struct
  include Time_repr

  let current = Raw_context.current_timestamp
end

include Operation_repr

module Operation = struct
  type 'kind t = 'kind operation = {
    shell : Operation.shell_header;
    protocol_data : 'kind protocol_data;
  }

  type packed = packed_operation

  let unsigned_encoding = unsigned_operation_encoding

  include Operation_repr
end

module Block_header = Block_header_repr

module Vote = struct
  include Vote_repr
  include Vote_storage
end

module Raw_level = Raw_level_repr
module Cycle = Cycle_repr
module Script_int = Script_int_repr

module Script_timestamp = struct
  include Script_timestamp_repr

  let now ctxt =
    let {Constants_repr.time_between_blocks; _} = Raw_context.constants ctxt in
    match time_between_blocks with
    | [] ->
        failwith
          "Internal error: 'time_between_block' constants is an empty list."
    | first_delay :: _ ->
        let current_timestamp = Raw_context.predecessor_timestamp ctxt in
        Time.add current_timestamp (Period_repr.to_seconds first_delay)
        |> Timestamp.to_seconds |> of_int64
end

module Script = struct
  include Michelson_v1_primitives
  include Script_repr

  let force_decode ctxt lexpr =
    Lwt.return
      ( Script_repr.force_decode lexpr
      >>? fun (v, cost) ->
      Raw_context.consume_gas ctxt cost >|? fun ctxt -> (v, ctxt) )

  let force_bytes ctxt lexpr =
    Lwt.return
      ( Script_repr.force_bytes lexpr
      >>? fun (b, cost) ->
      Raw_context.consume_gas ctxt cost >|? fun ctxt -> (b, ctxt) )

  module Legacy_support = Legacy_script_support_repr
end

module Fees = Fees_storage

type public_key = Signature.Public_key.t

type public_key_hash = Signature.Public_key_hash.t

type signature = Signature.t

module Constants = struct
  include Constants_repr
  include Constants_storage
end

module Voting_period = Voting_period_repr

module Gas = struct
  include Gas_limit_repr

  type error += Gas_limit_too_high = Raw_context.Gas_limit_too_high

  let check_limit = Raw_context.check_gas_limit

  let set_limit = Raw_context.set_gas_limit

  let set_unlimited = Raw_context.set_gas_unlimited

  let consume = Raw_context.consume_gas

  let check_enough = Raw_context.check_enough_gas

  let level = Raw_context.gas_level

  let consumed = Raw_context.gas_consumed

  let block_level = Raw_context.block_gas_level
end

module Level = struct
  include Level_repr
  include Level_storage
end

module Contract = struct
  include Contract_repr
  include Contract_storage

  let originate c contract ~balance ~script ~delegate =
    originate c contract ~balance ~script ~delegate

  let init_origination_nonce = Raw_context.init_origination_nonce

  let unset_origination_nonce = Raw_context.unset_origination_nonce
end

module Big_map = struct
  type id = Z.t

  let fresh = Storage.Big_map.Next.incr

  let fresh_temporary = Raw_context.fresh_temporary_big_map

  let mem c m k = Storage.Big_map.Contents.mem (c, m) k

  let get_opt c m k = Storage.Big_map.Contents.get_option (c, m) k

  let rpc_arg = Storage.Big_map.rpc_arg

  let cleanup_temporary c =
    Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c
    >>= fun c -> Lwt.return (Raw_context.reset_temporary_big_map c)

  let exists c id =
    Lwt.return
      (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))
    >>=? fun c ->
    Storage.Big_map.Key_type.get_option c id
    >>=? fun kt ->
    match kt with
    | None ->
        return (c, None)
    | Some kt ->
        Storage.Big_map.Value_type.get c id
        >>=? fun kv -> return (c, Some (kt, kv))
end

module Delegate = Delegate_storage

module Roll = struct
  include Roll_repr
  include Roll_storage
end

module Nonce = Nonce_storage

module Seed = struct
  include Seed_repr
  include Seed_storage
end

module Fitness = struct
  include Fitness_repr
  include Fitness

  type fitness = t

  include Fitness_storage
end

module Bootstrap = Bootstrap_storage

module Commitment = struct
  include Commitment_repr
  include Commitment_storage
end

module Global = struct
  let get_block_priority = Storage.Block_priority.get

  let set_block_priority = Storage.Block_priority.set
end

let prepare_first_block = Init_storage.prepare_first_block

let prepare = Init_storage.prepare

let finalize ?commit_message:message c =
  let fitness = Fitness.from_int64 (Fitness.current c) in
  let context = Raw_context.recover c in
  {
    Updater.context;
    fitness;
    message;
    max_operations_ttl = 60;
    last_allowed_fork_level =
      Raw_level.to_int32 @@ Level.last_allowed_fork_level c;
  }

let activate = Raw_context.activate

let fork_test_chain = Raw_context.fork_test_chain

let record_endorsement = Raw_context.record_endorsement

let allowed_endorsements = Raw_context.allowed_endorsements

let init_endorsements = Raw_context.init_endorsements

let included_endorsements = Raw_context.included_endorsements

let reset_internal_nonce = Raw_context.reset_internal_nonce

let fresh_internal_nonce = Raw_context.fresh_internal_nonce

let record_internal_nonce = Raw_context.record_internal_nonce

let internal_nonce_already_recorded =
  Raw_context.internal_nonce_already_recorded

let add_deposit = Raw_context.add_deposit

let add_fees = Raw_context.add_fees

let add_rewards = Raw_context.add_rewards

let get_deposits = Raw_context.get_deposits

let get_fees = Raw_context.get_fees

let get_rewards = Raw_context.get_rewards

let description = Raw_context.description
src/proto_alpha/lib_protocol/alpha_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_raw_protocol_alpha.Raw_context.t.

Definition context := t.

Module BASIC_DATA.
  Record signature {t : Type} := {
    t := t;
    include;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
    pp : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
      t -> unit;
  }.
  Arguments signature : clear implicits.
End BASIC_DATA.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Timestamp.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition current
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_protocol_environment_alpha__Environment.Time.t :=
    Raw_context.current_timestamp.
End Timestamp.

(* ❌ Structure item `include` not handled. *)
include

Module Operation.
  Record t {kind : Type} := {
    shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
    protocol_data : protocol_data kind }.
  Arguments t : clear implicits.
  
  Definition packed := packed_operation.
  
  Definition unsigned_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
      (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
        packed_contents_list) := unsigned_operation_encoding.
  
  (* ❌ Structure item `include` not handled. *)
  include
End Operation.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Vote.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Vote.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Script_timestamp.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition now (ctxt : Tezos_raw_protocol_alpha.Raw_context.context) : t :=
    let '{| Constants_repr.time_between_blocks := time_between_blocks |} :=
      Raw_context.constants ctxt in
    match time_between_blocks with
    | [] =>
      failwith
        "Internal error: 'time_between_block' constants is an empty list." %
          string
    | cons first_delay _ =>
      let current_timestamp := Raw_context.predecessor_timestamp ctxt in
      op_pipegt
        (op_pipegt
          (Time.add current_timestamp (Period_repr.to_seconds first_delay))
          Timestamp.to_seconds) of_int64
    end.
End Script_timestamp.

Module Script.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition force_decode
    (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
    (lexpr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Script_repr.expr *
          Tezos_raw_protocol_alpha.Raw_context.context)) :=
    Lwt._return
      (op_gtgtquestion (Script_repr.force_decode lexpr)
        (fun function_parameter =>
          let '(v, cost) := function_parameter in
          op_gtpipequestion (Raw_context.consume_gas ctxt cost)
            (fun ctxt => (v, ctxt)))).
  
  Definition force_bytes
    (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
    (lexpr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_protocol_environment_alpha__Environment.MBytes.t *
          Tezos_raw_protocol_alpha.Raw_context.context)) :=
    Lwt._return
      (op_gtgtquestion (Script_repr.force_bytes lexpr)
        (fun function_parameter =>
          let '(b, cost) := function_parameter in
          op_gtpipequestion (Raw_context.consume_gas ctxt cost)
            (fun ctxt => (b, ctxt)))).
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
End Script.

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition public_key :=
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t.

Definition public_key_hash :=
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t.

Definition signature :=
  Tezos_protocol_environment_alpha__Environment.Signature.t.

Module Constants.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Constants.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Gas.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition check_limit
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
    Raw_context.check_gas_limit.
  
  Definition set_limit
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.set_gas_limit.
  
  Definition set_unlimited
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.set_gas_unlimited.
  
  Definition consume
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.context :=
    Raw_context.consume_gas.
  
  Definition check_enough
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
    Raw_context.check_enough_gas.
  
  Definition level
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.t := Raw_context.gas_level.
  
  Definition consumed
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Raw_context.t ->
        Tezos_protocol_environment_alpha__Environment.Z.t :=
    Raw_context.gas_consumed.
  
  Definition block_level
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    Raw_context.block_gas_level.
End Gas.

Module Level.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Level.

Module Contract.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition originate
    (c : Tezos_raw_protocol_alpha.Raw_context.t)
    (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
    (balance : Tezos_raw_protocol_alpha.Tez_repr.t)
    (script : Tezos_raw_protocol_alpha.Script_repr.t * (option big_map_diff))
    (delegate :
      option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    originate c None contract balance script delegate.
  
  Definition init_origination_nonce
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        -> Tezos_raw_protocol_alpha.Raw_context.t :=
    Raw_context.init_origination_nonce.
  
  Definition unset_origination_nonce
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Raw_context.t :=
    Raw_context.unset_origination_nonce.
End Contract.

Module Big_map.
  Definition id := Tezos_protocol_environment_alpha__Environment.Z.t.
  
  Definition fresh
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t *
            Tezos_protocol_environment_alpha__Environment.Z.t)) :=
    Storage.Big_map.Next.incr.
  
  Definition fresh_temporary
    : Tezos_raw_protocol_alpha.Raw_context.context ->
      Tezos_raw_protocol_alpha.Raw_context.context *
        Tezos_protocol_environment_alpha__Environment.Z.t :=
    Raw_context.fresh_temporary_big_map.
  
  Definition mem
    (c : Tezos_raw_protocol_alpha.Raw_context.t)
    (m : Tezos_protocol_environment_alpha__Environment.Z.t)
    (k : Tezos_raw_protocol_alpha.Storage.Big_map.Contents.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t * bool)) :=
    Storage.Big_map.Contents.mem (c, m) k.
  
  Definition get_opt
    (c : Tezos_raw_protocol_alpha.Raw_context.t)
    (m : Tezos_protocol_environment_alpha__Environment.Z.t)
    (k : Tezos_raw_protocol_alpha.Storage.Big_map.Contents.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.t *
          (option Tezos_raw_protocol_alpha.Storage.Big_map.Contents.value))) :=
    Storage.Big_map.Contents.get_option (c, m) k.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.t
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    Storage.Big_map.rpc_arg.
  
  Definition cleanup_temporary
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      Tezos_raw_protocol_alpha.Raw_context.context :=
    op_gtgteq (Raw_context.temporary_big_maps c Storage.Big_map.remove_rec c)
      (fun c => Lwt._return (Raw_context.reset_temporary_big_map c)).
  
  Definition _exists
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (id : Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Raw_context.context *
          (option
            (Tezos_raw_protocol_alpha.Storage.Big_map.Key_type.value *
              Tezos_raw_protocol_alpha.Storage.Big_map.Value_type.value)))) :=
    op_gtgteqquestion
      (Lwt._return
        (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero)))
      (fun c =>
        op_gtgteqquestion (Storage.Big_map.Key_type.get_option c id)
          (fun kt =>
            match kt with
            | None => _return (c, None)
            | Some kt =>
              op_gtgteqquestion (Storage.Big_map.Value_type.get c id)
                (fun kv => _return (c, (Some (kt, kv))))
            end)).
End Big_map.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Roll.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Roll.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Seed.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Seed.

Module Fitness.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition fitness := t.
  
  (* ❌ Structure item `include` not handled. *)
  include
End Fitness.

(* ❌ This kind of module is not handled. *)
unhandled_module

Module Commitment.
  (* ❌ Structure item `include` not handled. *)
  include
  
  (* ❌ Structure item `include` not handled. *)
  include
End Commitment.

Module Global.
  Definition get_block_priority
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
    Storage.Block_priority.get.
  
  Definition set_block_priority
    : Tezos_raw_protocol_alpha.Raw_context.t ->
      Z ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t) :=
    Storage.Block_priority.set.
End Global.

Definition prepare_first_block
  : Tezos_protocol_environment_alpha__Environment.Context.t ->
    (Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t))) ->
      int32 ->
        Tezos_protocol_environment_alpha__Environment.Time.t ->
          Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
            ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                Tezos_raw_protocol_alpha.Raw_context.t) :=
  Init_storage.prepare_first_block.

Definition prepare
  : Tezos_protocol_environment_alpha__Environment.Context.t ->
    Tezos_protocol_environment_alpha__Environment.Int32.t ->
      Tezos_protocol_environment_alpha__Environment.Time.t ->
        Tezos_protocol_environment_alpha__Environment.Time.t ->
          Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t)
            ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                Tezos_raw_protocol_alpha.Raw_context.context) :=
  Init_storage.prepare.

Definition finalize
  (message : option string) (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Updater.validation_result :=
  let fitness := Fitness.from_int64 (Fitness.current c) in
  let context := Raw_context.recover c in
  {| Updater.context := context; Updater.fitness := fitness;
    Updater.message := message; Updater.max_operations_ttl := 60;
    Updater.last_allowed_fork_level :=
      op_atat Raw_level.to_int32 (Level.last_allowed_fork_level c) |}.

Definition activate
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.activate.

Definition fork_test_chain
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      ->
      Tezos_protocol_environment_alpha__Environment.Time.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t := Raw_context.fork_test_chain.

Definition record_endorsement
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_raw_protocol_alpha.Raw_context.context :=
  Raw_context.record_endorsement.

Definition allowed_endorsements
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool) := Raw_context.allowed_endorsements.

Definition init_endorsements
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool)) -> Tezos_raw_protocol_alpha.Raw_context.context :=
  Raw_context.init_endorsements.

Definition included_endorsements
  : Tezos_raw_protocol_alpha.Raw_context.context -> Z :=
  Raw_context.included_endorsements.

Definition reset_internal_nonce
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Raw_context.context :=
  Raw_context.reset_internal_nonce.

Definition fresh_internal_nonce
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.context * Z) :=
  Raw_context.fresh_internal_nonce.

Definition record_internal_nonce
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Z -> Tezos_raw_protocol_alpha.Raw_context.context :=
  Raw_context.record_internal_nonce.

Definition internal_nonce_already_recorded
  : Tezos_raw_protocol_alpha.Raw_context.context -> Z -> bool :=
  Raw_context.internal_nonce_already_recorded.

Definition add_deposit
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_raw_protocol_alpha.Tez_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.context) :=
  Raw_context.add_deposit.

Definition add_fees
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.context) := Raw_context.add_fees.

Definition add_rewards
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.context) :=
  Raw_context.add_rewards.

Definition get_deposits
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      Tezos_raw_protocol_alpha.Tez_repr.t := Raw_context.get_deposits.

Definition get_fees
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t := Raw_context.get_fees.

Definition get_rewards
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Tez_repr.t := Raw_context.get_rewards.

Definition description
  : Tezos_raw_protocol_alpha.Storage_description.t
    Tezos_raw_protocol_alpha.Raw_context.context := Raw_context.description.

src/proto_alpha/lib_protocol/alpha_services.ml 52 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root = RPC_path.open_root

module Seed = struct
  module S = struct
    open Data_encoding

    let seed =
      RPC_service.post_service
        ~description:"Seed of the cycle to which the block belongs."
        ~query:RPC_query.empty
        ~input:empty
        ~output:Seed.seed_encoding
        RPC_path.(custom_root / "context" / "seed")
  end

  let () =
    let open Services_registration in
    register0 S.seed (fun ctxt () () ->
        let l = Level.current ctxt in
        Seed.for_cycle ctxt l.cycle)

  let get ctxt block = RPC_context.make_call0 S.seed ctxt block () ()
end

module Nonce = struct
  type info = Revealed of Nonce.t | Missing of Nonce_hash.t | Forgotten

  let info_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Revealed"
          (obj1 (req "nonce" Nonce.encoding))
          (function Revealed nonce -> Some nonce | _ -> None)
          (fun nonce -> Revealed nonce);
        case
          (Tag 1)
          ~title:"Missing"
          (obj1 (req "hash" Nonce_hash.encoding))
          (function Missing nonce -> Some nonce | _ -> None)
          (fun nonce -> Missing nonce);
        case
          (Tag 2)
          ~title:"Forgotten"
          empty
          (function Forgotten -> Some () | _ -> None)
          (fun () -> Forgotten) ]

  module S = struct
    let get =
      RPC_service.get_service
        ~description:"Info about the nonce of a previous block."
        ~query:RPC_query.empty
        ~output:info_encoding
        RPC_path.(custom_root / "context" / "nonces" /: Raw_level.rpc_arg)
  end

  let register () =
    let open Services_registration in
    register1 S.get (fun ctxt raw_level () () ->
        let level = Level.from_raw ctxt raw_level in
        Nonce.get ctxt level
        >>= function
        | Ok (Revealed nonce) ->
            return (Revealed nonce)
        | Ok (Unrevealed {nonce_hash; _}) ->
            return (Missing nonce_hash)
        | Error _ ->
            return Forgotten)

  let get ctxt block level =
    RPC_context.make_call1 S.get ctxt block level () ()
end

module Contract = Contract_services
module Constants = Constants_services
module Delegate = Delegate_services
module Helpers = Helpers_services
module Forge = Helpers_services.Forge
module Parse = Helpers_services.Parse
module Voting = Voting_services

let register () =
  Contract.register () ;
  Constants.register () ;
  Delegate.register () ;
  Helpers.register () ;
  Nonce.register () ;
  Voting.register ()
src/proto_alpha/lib_protocol/alpha_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Definition custom_root {A : Type}
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context A :=
  RPC_path.open_root.

Module Seed.
  Module S.
    Import Data_encoding.
    
    Definition seed
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        unit Tezos_raw_protocol_alpha.Alpha_context.Seed.seed :=
      RPC_service.post_service
        (Some "Seed of the cycle to which the block belongs." % string)
        RPC_query.empty empty Seed.seed_encoding
        (op_div (op_div custom_root "context" % string) "seed" % string).
  End S.
  
  
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Seed.seed) :=
    RPC_context.make_call0 S.seed ctxt block tt tt.
End Seed.

Module Nonce.
  Inductive info : Type :=
  | Revealed : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t -> info
  | Missing : Tezos_raw_protocol_alpha.Nonce_hash.t -> info
  | Forgotten : info.
  
  Definition info_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
    union None
      (cons
        (case "Revealed" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
          (obj1 (req None None "nonce" % string Nonce.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Revealed nonce => Some nonce
            | _ => None
            end) (fun nonce => Revealed nonce))
        (cons
          (case "Missing" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
            (obj1 (req None None "hash" % string Nonce_hash.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Missing nonce => Some nonce
              | _ => None
              end) (fun nonce => Missing nonce))
          (cons
            (case "Forgotten" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
              empty
              (fun function_parameter =>
                match function_parameter with
                | Forgotten => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Forgotten)) []))).
  
  Module S.
    Definition get
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.raw_level) unit unit
        info :=
      RPC_service.get_service
        (Some "Info about the nonce of a previous block." % string)
        RPC_query.empty info_encoding
        (op_divcolon
          (op_div (op_div custom_root "context" % string) "nonces" % string)
          Raw_level.rpc_arg).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    register1 S.get
      (fun ctxt =>
        fun raw_level =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              let level := Level.from_raw ctxt None raw_level in
              op_gtgteq (Nonce.get ctxt level)
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                      (Tezos_raw_protocol_alpha.Alpha_context.Nonce.Revealed
                        nonce) => _return (Revealed nonce)
                  |
                    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                      (Tezos_raw_protocol_alpha.Alpha_context.Nonce.Unrevealed
                        {| nonce_hash := nonce_hash |}) =>
                    _return (Missing nonce_hash)
                  |
                    Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                      _ => _return Forgotten
                  end)).
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.raw_level)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        info) := RPC_context.make_call1 S.get ctxt block level tt tt.
End Nonce.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Contract.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Constants.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Delegate.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Helpers.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Nonce.register tt in
  Voting.register tt.

src/proto_alpha/lib_protocol/amendment.ml 67 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

(** Returns the proposal submitted by the most delegates.
    Returns None in case of a tie, if proposal quorum is below required
    minimum or if there are no proposals. *)
let select_winning_proposal ctxt =
  Vote.get_proposals ctxt
  >>=? fun proposals ->
  let merge proposal vote winners =
    match winners with
    | None ->
        Some ([proposal], vote)
    | Some (winners, winners_vote) as previous ->
        if Compare.Int32.(vote = winners_vote) then
          Some (proposal :: winners, winners_vote)
        else if Compare.Int32.(vote > winners_vote) then Some ([proposal], vote)
        else previous
  in
  match Protocol_hash.Map.fold merge proposals None with
  | Some ([proposal], vote) ->
      Vote.listing_size ctxt
      >>=? fun max_vote ->
      let min_proposal_quorum = Constants.min_proposal_quorum ctxt in
      let min_vote_to_pass =
        Int32.div (Int32.mul min_proposal_quorum max_vote) 100_00l
      in
      if Compare.Int32.(vote >= min_vote_to_pass) then return_some proposal
      else return_none
  | _ ->
      return_none

(* in case of a tie, let's do nothing. *)

(** A proposal is approved if it has supermajority and the participation reaches
    the current quorum.
    Supermajority means the yays are more 8/10 of casted votes.
    The participation is the ratio of all received votes, including passes, with
    respect to the number of possible votes.
    The participation EMA (exponential moving average) uses the last
    participation EMA and the current participation./
    The expected quorum is calculated using the last participation EMA, capped
    by the min/max quorum protocol constants. *)
let check_approval_and_update_participation_ema ctxt =
  Vote.get_ballots ctxt
  >>=? fun ballots ->
  Vote.listing_size ctxt
  >>=? fun maximum_vote ->
  Vote.get_participation_ema ctxt
  >>=? fun participation_ema ->
  Vote.get_current_quorum ctxt
  >>=? fun expected_quorum ->
  (* Note overflows: considering a maximum of 8e8 tokens, with roll size as
     small as 1e3, there is a maximum of 8e5 rolls and thus votes.
     In 'participation' an Int64 is used because in the worst case 'all_votes is
     8e5 and after the multiplication is 8e9, making it potentially overflow a
     signed Int32 which is 2e9. *)
  let casted_votes = Int32.add ballots.yay ballots.nay in
  let all_votes = Int32.add casted_votes ballots.pass in
  let supermajority = Int32.div (Int32.mul 8l casted_votes) 10l in
  let participation =
    (* in centile of percentage *)
    Int64.(
      to_int32 (div (mul (of_int32 all_votes) 100_00L) (of_int32 maximum_vote)))
  in
  let outcome =
    Compare.Int32.(
      participation >= expected_quorum && ballots.yay >= supermajority)
  in
  let new_participation_ema =
    Int32.(div (add (mul 8l participation_ema) (mul 2l participation)) 10l)
  in
  Vote.set_participation_ema ctxt new_participation_ema
  >>=? fun ctxt -> return (ctxt, outcome)

(** Implements the state machine of the amendment procedure.
    Note that [freeze_listings], that computes the vote weight of each delegate,
    is run at the beginning of each voting period.
*)
let start_new_voting_period ctxt =
  Vote.get_current_period_kind ctxt
  >>=? function
  | Proposal -> (
      select_winning_proposal ctxt
      >>=? fun proposal ->
      Vote.clear_proposals ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      match proposal with
      | None ->
          Vote.freeze_listings ctxt >>=? fun ctxt -> return ctxt
      | Some proposal ->
          Vote.init_current_proposal ctxt proposal
          >>=? fun ctxt ->
          Vote.freeze_listings ctxt
          >>=? fun ctxt ->
          Vote.set_current_period_kind ctxt Testing_vote
          >>=? fun ctxt -> return ctxt )
  | Testing_vote ->
      check_approval_and_update_participation_ema ctxt
      >>=? fun (ctxt, approved) ->
      Vote.clear_ballots ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      if approved then
        let expiration =
          (* in two days maximum... *)
          Time.add
            (Timestamp.current ctxt)
            (Constants.test_chain_duration ctxt)
        in
        Vote.get_current_proposal ctxt
        >>=? fun proposal ->
        fork_test_chain ctxt proposal expiration
        >>= fun ctxt ->
        Vote.set_current_period_kind ctxt Testing >>=? fun ctxt -> return ctxt
      else
        Vote.clear_current_proposal ctxt
        >>=? fun ctxt ->
        Vote.freeze_listings ctxt
        >>=? fun ctxt ->
        Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt
  | Testing ->
      Vote.freeze_listings ctxt
      >>=? fun ctxt ->
      Vote.set_current_period_kind ctxt Promotion_vote
      >>=? fun ctxt -> return ctxt
  | Promotion_vote ->
      check_approval_and_update_participation_ema ctxt
      >>=? fun (ctxt, approved) ->
      ( if approved then
        Vote.get_current_proposal ctxt
        >>=? fun proposal -> activate ctxt proposal >>= fun ctxt -> return ctxt
      else return ctxt )
      >>=? fun ctxt ->
      Vote.clear_ballots ctxt
      >>= fun ctxt ->
      Vote.clear_listings ctxt
      >>=? fun ctxt ->
      Vote.clear_current_proposal ctxt
      >>=? fun ctxt ->
      Vote.freeze_listings ctxt
      >>=? fun ctxt ->
      Vote.set_current_period_kind ctxt Proposal >>=? fun ctxt -> return ctxt

type error +=
  | (* `Branch *)
      Invalid_proposal
  | Unexpected_proposal
  | Unauthorized_proposal
  | Too_many_proposals
  | Empty_proposal
  | Unexpected_ballot
  | Unauthorized_ballot

let () =
  let open Data_encoding in
  (* Invalid proposal *)
  register_error_kind
    `Branch
    ~id:"invalid_proposal"
    ~title:"Invalid proposal"
    ~description:"Ballot provided for a proposal that is not the current one."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid proposal")
    empty
    (function Invalid_proposal -> Some () | _ -> None)
    (fun () -> Invalid_proposal) ;
  (* Unexpected proposal *)
  register_error_kind
    `Branch
    ~id:"unexpected_proposal"
    ~title:"Unexpected proposal"
    ~description:"Proposal recorded outside of a proposal period."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected proposal")
    empty
    (function Unexpected_proposal -> Some () | _ -> None)
    (fun () -> Unexpected_proposal) ;
  (* Unauthorized proposal *)
  register_error_kind
    `Branch
    ~id:"unauthorized_proposal"
    ~title:"Unauthorized proposal"
    ~description:
      "The delegate provided for the proposal is not in the voting listings."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized proposal")
    empty
    (function Unauthorized_proposal -> Some () | _ -> None)
    (fun () -> Unauthorized_proposal) ;
  (* Unexpected ballot *)
  register_error_kind
    `Branch
    ~id:"unexpected_ballot"
    ~title:"Unexpected ballot"
    ~description:"Ballot recorded outside of a voting period."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected ballot")
    empty
    (function Unexpected_ballot -> Some () | _ -> None)
    (fun () -> Unexpected_ballot) ;
  (* Unauthorized ballot *)
  register_error_kind
    `Branch
    ~id:"unauthorized_ballot"
    ~title:"Unauthorized ballot"
    ~description:
      "The delegate provided for the ballot is not in the voting listings."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unauthorized ballot")
    empty
    (function Unauthorized_ballot -> Some () | _ -> None)
    (fun () -> Unauthorized_ballot) ;
  (* Too many proposals *)
  register_error_kind
    `Branch
    ~id:"too_many_proposals"
    ~title:"Too many proposals"
    ~description:
      "The delegate reached the maximum number of allowed proposals."
    ~pp:(fun ppf () -> Format.fprintf ppf "Too many proposals")
    empty
    (function Too_many_proposals -> Some () | _ -> None)
    (fun () -> Too_many_proposals) ;
  (* Empty proposal *)
  register_error_kind
    `Branch
    ~id:"empty_proposal"
    ~title:"Empty proposal"
    ~description:"Proposal lists cannot be empty."
    ~pp:(fun ppf () -> Format.fprintf ppf "Empty proposal")
    empty
    (function Empty_proposal -> Some () | _ -> None)
    (fun () -> Empty_proposal)

(* @return [true] if [List.length l] > [n] w/o computing length *)
let rec longer_than l n =
  if Compare.Int.(n < 0) then assert false
  else
    match l with
    | [] ->
        false
    | _ :: rest ->
        if Compare.Int.(n = 0) then true
        else (* n > 0 *)
          longer_than rest (n - 1)

let record_proposals ctxt delegate proposals =
  (match proposals with [] -> fail Empty_proposal | _ :: _ -> return_unit)
  >>=? fun () ->
  Vote.get_current_period_kind ctxt
  >>=? function
  | Proposal ->
      Vote.in_listings ctxt delegate
      >>= fun in_listings ->
      if in_listings then
        Vote.recorded_proposal_count_for_delegate ctxt delegate
        >>=? fun count ->
        fail_when
          (longer_than proposals (Constants.max_proposals_per_delegate - count))
          Too_many_proposals
        >>=? fun () ->
        fold_left_s
          (fun ctxt proposal -> Vote.record_proposal ctxt proposal delegate)
          ctxt
          proposals
        >>=? fun ctxt -> return ctxt
      else fail Unauthorized_proposal
  | Testing_vote | Testing | Promotion_vote ->
      fail Unexpected_proposal

let record_ballot ctxt delegate proposal ballot =
  Vote.get_current_period_kind ctxt
  >>=? function
  | Testing_vote | Promotion_vote ->
      Vote.get_current_proposal ctxt
      >>=? fun current_proposal ->
      fail_unless
        (Protocol_hash.equal proposal current_proposal)
        Invalid_proposal
      >>=? fun () ->
      Vote.has_recorded_ballot ctxt delegate
      >>= fun has_ballot ->
      fail_when has_ballot Unauthorized_ballot
      >>=? fun () ->
      Vote.in_listings ctxt delegate
      >>= fun in_listings ->
      if in_listings then Vote.record_ballot ctxt delegate ballot
      else fail Unauthorized_ballot
  | Testing | Proposal ->
      fail Unexpected_ballot

let last_of_a_voting_period ctxt l =
  Compare.Int32.(
    Int32.succ l.Level.voting_period_position
    = Constants.blocks_per_voting_period ctxt)

let may_start_new_voting_period ctxt =
  let level = Level.current ctxt in
  if last_of_a_voting_period ctxt level then start_new_voting_period ctxt
  else return ctxt
src/proto_alpha/lib_protocol/amendment.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Definition select_winning_proposal
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.key)) :=
  op_gtgteqquestion (Vote.get_proposals ctxt)
    (fun proposals =>
      let merge {A : Type}
        (proposal : A) (vote :
        Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
        (winners :
        option
          ((list A) *
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)))
        : option
          ((list A) *
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
        match winners with
        | None => Some ((cons proposal []), vote)
        | (Some (winners, winners_vote)) as previous =>
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              vote winners_vote then
            Some ((cons proposal winners), winners_vote)
          else
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                vote winners_vote then
              Some ((cons proposal []), vote)
            else
              previous
        end in
      match Protocol_hash.Map.fold merge proposals None with
      | Some (cons proposal [], vote) =>
        op_gtgteqquestion (Vote.listing_size ctxt)
          (fun max_vote =>
            let min_proposal_quorum := Constants.min_proposal_quorum ctxt in
            let min_vote_to_pass :=
              Int32.div (Int32.mul min_proposal_quorum max_vote)
                (* ❌ Constant of type int32 is converted to int *)
                10000 in
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
                vote min_vote_to_pass then
              return_some proposal
            else
              return_none)
      | _ => return_none
      end).

Definition check_approval_and_update_participation_ema
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.context * bool)) :=
  op_gtgteqquestion (Vote.get_ballots ctxt)
    (fun ballots =>
      op_gtgteqquestion (Vote.listing_size ctxt)
        (fun maximum_vote =>
          op_gtgteqquestion (Vote.get_participation_ema ctxt)
            (fun participation_ema =>
              op_gtgteqquestion (Vote.get_current_quorum ctxt)
                (fun expected_quorum =>
                  let casted_votes := Int32.add (yay ballots) (nay ballots) in
                  let all_votes := Int32.add casted_votes (pass ballots) in
                  let supermajority :=
                    Int32.div
                      (Int32.mul
                        (* ❌ Constant of type int32 is converted to int *)
                        8 casted_votes)
                      (* ❌ Constant of type int32 is converted to int *)
                      10 in
                  let participation :=
                    to_int32
                      (div
                        (mul (of_int32 all_votes)
                          (* ❌ Constant of type int64 is converted to int *)
                          10000) (of_int32 maximum_vote)) in
                  let outcome :=
                    op_andand
                      (Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
                        participation expected_quorum)
                      (Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
                        (yay ballots) supermajority) in
                  let new_participation_ema :=
                    div
                      (add
                        (mul
                          (* ❌ Constant of type int32 is converted to int *)
                          8 participation_ema)
                        (mul
                          (* ❌ Constant of type int32 is converted to int *)
                          2 participation))
                      (* ❌ Constant of type int32 is converted to int *)
                      10 in
                  op_gtgteqquestion
                    (Vote.set_participation_ema ctxt new_participation_ema)
                    (fun ctxt => _return (ctxt, outcome)))))).

Definition start_new_voting_period
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  op_gtgteqquestion (Vote.get_current_period_kind ctxt)
    (fun function_parameter =>
      match function_parameter with
      | Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal =>
        op_gtgteqquestion (select_winning_proposal ctxt)
          (fun proposal =>
            op_gtgteq (Vote.clear_proposals ctxt)
              (fun ctxt =>
                op_gtgteqquestion (Vote.clear_listings ctxt)
                  (fun ctxt =>
                    match proposal with
                    | None =>
                      op_gtgteqquestion (Vote.freeze_listings ctxt)
                        (fun ctxt => _return ctxt)
                    | Some proposal =>
                      op_gtgteqquestion
                        (Vote.init_current_proposal ctxt proposal)
                        (fun ctxt =>
                          op_gtgteqquestion (Vote.freeze_listings ctxt)
                            (fun ctxt =>
                              op_gtgteqquestion
                                (Vote.set_current_period_kind ctxt
                                  Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote)
                                (fun ctxt => _return ctxt)))
                    end)))
      | Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote =>
        op_gtgteqquestion (check_approval_and_update_participation_ema ctxt)
          (fun function_parameter =>
            let '(ctxt, approved) := function_parameter in
            op_gtgteq (Vote.clear_ballots ctxt)
              (fun ctxt =>
                op_gtgteqquestion (Vote.clear_listings ctxt)
                  (fun ctxt =>
                    if approved then
                      let expiration :=
                        Time.add (Timestamp.current ctxt)
                          (Constants.test_chain_duration ctxt) in
                      op_gtgteqquestion (Vote.get_current_proposal ctxt)
                        (fun proposal =>
                          op_gtgteq (fork_test_chain ctxt proposal expiration)
                            (fun ctxt =>
                              op_gtgteqquestion
                                (Vote.set_current_period_kind ctxt
                                  Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing)
                                (fun ctxt => _return ctxt)))
                    else
                      op_gtgteqquestion (Vote.clear_current_proposal ctxt)
                        (fun ctxt =>
                          op_gtgteqquestion (Vote.freeze_listings ctxt)
                            (fun ctxt =>
                              op_gtgteqquestion
                                (Vote.set_current_period_kind ctxt
                                  Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal)
                                (fun ctxt => _return ctxt))))))
      | Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing =>
        op_gtgteqquestion (Vote.freeze_listings ctxt)
          (fun ctxt =>
            op_gtgteqquestion
              (Vote.set_current_period_kind ctxt
                Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote)
              (fun ctxt => _return ctxt))
      | Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote =>
        op_gtgteqquestion (check_approval_and_update_participation_ema ctxt)
          (fun function_parameter =>
            let '(ctxt, approved) := function_parameter in
            op_gtgteqquestion
              (if approved then
                op_gtgteqquestion (Vote.get_current_proposal ctxt)
                  (fun proposal =>
                    op_gtgteq (activate ctxt proposal)
                      (fun ctxt => _return ctxt))
              else
                _return ctxt)
              (fun ctxt =>
                op_gtgteq (Vote.clear_ballots ctxt)
                  (fun ctxt =>
                    op_gtgteqquestion (Vote.clear_listings ctxt)
                      (fun ctxt =>
                        op_gtgteqquestion (Vote.clear_current_proposal ctxt)
                          (fun ctxt =>
                            op_gtgteqquestion (Vote.freeze_listings ctxt)
                              (fun ctxt =>
                                op_gtgteqquestion
                                  (Vote.set_current_period_kind ctxt
                                    Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal)
                                  (fun ctxt => _return ctxt)))))))
      end).

(* ❌ Structure item `typext` not handled. *)
type_extension



Fixpoint longer_than {A : Type}
  (l : list A)
  (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : bool :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      n 0 then
    (* ❌ Assert instruction is not handled. *)
    assert false
  else
    match l with
    | [] => false
    | cons _ rest =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          n 0 then
        true
      else
        longer_than rest (op_minus n 1)
    end.

Definition record_proposals
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (delegate : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  (proposals :
    list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  op_gtgteqquestion
    match proposals with
    | [] =>
      fail
        Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_proposal
    | cons _ _ => return_unit
    end
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (Vote.get_current_period_kind ctxt)
        (fun function_parameter =>
          match function_parameter with
          | Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal =>
            op_gtgteq (Vote.in_listings ctxt delegate)
              (fun in_listings =>
                if in_listings then
                  op_gtgteqquestion
                    (Vote.recorded_proposal_count_for_delegate ctxt delegate)
                    (fun count =>
                      op_gtgteqquestion
                        (fail_when
                          (longer_than proposals
                            (op_minus Constants.max_proposals_per_delegate count))
                          Tezos_protocol_environment_alpha__Environment.Error_monad.Too_many_proposals)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (fold_left_s
                              (fun ctxt =>
                                fun proposal =>
                                  Vote.record_proposal ctxt proposal delegate)
                              ctxt proposals) (fun ctxt => _return ctxt)))
                else
                  fail
                    Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_proposal)
          |
            Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote |
              Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing |
              Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote
            =>
            fail
              Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_proposal
          end)).

Definition record_ballot
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (delegate : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ballot : Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  op_gtgteqquestion (Vote.get_current_period_kind ctxt)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing_vote |
          Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Promotion_vote
        =>
        op_gtgteqquestion (Vote.get_current_proposal ctxt)
          (fun current_proposal =>
            op_gtgteqquestion
              (fail_unless
                (Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                  proposal current_proposal)
                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_proposal)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteq (Vote.has_recorded_ballot ctxt delegate)
                  (fun has_ballot =>
                    op_gtgteqquestion
                      (fail_when has_ballot
                        Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_ballot)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteq (Vote.in_listings ctxt delegate)
                          (fun in_listings =>
                            if in_listings then
                              Vote.record_ballot ctxt delegate ballot
                            else
                              fail
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_ballot)))))
      |
        Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Testing |
          Tezos_raw_protocol_alpha__Alpha_context.Voting_period.Proposal =>
        fail
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_ballot
      end).

Definition last_of_a_voting_period
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (l : Tezos_raw_protocol_alpha.Alpha_context.Level.t) : bool :=
  Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
    (Int32.succ (Level.voting_period_position l))
    (Constants.blocks_per_voting_period ctxt).

Definition may_start_new_voting_period
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  let level := Level.current ctxt in
  if last_of_a_voting_period ctxt level then
    start_new_voting_period ctxt
  else
    _return ctxt.

src/proto_alpha/lib_protocol/apply.ml 261 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tezos Protocol Implementation - Main Entry Points *)

open Alpha_context

type error += Wrong_voting_period of Voting_period.t * Voting_period.t

(* `Temporary *)

type error += Wrong_endorsement_predecessor of Block_hash.t * Block_hash.t

(* `Temporary *)

type error += Duplicate_endorsement of Signature.Public_key_hash.t

(* `Branch *)

type error += Invalid_endorsement_level

type error += Invalid_commitment of {expected : bool}

type error += Internal_operation_replay of packed_internal_operation

type error += Invalid_double_endorsement_evidence (* `Permanent *)

type error +=
  | Inconsistent_double_endorsement_evidence of {
      delegate1 : Signature.Public_key_hash.t;
      delegate2 : Signature.Public_key_hash.t;
    }

(* `Permanent *)

type error += Unrequired_double_endorsement_evidence (* `Branch*)

type error +=
  | Too_early_double_endorsement_evidence of {
      level : Raw_level.t;
      current : Raw_level.t;
    }

(* `Temporary *)

type error +=
  | Outdated_double_endorsement_evidence of {
      level : Raw_level.t;
      last : Raw_level.t;
    }

(* `Permanent *)

type error +=
  | Invalid_double_baking_evidence of {
      hash1 : Block_hash.t;
      level1 : Int32.t;
      hash2 : Block_hash.t;
      level2 : Int32.t;
    }

(* `Permanent *)

type error +=
  | Inconsistent_double_baking_evidence of {
      delegate1 : Signature.Public_key_hash.t;
      delegate2 : Signature.Public_key_hash.t;
    }

(* `Permanent *)

type error += Unrequired_double_baking_evidence (* `Branch*)

type error +=
  | Too_early_double_baking_evidence of {
      level : Raw_level.t;
      current : Raw_level.t;
    }

(* `Temporary *)

type error +=
  | Outdated_double_baking_evidence of {
      level : Raw_level.t;
      last : Raw_level.t;
    }

(* `Permanent *)

type error += Invalid_activation of {pkh : Ed25519.Public_key_hash.t}

type error += Multiple_revelation

type error += Gas_quota_exceeded_init_deserialize (* Permanent *)

type error +=
  | Not_enough_endorsements_for_priority of {
      required : int;
      priority : int;
      endorsements : int;
      timestamp : Time.t;
    }

let () =
  register_error_kind
    `Temporary
    ~id:"operation.wrong_endorsement_predecessor"
    ~title:"Wrong endorsement predecessor"
    ~description:
      "Trying to include an endorsement in a block that is not the successor \
       of the endorsed one"
    ~pp:(fun ppf (e, p) ->
      Format.fprintf
        ppf
        "Wrong predecessor %a, expected %a"
        Block_hash.pp
        p
        Block_hash.pp
        e)
    Data_encoding.(
      obj2
        (req "expected" Block_hash.encoding)
        (req "provided" Block_hash.encoding))
    (function
      | Wrong_endorsement_predecessor (e, p) -> Some (e, p) | _ -> None)
    (fun (e, p) -> Wrong_endorsement_predecessor (e, p)) ;
  register_error_kind
    `Temporary
    ~id:"operation.wrong_voting_period"
    ~title:"Wrong voting period"
    ~description:
      "Trying to onclude a proposal or ballot meant for another voting period"
    ~pp:(fun ppf (e, p) ->
      Format.fprintf
        ppf
        "Wrong voting period %a, current is %a"
        Voting_period.pp
        p
        Voting_period.pp
        e)
    Data_encoding.(
      obj2
        (req "current" Voting_period.encoding)
        (req "provided" Voting_period.encoding))
    (function Wrong_voting_period (e, p) -> Some (e, p) | _ -> None)
    (fun (e, p) -> Wrong_voting_period (e, p)) ;
  register_error_kind
    `Branch
    ~id:"operation.duplicate_endorsement"
    ~title:"Duplicate endorsement"
    ~description:"Two endorsements received from same delegate"
    ~pp:(fun ppf k ->
      Format.fprintf
        ppf
        "Duplicate endorsement from delegate %a (possible replay attack)."
        Signature.Public_key_hash.pp_short
        k)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function Duplicate_endorsement k -> Some k | _ -> None)
    (fun k -> Duplicate_endorsement k) ;
  register_error_kind
    `Temporary
    ~id:"operation.invalid_endorsement_level"
    ~title:"Unexpected level in endorsement"
    ~description:
      "The level of an endorsement is inconsistent with the  provided block \
       hash."
    ~pp:(fun ppf () -> Format.fprintf ppf "Unexpected level in endorsement.")
    Data_encoding.unit
    (function Invalid_endorsement_level -> Some () | _ -> None)
    (fun () -> Invalid_endorsement_level) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_commitment"
    ~title:"Invalid commitment in block header"
    ~description:"The block header has invalid commitment."
    ~pp:(fun ppf expected ->
      if expected then
        Format.fprintf ppf "Missing seed's nonce commitment in block header."
      else
        Format.fprintf
          ppf
          "Unexpected seed's nonce commitment in block header.")
    Data_encoding.(obj1 (req "expected" bool))
    (function Invalid_commitment {expected} -> Some expected | _ -> None)
    (fun expected -> Invalid_commitment {expected}) ;
  register_error_kind
    `Permanent
    ~id:"internal_operation_replay"
    ~title:"Internal operation replay"
    ~description:"An internal operation was emitted twice by a script"
    ~pp:(fun ppf (Internal_operation {nonce; _}) ->
      Format.fprintf
        ppf
        "Internal operation %d was emitted twice by a script"
        nonce)
    Operation.internal_operation_encoding
    (function Internal_operation_replay op -> Some op | _ -> None)
    (fun op -> Internal_operation_replay op) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_double_endorsement_evidence"
    ~title:"Invalid double endorsement evidence"
    ~description:"A double-endorsement evidence is malformed"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Malformed double-endorsement evidence")
    Data_encoding.empty
    (function Invalid_double_endorsement_evidence -> Some () | _ -> None)
    (fun () -> Invalid_double_endorsement_evidence) ;
  register_error_kind
    `Permanent
    ~id:"block.inconsistent_double_endorsement_evidence"
    ~title:"Inconsistent double endorsement evidence"
    ~description:
      "A double-endorsement evidence is inconsistent  (two distinct delegates)"
    ~pp:(fun ppf (delegate1, delegate2) ->
      Format.fprintf
        ppf
        "Inconsistent double-endorsement evidence  (distinct delegate: %a and \
         %a)"
        Signature.Public_key_hash.pp_short
        delegate1
        Signature.Public_key_hash.pp_short
        delegate2)
    Data_encoding.(
      obj2
        (req "delegate1" Signature.Public_key_hash.encoding)
        (req "delegate2" Signature.Public_key_hash.encoding))
    (function
      | Inconsistent_double_endorsement_evidence {delegate1; delegate2} ->
          Some (delegate1, delegate2)
      | _ ->
          None)
    (fun (delegate1, delegate2) ->
      Inconsistent_double_endorsement_evidence {delegate1; delegate2}) ;
  register_error_kind
    `Branch
    ~id:"block.unrequired_double_endorsement_evidence"
    ~title:"Unrequired double endorsement evidence"
    ~description:"A double-endorsement evidence is unrequired"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "A valid double-endorsement operation cannot  be applied: the \
         associated delegate  has previously been denunciated in this cycle.")
    Data_encoding.empty
    (function Unrequired_double_endorsement_evidence -> Some () | _ -> None)
    (fun () -> Unrequired_double_endorsement_evidence) ;
  register_error_kind
    `Temporary
    ~id:"block.too_early_double_endorsement_evidence"
    ~title:"Too early double endorsement evidence"
    ~description:"A double-endorsement evidence is in the future"
    ~pp:(fun ppf (level, current) ->
      Format.fprintf
        ppf
        "A double-endorsement evidence is in the future  (current level: %a, \
         endorsement level: %a)"
        Raw_level.pp
        current
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
    (function
      | Too_early_double_endorsement_evidence {level; current} ->
          Some (level, current)
      | _ ->
          None)
    (fun (level, current) ->
      Too_early_double_endorsement_evidence {level; current}) ;
  register_error_kind
    `Permanent
    ~id:"block.outdated_double_endorsement_evidence"
    ~title:"Outdated double endorsement evidence"
    ~description:"A double-endorsement evidence is outdated."
    ~pp:(fun ppf (level, last) ->
      Format.fprintf
        ppf
        "A double-endorsement evidence is outdated  (last acceptable level: \
         %a, endorsement level: %a)"
        Raw_level.pp
        last
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
    (function
      | Outdated_double_endorsement_evidence {level; last} ->
          Some (level, last)
      | _ ->
          None)
    (fun (level, last) -> Outdated_double_endorsement_evidence {level; last}) ;
  register_error_kind
    `Permanent
    ~id:"block.invalid_double_baking_evidence"
    ~title:"Invalid double baking evidence"
    ~description:
      "A double-baking evidence is inconsistent  (two distinct level)"
    ~pp:(fun ppf (hash1, level1, hash2, level2) ->
      Format.fprintf
        ppf
        "Invalid double-baking evidence (hash: %a and %a, levels: %ld and %ld)"
        Block_hash.pp
        hash1
        Block_hash.pp
        hash2
        level1
        level2)
    Data_encoding.(
      obj4
        (req "hash1" Block_hash.encoding)
        (req "level1" int32)
        (req "hash2" Block_hash.encoding)
        (req "level2" int32))
    (function
      | Invalid_double_baking_evidence {hash1; level1; hash2; level2} ->
          Some (hash1, level1, hash2, level2)
      | _ ->
          None)
    (fun (hash1, level1, hash2, level2) ->
      Invalid_double_baking_evidence {hash1; level1; hash2; level2}) ;
  register_error_kind
    `Permanent
    ~id:"block.inconsistent_double_baking_evidence"
    ~title:"Inconsistent double baking evidence"
    ~description:
      "A double-baking evidence is inconsistent  (two distinct delegates)"
    ~pp:(fun ppf (delegate1, delegate2) ->
      Format.fprintf
        ppf
        "Inconsistent double-baking evidence  (distinct delegate: %a and %a)"
        Signature.Public_key_hash.pp_short
        delegate1
        Signature.Public_key_hash.pp_short
        delegate2)
    Data_encoding.(
      obj2
        (req "delegate1" Signature.Public_key_hash.encoding)
        (req "delegate2" Signature.Public_key_hash.encoding))
    (function
      | Inconsistent_double_baking_evidence {delegate1; delegate2} ->
          Some (delegate1, delegate2)
      | _ ->
          None)
    (fun (delegate1, delegate2) ->
      Inconsistent_double_baking_evidence {delegate1; delegate2}) ;
  register_error_kind
    `Branch
    ~id:"block.unrequired_double_baking_evidence"
    ~title:"Unrequired double baking evidence"
    ~description:"A double-baking evidence is unrequired"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "A valid double-baking operation cannot  be applied: the associated \
         delegate  has previously been denunciated in this cycle.")
    Data_encoding.empty
    (function Unrequired_double_baking_evidence -> Some () | _ -> None)
    (fun () -> Unrequired_double_baking_evidence) ;
  register_error_kind
    `Temporary
    ~id:"block.too_early_double_baking_evidence"
    ~title:"Too early double baking evidence"
    ~description:"A double-baking evidence is in the future"
    ~pp:(fun ppf (level, current) ->
      Format.fprintf
        ppf
        "A double-baking evidence is in the future  (current level: %a, \
         baking level: %a)"
        Raw_level.pp
        current
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "current" Raw_level.encoding))
    (function
      | Too_early_double_baking_evidence {level; current} ->
          Some (level, current)
      | _ ->
          None)
    (fun (level, current) -> Too_early_double_baking_evidence {level; current}) ;
  register_error_kind
    `Permanent
    ~id:"block.outdated_double_baking_evidence"
    ~title:"Outdated double baking evidence"
    ~description:"A double-baking evidence is outdated."
    ~pp:(fun ppf (level, last) ->
      Format.fprintf
        ppf
        "A double-baking evidence is outdated  (last acceptable level: %a, \
         baking level: %a)"
        Raw_level.pp
        last
        Raw_level.pp
        level)
    Data_encoding.(
      obj2 (req "level" Raw_level.encoding) (req "last" Raw_level.encoding))
    (function
      | Outdated_double_baking_evidence {level; last} ->
          Some (level, last)
      | _ ->
          None)
    (fun (level, last) -> Outdated_double_baking_evidence {level; last}) ;
  register_error_kind
    `Permanent
    ~id:"operation.invalid_activation"
    ~title:"Invalid activation"
    ~description:
      "The given key and secret do not correspond to any existing \
       preallocated contract"
    ~pp:(fun ppf pkh ->
      Format.fprintf
        ppf
        "Invalid activation. The public key %a does not match any commitment."
        Ed25519.Public_key_hash.pp
        pkh)
    Data_encoding.(obj1 (req "pkh" Ed25519.Public_key_hash.encoding))
    (function Invalid_activation {pkh} -> Some pkh | _ -> None)
    (fun pkh -> Invalid_activation {pkh}) ;
  register_error_kind
    `Permanent
    ~id:"block.multiple_revelation"
    ~title:"Multiple revelations were included in a manager operation"
    ~description:
      "A manager operation should not contain more than one revelation"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Multiple revelations were included in a manager operation")
    Data_encoding.empty
    (function Multiple_revelation -> Some () | _ -> None)
    (fun () -> Multiple_revelation) ;
  register_error_kind
    `Permanent
    ~id:"gas_exhausted.init_deserialize"
    ~title:"Not enough gas for initial deserialization of script expresions"
    ~description:
      "Gas limit was not high enough to deserialize the transaction \
       parameters or origination script code or initial storage, making the \
       operation impossible to parse within the provided gas bounds."
    Data_encoding.empty
    (function Gas_quota_exceeded_init_deserialize -> Some () | _ -> None)
    (fun () -> Gas_quota_exceeded_init_deserialize) ;
  register_error_kind
    `Permanent
    ~id:"operation.not_enought_endorsements_for_priority"
    ~title:"Not enough endorsements for priority"
    ~description:
      "The block being validated does not include the required minimum number \
       of endorsements for this priority."
    ~pp:(fun ppf (required, endorsements, priority, timestamp) ->
      Format.fprintf
        ppf
        "Wrong number of endorsements (%i) for priority (%i), %i are expected \
         at %a"
        endorsements
        priority
        required
        Time.pp_hum
        timestamp)
    Data_encoding.(
      obj4
        (req "required" int31)
        (req "endorsements" int31)
        (req "priority" int31)
        (req "timestamp" Time.encoding))
    (function
      | Not_enough_endorsements_for_priority
          {required; endorsements; priority; timestamp} ->
          Some (required, endorsements, priority, timestamp)
      | _ ->
          None)
    (fun (required, endorsements, priority, timestamp) ->
      Not_enough_endorsements_for_priority
        {required; endorsements; priority; timestamp})

open Apply_results

let apply_manager_operation_content :
    type kind.
    Alpha_context.t ->
    Script_ir_translator.unparsing_mode ->
    payer:Contract.t ->
    source:Contract.t ->
    chain_id:Chain_id.t ->
    internal:bool ->
    kind manager_operation ->
    ( context
    * kind successful_manager_operation_result
    * packed_internal_operation list )
    tzresult
    Lwt.t =
 fun ctxt mode ~payer ~source ~chain_id ~internal operation ->
  let before_operation =
    (* This context is not used for backtracking. Only to compute
         gas consumption and originations for the operation result. *)
    ctxt
  in
  Contract.must_exist ctxt source
  >>=? fun () ->
  Lwt.return (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation)
  >>=? fun ctxt ->
  match operation with
  | Reveal _ ->
      return
        (* No-op: action already performed by `precheck_manager_contents`. *)
        ( ctxt,
          ( Reveal_result
              {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt}
            : kind successful_manager_operation_result ),
          [] )
  | Transaction {amount; parameters; destination; entrypoint} -> (
      Contract.spend ctxt source amount
      >>=? fun ctxt ->
      ( match Contract.is_implicit destination with
      | None ->
          return (ctxt, [], false)
      | Some _ -> (
          Contract.allocated ctxt destination
          >>=? function
          | true ->
              return (ctxt, [], false)
          | false ->
              Fees.origination_burn ctxt
              >>=? fun (ctxt, origination_burn) ->
              return
                ( ctxt,
                  [(Delegate.Contract payer, Delegate.Debited origination_burn)],
                  true ) ) )
      >>=? fun (ctxt, maybe_burn_balance_update, allocated_destination_contract)
               ->
      Contract.credit ctxt destination amount
      >>=? fun ctxt ->
      Contract.get_script ctxt destination
      >>=? fun (ctxt, script) ->
      match script with
      | None ->
          ( match entrypoint with
          | "default" ->
              return ()
          | entrypoint ->
              fail (Script_tc_errors.No_such_entrypoint entrypoint) )
          >>=? (fun () ->
                 Script.force_decode ctxt parameters
                 >>=? fun (arg, ctxt) ->
                 (* see [note] *)
                 (* [note]: for toplevel ops, cost is nil since the
               lazy value has already been forced at precheck, so
               we compute and consume the full cost again *)
                 let cost_arg = Script.deserialized_cost arg in
                 Lwt.return (Gas.consume ctxt cost_arg)
                 >>=? fun ctxt ->
                 match Micheline.root arg with
                 | Prim (_, D_Unit, [], _) ->
                     (* Allow [Unit] parameter to non-scripted contracts. *)
                     return ctxt
                 | _ ->
                     fail
                       (Script_interpreter.Bad_contract_parameter destination))
          >>=? fun ctxt ->
          let result =
            Transaction_result
              {
                storage = None;
                big_map_diff = None;
                balance_updates =
                  Delegate.cleanup_balance_updates
                    ( [ (Delegate.Contract source, Delegate.Debited amount);
                        (Contract destination, Credited amount) ]
                    @ maybe_burn_balance_update );
                originated_contracts = [];
                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
                storage_size = Z.zero;
                paid_storage_size_diff = Z.zero;
                allocated_destination_contract;
              }
          in
          return (ctxt, result, [])
      | Some script ->
          Script.force_decode ctxt parameters
          >>=? fun (parameter, ctxt) ->
          (* see [note] *)
          let cost_parameter = Script.deserialized_cost parameter in
          Lwt.return (Gas.consume ctxt cost_parameter)
          >>=? fun ctxt ->
          let step_constants =
            let open Script_interpreter in
            {source; payer; self = destination; amount; chain_id}
          in
          Script_interpreter.execute
            ctxt
            mode
            step_constants
            ~script
            ~parameter
            ~entrypoint
          >>=? fun {ctxt; storage; big_map_diff; operations} ->
          Contract.update_script_storage ctxt destination storage big_map_diff
          >>=? fun ctxt ->
          Fees.record_paid_storage_space ctxt destination
          >>=? fun (ctxt, new_size, paid_storage_size_diff, fees) ->
          Contract.originated_from_current_nonce
            ~since:before_operation
            ~until:ctxt
          >>=? fun originated_contracts ->
          let result =
            Transaction_result
              {
                storage = Some storage;
                big_map_diff;
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract payer, Debited fees);
                      (Contract source, Debited amount);
                      (Contract destination, Credited amount) ];
                originated_contracts;
                consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
                storage_size = new_size;
                paid_storage_size_diff;
                allocated_destination_contract;
              }
          in
          return (ctxt, result, operations) )
  | Origination {delegate; script; preorigination; credit} ->
      Script.force_decode ctxt script.storage
      >>=? fun (unparsed_storage, ctxt) ->
      (* see [note] *)
      Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_storage))
      >>=? fun ctxt ->
      Script.force_decode ctxt script.code
      >>=? fun (unparsed_code, ctxt) ->
      (* see [note] *)
      Lwt.return (Gas.consume ctxt (Script.deserialized_cost unparsed_code))
      >>=? fun ctxt ->
      Script_ir_translator.parse_script ctxt ~legacy:false script
      >>=? fun (Ex_script parsed_script, ctxt) ->
      Script_ir_translator.collect_big_maps
        ctxt
        parsed_script.storage_type
        parsed_script.storage
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = Script_ir_translator.no_big_map_id in
      Script_ir_translator.extract_big_map_diff
        ctxt
        Optimized
        parsed_script.storage_type
        parsed_script.storage
        ~to_duplicate
        ~to_update
        ~temporary:false
      >>=? fun (storage, big_map_diff, ctxt) ->
      Script_ir_translator.unparse_data
        ctxt
        Optimized
        parsed_script.storage_type
        storage
      >>=? fun (storage, ctxt) ->
      let storage = Script.lazy_expr (Micheline.strip_locations storage) in
      let script = {script with storage} in
      Contract.spend ctxt source credit
      >>=? fun ctxt ->
      ( match preorigination with
      | Some contract ->
          assert internal ;
          (* The preorigination field is only used to early return
                 the address of an originated contract in Michelson.
                 It cannot come from the outside. *)
          return (ctxt, contract)
      | None ->
          Contract.fresh_contract_from_current_nonce ctxt )
      >>=? fun (ctxt, contract) ->
      Contract.originate
        ctxt
        contract
        ~delegate
        ~balance:credit
        ~script:(script, big_map_diff)
      >>=? fun ctxt ->
      Fees.origination_burn ctxt
      >>=? fun (ctxt, origination_burn) ->
      Fees.record_paid_storage_space ctxt contract
      >>=? fun (ctxt, size, paid_storage_size_diff, fees) ->
      let result =
        Origination_result
          {
            big_map_diff;
            balance_updates =
              Delegate.cleanup_balance_updates
                [ (Contract payer, Debited fees);
                  (Contract payer, Debited origination_burn);
                  (Contract source, Debited credit);
                  (Contract contract, Credited credit) ];
            originated_contracts = [contract];
            consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt;
            storage_size = size;
            paid_storage_size_diff;
          }
      in
      return (ctxt, result, [])
  | Delegation delegate ->
      Delegate.set ctxt source delegate
      >>=? fun ctxt ->
      return
        ( ctxt,
          Delegation_result
            {consumed_gas = Gas.consumed ~since:before_operation ~until:ctxt},
          [] )

let apply_internal_manager_operations ctxt mode ~payer ~chain_id ops =
  let rec apply ctxt applied worklist =
    match worklist with
    | [] ->
        Lwt.return (`Success ctxt, List.rev applied)
    | Internal_operation ({source; operation; nonce} as op) :: rest -> (
        ( if internal_nonce_already_recorded ctxt nonce then
          fail (Internal_operation_replay (Internal_operation op))
        else
          let ctxt = record_internal_nonce ctxt nonce in
          apply_manager_operation_content
            ctxt
            mode
            ~source
            ~payer
            ~chain_id
            ~internal:true
            operation )
        >>= function
        | Error errors ->
            let result =
              Internal_operation_result
                (op, Failed (manager_kind op.operation, errors))
            in
            let skipped =
              List.rev_map
                (fun (Internal_operation op) ->
                  Internal_operation_result
                    (op, Skipped (manager_kind op.operation)))
                rest
            in
            Lwt.return (`Failure, List.rev (skipped @ (result :: applied)))
        | Ok (ctxt, result, emitted) ->
            apply
              ctxt
              (Internal_operation_result (op, Applied result) :: applied)
              (rest @ emitted) )
  in
  apply ctxt [] ops

let precheck_manager_contents (type kind) ctxt chain_id raw_operation
    (op : kind Kind.manager contents) : context tzresult Lwt.t =
  let (Manager_operation
        {source; fee; counter; operation; gas_limit; storage_limit}) =
    op
  in
  Lwt.return (Gas.check_limit ctxt gas_limit)
  >>=? fun () ->
  let ctxt = Gas.set_limit ctxt gas_limit in
  Lwt.return (Fees.check_storage_limit ctxt storage_limit)
  >>=? fun () ->
  Contract.must_be_allocated ctxt (Contract.implicit_contract source)
  >>=? fun () ->
  Contract.check_counter_increment ctxt source counter
  >>=? fun () ->
  ( match operation with
  | Reveal pk ->
      Contract.reveal_manager_key ctxt source pk
  | Transaction {parameters; _} ->
      (* Fail quickly if not enough gas for minimal deserialization cost *)
      Lwt.return
      @@ record_trace Gas_quota_exceeded_init_deserialize
      @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost parameters)
      >>=? fun () ->
      (* Fail if not enough gas for complete deserialization cost *)
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt parameters
      >>|? fun (_arg, ctxt) -> ctxt
  | Origination {script; _} ->
      (* Fail quickly if not enough gas for minimal deserialization cost *)
      Lwt.return
      @@ record_trace Gas_quota_exceeded_init_deserialize
      @@ ( Gas.consume ctxt (Script.minimal_deserialize_cost script.code)
         >>? fun ctxt ->
         Gas.check_enough ctxt (Script.minimal_deserialize_cost script.storage)
         )
      >>=? fun () ->
      (* Fail if not enough gas for complete deserialization cost *)
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt script.code
      >>=? fun (_code, ctxt) ->
      trace Gas_quota_exceeded_init_deserialize
      @@ Script.force_decode ctxt script.storage
      >>|? fun (_storage, ctxt) -> ctxt
  | _ ->
      return ctxt )
  >>=? fun ctxt ->
  Contract.get_manager_key ctxt source
  >>=? fun public_key ->
  (* Currently, the `raw_operation` only contains one signature, so
     all operations are required to be from the same manager. This may
     change in the future, allowing several managers to group-sign a
     sequence of transactions.  *)
  Operation.check_signature public_key chain_id raw_operation
  >>=? fun () ->
  Contract.increment_counter ctxt source
  >>=? fun ctxt ->
  Contract.spend ctxt (Contract.implicit_contract source) fee
  >>=? fun ctxt -> add_fees ctxt fee >>=? fun ctxt -> return ctxt

let apply_manager_contents (type kind) ctxt mode chain_id
    (op : kind Kind.manager contents) :
    ( [`Success of context | `Failure]
    * kind manager_operation_result
    * packed_internal_operation_result list )
    Lwt.t =
  let (Manager_operation {source; operation; gas_limit; storage_limit}) = op in
  let ctxt = Gas.set_limit ctxt gas_limit in
  let ctxt = Fees.start_counting_storage_fees ctxt in
  let source = Contract.implicit_contract source in
  apply_manager_operation_content
    ctxt
    mode
    ~source
    ~payer:source
    ~internal:false
    ~chain_id
    operation
  >>= function
  | Ok (ctxt, operation_results, internal_operations) -> (
      apply_internal_manager_operations
        ctxt
        mode
        ~payer:source
        ~chain_id
        internal_operations
      >>= function
      | (`Success ctxt, internal_operations_results) -> (
          Fees.burn_storage_fees ctxt ~storage_limit ~payer:source
          >>= function
          | Ok ctxt ->
              Lwt.return
                ( `Success ctxt,
                  Applied operation_results,
                  internal_operations_results )
          | Error errors ->
              Lwt.return
                ( `Failure,
                  Backtracked (operation_results, Some errors),
                  internal_operations_results ) )
      | (`Failure, internal_operations_results) ->
          Lwt.return
            (`Failure, Applied operation_results, internal_operations_results)
      )
  | Error errors ->
      Lwt.return (`Failure, Failed (manager_kind operation, errors), [])

let skipped_operation_result :
    type kind. kind manager_operation -> kind manager_operation_result =
  function
  | operation -> (
    match operation with
    | Reveal _ ->
        Applied
          ( Reveal_result {consumed_gas = Z.zero}
            : kind successful_manager_operation_result )
    | _ ->
        Skipped (manager_kind operation) )

let rec mark_skipped :
    type kind.
    baker:Signature.Public_key_hash.t ->
    Level.t ->
    kind Kind.manager contents_list ->
    kind Kind.manager contents_result_list =
 fun ~baker level -> function
  | Single (Manager_operation {source; fee; operation}) ->
      let source = Contract.implicit_contract source in
      Single_result
        (Manager_operation_result
           {
             balance_updates =
               Delegate.cleanup_balance_updates
                 [ (Contract source, Debited fee);
                   (Fees (baker, level.cycle), Credited fee) ];
             operation_result = skipped_operation_result operation;
             internal_operation_results = [];
           })
  | Cons (Manager_operation {source; fee; operation}, rest) ->
      let source = Contract.implicit_contract source in
      Cons_result
        ( Manager_operation_result
            {
              balance_updates =
                Delegate.cleanup_balance_updates
                  [ (Contract source, Debited fee);
                    (Fees (baker, level.cycle), Credited fee) ];
              operation_result = skipped_operation_result operation;
              internal_operation_results = [];
            },
          mark_skipped ~baker level rest )

let rec precheck_manager_contents_list :
    type kind.
    Alpha_context.t ->
    Chain_id.t ->
    _ Operation.t ->
    kind Kind.manager contents_list ->
    context tzresult Lwt.t =
 fun ctxt chain_id raw_operation contents_list ->
  match contents_list with
  | Single (Manager_operation _ as op) ->
      precheck_manager_contents ctxt chain_id raw_operation op
  | Cons ((Manager_operation _ as op), rest) ->
      precheck_manager_contents ctxt chain_id raw_operation op
      >>=? fun ctxt ->
      precheck_manager_contents_list ctxt chain_id raw_operation rest

let rec apply_manager_contents_list_rec :
    type kind.
    Alpha_context.t ->
    Script_ir_translator.unparsing_mode ->
    public_key_hash ->
    Chain_id.t ->
    kind Kind.manager contents_list ->
    ([`Success of context | `Failure] * kind Kind.manager contents_result_list)
    Lwt.t =
 fun ctxt mode baker chain_id contents_list ->
  let level = Level.current ctxt in
  match contents_list with
  | Single (Manager_operation {source; fee; _} as op) ->
      let source = Contract.implicit_contract source in
      apply_manager_contents ctxt mode chain_id op
      >>= fun (ctxt_result, operation_result, internal_operation_results) ->
      let result =
        Manager_operation_result
          {
            balance_updates =
              Delegate.cleanup_balance_updates
                [ (Contract source, Debited fee);
                  (Fees (baker, level.cycle), Credited fee) ];
            operation_result;
            internal_operation_results;
          }
      in
      Lwt.return (ctxt_result, Single_result result)
  | Cons ((Manager_operation {source; fee; _} as op), rest) -> (
      let source = Contract.implicit_contract source in
      apply_manager_contents ctxt mode chain_id op
      >>= function
      | (`Failure, operation_result, internal_operation_results) ->
          let result =
            Manager_operation_result
              {
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract source, Debited fee);
                      (Fees (baker, level.cycle), Credited fee) ];
                operation_result;
                internal_operation_results;
              }
          in
          Lwt.return
            (`Failure, Cons_result (result, mark_skipped ~baker level rest))
      | (`Success ctxt, operation_result, internal_operation_results) ->
          let result =
            Manager_operation_result
              {
                balance_updates =
                  Delegate.cleanup_balance_updates
                    [ (Contract source, Debited fee);
                      (Fees (baker, level.cycle), Credited fee) ];
                operation_result;
                internal_operation_results;
              }
          in
          apply_manager_contents_list_rec ctxt mode baker chain_id rest
          >>= fun (ctxt_result, results) ->
          Lwt.return (ctxt_result, Cons_result (result, results)) )

let mark_backtracked results =
  let rec mark_contents_list :
      type kind.
      kind Kind.manager contents_result_list ->
      kind Kind.manager contents_result_list = function
    | Single_result (Manager_operation_result op) ->
        Single_result
          (Manager_operation_result
             {
               balance_updates = op.balance_updates;
               operation_result =
                 mark_manager_operation_result op.operation_result;
               internal_operation_results =
                 List.map
                   mark_internal_operation_results
                   op.internal_operation_results;
             })
    | Cons_result (Manager_operation_result op, rest) ->
        Cons_result
          ( Manager_operation_result
              {
                balance_updates = op.balance_updates;
                operation_result =
                  mark_manager_operation_result op.operation_result;
                internal_operation_results =
                  List.map
                    mark_internal_operation_results
                    op.internal_operation_results;
              },
            mark_contents_list rest )
  and mark_internal_operation_results
      (Internal_operation_result (kind, result)) =
    Internal_operation_result (kind, mark_manager_operation_result result)
  and mark_manager_operation_result :
      type kind. kind manager_operation_result -> kind manager_operation_result
      = function
    | (Failed _ | Skipped _ | Backtracked _) as result ->
        result
    | Applied (Reveal_result _) as result ->
        result
    | Applied result ->
        Backtracked (result, None)
  in
  mark_contents_list results

let apply_manager_contents_list ctxt mode baker chain_id contents_list =
  apply_manager_contents_list_rec ctxt mode baker chain_id contents_list
  >>= fun (ctxt_result, results) ->
  match ctxt_result with
  | `Failure ->
      Lwt.return (ctxt (* backtracked *), mark_backtracked results)
  | `Success ctxt ->
      Big_map.cleanup_temporary ctxt >>= fun ctxt -> Lwt.return (ctxt, results)

let apply_contents_list (type kind) ctxt chain_id mode pred_block baker
    (operation : kind operation) (contents_list : kind contents_list) :
    (context * kind contents_result_list) tzresult Lwt.t =
  match contents_list with
  | Single (Endorsement {level}) ->
      let block = operation.shell.branch in
      fail_unless
        (Block_hash.equal block pred_block)
        (Wrong_endorsement_predecessor (pred_block, block))
      >>=? fun () ->
      let current_level = (Level.current ctxt).level in
      fail_unless
        Raw_level.(succ level = current_level)
        Invalid_endorsement_level
      >>=? fun () ->
      Baking.check_endorsement_rights ctxt chain_id operation
      >>=? fun (delegate, slots, used) ->
      if used then fail (Duplicate_endorsement delegate)
      else
        let ctxt = record_endorsement ctxt delegate in
        let gap = List.length slots in
        Lwt.return
          Tez.(Constants.endorsement_security_deposit ctxt *? Int64.of_int gap)
        >>=? fun deposit ->
        Delegate.freeze_deposit ctxt delegate deposit
        >>=? fun ctxt ->
        Global.get_block_priority ctxt
        >>=? fun block_priority ->
        Baking.endorsing_reward ctxt ~block_priority gap
        >>=? fun reward ->
        Delegate.freeze_rewards ctxt delegate reward
        >>=? fun ctxt ->
        let level = Level.from_raw ctxt level in
        return
          ( ctxt,
            Single_result
              (Endorsement_result
                 {
                   balance_updates =
                     Delegate.cleanup_balance_updates
                       [ ( Contract (Contract.implicit_contract delegate),
                           Debited deposit );
                         (Deposits (delegate, level.cycle), Credited deposit);
                         (Rewards (delegate, level.cycle), Credited reward) ];
                   delegate;
                   slots;
                 }) )
  | Single (Seed_nonce_revelation {level; nonce}) ->
      let level = Level.from_raw ctxt level in
      Nonce.reveal ctxt level nonce
      >>=? fun ctxt ->
      let seed_nonce_revelation_tip =
        Constants.seed_nonce_revelation_tip ctxt
      in
      add_rewards ctxt seed_nonce_revelation_tip
      >>=? fun ctxt ->
      return
        ( ctxt,
          Single_result
            (Seed_nonce_revelation_result
               [ ( Rewards (baker, level.cycle),
                   Credited seed_nonce_revelation_tip ) ]) )
  | Single (Double_endorsement_evidence {op1; op2}) -> (
    match (op1.protocol_data.contents, op2.protocol_data.contents) with
    | (Single (Endorsement e1), Single (Endorsement e2))
      when Raw_level.(e1.level = e2.level)
           && not (Block_hash.equal op1.shell.branch op2.shell.branch) ->
        let level = Level.from_raw ctxt e1.level in
        let oldest_level = Level.last_allowed_fork_level ctxt in
        fail_unless
          Level.(level < Level.current ctxt)
          (Too_early_double_endorsement_evidence
             {level = level.level; current = (Level.current ctxt).level})
        >>=? fun () ->
        fail_unless
          Raw_level.(oldest_level <= level.level)
          (Outdated_double_endorsement_evidence
             {level = level.level; last = oldest_level})
        >>=? fun () ->
        Baking.check_endorsement_rights ctxt chain_id op1
        >>=? fun (delegate1, _, _) ->
        Baking.check_endorsement_rights ctxt chain_id op2
        >>=? fun (delegate2, _, _) ->
        fail_unless
          (Signature.Public_key_hash.equal delegate1 delegate2)
          (Inconsistent_double_endorsement_evidence {delegate1; delegate2})
        >>=? fun () ->
        Delegate.has_frozen_balance ctxt delegate1 level.cycle
        >>=? fun valid ->
        fail_unless valid Unrequired_double_endorsement_evidence
        >>=? fun () ->
        Delegate.punish ctxt delegate1 level.cycle
        >>=? fun (ctxt, balance) ->
        Lwt.return Tez.(balance.deposit +? balance.fees)
        >>=? fun burned ->
        let reward =
          match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
        in
        add_rewards ctxt reward
        >>=? fun ctxt ->
        let current_cycle = (Level.current ctxt).cycle in
        return
          ( ctxt,
            Single_result
              (Double_endorsement_evidence_result
                 (Delegate.cleanup_balance_updates
                    [ ( Deposits (delegate1, level.cycle),
                        Debited balance.deposit );
                      (Fees (delegate1, level.cycle), Debited balance.fees);
                      ( Rewards (delegate1, level.cycle),
                        Debited balance.rewards );
                      (Rewards (baker, current_cycle), Credited reward) ])) )
    | (_, _) ->
        fail Invalid_double_endorsement_evidence )
  | Single (Double_baking_evidence {bh1; bh2}) ->
      let hash1 = Block_header.hash bh1 in
      let hash2 = Block_header.hash bh2 in
      fail_unless
        ( Compare.Int32.(bh1.shell.level = bh2.shell.level)
        && not (Block_hash.equal hash1 hash2) )
        (Invalid_double_baking_evidence
           {hash1; level1 = bh1.shell.level; hash2; level2 = bh2.shell.level})
      >>=? fun () ->
      Lwt.return (Raw_level.of_int32 bh1.shell.level)
      >>=? fun raw_level ->
      let oldest_level = Level.last_allowed_fork_level ctxt in
      fail_unless
        Raw_level.(raw_level < (Level.current ctxt).level)
        (Too_early_double_baking_evidence
           {level = raw_level; current = (Level.current ctxt).level})
      >>=? fun () ->
      fail_unless
        Raw_level.(oldest_level <= raw_level)
        (Outdated_double_baking_evidence
           {level = raw_level; last = oldest_level})
      >>=? fun () ->
      let level = Level.from_raw ctxt raw_level in
      Roll.baking_rights_owner
        ctxt
        level
        ~priority:bh1.protocol_data.contents.priority
      >>=? fun delegate1 ->
      Baking.check_signature bh1 chain_id delegate1
      >>=? fun () ->
      Roll.baking_rights_owner
        ctxt
        level
        ~priority:bh2.protocol_data.contents.priority
      >>=? fun delegate2 ->
      Baking.check_signature bh2 chain_id delegate2
      >>=? fun () ->
      fail_unless
        (Signature.Public_key.equal delegate1 delegate2)
        (Inconsistent_double_baking_evidence
           {
             delegate1 = Signature.Public_key.hash delegate1;
             delegate2 = Signature.Public_key.hash delegate2;
           })
      >>=? fun () ->
      let delegate = Signature.Public_key.hash delegate1 in
      Delegate.has_frozen_balance ctxt delegate level.cycle
      >>=? fun valid ->
      fail_unless valid Unrequired_double_baking_evidence
      >>=? fun () ->
      Delegate.punish ctxt delegate level.cycle
      >>=? fun (ctxt, balance) ->
      Lwt.return Tez.(balance.deposit +? balance.fees)
      >>=? fun burned ->
      let reward =
        match Tez.(burned /? 2L) with Ok v -> v | Error _ -> Tez.zero
      in
      add_rewards ctxt reward
      >>=? fun ctxt ->
      let current_cycle = (Level.current ctxt).cycle in
      return
        ( ctxt,
          Single_result
            (Double_baking_evidence_result
               (Delegate.cleanup_balance_updates
                  [ (Deposits (delegate, level.cycle), Debited balance.deposit);
                    (Fees (delegate, level.cycle), Debited balance.fees);
                    (Rewards (delegate, level.cycle), Debited balance.rewards);
                    (Rewards (baker, current_cycle), Credited reward) ])) )
  | Single (Activate_account {id = pkh; activation_code}) -> (
      let blinded_pkh =
        Blinded_public_key_hash.of_ed25519_pkh activation_code pkh
      in
      Commitment.get_opt ctxt blinded_pkh
      >>=? function
      | None ->
          fail (Invalid_activation {pkh})
      | Some amount ->
          Commitment.delete ctxt blinded_pkh
          >>=? fun ctxt ->
          let contract = Contract.implicit_contract (Signature.Ed25519 pkh) in
          Contract.(credit ctxt contract amount)
          >>=? fun ctxt ->
          return
            ( ctxt,
              Single_result
                (Activate_account_result [(Contract contract, Credited amount)])
            ) )
  | Single (Proposals {source; period; proposals}) ->
      Roll.delegate_pubkey ctxt source
      >>=? fun delegate ->
      Operation.check_signature delegate chain_id operation
      >>=? fun () ->
      let level = Level.current ctxt in
      fail_unless
        Voting_period.(level.voting_period = period)
        (Wrong_voting_period (level.voting_period, period))
      >>=? fun () ->
      Amendment.record_proposals ctxt source proposals
      >>=? fun ctxt -> return (ctxt, Single_result Proposals_result)
  | Single (Ballot {source; period; proposal; ballot}) ->
      Roll.delegate_pubkey ctxt source
      >>=? fun delegate ->
      Operation.check_signature delegate chain_id operation
      >>=? fun () ->
      let level = Level.current ctxt in
      fail_unless
        Voting_period.(level.voting_period = period)
        (Wrong_voting_period (level.voting_period, period))
      >>=? fun () ->
      Amendment.record_ballot ctxt source proposal ballot
      >>=? fun ctxt -> return (ctxt, Single_result Ballot_result)
  | Single (Manager_operation _) as op ->
      precheck_manager_contents_list ctxt chain_id operation op
      >>=? fun ctxt ->
      apply_manager_contents_list ctxt mode baker chain_id op
      >>= fun (ctxt, result) -> return (ctxt, result)
  | Cons (Manager_operation _, _) as op ->
      precheck_manager_contents_list ctxt chain_id operation op
      >>=? fun ctxt ->
      apply_manager_contents_list ctxt mode baker chain_id op
      >>= fun (ctxt, result) -> return (ctxt, result)

let apply_operation ctxt chain_id mode pred_block baker hash operation =
  let ctxt = Contract.init_origination_nonce ctxt hash in
  apply_contents_list
    ctxt
    chain_id
    mode
    pred_block
    baker
    operation
    operation.protocol_data.contents
  >>=? fun (ctxt, result) ->
  let ctxt = Gas.set_unlimited ctxt in
  let ctxt = Contract.unset_origination_nonce ctxt in
  return (ctxt, {contents = result})

let may_snapshot_roll ctxt =
  let level = Alpha_context.Level.current ctxt in
  let blocks_per_roll_snapshot = Constants.blocks_per_roll_snapshot ctxt in
  if
    Compare.Int32.equal
      (Int32.rem level.cycle_position blocks_per_roll_snapshot)
      (Int32.pred blocks_per_roll_snapshot)
  then Alpha_context.Roll.snapshot_rolls ctxt >>=? fun ctxt -> return ctxt
  else return ctxt

let may_start_new_cycle ctxt =
  Baking.dawn_of_a_new_cycle ctxt
  >>=? function
  | None ->
      return (ctxt, [], [])
  | Some last_cycle ->
      Seed.cycle_end ctxt last_cycle
      >>=? fun (ctxt, unrevealed) ->
      Roll.cycle_end ctxt last_cycle
      >>=? fun ctxt ->
      Delegate.cycle_end ctxt last_cycle unrevealed
      >>=? fun (ctxt, update_balances, deactivated) ->
      Bootstrap.cycle_end ctxt last_cycle
      >>=? fun ctxt -> return (ctxt, update_balances, deactivated)

let begin_full_construction ctxt pred_timestamp protocol_data =
  Alpha_context.Global.set_block_priority
    ctxt
    protocol_data.Block_header.priority
  >>=? fun ctxt ->
  Baking.check_baking_rights ctxt protocol_data pred_timestamp
  >>=? fun (delegate_pk, block_delay) ->
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return (ctxt, protocol_data, delegate_pk, block_delay)

let begin_partial_construction ctxt =
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return ctxt

let begin_application ctxt chain_id block_header pred_timestamp =
  Alpha_context.Global.set_block_priority
    ctxt
    block_header.Block_header.protocol_data.contents.priority
  >>=? fun ctxt ->
  let current_level = Alpha_context.Level.current ctxt in
  Baking.check_proof_of_work_stamp ctxt block_header
  >>=? fun () ->
  Baking.check_fitness_gap ctxt block_header
  >>=? fun () ->
  Baking.check_baking_rights
    ctxt
    block_header.protocol_data.contents
    pred_timestamp
  >>=? fun (delegate_pk, block_delay) ->
  Baking.check_signature block_header chain_id delegate_pk
  >>=? fun () ->
  let has_commitment =
    match block_header.protocol_data.contents.seed_nonce_hash with
    | None ->
        false
    | Some _ ->
        true
  in
  fail_unless
    Compare.Bool.(has_commitment = current_level.expected_commitment)
    (Invalid_commitment {expected = current_level.expected_commitment})
  >>=? fun () ->
  let ctxt = Fitness.increase ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None ->
      assert false (* genesis *)
  | Some pred_level ->
      Baking.endorsement_rights ctxt pred_level
      >>=? fun rights ->
      let ctxt = init_endorsements ctxt rights in
      return (ctxt, delegate_pk, block_delay)

let check_minimum_endorsements ctxt protocol_data block_delay
    included_endorsements =
  let minimum = Baking.minimum_allowed_endorsements ctxt ~block_delay in
  let timestamp = Timestamp.current ctxt in
  fail_unless
    Compare.Int.(included_endorsements >= minimum)
    (Not_enough_endorsements_for_priority
       {
         required = minimum;
         priority = protocol_data.Block_header.priority;
         endorsements = included_endorsements;
         timestamp;
       })

let finalize_application ctxt protocol_data delegate ~block_delay =
  let included_endorsements = included_endorsements ctxt in
  check_minimum_endorsements
    ctxt
    protocol_data
    block_delay
    included_endorsements
  >>=? fun () ->
  let deposit = Constants.block_security_deposit ctxt in
  add_deposit ctxt delegate deposit
  >>=? fun ctxt ->
  Baking.baking_reward
    ctxt
    ~block_priority:protocol_data.priority
    ~included_endorsements
  >>=? fun reward ->
  add_rewards ctxt reward
  >>=? fun ctxt ->
  Signature.Public_key_hash.Map.fold
    (fun delegate deposit ctxt ->
      ctxt >>=? fun ctxt -> Delegate.freeze_deposit ctxt delegate deposit)
    (get_deposits ctxt)
    (return ctxt)
  >>=? fun ctxt ->
  (* end of level (from this point nothing should fail) *)
  let fees = Alpha_context.get_fees ctxt in
  Delegate.freeze_fees ctxt delegate fees
  >>=? fun ctxt ->
  let rewards = Alpha_context.get_rewards ctxt in
  Delegate.freeze_rewards ctxt delegate rewards
  >>=? fun ctxt ->
  ( match protocol_data.Block_header.seed_nonce_hash with
  | None ->
      return ctxt
  | Some nonce_hash ->
      Nonce.record_hash ctxt {nonce_hash; delegate; rewards; fees} )
  >>=? fun ctxt ->
  (* end of cycle *)
  may_snapshot_roll ctxt
  >>=? fun ctxt ->
  may_start_new_cycle ctxt
  >>=? fun (ctxt, balance_updates, deactivated) ->
  Amendment.may_start_new_voting_period ctxt
  >>=? fun ctxt ->
  let cycle = (Level.current ctxt).cycle in
  let balance_updates =
    Delegate.(
      cleanup_balance_updates
        ( [ (Contract (Contract.implicit_contract delegate), Debited deposit);
            (Deposits (delegate, cycle), Credited deposit);
            (Rewards (delegate, cycle), Credited reward) ]
        @ balance_updates ))
  in
  let consumed_gas =
    Z.sub
      (Constants.hard_gas_limit_per_block ctxt)
      (Alpha_context.Gas.block_level ctxt)
  in
  Alpha_context.Vote.get_current_period_kind ctxt
  >>=? fun voting_period_kind ->
  let receipt =
    Apply_results.
      {
        baker = delegate;
        level = Level.current ctxt;
        voting_period_kind;
        nonce_hash = protocol_data.seed_nonce_hash;
        consumed_gas;
        deactivated;
        balance_updates;
      }
  in
  return (ctxt, receipt)
src/proto_alpha/lib_protocol/apply.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Import Apply_results.

Definition apply_manager_operation_content {kind : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (internal : bool)
  (operation : Tezos_raw_protocol_alpha.Alpha_context.manager_operation kind)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (Tezos_raw_protocol_alpha.Apply_results.successful_manager_operation_result
          kind) *
        (list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation))) :=
  let before_operation := ctxt in
  op_gtgteqquestion (Contract.must_exist ctxt source)
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (Lwt._return
          (Gas.consume ctxt Michelson_v1_gas.Cost_of.manager_operation))
        (fun ctxt =>
          match operation with
          | Tezos_raw_protocol_alpha.Alpha_context.Reveal _ =>
            _return
              (ctxt,
                (Tezos_raw_protocol_alpha.Apply_results.Reveal_result
                  {| consumed_gas := Gas.consumed before_operation ctxt |}), [])
          |
            Tezos_raw_protocol_alpha.Alpha_context.Transaction {|
              amount := amount;
                parameters := parameters;
                entrypoint := entrypoint;
                destination := destination
                |} =>
            op_gtgteqquestion (Contract.spend ctxt source amount)
              (fun ctxt =>
                op_gtgteqquestion
                  match Contract.is_implicit destination with
                  | None => _return (ctxt, [], false)
                  | Some _ =>
                    op_gtgteqquestion (Contract.allocated ctxt destination)
                      (fun function_parameter =>
                        match function_parameter with
                        | true => _return (ctxt, [], false)
                        | false =>
                          op_gtgteqquestion (Fees.origination_burn ctxt)
                            (fun function_parameter =>
                              let '(ctxt, origination_burn) :=
                                function_parameter in
                              _return
                                (ctxt,
                                  (cons
                                    ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                      payer),
                                      (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                        origination_burn)) []), true))
                        end)
                  end
                  (fun function_parameter =>
                    let
                      '(ctxt, maybe_burn_balance_update,
                        allocated_destination_contract) := function_parameter in
                    op_gtgteqquestion (Contract.credit ctxt destination amount)
                      (fun ctxt =>
                        op_gtgteqquestion (Contract.get_script ctxt destination)
                          (fun function_parameter =>
                            let '(ctxt, script) := function_parameter in
                            match script with
                            | None =>
                              op_gtgteqquestion
                                (op_gtgteqquestion
                                  match entrypoint with
                                  | "default" % string => _return tt
                                  | entrypoint =>
                                    fail
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
                                        entrypoint)
                                  end
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (Script.force_decode ctxt parameters)
                                      (fun function_parameter =>
                                        let '(arg, ctxt) := function_parameter
                                          in
                                        let cost_arg :=
                                          Script.deserialized_cost arg in
                                        op_gtgteqquestion
                                          (Lwt._return
                                            (Gas.consume ctxt cost_arg))
                                          (fun ctxt =>
                                            match Micheline.root arg with
                                            |
                                              Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                _
                                                Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit
                                                [] _ => _return ctxt
                                            | _ =>
                                              fail
                                                (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
                                                  destination)
                                            end))))
                                (fun ctxt =>
                                  let result :=
                                    Tezos_raw_protocol_alpha.Apply_results.Transaction_result
                                      {| storage := None; big_map_diff := None;
                                        balance_updates :=
                                          Delegate.cleanup_balance_updates
                                            (op_at
                                              (cons
                                                ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                  source),
                                                  (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                    amount))
                                                (cons
                                                  ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                    destination),
                                                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                      amount)) []))
                                              maybe_burn_balance_update);
                                        originated_contracts := [];
                                        consumed_gas :=
                                          Gas.consumed before_operation ctxt;
                                        storage_size := Z.zero;
                                        paid_storage_size_diff := Z.zero;
                                        allocated_destination_contract :=
                                          allocated_destination_contract |} in
                                  _return (ctxt, result, []))
                            | Some script =>
                              op_gtgteqquestion
                                (Script.force_decode ctxt parameters)
                                (fun function_parameter =>
                                  let '(parameter, ctxt) := function_parameter
                                    in
                                  let cost_parameter :=
                                    Script.deserialized_cost parameter in
                                  op_gtgteqquestion
                                    (Lwt._return
                                      (Gas.consume ctxt cost_parameter))
                                    (fun ctxt =>
                                      let step_constants :=
                                        {| source := source; payer := payer;
                                          self := destination; amount := amount;
                                          chain_id := chain_id |} in
                                      op_gtgteqquestion
                                        (Script_interpreter.execute ctxt mode
                                          step_constants script entrypoint
                                          parameter)
                                        (fun function_parameter =>
                                          let '{|
                                            ctxt := ctxt;
                                              storage := storage;
                                              big_map_diff := big_map_diff;
                                              operations := operations
                                              |} := function_parameter in
                                          op_gtgteqquestion
                                            (Contract.update_script_storage ctxt
                                              destination storage big_map_diff)
                                            (fun ctxt =>
                                              op_gtgteqquestion
                                                (Fees.record_paid_storage_space
                                                  ctxt destination)
                                                (fun function_parameter =>
                                                  let
                                                    '(ctxt, new_size,
                                                      paid_storage_size_diff,
                                                      fees) :=
                                                    function_parameter in
                                                  op_gtgteqquestion
                                                    (Contract.originated_from_current_nonce
                                                      before_operation ctxt)
                                                    (fun originated_contracts =>
                                                      let result :=
                                                        Tezos_raw_protocol_alpha.Apply_results.Transaction_result
                                                          {|
                                                            storage :=
                                                              Some storage;
                                                            big_map_diff :=
                                                              big_map_diff;
                                                            balance_updates :=
                                                              Delegate.cleanup_balance_updates
                                                                (cons
                                                                  ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                    payer),
                                                                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                      fees))
                                                                  (cons
                                                                    ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                      source),
                                                                      (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                        amount))
                                                                    (cons
                                                                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                        destination),
                                                                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                                          amount))
                                                                      [])));
                                                            originated_contracts :=
                                                              originated_contracts;
                                                            consumed_gas :=
                                                              Gas.consumed
                                                                before_operation
                                                                ctxt;
                                                            storage_size :=
                                                              new_size;
                                                            paid_storage_size_diff :=
                                                              paid_storage_size_diff;
                                                            allocated_destination_contract :=
                                                              allocated_destination_contract
                                                            |} in
                                                      _return
                                                        (ctxt, result,
                                                          operations)))))))
                            end))))
          |
            Tezos_raw_protocol_alpha.Alpha_context.Origination {|
              delegate := delegate;
                script := script;
                credit := credit;
                preorigination := preorigination
                |} =>
            op_gtgteqquestion (Script.force_decode ctxt (storage script))
              (fun function_parameter =>
                let '(unparsed_storage, ctxt) := function_parameter in
                op_gtgteqquestion
                  (Lwt._return
                    (Gas.consume ctxt
                      (Script.deserialized_cost unparsed_storage)))
                  (fun ctxt =>
                    op_gtgteqquestion (Script.force_decode ctxt (code script))
                      (fun function_parameter =>
                        let '(unparsed_code, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (Lwt._return
                            (Gas.consume ctxt
                              (Script.deserialized_cost unparsed_code)))
                          (fun ctxt =>
                            op_gtgteqquestion
                              (Script_ir_translator.parse_script None ctxt false
                                script)
                              (fun function_parameter =>
                                let
                                  '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
                                    parsed_script, ctxt) := function_parameter
                                  in
                                op_gtgteqquestion
                                  (Script_ir_translator.collect_big_maps ctxt
                                    (storage_type parsed_script)
                                    (storage parsed_script))
                                  (fun function_parameter =>
                                    let '(to_duplicate, ctxt) :=
                                      function_parameter in
                                    let to_update :=
                                      Script_ir_translator.no_big_map_id in
                                    op_gtgteqquestion
                                      (Script_ir_translator.extract_big_map_diff
                                        ctxt
                                        Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                                        false to_duplicate to_update
                                        (storage_type parsed_script)
                                        (storage parsed_script))
                                      (fun function_parameter =>
                                        let '(storage, big_map_diff, ctxt) :=
                                          function_parameter in
                                        op_gtgteqquestion
                                          (Script_ir_translator.unparse_data
                                            ctxt
                                            Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                                            (storage_type parsed_script) storage)
                                          (fun function_parameter =>
                                            let '(storage, ctxt) :=
                                              function_parameter in
                                            let storage :=
                                              Script.lazy_expr
                                                (Micheline.strip_locations
                                                  storage) in
                                            let script :=
                                              (* ❌ Record substitution not handled *)
                                              record_substitution in
                                            op_gtgteqquestion
                                              (Contract.spend ctxt source credit)
                                              (fun ctxt =>
                                                op_gtgteqquestion
                                                  match preorigination with
                                                  | Some contract =>
                                                    (* ❌ Sequences of instructions are not handled (operator ";") *)
                                                    let _ :=
                                                      (* ❌ Assert instruction is not handled. *)
                                                      assert internal in
                                                    _return (ctxt, contract)
                                                  | None =>
                                                    Contract.fresh_contract_from_current_nonce
                                                      ctxt
                                                  end
                                                  (fun function_parameter =>
                                                    let '(ctxt, contract) :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (Contract.originate ctxt
                                                        contract credit
                                                        (script, big_map_diff)
                                                        delegate)
                                                      (fun ctxt =>
                                                        op_gtgteqquestion
                                                          (Fees.origination_burn
                                                            ctxt)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let
                                                              '(ctxt,
                                                                origination_burn) :=
                                                              function_parameter
                                                              in
                                                            op_gtgteqquestion
                                                              (Fees.record_paid_storage_space
                                                                ctxt contract)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let
                                                                  '(ctxt, size,
                                                                    paid_storage_size_diff,
                                                                    fees) :=
                                                                  function_parameter
                                                                  in
                                                                let result :=
                                                                  Tezos_raw_protocol_alpha.Apply_results.Origination_result
                                                                    {|
                                                                      big_map_diff :=
                                                                        big_map_diff;
                                                                      balance_updates :=
                                                                        Delegate.cleanup_balance_updates
                                                                          (cons
                                                                            ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                              payer),
                                                                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                                fees))
                                                                            (cons
                                                                              ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                                payer),
                                                                                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                                  origination_burn))
                                                                              (cons
                                                                                ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                                  source),
                                                                                  (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                                    credit))
                                                                                (cons
                                                                                  ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                                                    contract),
                                                                                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                                                      credit))
                                                                                  []))));
                                                                      originated_contracts :=
                                                                        cons
                                                                          contract
                                                                          [];
                                                                      consumed_gas :=
                                                                        Gas.consumed
                                                                          before_operation
                                                                          ctxt;
                                                                      storage_size :=
                                                                        size;
                                                                      paid_storage_size_diff :=
                                                                        paid_storage_size_diff
                                                                      |} in
                                                                _return
                                                                  (ctxt, result,
                                                                    []))))))))))))))
          | Tezos_raw_protocol_alpha.Alpha_context.Delegation delegate =>
            op_gtgteqquestion (Delegate.set ctxt source delegate)
              (fun ctxt =>
                _return
                  (ctxt,
                    (Tezos_raw_protocol_alpha.Apply_results.Delegation_result
                      {| consumed_gas := Gas.consumed before_operation ctxt |}),
                    []))
          end)).

Definition apply_internal_manager_operations
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ops : list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (variant *
      (list
        Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
  let fix apply
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (applied :
    list Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)
    (worklist :
    list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (variant *
        (list
          Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
    match worklist with
    | [] =>
      Lwt._return
        ((* ❌ Variants not supported *)
        variant, (List.rev applied))
    |
      cons
        (Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
          ({| source := source; operation := operation; nonce := nonce |} as op))
        rest =>
      op_gtgteq
        (if internal_nonce_already_recorded ctxt nonce then
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Internal_operation_replay
              (Tezos_raw_protocol_alpha.Alpha_context.Internal_operation op))
        else
          let ctxt := record_internal_nonce ctxt nonce in
          apply_manager_operation_content ctxt mode payer source chain_id true
            operation)
        (fun function_parameter =>
          match function_parameter with
          |
            Tezos_protocol_environment_alpha__Environment.Pervasives.Error
              errors =>
            let result :=
              Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result
                op
                (Tezos_raw_protocol_alpha.Apply_results.Failed
                  (manager_kind (operation op)) errors) in
            let skipped :=
              List.rev_map
                (fun function_parameter =>
                  let
                    'Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
                      op := function_parameter in
                  Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result
                    op
                    (Tezos_raw_protocol_alpha.Apply_results.Skipped
                      (manager_kind (operation op)))) rest in
            Lwt._return
              ((* ❌ Variants not supported *)
              variant, (List.rev (op_at skipped (cons result applied))))
          |
            Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
              (ctxt, result, emitted) =>
            apply ctxt
              (cons
                (Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result
                  op (Tezos_raw_protocol_alpha.Apply_results.Applied result))
                applied) (op_at rest emitted)
          end)
    end in
  apply ctxt [] ops.

Definition precheck_manager_contents {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (raw_operation : Tezos_raw_protocol_alpha__Alpha_context.operation A)
  (op :
    Tezos_raw_protocol_alpha.Alpha_context.contents
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager B))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let
    'Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      source := source;
        fee := fee;
        counter := counter;
        operation := operation;
        gas_limit := gas_limit;
        storage_limit := storage_limit
        |} := op in
  op_gtgteqquestion (Lwt._return (Gas.check_limit ctxt gas_limit))
    (fun function_parameter =>
      let 'tt := function_parameter in
      let ctxt := Gas.set_limit ctxt gas_limit in
      op_gtgteqquestion
        (Lwt._return (Fees.check_storage_limit ctxt storage_limit))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (Contract.must_be_allocated ctxt (Contract.implicit_contract source))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (Contract.check_counter_increment ctxt source counter)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    match operation with
                    | Tezos_raw_protocol_alpha.Alpha_context.Reveal pk =>
                      Contract.reveal_manager_key ctxt source pk
                    |
                      Tezos_raw_protocol_alpha.Alpha_context.Transaction {|
                        parameters := parameters |} =>
                      op_gtgteqquestion
                        (op_atat Lwt._return
                          (op_atat
                            (record_trace
                              Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                            (Gas.check_enough ctxt
                              (Script.minimal_deserialize_cost parameters))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgtpipequestion
                            (op_atat
                              (trace
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                              (Script.force_decode ctxt parameters))
                            (fun function_parameter =>
                              let '(_arg, ctxt) := function_parameter in
                              ctxt))
                    |
                      Tezos_raw_protocol_alpha.Alpha_context.Origination {|
                        script := script |} =>
                      op_gtgteqquestion
                        (op_atat Lwt._return
                          (op_atat
                            (record_trace
                              Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                            (op_gtgtquestion
                              (Gas.consume ctxt
                                (Script.minimal_deserialize_cost (code script)))
                              (fun ctxt =>
                                Gas.check_enough ctxt
                                  (Script.minimal_deserialize_cost
                                    (storage script))))))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (op_atat
                              (trace
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                              (Script.force_decode ctxt (code script)))
                            (fun function_parameter =>
                              let '(_code, ctxt) := function_parameter in
                              op_gtgtpipequestion
                                (op_atat
                                  (trace
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                                  (Script.force_decode ctxt (storage script)))
                                (fun function_parameter =>
                                  let '(_storage, ctxt) := function_parameter in
                                  ctxt)))
                    | _ => _return ctxt
                    end
                    (fun ctxt =>
                      op_gtgteqquestion (Contract.get_manager_key ctxt source)
                        (fun public_key =>
                          op_gtgteqquestion
                            (Operation.check_signature public_key chain_id
                              raw_operation)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (Contract.increment_counter ctxt source)
                                (fun ctxt =>
                                  op_gtgteqquestion
                                    (Contract.spend ctxt
                                      (Contract.implicit_contract source) fee)
                                    (fun ctxt =>
                                      op_gtgteqquestion (add_fees ctxt fee)
                                        (fun ctxt => _return ctxt)))))))))).

Definition apply_manager_contents {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (op :
    Tezos_raw_protocol_alpha.Alpha_context.contents
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (variant *
      (Tezos_raw_protocol_alpha.Apply_results.manager_operation_result A) *
      (list
        Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)) :=
  let
    'Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      source := source;
        operation := operation;
        gas_limit := gas_limit;
        storage_limit := storage_limit
        |} := op in
  let ctxt := Gas.set_limit ctxt gas_limit in
  let ctxt := Fees.start_counting_storage_fees ctxt in
  let source := Contract.implicit_contract source in
  op_gtgteq
    (apply_manager_operation_content ctxt mode source source chain_id false
      operation)
    (fun function_parameter =>
      match function_parameter with
      |
        Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
          (ctxt, operation_results, internal_operations) =>
        op_gtgteq
          (apply_internal_manager_operations ctxt mode source chain_id
            internal_operations)
          (fun function_parameter =>
            match function_parameter with
            | (Success ctxt, internal_operations_results) =>
              op_gtgteq (Fees.burn_storage_fees ctxt storage_limit source)
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                      ctxt =>
                    Lwt._return
                      ((* ❌ Variants not supported *)
                      variant,
                        (Tezos_raw_protocol_alpha.Apply_results.Applied
                          operation_results), internal_operations_results)
                  |
                    Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                      errors =>
                    Lwt._return
                      ((* ❌ Variants not supported *)
                      variant,
                        (Tezos_raw_protocol_alpha.Apply_results.Backtracked
                          operation_results (Some errors)),
                        internal_operations_results)
                  end)
            | (Failure, internal_operations_results) =>
              Lwt._return
                ((* ❌ Variants not supported *)
                variant,
                  (Tezos_raw_protocol_alpha.Apply_results.Applied
                    operation_results), internal_operations_results)
            end)
      | Tezos_protocol_environment_alpha__Environment.Pervasives.Error errors =>
        Lwt._return
          ((* ❌ Variants not supported *)
          variant,
            (Tezos_raw_protocol_alpha.Apply_results.Failed
              (manager_kind operation) errors), [])
      end).

Definition skipped_operation_result {kind : Type}
  (operation : Tezos_raw_protocol_alpha.Alpha_context.manager_operation kind)
  : Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind :=
  match operation with
  | Tezos_raw_protocol_alpha.Alpha_context.Reveal _ =>
    Tezos_raw_protocol_alpha.Apply_results.Applied
      (Tezos_raw_protocol_alpha.Apply_results.Reveal_result
        {| consumed_gas := Z.zero |})
  | _ => Tezos_raw_protocol_alpha.Apply_results.Skipped (manager_kind operation)
  end.

Fixpoint mark_skipped {kind : Type}
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Level.t)
  (function_parameter :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  : Tezos_raw_protocol_alpha.Apply_results.contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) :=
  match function_parameter with
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
        source := source; fee := fee; operation := operation |}) =>
    let source := Contract.implicit_contract source in
    Tezos_raw_protocol_alpha.Apply_results.Single_result
      (Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
        {|
          balance_updates :=
            Delegate.cleanup_balance_updates
              (cons
                ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                  source),
                  (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited fee))
                (cons
                  ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees baker
                    (cycle level)),
                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                      fee)) []));
          operation_result := skipped_operation_result operation;
          internal_operation_results := [] |})
  |
    Tezos_raw_protocol_alpha.Alpha_context.Cons
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
        source := source; fee := fee; operation := operation |}) rest =>
    let source := Contract.implicit_contract source in
    Tezos_raw_protocol_alpha.Apply_results.Cons_result
      (Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
        {|
          balance_updates :=
            Delegate.cleanup_balance_updates
              (cons
                ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                  source),
                  (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited fee))
                (cons
                  ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees baker
                    (cycle level)),
                    (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                      fee)) []));
          operation_result := skipped_operation_result operation;
          internal_operation_results := [] |}) (mark_skipped baker level rest)
  end.

Fixpoint precheck_manager_contents_list {A kind : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (raw_operation : Tezos_raw_protocol_alpha.Alpha_context.Operation.t A)
  (contents_list :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match contents_list with
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) as op) =>
    precheck_manager_contents ctxt chain_id raw_operation op
  |
    Tezos_raw_protocol_alpha.Alpha_context.Cons
      ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) as op) rest
    =>
    op_gtgteqquestion (precheck_manager_contents ctxt chain_id raw_operation op)
      (fun ctxt =>
        precheck_manager_contents_list ctxt chain_id raw_operation rest)
  end.

Fixpoint apply_manager_contents_list_rec {kind : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (baker : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (contents_list :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (variant *
      (Tezos_raw_protocol_alpha.Apply_results.contents_result_list
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))) :=
  let level := Level.current ctxt in
  match contents_list with
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
        source := source; fee := fee |}) as op) =>
    let source := Contract.implicit_contract source in
    op_gtgteq (apply_manager_contents ctxt mode chain_id op)
      (fun function_parameter =>
        let '(ctxt_result, operation_result, internal_operation_results) :=
          function_parameter in
        let result :=
          Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
            {|
              balance_updates :=
                Delegate.cleanup_balance_updates
                  (cons
                    ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                      source),
                      (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                        fee))
                    (cons
                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
                        baker (cycle level)),
                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                          fee)) [])); operation_result := operation_result;
              internal_operation_results := internal_operation_results |} in
        Lwt._return
          (ctxt_result,
            (Tezos_raw_protocol_alpha.Apply_results.Single_result result)))
  |
    Tezos_raw_protocol_alpha.Alpha_context.Cons
      ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
        source := source; fee := fee |}) as op) rest =>
    let source := Contract.implicit_contract source in
    op_gtgteq (apply_manager_contents ctxt mode chain_id op)
      (fun function_parameter =>
        match function_parameter with
        | (Failure, operation_result, internal_operation_results) =>
          let result :=
            Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
              {|
                balance_updates :=
                  Delegate.cleanup_balance_updates
                    (cons
                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                        source),
                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                          fee))
                      (cons
                        ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
                          baker (cycle level)),
                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                            fee)) [])); operation_result := operation_result;
                internal_operation_results := internal_operation_results |} in
          Lwt._return
            ((* ❌ Variants not supported *)
            variant,
              (Tezos_raw_protocol_alpha.Apply_results.Cons_result result
                (mark_skipped baker level rest)))
        | (Success ctxt, operation_result, internal_operation_results) =>
          let result :=
            Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
              {|
                balance_updates :=
                  Delegate.cleanup_balance_updates
                    (cons
                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                        source),
                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                          fee))
                      (cons
                        ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
                          baker (cycle level)),
                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                            fee)) [])); operation_result := operation_result;
                internal_operation_results := internal_operation_results |} in
          op_gtgteq
            (apply_manager_contents_list_rec ctxt mode baker chain_id rest)
            (fun function_parameter =>
              let '(ctxt_result, results) := function_parameter in
              Lwt._return
                (ctxt_result,
                  (Tezos_raw_protocol_alpha.Apply_results.Cons_result result
                    results)))
        end)
  end.

Definition mark_backtracked {A : Type}
  (results :
    Tezos_raw_protocol_alpha.Apply_results.contents_result_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
  : Tezos_raw_protocol_alpha.Apply_results.contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A) :=
  let fix mark_contents_list {kind : Type}
    (function_parameter :
    Tezos_raw_protocol_alpha.Apply_results.contents_result_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
    : Tezos_raw_protocol_alpha.Apply_results.contents_result_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) :=
    match function_parameter with
    |
      Tezos_raw_protocol_alpha.Apply_results.Single_result
        (Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result op) =>
      Tezos_raw_protocol_alpha.Apply_results.Single_result
        (Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
          {| balance_updates := balance_updates op;
            operation_result :=
              mark_manager_operation_result (operation_result op);
            internal_operation_results :=
              List.map mark_internal_operation_results
                (internal_operation_results op) |})
    |
      Tezos_raw_protocol_alpha.Apply_results.Cons_result
        (Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result op)
        rest =>
      Tezos_raw_protocol_alpha.Apply_results.Cons_result
        (Tezos_raw_protocol_alpha.Apply_results.Manager_operation_result
          {| balance_updates := balance_updates op;
            operation_result :=
              mark_manager_operation_result (operation_result op);
            internal_operation_results :=
              List.map mark_internal_operation_results
                (internal_operation_results op) |}) (mark_contents_list rest)
    end
  with mark_internal_operation_results
    (function_parameter :
    Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result)
    : Tezos_raw_protocol_alpha.Apply_results.packed_internal_operation_result :=
    let
      'Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result kind
        result := function_parameter in
    Tezos_raw_protocol_alpha.Apply_results.Internal_operation_result kind
      (mark_manager_operation_result result)
  with mark_manager_operation_result {kind : Type}
    (function_parameter :
    Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind)
    : Tezos_raw_protocol_alpha.Apply_results.manager_operation_result kind :=
    match function_parameter with
    |
      (Tezos_raw_protocol_alpha.Apply_results.Failed _ _ |
        Tezos_raw_protocol_alpha.Apply_results.Skipped _ |
        Tezos_raw_protocol_alpha.Apply_results.Backtracked _ _) as result =>
      result
    |
      (Tezos_raw_protocol_alpha.Apply_results.Applied
        (Tezos_raw_protocol_alpha.Apply_results.Reveal_result _)) as result =>
      result
    | Tezos_raw_protocol_alpha.Apply_results.Applied result =>
      Tezos_raw_protocol_alpha.Apply_results.Backtracked result None
    end in
  mark_contents_list results.

Definition apply_manager_contents_list {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (baker : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (contents_list :
    Tezos_raw_protocol_alpha.Alpha_context.contents_list
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_raw_protocol_alpha.Alpha_context.t *
      (Tezos_raw_protocol_alpha.Apply_results.contents_result_list
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))) :=
  op_gtgteq
    (apply_manager_contents_list_rec ctxt mode baker chain_id contents_list)
    (fun function_parameter =>
      let '(ctxt_result, results) := function_parameter in
      match ctxt_result with
      | Failure => Lwt._return (ctxt, (mark_backtracked results))
      | Success ctxt =>
        op_gtgteq (Big_map.cleanup_temporary ctxt)
          (fun ctxt => Lwt._return (ctxt, results))
      end).

Definition apply_contents_list {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (pred_block :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (operation : Tezos_raw_protocol_alpha.Alpha_context.operation A)
  (contents_list : Tezos_raw_protocol_alpha.Alpha_context.contents_list A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (Tezos_raw_protocol_alpha.Apply_results.contents_result_list A))) :=
  match contents_list with
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Endorsement {| level := level |})
    =>
    let block := branch (shell operation) in
    op_gtgteqquestion
      (fail_unless
        (Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
          block pred_block)
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_endorsement_predecessor
          pred_block block))
      (fun function_parameter =>
        let 'tt := function_parameter in
        let current_level := level (Level.current ctxt) in
        op_gtgteqquestion
          (fail_unless (op_eq (succ level) current_level)
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_endorsement_level)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Baking.check_endorsement_rights ctxt chain_id operation)
              (fun function_parameter =>
                let '(delegate, slots, used) := function_parameter in
                if used then
                  fail
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_endorsement
                      delegate)
                else
                  let ctxt := record_endorsement ctxt delegate in
                  let gap := List.length slots in
                  op_gtgteqquestion
                    (Lwt._return
                      (op_starquestion
                        (Constants.endorsement_security_deposit ctxt)
                        (Int64.of_int gap)))
                    (fun deposit =>
                      op_gtgteqquestion
                        (Delegate.freeze_deposit ctxt delegate deposit)
                        (fun ctxt =>
                          op_gtgteqquestion (Global.get_block_priority ctxt)
                            (fun block_priority =>
                              op_gtgteqquestion
                                (Baking.endorsing_reward ctxt block_priority gap)
                                (fun reward =>
                                  op_gtgteqquestion
                                    (Delegate.freeze_rewards ctxt delegate
                                      reward)
                                    (fun ctxt =>
                                      let level :=
                                        Level.from_raw ctxt None level in
                                      _return
                                        (ctxt,
                                          (Tezos_raw_protocol_alpha.Apply_results.Single_result
                                            (Tezos_raw_protocol_alpha.Apply_results.Endorsement_result
                                              {|
                                                balance_updates :=
                                                  Delegate.cleanup_balance_updates
                                                    (cons
                                                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                        (Contract.implicit_contract
                                                          delegate)),
                                                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                          deposit))
                                                      (cons
                                                        ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
                                                          delegate (cycle level)),
                                                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                            deposit))
                                                        (cons
                                                          ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                                                            delegate
                                                            (cycle level)),
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                              reward)) [])));
                                                delegate := delegate;
                                                slots := slots |})))))))))))
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation {|
        level := level; nonce := nonce |}) =>
    let level := Level.from_raw ctxt None level in
    op_gtgteqquestion (Nonce.reveal ctxt level nonce)
      (fun ctxt =>
        let seed_nonce_revelation_tip :=
          Constants.seed_nonce_revelation_tip ctxt in
        op_gtgteqquestion (add_rewards ctxt seed_nonce_revelation_tip)
          (fun ctxt =>
            _return
              (ctxt,
                (Tezos_raw_protocol_alpha.Apply_results.Single_result
                  (Tezos_raw_protocol_alpha.Apply_results.Seed_nonce_revelation_result
                    (cons
                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                        baker (cycle level)),
                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                          seed_nonce_revelation_tip)) []))))))
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence {|
        op1 := op1; op2 := op2 |}) =>
    match ((contents (protocol_data op1)), (contents (protocol_data op2))) with
    |
      (Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Endorsement e1),
        Tezos_raw_protocol_alpha.Alpha_context.Single
          (Tezos_raw_protocol_alpha.Alpha_context.Endorsement e2)) =>
      let level := Level.from_raw ctxt None (level e1) in
      let oldest_level := Level.last_allowed_fork_level ctxt in
      op_gtgteqquestion
        (fail_unless (op_lt level (Level.current ctxt))
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_endorsement_evidence
            {| level := level level; current := level (Level.current ctxt) |}))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (fail_unless (op_lteq oldest_level (level level))
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_endorsement_evidence
                {| level := level level; last := oldest_level |}))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (Baking.check_endorsement_rights ctxt chain_id op1)
                (fun function_parameter =>
                  let '(delegate1, _, _) := function_parameter in
                  op_gtgteqquestion
                    (Baking.check_endorsement_rights ctxt chain_id op2)
                    (fun function_parameter =>
                      let '(delegate2, _, _) := function_parameter in
                      op_gtgteqquestion
                        (fail_unless
                          (Signature.Public_key_hash.equal delegate1 delegate2)
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_endorsement_evidence
                            {| delegate1 := delegate1; delegate2 := delegate2 |}))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (Delegate.has_frozen_balance ctxt delegate1
                              (cycle level))
                            (fun valid =>
                              op_gtgteqquestion
                                (fail_unless valid
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.Unrequired_double_endorsement_evidence)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (Delegate.punish ctxt delegate1
                                      (cycle level))
                                    (fun function_parameter =>
                                      let '(ctxt, balance) := function_parameter
                                        in
                                      op_gtgteqquestion
                                        (Lwt._return
                                          (op_plusquestion (deposit balance)
                                            (fees balance)))
                                        (fun burned =>
                                          let reward :=
                                            match
                                              op_divquestion burned
                                                (* ❌ Constant of type int64 is converted to int *)
                                                2 with
                                            |
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                                v => v
                                            |
                                              Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                                _ => Tez.zero
                                            end in
                                          op_gtgteqquestion
                                            (add_rewards ctxt reward)
                                            (fun ctxt =>
                                              let current_cycle :=
                                                cycle (Level.current ctxt) in
                                              _return
                                                (ctxt,
                                                  (Tezos_raw_protocol_alpha.Apply_results.Single_result
                                                    (Tezos_raw_protocol_alpha.Apply_results.Double_endorsement_evidence_result
                                                      (Delegate.cleanup_balance_updates
                                                        (cons
                                                          ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
                                                            delegate1
                                                            (cycle level)),
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                              (deposit balance)))
                                                          (cons
                                                            ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
                                                              delegate1
                                                              (cycle level)),
                                                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                (fees balance)))
                                                            (cons
                                                              ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                                                                delegate1
                                                                (cycle level)),
                                                                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                  (rewards
                                                                    balance)))
                                                              (cons
                                                                ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                                                                  baker
                                                                  current_cycle),
                                                                  (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                                    reward)) []))))))))))))))))))
    | (_, _) =>
      fail
        Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_endorsement_evidence
    end
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence {|
        bh1 := bh1; bh2 := bh2 |}) =>
    let hash1 := Block_header.hash bh1 in
    let hash2 := Block_header.hash bh2 in
    op_gtgteqquestion
      (fail_unless
        (op_andand
          (Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (level (shell bh1)) (level (shell bh2)))
          (not
            (Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
              hash1 hash2)))
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_baking_evidence
          {| hash1 := hash1; level1 := level (shell bh1); hash2 := hash2;
            level2 := level (shell bh2) |}))
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion (Lwt._return (Raw_level.of_int32 (level (shell bh1))))
          (fun raw_level =>
            let oldest_level := Level.last_allowed_fork_level ctxt in
            op_gtgteqquestion
              (fail_unless (op_lt raw_level (level (Level.current ctxt)))
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_baking_evidence
                  {| level := raw_level; current := level (Level.current ctxt)
                    |}))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (fail_unless (op_lteq oldest_level raw_level)
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_baking_evidence
                      {| level := raw_level; last := oldest_level |}))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let level := Level.from_raw ctxt None raw_level in
                    op_gtgteqquestion
                      (Roll.baking_rights_owner ctxt level
                        (priority (contents (protocol_data bh1))))
                      (fun delegate1 =>
                        op_gtgteqquestion
                          (Baking.check_signature bh1 chain_id delegate1)
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Roll.baking_rights_owner ctxt level
                                (priority (contents (protocol_data bh2))))
                              (fun delegate2 =>
                                op_gtgteqquestion
                                  (Baking.check_signature bh2 chain_id delegate2)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteqquestion
                                      (fail_unless
                                        (Signature.Public_key.equal delegate1
                                          delegate2)
                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_baking_evidence
                                          {|
                                            delegate1 :=
                                              Signature.Public_key.hash
                                                delegate1;
                                            delegate2 :=
                                              Signature.Public_key.hash
                                                delegate2 |}))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        let delegate :=
                                          Signature.Public_key.hash delegate1 in
                                        op_gtgteqquestion
                                          (Delegate.has_frozen_balance ctxt
                                            delegate (cycle level))
                                          (fun valid =>
                                            op_gtgteqquestion
                                              (fail_unless valid
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.Unrequired_double_baking_evidence)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                op_gtgteqquestion
                                                  (Delegate.punish ctxt delegate
                                                    (cycle level))
                                                  (fun function_parameter =>
                                                    let '(ctxt, balance) :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (Lwt._return
                                                        (op_plusquestion
                                                          (deposit balance)
                                                          (fees balance)))
                                                      (fun burned =>
                                                        let reward :=
                                                          match
                                                            op_divquestion
                                                              burned
                                                              (* ❌ Constant of type int64 is converted to int *)
                                                              2 with
                                                          |
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                                              v => v
                                                          |
                                                            Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                                              _ => Tez.zero
                                                          end in
                                                        op_gtgteqquestion
                                                          (add_rewards ctxt
                                                            reward)
                                                          (fun ctxt =>
                                                            let current_cycle :=
                                                              cycle
                                                                (Level.current
                                                                  ctxt) in
                                                            _return
                                                              (ctxt,
                                                                (Tezos_raw_protocol_alpha.Apply_results.Single_result
                                                                  (Tezos_raw_protocol_alpha.Apply_results.Double_baking_evidence_result
                                                                    (Delegate.cleanup_balance_updates
                                                                      (cons
                                                                        ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
                                                                          delegate
                                                                          (cycle
                                                                            level)),
                                                                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                            (deposit
                                                                              balance)))
                                                                        (cons
                                                                          ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Fees
                                                                            delegate
                                                                            (cycle
                                                                              level)),
                                                                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                              (fees
                                                                                balance)))
                                                                          (cons
                                                                            ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                                                                              delegate
                                                                              (cycle
                                                                                level)),
                                                                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                                                (rewards
                                                                                  balance)))
                                                                            (cons
                                                                              ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                                                                                baker
                                                                                current_cycle),
                                                                                (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                                                  reward))
                                                                              []))))))))))))))))))))))
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Activate_account {|
        id := pkh; activation_code := activation_code |}) =>
    let blinded_pkh :=
      Blinded_public_key_hash.of_ed25519_pkh activation_code pkh in
    op_gtgteqquestion (Commitment.get_opt ctxt blinded_pkh)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
              {| pkh := pkh |})
        | Some amount =>
          op_gtgteqquestion (Commitment.delete ctxt blinded_pkh)
            (fun ctxt =>
              let contract :=
                Contract.implicit_contract
                  (Tezos_protocol_environment_alpha__Environment.Signature.Ed25519
                    pkh) in
              op_gtgteqquestion (credit ctxt contract amount)
                (fun ctxt =>
                  _return
                    (ctxt,
                      (Tezos_raw_protocol_alpha.Apply_results.Single_result
                        (Tezos_raw_protocol_alpha.Apply_results.Activate_account_result
                          (cons
                            ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                              contract),
                              (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                amount)) []))))))
        end)
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Proposals {|
        source := source; period := period; proposals := proposals |}) =>
    op_gtgteqquestion (Roll.delegate_pubkey ctxt source)
      (fun delegate =>
        op_gtgteqquestion
          (Operation.check_signature delegate chain_id operation)
          (fun function_parameter =>
            let 'tt := function_parameter in
            let level := Level.current ctxt in
            op_gtgteqquestion
              (fail_unless (op_eq (voting_period level) period)
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_voting_period
                  (voting_period level) period))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (Amendment.record_proposals ctxt source proposals)
                  (fun ctxt =>
                    _return
                      (ctxt,
                        (Tezos_raw_protocol_alpha.Apply_results.Single_result
                          Tezos_raw_protocol_alpha.Apply_results.Proposals_result))))))
  |
    Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Ballot {|
        source := source;
          period := period;
          proposal := proposal;
          ballot := ballot
          |}) =>
    op_gtgteqquestion (Roll.delegate_pubkey ctxt source)
      (fun delegate =>
        op_gtgteqquestion
          (Operation.check_signature delegate chain_id operation)
          (fun function_parameter =>
            let 'tt := function_parameter in
            let level := Level.current ctxt in
            op_gtgteqquestion
              (fail_unless (op_eq (voting_period level) period)
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_voting_period
                  (voting_period level) period))
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (Amendment.record_ballot ctxt source proposal ballot)
                  (fun ctxt =>
                    _return
                      (ctxt,
                        (Tezos_raw_protocol_alpha.Apply_results.Single_result
                          Tezos_raw_protocol_alpha.Apply_results.Ballot_result))))))
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _)) as op =>
    op_gtgteqquestion
      (precheck_manager_contents_list ctxt chain_id operation op)
      (fun ctxt =>
        op_gtgteq (apply_manager_contents_list ctxt mode baker chain_id op)
          (fun function_parameter =>
            let '(ctxt, result) := function_parameter in
            _return (ctxt, result)))
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) _) as op =>
    op_gtgteqquestion
      (precheck_manager_contents_list ctxt chain_id operation op)
      (fun ctxt =>
        op_gtgteq (apply_manager_contents_list ctxt mode baker chain_id op)
          (fun function_parameter =>
            let '(ctxt, result) := function_parameter in
            _return (ctxt, result)))
  end.

Definition apply_operation {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (pred_block :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (operation : Tezos_raw_protocol_alpha.Alpha_context.operation A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.context *
        (Tezos_raw_protocol_alpha.Apply_results.operation_metadata A))) :=
  let ctxt := Contract.init_origination_nonce ctxt hash in
  op_gtgteqquestion
    (apply_contents_list ctxt chain_id mode pred_block baker operation
      (contents (protocol_data operation)))
    (fun function_parameter =>
      let '(ctxt, result) := function_parameter in
      let ctxt := Gas.set_unlimited ctxt in
      let ctxt := Contract.unset_origination_nonce ctxt in
      _return (ctxt, {| contents := result |})).

Definition may_snapshot_roll
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.context) :=
  let level := Alpha_context.Level.current ctxt in
  let blocks_per_roll_snapshot := Constants.blocks_per_roll_snapshot ctxt in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
      (Int32.rem (cycle_position level) blocks_per_roll_snapshot)
      (Int32.pred blocks_per_roll_snapshot) then
    op_gtgteqquestion (Alpha_context.Roll.snapshot_rolls ctxt)
      (fun ctxt => _return ctxt)
  else
    _return ctxt.

Definition may_start_new_cycle
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates *
        (list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))) :=
  op_gtgteqquestion (Baking.dawn_of_a_new_cycle ctxt)
    (fun function_parameter =>
      match function_parameter with
      | None => _return (ctxt, [], [])
      | Some last_cycle =>
        op_gtgteqquestion (Seed.cycle_end ctxt last_cycle)
          (fun function_parameter =>
            let '(ctxt, unrevealed) := function_parameter in
            op_gtgteqquestion (Roll.cycle_end ctxt last_cycle)
              (fun ctxt =>
                op_gtgteqquestion
                  (Delegate.cycle_end ctxt last_cycle unrevealed)
                  (fun function_parameter =>
                    let '(ctxt, update_balances, deactivated) :=
                      function_parameter in
                    op_gtgteqquestion (Bootstrap.cycle_end ctxt last_cycle)
                      (fun ctxt => _return (ctxt, update_balances, deactivated)))))
      end).

Definition begin_full_construction
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (pred_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents *
        Tezos_raw_protocol_alpha.Alpha_context.public_key *
        Tezos_raw_protocol_alpha.Alpha_context.Period.t)) :=
  op_gtgteqquestion
    (Alpha_context.Global.set_block_priority ctxt
      (Block_header.priority protocol_data))
    (fun ctxt =>
      op_gtgteqquestion
        (Baking.check_baking_rights ctxt protocol_data pred_timestamp)
        (fun function_parameter =>
          let '(delegate_pk, block_delay) := function_parameter in
          let ctxt := Fitness.increase None ctxt in
          match Level.pred ctxt (Level.current ctxt) with
          | None =>
            (* ❌ Assert instruction is not handled. *)
            assert false
          | Some pred_level =>
            op_gtgteqquestion (Baking.endorsement_rights ctxt pred_level)
              (fun rights =>
                let ctxt := init_endorsements ctxt rights in
                _return (ctxt, protocol_data, delegate_pk, block_delay))
          end)).

Definition begin_partial_construction
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let ctxt := Fitness.increase None ctxt in
  match Level.pred ctxt (Level.current ctxt) with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some pred_level =>
    op_gtgteqquestion (Baking.endorsement_rights ctxt pred_level)
      (fun rights =>
        let ctxt := init_endorsements ctxt rights in
        _return ctxt)
  end.

Definition begin_application
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  (pred_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Alpha_context.public_key *
        Tezos_raw_protocol_alpha.Alpha_context.Period.t)) :=
  op_gtgteqquestion
    (Alpha_context.Global.set_block_priority ctxt
      (priority (contents (Block_header.protocol_data block_header))))
    (fun ctxt =>
      let current_level := Alpha_context.Level.current ctxt in
      op_gtgteqquestion (Baking.check_proof_of_work_stamp ctxt block_header)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion (Baking.check_fitness_gap ctxt block_header)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (Baking.check_baking_rights ctxt
                  (contents (protocol_data block_header)) pred_timestamp)
                (fun function_parameter =>
                  let '(delegate_pk, block_delay) := function_parameter in
                  op_gtgteqquestion
                    (Baking.check_signature block_header chain_id delegate_pk)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      let has_commitment :=
                        match
                          seed_nonce_hash
                            (contents (protocol_data block_header)) with
                        | None => false
                        | Some _ => true
                        end in
                      op_gtgteqquestion
                        (fail_unless
                          (Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                            has_commitment (expected_commitment current_level))
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_commitment
                            {| expected := expected_commitment current_level |}))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          let ctxt := Fitness.increase None ctxt in
                          match Level.pred ctxt (Level.current ctxt) with
                          | None =>
                            (* ❌ Assert instruction is not handled. *)
                            assert false
                          | Some pred_level =>
                            op_gtgteqquestion
                              (Baking.endorsement_rights ctxt pred_level)
                              (fun rights =>
                                let ctxt := init_endorsements ctxt rights in
                                _return (ctxt, delegate_pk, block_delay))
                          end)))))).

Definition check_minimum_endorsements
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
  (included_endorsements :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let minimum := Baking.minimum_allowed_endorsements ctxt block_delay in
  let timestamp := Timestamp.current ctxt in
  fail_unless
    (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      included_endorsements minimum)
    (Tezos_protocol_environment_alpha__Environment.Error_monad.Not_enough_endorsements_for_priority
      {| required := minimum; priority := Block_header.priority protocol_data;
        endorsements := included_endorsements; timestamp := timestamp |}).

Definition finalize_application
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (protocol_data : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        Tezos_raw_protocol_alpha.Apply_results.block_metadata)) :=
  let included_endorsements := included_endorsements ctxt in
  op_gtgteqquestion
    (check_minimum_endorsements ctxt protocol_data block_delay
      included_endorsements)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let deposit := Constants.block_security_deposit ctxt in
      op_gtgteqquestion (add_deposit ctxt delegate deposit)
        (fun ctxt =>
          op_gtgteqquestion
            (Baking.baking_reward ctxt (priority protocol_data)
              included_endorsements)
            (fun reward =>
              op_gtgteqquestion (add_rewards ctxt reward)
                (fun ctxt =>
                  op_gtgteqquestion
                    (Signature.Public_key_hash.Map.fold
                      (fun delegate =>
                        fun deposit =>
                          fun ctxt =>
                            op_gtgteqquestion ctxt
                              (fun ctxt =>
                                Delegate.freeze_deposit ctxt delegate deposit))
                      (get_deposits ctxt) (_return ctxt))
                    (fun ctxt =>
                      let fees := Alpha_context.get_fees ctxt in
                      op_gtgteqquestion
                        (Delegate.freeze_fees ctxt delegate fees)
                        (fun ctxt =>
                          let rewards := Alpha_context.get_rewards ctxt in
                          op_gtgteqquestion
                            (Delegate.freeze_rewards ctxt delegate rewards)
                            (fun ctxt =>
                              op_gtgteqquestion
                                match Block_header.seed_nonce_hash protocol_data
                                  with
                                | None => _return ctxt
                                | Some nonce_hash =>
                                  Nonce.record_hash ctxt
                                    {| nonce_hash := nonce_hash;
                                      delegate := delegate; rewards := rewards;
                                      fees := fees |}
                                end
                                (fun ctxt =>
                                  op_gtgteqquestion (may_snapshot_roll ctxt)
                                    (fun ctxt =>
                                      op_gtgteqquestion
                                        (may_start_new_cycle ctxt)
                                        (fun function_parameter =>
                                          let
                                            '(ctxt, balance_updates, deactivated) :=
                                            function_parameter in
                                          op_gtgteqquestion
                                            (Amendment.may_start_new_voting_period
                                              ctxt)
                                            (fun ctxt =>
                                              let cycle :=
                                                cycle (Level.current ctxt) in
                                              let balance_updates :=
                                                cleanup_balance_updates
                                                  (op_at
                                                    (cons
                                                      ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Contract
                                                        (Contract.implicit_contract
                                                          delegate)),
                                                        (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Debited
                                                          deposit))
                                                      (cons
                                                        ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Deposits
                                                          delegate cycle),
                                                          (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                            deposit))
                                                        (cons
                                                          ((Tezos_raw_protocol_alpha.Alpha_context.Delegate.Rewards
                                                            delegate cycle),
                                                            (Tezos_raw_protocol_alpha.Alpha_context.Delegate.Credited
                                                              reward)) [])))
                                                    balance_updates) in
                                              let consumed_gas :=
                                                Z.sub
                                                  (Constants.hard_gas_limit_per_block
                                                    ctxt)
                                                  (Alpha_context.Gas.block_level
                                                    ctxt) in
                                              op_gtgteqquestion
                                                (Alpha_context.Vote.get_current_period_kind
                                                  ctxt)
                                                (fun voting_period_kind =>
                                                  let receipt :=
                                                    {| baker := delegate;
                                                      level :=
                                                        Level.current ctxt;
                                                      voting_period_kind :=
                                                        voting_period_kind;
                                                      nonce_hash :=
                                                        seed_nonce_hash
                                                          protocol_data;
                                                      consumed_gas :=
                                                        consumed_gas;
                                                      deactivated := deactivated;
                                                      balance_updates :=
                                                        balance_updates |} in
                                                  _return (ctxt, receipt))))))))))))).

src/proto_alpha/lib_protocol/apply_results.ml 147 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Data_encoding

let error_encoding =
  def
    "error"
    ~description:
      "The full list of RPC errors would be too long to include.\n\
       It is available at RPC `/errors` (GET).\n\
       Errors specific to protocol Alpha have an id that starts with \
       `proto.alpha`."
  @@ splitted
       ~json:
         (conv
            (fun err ->
              Data_encoding.Json.construct Error_monad.error_encoding err)
            (fun json ->
              Data_encoding.Json.destruct Error_monad.error_encoding json)
            json)
       ~binary:Error_monad.error_encoding

type _ successful_manager_operation_result =
  | Reveal_result : {
      consumed_gas : Z.t;
    }
      -> Kind.reveal successful_manager_operation_result
  | Transaction_result : {
      storage : Script.expr option;
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
      allocated_destination_contract : bool;
    }
      -> Kind.transaction successful_manager_operation_result
  | Origination_result : {
      big_map_diff : Contract.big_map_diff option;
      balance_updates : Delegate.balance_updates;
      originated_contracts : Contract.t list;
      consumed_gas : Z.t;
      storage_size : Z.t;
      paid_storage_size_diff : Z.t;
    }
      -> Kind.origination successful_manager_operation_result
  | Delegation_result : {
      consumed_gas : Z.t;
    }
      -> Kind.delegation successful_manager_operation_result

type packed_successful_manager_operation_result =
  | Successful_manager_result :
      'kind successful_manager_operation_result
      -> packed_successful_manager_operation_result

type 'kind manager_operation_result =
  | Applied of 'kind successful_manager_operation_result
  | Backtracked of
      'kind successful_manager_operation_result * error list option
  | Failed : 'kind Kind.manager * error list -> 'kind manager_operation_result
  | Skipped : 'kind Kind.manager -> 'kind manager_operation_result

type packed_internal_operation_result =
  | Internal_operation_result :
      'kind internal_operation * 'kind manager_operation_result
      -> packed_internal_operation_result

module Manager_result = struct
  type 'kind case =
    | MCase : {
        op_case : 'kind Operation.Encoding.Manager_operations.case;
        encoding : 'a Data_encoding.t;
        kind : 'kind Kind.manager;
        iselect :
          packed_internal_operation_result ->
          ('kind internal_operation * 'kind manager_operation_result) option;
        select :
          packed_successful_manager_operation_result ->
          'kind successful_manager_operation_result option;
        proj : 'kind successful_manager_operation_result -> 'a;
        inj : 'a -> 'kind successful_manager_operation_result;
        t : 'kind manager_operation_result Data_encoding.t;
      }
        -> 'kind case

  let make ~op_case ~encoding ~kind ~iselect ~select ~proj ~inj =
    let (Operation.Encoding.Manager_operations.MCase {name; _}) = op_case in
    let t =
      def (Format.asprintf "operation.alpha.operation_result.%s" name)
      @@ union
           ~tag_size:`Uint8
           [ case
               (Tag 0)
               ~title:"Applied"
               (merge_objs (obj1 (req "status" (constant "applied"))) encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Backtracked _ ->
                     None
                 | Applied o -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some ((), proj o) ))
               (fun ((), x) -> Applied (inj x));
             case
               (Tag 1)
               ~title:"Failed"
               (obj2
                  (req "status" (constant "failed"))
                  (req "errors" (list error_encoding)))
               (function Failed (_, errs) -> Some ((), errs) | _ -> None)
               (fun ((), errs) -> Failed (kind, errs));
             case
               (Tag 2)
               ~title:"Skipped"
               (obj1 (req "status" (constant "skipped")))
               (function Skipped _ -> Some () | _ -> None)
               (fun () -> Skipped kind);
             case
               (Tag 3)
               ~title:"Backtracked"
               (merge_objs
                  (obj2
                     (req "status" (constant "backtracked"))
                     (opt "errors" (list error_encoding)))
                  encoding)
               (fun o ->
                 match o with
                 | Skipped _ | Failed _ | Applied _ ->
                     None
                 | Backtracked (o, errs) -> (
                   match select (Successful_manager_result o) with
                   | None ->
                       None
                   | Some o ->
                       Some (((), errs), proj o) ))
               (fun (((), errs), x) -> Backtracked (inj x, errs)) ]
    in
    MCase {op_case; encoding; kind; iselect; select; proj; inj; t}

  let reveal_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.reveal_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Reveal_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Reveal_manager_kind
      ~proj:(function Reveal_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Reveal_result {consumed_gas})

  let transaction_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.transaction_case
      ~encoding:
        (obj8
           (opt "storage" Script.expr_encoding)
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero)
           (dft "allocated_destination_contract" bool false))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Transaction_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Transaction_manager_kind
      ~proj:(function
        | Transaction_result
            { storage;
              big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff;
              allocated_destination_contract } ->
            ( storage,
              big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff,
              allocated_destination_contract ))
      ~inj:
        (fun ( storage,
               big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff,
               allocated_destination_contract ) ->
        Transaction_result
          {
            storage;
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
            allocated_destination_contract;
          })

  let origination_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.origination_case
      ~encoding:
        (obj6
           (opt "big_map_diff" Contract.big_map_diff_encoding)
           (dft "balance_updates" Delegate.balance_updates_encoding [])
           (dft "originated_contracts" (list Contract.encoding) [])
           (dft "consumed_gas" z Z.zero)
           (dft "storage_size" z Z.zero)
           (dft "paid_storage_size_diff" z Z.zero))
      ~iselect:(function
        | Internal_operation_result
            (({operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Origination_result _ as op) ->
            Some op
        | _ ->
            None)
      ~proj:(function
        | Origination_result
            { big_map_diff;
              balance_updates;
              originated_contracts;
              consumed_gas;
              storage_size;
              paid_storage_size_diff } ->
            ( big_map_diff,
              balance_updates,
              originated_contracts,
              consumed_gas,
              storage_size,
              paid_storage_size_diff ))
      ~kind:Kind.Origination_manager_kind
      ~inj:
        (fun ( big_map_diff,
               balance_updates,
               originated_contracts,
               consumed_gas,
               storage_size,
               paid_storage_size_diff ) ->
        Origination_result
          {
            big_map_diff;
            balance_updates;
            originated_contracts;
            consumed_gas;
            storage_size;
            paid_storage_size_diff;
          })

  let delegation_case =
    make
      ~op_case:Operation.Encoding.Manager_operations.delegation_case
      ~encoding:Data_encoding.(obj1 (dft "consumed_gas" z Z.zero))
      ~iselect:(function
        | Internal_operation_result (({operation = Delegation _; _} as op), res)
          ->
            Some (op, res)
        | _ ->
            None)
      ~select:(function
        | Successful_manager_result (Delegation_result _ as op) ->
            Some op
        | _ ->
            None)
      ~kind:Kind.Delegation_manager_kind
      ~proj:(function Delegation_result {consumed_gas} -> consumed_gas)
      ~inj:(fun consumed_gas -> Delegation_result {consumed_gas})
end

let internal_operation_result_encoding :
    packed_internal_operation_result Data_encoding.t =
  let make (type kind)
      (Manager_result.MCase res_case : kind Manager_result.case) =
    let (Operation.Encoding.Manager_operations.MCase op_case) =
      res_case.op_case
    in
    case
      (Tag op_case.tag)
      ~title:op_case.name
      (merge_objs
         (obj3
            (req "kind" (constant op_case.name))
            (req "source" Contract.encoding)
            (req "nonce" uint16))
         (merge_objs op_case.encoding (obj1 (req "result" res_case.t))))
      (fun op ->
        match res_case.iselect op with
        | Some (op, res) ->
            Some (((), op.source, op.nonce), (op_case.proj op.operation, res))
        | None ->
            None)
      (fun (((), source, nonce), (op, res)) ->
        let op = {source; operation = op_case.inj op; nonce} in
        Internal_operation_result (op, res))
  in
  def "operation.alpha.internal_operation_result"
  @@ union
       [ make Manager_result.reveal_case;
         make Manager_result.transaction_case;
         make Manager_result.origination_case;
         make Manager_result.delegation_case ]

type 'kind contents_result =
  | Endorsement_result : {
      balance_updates : Delegate.balance_updates;
      delegate : Signature.Public_key_hash.t;
      slots : int list;
    }
      -> Kind.endorsement contents_result
  | Seed_nonce_revelation_result :
      Delegate.balance_updates
      -> Kind.seed_nonce_revelation contents_result
  | Double_endorsement_evidence_result :
      Delegate.balance_updates
      -> Kind.double_endorsement_evidence contents_result
  | Double_baking_evidence_result :
      Delegate.balance_updates
      -> Kind.double_baking_evidence contents_result
  | Activate_account_result :
      Delegate.balance_updates
      -> Kind.activate_account contents_result
  | Proposals_result : Kind.proposals contents_result
  | Ballot_result : Kind.ballot contents_result
  | Manager_operation_result : {
      balance_updates : Delegate.balance_updates;
      operation_result : 'kind manager_operation_result;
      internal_operation_results : packed_internal_operation_result list;
    }
      -> 'kind Kind.manager contents_result

type packed_contents_result =
  | Contents_result : 'kind contents_result -> packed_contents_result

type packed_contents_and_result =
  | Contents_and_result :
      'kind Operation.contents * 'kind contents_result
      -> packed_contents_and_result

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_kind :
    type a b. a Kind.manager -> b Kind.manager -> (a, b) eq option =
 fun ka kb ->
  match (ka, kb) with
  | (Kind.Reveal_manager_kind, Kind.Reveal_manager_kind) ->
      Some Eq
  | (Kind.Reveal_manager_kind, _) ->
      None
  | (Kind.Transaction_manager_kind, Kind.Transaction_manager_kind) ->
      Some Eq
  | (Kind.Transaction_manager_kind, _) ->
      None
  | (Kind.Origination_manager_kind, Kind.Origination_manager_kind) ->
      Some Eq
  | (Kind.Origination_manager_kind, _) ->
      None
  | (Kind.Delegation_manager_kind, Kind.Delegation_manager_kind) ->
      Some Eq
  | (Kind.Delegation_manager_kind, _) ->
      None

module Encoding = struct
  type 'kind case =
    | Case : {
        op_case : 'kind Operation.Encoding.case;
        encoding : 'a Data_encoding.t;
        select : packed_contents_result -> 'kind contents_result option;
        mselect :
          packed_contents_and_result ->
          ('kind contents * 'kind contents_result) option;
        proj : 'kind contents_result -> 'a;
        inj : 'a -> 'kind contents_result;
      }
        -> 'kind case

  let tagged_case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  let endorsement_case =
    Case
      {
        op_case = Operation.Encoding.endorsement_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "delegate" Signature.Public_key_hash.encoding)
            (req "slots" (list uint8));
        select =
          (function
          | Contents_result (Endorsement_result _ as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Endorsement _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj =
          (function
          | Endorsement_result {balance_updates; delegate; slots} ->
              (balance_updates, delegate, slots));
        inj =
          (fun (balance_updates, delegate, slots) ->
            Endorsement_result {balance_updates; delegate; slots});
      }

  let seed_nonce_revelation_case =
    Case
      {
        op_case = Operation.Encoding.seed_nonce_revelation_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Seed_nonce_revelation_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Seed_nonce_revelation _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Seed_nonce_revelation_result bus) -> bus);
        inj = (fun bus -> Seed_nonce_revelation_result bus);
      }

  let double_endorsement_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_endorsement_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_endorsement_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_endorsement_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence_result bus) -> bus);
        inj = (fun bus -> Double_endorsement_evidence_result bus);
      }

  let double_baking_evidence_case =
    Case
      {
        op_case = Operation.Encoding.double_baking_evidence_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Double_baking_evidence_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Double_baking_evidence _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Double_baking_evidence_result bus) -> bus);
        inj = (fun bus -> Double_baking_evidence_result bus);
      }

  let activate_account_case =
    Case
      {
        op_case = Operation.Encoding.activate_account_case;
        encoding =
          obj1 (req "balance_updates" Delegate.balance_updates_encoding);
        select =
          (function
          | Contents_result (Activate_account_result _ as op) ->
              Some op
          | _ ->
              None);
        mselect =
          (function
          | Contents_and_result ((Activate_account _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun (Activate_account_result bus) -> bus);
        inj = (fun bus -> Activate_account_result bus);
      }

  let proposals_case =
    Case
      {
        op_case = Operation.Encoding.proposals_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Proposals_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Proposals _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Proposals_result -> ());
        inj = (fun () -> Proposals_result);
      }

  let ballot_case =
    Case
      {
        op_case = Operation.Encoding.ballot_case;
        encoding = Data_encoding.empty;
        select =
          (function
          | Contents_result (Ballot_result as op) -> Some op | _ -> None);
        mselect =
          (function
          | Contents_and_result ((Ballot _ as op), res) ->
              Some (op, res)
          | _ ->
              None);
        proj = (fun Ballot_result -> ());
        inj = (fun () -> Ballot_result);
      }

  let make_manager_case (type kind)
      (Operation.Encoding.Case op_case :
        kind Kind.manager Operation.Encoding.case)
      (Manager_result.MCase res_case : kind Manager_result.case) mselect =
    Case
      {
        op_case = Operation.Encoding.Case op_case;
        encoding =
          obj3
            (req "balance_updates" Delegate.balance_updates_encoding)
            (req "operation_result" res_case.t)
            (dft
               "internal_operation_results"
               (list internal_operation_result_encoding)
               []);
        select =
          (function
          | Contents_result
              (Manager_operation_result
                ({operation_result = Applied res; _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Applied res})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Backtracked (res, errs); _} as op)) -> (
            match res_case.select (Successful_manager_result res) with
            | Some res ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Backtracked (res, errs)})
            | None ->
                None )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Skipped kind; _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Skipped kind}) )
          | Contents_result
              (Manager_operation_result
                ({operation_result = Failed (kind, errs); _} as op)) -> (
            match equal_manager_kind kind res_case.kind with
            | None ->
                None
            | Some Eq ->
                Some
                  (Manager_operation_result
                     {op with operation_result = Failed (kind, errs)}) )
          | Contents_result Ballot_result ->
              None
          | Contents_result (Endorsement_result _) ->
              None
          | Contents_result (Seed_nonce_revelation_result _) ->
              None
          | Contents_result (Double_endorsement_evidence_result _) ->
              None
          | Contents_result (Double_baking_evidence_result _) ->
              None
          | Contents_result (Activate_account_result _) ->
              None
          | Contents_result Proposals_result ->
              None);
        mselect;
        proj =
          (fun (Manager_operation_result
                 { balance_updates = bus;
                   operation_result = r;
                   internal_operation_results = rs }) ->
            (bus, r, rs));
        inj =
          (fun (bus, r, rs) ->
            Manager_operation_result
              {
                balance_updates = bus;
                operation_result = r;
                internal_operation_results = rs;
              });
      }

  let reveal_case =
    make_manager_case
      Operation.Encoding.reveal_case
      Manager_result.reveal_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Reveal _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let transaction_case =
    make_manager_case
      Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Transaction _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let origination_case =
    make_manager_case
      Operation.Encoding.origination_case
      Manager_result.origination_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Origination _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)

  let delegation_case =
    make_manager_case
      Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (function
        | Contents_and_result
            ((Manager_operation {operation = Delegation _; _} as op), res) ->
            Some (op, res)
        | _ ->
            None)
end

let contents_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; _};
          encoding;
          mselect = _;
          select;
          proj;
          inj }) =
    let proj x =
      match select x with None -> None | Some x -> Some (proj x)
    in
    let inj x = Contents_result (inj x) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.contents_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

let contents_and_result_encoding =
  let open Encoding in
  let make
      (Case
        { op_case = Operation.Encoding.Case {tag; name; encoding; proj; inj; _};
          mselect;
          encoding = meta_encoding;
          proj = meta_proj;
          inj = meta_inj;
          _ }) =
    let proj c =
      match mselect c with
      | Some (op, res) ->
          Some (proj op, meta_proj res)
      | _ ->
          None
    in
    let inj (op, res) = Contents_and_result (inj op, meta_inj res) in
    let encoding = merge_objs encoding (obj1 (req "metadata" meta_encoding)) in
    tagged_case (Tag tag) name encoding proj inj
  in
  def "operation.alpha.operation_contents_and_result"
  @@ union
       [ make endorsement_case;
         make seed_nonce_revelation_case;
         make double_endorsement_evidence_case;
         make double_baking_evidence_case;
         make activate_account_case;
         make proposals_case;
         make ballot_case;
         make reveal_case;
         make transaction_case;
         make origination_case;
         make delegation_case ]

type 'kind contents_result_list =
  | Single_result : 'kind contents_result -> 'kind contents_result_list
  | Cons_result :
      'kind Kind.manager contents_result
      * 'rest Kind.manager contents_result_list
      -> ('kind * 'rest) Kind.manager contents_result_list

type packed_contents_result_list =
  | Contents_result_list :
      'kind contents_result_list
      -> packed_contents_result_list

let contents_result_list_encoding =
  let rec to_list = function
    | Contents_result_list (Single_result o) ->
        [Contents_result o]
    | Contents_result_list (Cons_result (o, os)) ->
        Contents_result o :: to_list (Contents_result_list os)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty operation result"
    | [Contents_result o] ->
        Contents_result_list (Single_result o)
    | Contents_result o :: os -> (
        let (Contents_result_list os) = of_list os in
        match (o, os) with
        | ( Manager_operation_result _,
            Single_result (Manager_operation_result _) ) ->
            Contents_result_list (Cons_result (o, os))
        | (Manager_operation_result _, Cons_result _) ->
            Contents_result_list (Cons_result (o, os))
        | _ ->
            Pervasives.failwith "cannot decode ill-formed operation result" )
  in
  def "operation.alpha.contents_list_result"
  @@ conv to_list of_list (list contents_result_encoding)

type 'kind contents_and_result_list =
  | Single_and_result :
      'kind Alpha_context.contents * 'kind contents_result
      -> 'kind contents_and_result_list
  | Cons_and_result :
      'kind Kind.manager Alpha_context.contents
      * 'kind Kind.manager contents_result
      * 'rest Kind.manager contents_and_result_list
      -> ('kind * 'rest) Kind.manager contents_and_result_list

type packed_contents_and_result_list =
  | Contents_and_result_list :
      'kind contents_and_result_list
      -> packed_contents_and_result_list

let contents_and_result_list_encoding =
  let rec to_list = function
    | Contents_and_result_list (Single_and_result (op, res)) ->
        [Contents_and_result (op, res)]
    | Contents_and_result_list (Cons_and_result (op, res, rest)) ->
        Contents_and_result (op, res)
        :: to_list (Contents_and_result_list rest)
  in
  let rec of_list = function
    | [] ->
        Pervasives.failwith "cannot decode empty combined operation result"
    | [Contents_and_result (op, res)] ->
        Contents_and_result_list (Single_and_result (op, res))
    | Contents_and_result (op, res) :: rest -> (
        let (Contents_and_result_list rest) = of_list rest in
        match (op, rest) with
        | (Manager_operation _, Single_and_result (Manager_operation _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | (Manager_operation _, Cons_and_result (_, _, _)) ->
            Contents_and_result_list (Cons_and_result (op, res, rest))
        | _ ->
            Pervasives.failwith
              "cannot decode ill-formed combined operation result" )
  in
  conv to_list of_list (Variable.list contents_and_result_encoding)

type 'kind operation_metadata = {contents : 'kind contents_result_list}

type packed_operation_metadata =
  | Operation_metadata : 'kind operation_metadata -> packed_operation_metadata
  | No_operation_metadata : packed_operation_metadata

let operation_metadata_encoding =
  def "operation.alpha.result"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_metadata"
           contents_result_list_encoding
           (function
             | Operation_metadata {contents} ->
                 Some (Contents_result_list contents)
             | _ ->
                 None)
           (fun (Contents_result_list contents) ->
             Operation_metadata {contents});
         case
           (Tag 1)
           ~title:"No_operation_metadata"
           empty
           (function No_operation_metadata -> Some () | _ -> None)
           (fun () -> No_operation_metadata) ]

let kind_equal :
    type kind kind2.
    kind contents -> kind2 contents_result -> (kind, kind2) eq option =
 fun op res ->
  match (op, res) with
  | (Endorsement _, Endorsement_result _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation_result _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence_result _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence_result _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account_result _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals_result) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot_result) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result {operation_result = Applied (Reveal_result _); _}
    ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Backtracked (Reveal_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        { operation_result = Failed (Alpha_context.Kind.Reveal_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Reveal _; _},
      Manager_operation_result
        {operation_result = Skipped Alpha_context.Kind.Reveal_manager_kind; _}
    ) ->
      Some Eq
  | (Manager_operation {operation = Reveal _; _}, _) ->
      None
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Applied (Transaction_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        {operation_result = Backtracked (Transaction_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Transaction_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Transaction _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Transaction_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Transaction _; _}, _) ->
      None
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Applied (Origination_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        {operation_result = Backtracked (Origination_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Origination_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Origination _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Origination_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Origination _; _}, _) ->
      None
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Applied (Delegation_result _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        {operation_result = Backtracked (Delegation_result _, _); _} ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result =
            Failed (Alpha_context.Kind.Delegation_manager_kind, _);
          _ } ) ->
      Some Eq
  | ( Manager_operation {operation = Delegation _; _},
      Manager_operation_result
        { operation_result = Skipped Alpha_context.Kind.Delegation_manager_kind;
          _ } ) ->
      Some Eq
  | (Manager_operation {operation = Delegation _; _}, _) ->
      None

let rec kind_equal_list :
    type kind kind2.
    kind contents_list -> kind2 contents_result_list -> (kind, kind2) eq option
    =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) -> (
    match kind_equal op res with None -> None | Some Eq -> Some Eq )
  | (Cons (op, ops), Cons_result (res, ress)) -> (
    match kind_equal op res with
    | None ->
        None
    | Some Eq -> (
      match kind_equal_list ops ress with None -> None | Some Eq -> Some Eq ) )
  | _ ->
      None

let rec pack_contents_list :
    type kind.
    kind contents_list ->
    kind contents_result_list ->
    kind contents_and_result_list =
 fun contents res ->
  match (contents, res) with
  | (Single op, Single_result res) ->
      Single_and_result (op, res)
  | (Cons (op, ops), Cons_result (res, ress)) ->
      Cons_and_result (op, res, pack_contents_list ops ress)
  | ( Single (Manager_operation _),
      Cons_result (Manager_operation_result _, Single_result _) ) ->
      .
  | ( Cons (_, _),
      Single_result (Manager_operation_result {operation_result = Failed _; _})
    ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Skipped _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Applied _; _}) ) ->
      .
  | ( Cons (_, _),
      Single_result
        (Manager_operation_result {operation_result = Backtracked _; _}) ) ->
      .
  | (Single _, Cons_result _) ->
      .

let rec unpack_contents_list :
    type kind.
    kind contents_and_result_list ->
    kind contents_list * kind contents_result_list = function
  | Single_and_result (op, res) ->
      (Single op, Single_result res)
  | Cons_and_result (op, res, rest) ->
      let (ops, ress) = unpack_contents_list rest in
      (Cons (op, ops), Cons_result (res, ress))

let rec to_list = function
  | Contents_result_list (Single_result o) ->
      [Contents_result o]
  | Contents_result_list (Cons_result (o, os)) ->
      Contents_result o :: to_list (Contents_result_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents_result o] ->
      Contents_result_list (Single_result o)
  | Contents_result o :: os -> (
      let (Contents_result_list os) = of_list os in
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        ->
          Contents_result_list (Cons_result (o, os))
      | (Manager_operation_result _, Cons_result _) ->
          Contents_result_list (Cons_result (o, os))
      | _ ->
          Pervasives.failwith
            "Operation result list of length > 1 should only contains manager \
             operations result." )

let operation_data_and_metadata_encoding =
  def "operation.alpha.operation_with_metadata"
  @@ union
       [ case
           (Tag 0)
           ~title:"Operation_with_metadata"
           (obj2
              (req "contents" (dynamic_size contents_and_result_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data _, No_operation_metadata) ->
                 None
             | (Operation_data op, Operation_metadata res) -> (
               match kind_equal_list op.contents res.contents with
               | None ->
                   Pervasives.failwith
                     "cannot decode inconsistent combined operation result"
               | Some Eq ->
                   Some
                     ( Contents_and_result_list
                         (pack_contents_list op.contents res.contents),
                       op.signature ) ))
           (fun (Contents_and_result_list contents, signature) ->
             let (op_contents, res_contents) = unpack_contents_list contents in
             ( Operation_data {contents = op_contents; signature},
               Operation_metadata {contents = res_contents} ));
         case
           (Tag 1)
           ~title:"Operation_without_metadata"
           (obj2
              (req "contents" (dynamic_size Operation.contents_list_encoding))
              (opt "signature" Signature.encoding))
           (function
             | (Operation_data op, No_operation_metadata) ->
                 Some (Contents_list op.contents, op.signature)
             | (Operation_data _, Operation_metadata _) ->
                 None)
           (fun (Contents_list contents, signature) ->
             (Operation_data {contents; signature}, No_operation_metadata)) ]

type block_metadata = {
  baker : Signature.Public_key_hash.t;
  level : Level.t;
  voting_period_kind : Voting_period.kind;
  nonce_hash : Nonce_hash.t option;
  consumed_gas : Z.t;
  deactivated : Signature.Public_key_hash.t list;
  balance_updates : Delegate.balance_updates;
}

let block_metadata_encoding =
  let open Data_encoding in
  def "block_header.alpha.metadata"
  @@ conv
       (fun { baker;
              level;
              voting_period_kind;
              nonce_hash;
              consumed_gas;
              deactivated;
              balance_updates } ->
         ( baker,
           level,
           voting_period_kind,
           nonce_hash,
           consumed_gas,
           deactivated,
           balance_updates ))
       (fun ( baker,
              level,
              voting_period_kind,
              nonce_hash,
              consumed_gas,
              deactivated,
              balance_updates ) ->
         {
           baker;
           level;
           voting_period_kind;
           nonce_hash;
           consumed_gas;
           deactivated;
           balance_updates;
         })
       (obj7
          (req "baker" Signature.Public_key_hash.encoding)
          (req "level" Level.encoding)
          (req "voting_period_kind" Voting_period.kind_encoding)
          (req "nonce_hash" (option Nonce_hash.encoding))
          (req "consumed_gas" (check_size 10 n))
          (req "deactivated" (list Signature.Public_key_hash.encoding))
          (req "balance_updates" Delegate.balance_updates_encoding))
src/proto_alpha/lib_protocol/apply_results.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Data_encoding.

Definition error_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
  op_atat
    (let arg :=
      def "error" % string
        (* ❌ expected an argument *)
        expected_argument
        (Some
          "The full list of RPC errors would be too long to include.
It is available at RPC `/errors` (GET).
Errors specific to protocol Alpha have an id that starts with `proto.alpha`."
            % string) in
    fun eta => arg None eta)
    (splitted
      (conv
        (fun err => Data_encoding.Json.construct Error_monad.error_encoding err)
        (fun json => Data_encoding.Json.destruct Error_monad.error_encoding json)
        None json) Error_monad.error_encoding).

Inductive successful_manager_operation_result : forall (_ : Type), Type :=
| Reveal_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal
| Transaction_result :
  (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
  (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t -> bool ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction
| Origination_result :
  (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff) ->
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.origination
| Delegation_result : Tezos_protocol_environment_alpha__Environment.Z.t ->
  successful_manager_operation_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation.

Inductive packed_successful_manager_operation_result : Type :=
| Successful_manager_result : forall {kind : Type},
  (successful_manager_operation_result kind) ->
  packed_successful_manager_operation_result.

Inductive manager_operation_result (kind : Type) : Type :=
| Applied : (successful_manager_operation_result kind) ->
  manager_operation_result kind
| Backtracked : (successful_manager_operation_result kind) ->
  (option (list Tezos_protocol_environment_alpha__Environment.Error_monad.error))
  -> manager_operation_result kind
| Failed : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
  (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) ->
  manager_operation_result kind
| Skipped : (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
  manager_operation_result kind.

Arguments Applied {_}.
Arguments Backtracked {_}.
Arguments Failed {_}.
Arguments Skipped {_}.

Inductive packed_internal_operation_result : Type :=
| Internal_operation_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) ->
  (manager_operation_result kind) -> packed_internal_operation_result.

Module Manager_result.
  Inductive case (kind : Type) : Type :=
  | MCase : forall {a : Type},
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.case
      kind) -> (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a)
    -> (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind) ->
    (packed_internal_operation_result ->
      option
        ((Tezos_raw_protocol_alpha.Alpha_context.internal_operation kind) *
          (manager_operation_result kind))) ->
    (packed_successful_manager_operation_result ->
      option (successful_manager_operation_result kind)) ->
    ((successful_manager_operation_result kind) -> a) ->
    (a -> successful_manager_operation_result kind) ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t
      (manager_operation_result kind)) -> case kind.
  
  Arguments MCase {_}.
  
  Definition make {A B : Type}
    (op_case :
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.case
        A)
    (encoding :
      Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding B)
    (kind : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)
    (iselect :
      packed_internal_operation_result ->
        option
          ((Tezos_raw_protocol_alpha.Alpha_context.internal_operation A) *
            (manager_operation_result A)))
    (select :
      packed_successful_manager_operation_result ->
        option (successful_manager_operation_result A))
    (proj : (successful_manager_operation_result A) -> B)
    (inj : B -> successful_manager_operation_result A) : case A :=
    let
      'Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.MCase
        {| name := name |} := op_case in
    let t :=
      op_atat
        (let arg :=
          def
            (Format.asprintf
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                  "operation.alpha.operation_result." % string
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
                "operation.alpha.operation_result.%s" % string) name) in
        fun eta => arg None None eta)
        (union
          (Some
            (* ❌ Variants not supported *)
            variant)
          (cons
            (case "Applied" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
              (merge_objs
                (obj1
                  (req None None "status" % string (constant "applied" % string)))
                encoding)
              (fun o =>
                match o with
                | Skipped _ | Failed _ _ | Backtracked _ _ => None
                | Applied o =>
                  match select (Successful_manager_result o) with
                  | None => None
                  | Some o => Some (tt, (proj o))
                  end
                end)
              (fun function_parameter =>
                let '(tt, x) := function_parameter in
                Applied (inj x)))
            (cons
              (case "Failed" % string None
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
                  1)
                (obj2
                  (req None None "status" % string (constant "failed" % string))
                  (req None None "errors" % string (list None error_encoding)))
                (fun function_parameter =>
                  match function_parameter with
                  | Failed _ errs => Some (tt, errs)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, errs) := function_parameter in
                  Failed kind errs))
              (cons
                (case "Skipped" % string None
                  (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
                    2)
                  (obj1
                    (req None None "status" % string
                      (constant "skipped" % string)))
                  (fun function_parameter =>
                    match function_parameter with
                    | Skipped _ => Some tt
                    | _ => None
                    end)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    Skipped kind))
                (cons
                  (case "Backtracked" % string None
                    (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
                      3)
                    (merge_objs
                      (obj2
                        (req None None "status" % string
                          (constant "backtracked" % string))
                        (opt None None "errors" % string
                          (list None error_encoding))) encoding)
                    (fun o =>
                      match o with
                      | Skipped _ | Failed _ _ | Applied _ => None
                      | Backtracked o errs =>
                        match select (Successful_manager_result o) with
                        | None => None
                        | Some o => Some ((tt, errs), (proj o))
                        end
                      end)
                    (fun function_parameter =>
                      let '((tt, errs), x) := function_parameter in
                      Backtracked (inj x) errs)) []))))) in
    MCase
      {| op_case := op_case; encoding := encoding; kind := kind;
        iselect := iselect; select := select; proj := proj; inj := inj; t := t
        |}.
  
  Definition reveal_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal :=
    make Operation.Encoding.Manager_operations.reveal_case
      (obj1 (dft None None "consumed_gas" % string z Z.zero))
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({| operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |}
              as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Reveal_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let 'Reveal_result {| consumed_gas := consumed_gas |} :=
          function_parameter in
        consumed_gas)
      (fun consumed_gas => Reveal_result {| consumed_gas := consumed_gas |}).
  
  Definition transaction_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction :=
    make Operation.Encoding.Manager_operations.transaction_case
      (obj8 (opt None None "storage" % string Script.expr_encoding)
        (opt None None "big_map_diff" % string Contract.big_map_diff_encoding)
        (dft None None "balance_updates" % string
          Delegate.balance_updates_encoding [])
        (dft None None "originated_contracts" % string
          (list None Contract.encoding) [])
        (dft None None "consumed_gas" % string z Z.zero)
        (dft None None "storage_size" % string z Z.zero)
        (dft None None "paid_storage_size_diff" % string z Z.zero)
        (dft None None "allocated_destination_contract" % string bool false))
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Transaction_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let
          'Transaction_result {|
            storage := storage;
              big_map_diff := big_map_diff;
              balance_updates := balance_updates;
              originated_contracts := originated_contracts;
              consumed_gas := consumed_gas;
              storage_size := storage_size;
              paid_storage_size_diff := paid_storage_size_diff;
              allocated_destination_contract := allocated_destination_contract
              |} := function_parameter in
        (storage, big_map_diff, balance_updates, originated_contracts,
          consumed_gas, storage_size, paid_storage_size_diff,
          allocated_destination_contract))
      (fun function_parameter =>
        let
          '(storage, big_map_diff, balance_updates, originated_contracts,
            consumed_gas, storage_size, paid_storage_size_diff,
            allocated_destination_contract) := function_parameter in
        Transaction_result
          {| storage := storage; big_map_diff := big_map_diff;
            balance_updates := balance_updates;
            originated_contracts := originated_contracts;
            consumed_gas := consumed_gas; storage_size := storage_size;
            paid_storage_size_diff := paid_storage_size_diff;
            allocated_destination_contract := allocated_destination_contract |}).
  
  Definition origination_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.origination :=
    make Operation.Encoding.Manager_operations.origination_case
      (obj6
        (opt None None "big_map_diff" % string Contract.big_map_diff_encoding)
        (dft None None "balance_updates" % string
          Delegate.balance_updates_encoding [])
        (dft None None "originated_contracts" % string
          (list None Contract.encoding) [])
        (dft None None "consumed_gas" % string z Z.zero)
        (dft None None "storage_size" % string z Z.zero)
        (dft None None "paid_storage_size_diff" % string z Z.zero))
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Origination_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let
          'Origination_result {|
            big_map_diff := big_map_diff;
              balance_updates := balance_updates;
              originated_contracts := originated_contracts;
              consumed_gas := consumed_gas;
              storage_size := storage_size;
              paid_storage_size_diff := paid_storage_size_diff
              |} := function_parameter in
        (big_map_diff, balance_updates, originated_contracts, consumed_gas,
          storage_size, paid_storage_size_diff))
      (fun function_parameter =>
        let
          '(big_map_diff, balance_updates, originated_contracts, consumed_gas,
            storage_size, paid_storage_size_diff) := function_parameter in
        Origination_result
          {| big_map_diff := big_map_diff; balance_updates := balance_updates;
            originated_contracts := originated_contracts;
            consumed_gas := consumed_gas; storage_size := storage_size;
            paid_storage_size_diff := paid_storage_size_diff |}).
  
  Definition delegation_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation :=
    make Operation.Encoding.Manager_operations.delegation_case
      (obj1 (dft None None "consumed_gas" % string z Z.zero))
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind
      (fun function_parameter =>
        match function_parameter with
        |
          Internal_operation_result
            ({|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _
                |} as op) res => Some (op, res)
        | _ => None
        end)
      (fun function_parameter =>
        match function_parameter with
        | Successful_manager_result ((Delegation_result _) as op) => Some op
        | _ => None
        end)
      (fun function_parameter =>
        let 'Delegation_result {| consumed_gas := consumed_gas |} :=
          function_parameter in
        consumed_gas)
      (fun consumed_gas => Delegation_result {| consumed_gas := consumed_gas |}).
End Manager_result.

Definition internal_operation_result_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    packed_internal_operation_result :=
  let make {A : Type} (function_parameter : Manager_result.case A)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      packed_internal_operation_result :=
    let 'Manager_result.MCase res_case := function_parameter in
    let
      'Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Manager_operations.MCase
        op_case := op_case res_case in
    case (name op_case) None
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
        (tag op_case))
      (merge_objs
        (obj3 (req None None "kind" % string (constant (name op_case)))
          (req None None "source" % string Contract.encoding)
          (req None None "nonce" % string uint16))
        (merge_objs (encoding op_case)
          (obj1 (req None None "result" % string (t res_case)))))
      (fun op =>
        match (iselect res_case) op with
        | Some (op, res) =>
          Some
            ((tt, (source op), (nonce op)),
              (((proj op_case) (operation op)), res))
        | None => None
        end)
      (fun function_parameter =>
        let '((tt, source, nonce), (op, res)) := function_parameter in
        let op :=
          {| source := source; operation := (inj op_case) op; nonce := nonce |}
          in
        Internal_operation_result op res) in
  op_atat
    (let arg := def "operation.alpha.internal_operation_result" % string in
    fun eta => arg None None eta)
    (union None
      (cons (make Manager_result.reveal_case)
        (cons (make Manager_result.transaction_case)
          (cons (make Manager_result.origination_case)
            (cons (make Manager_result.delegation_case) []))))).

Inductive contents_result : forall (kind : Type), Type :=
| Endorsement_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  (list Z) ->
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement
| Seed_nonce_revelation_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation
| Double_endorsement_evidence_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence
| Double_baking_evidence_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result
    Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence
| Activate_account_result :
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account
| Proposals_result :
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.proposals
| Ballot_result :
  contents_result Tezos_raw_protocol_alpha.Alpha_context.Kind.ballot
| Manager_operation_result : forall {kind : Type},
  Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates ->
  (manager_operation_result kind) -> (list packed_internal_operation_result) ->
  contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind).

Inductive packed_contents_result : Type :=
| Contents_result : forall {kind : Type}, (contents_result kind) ->
  packed_contents_result.

Inductive packed_contents_and_result : Type :=
| Contents_and_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.Operation.contents kind) ->
  (contents_result kind) -> packed_contents_and_result.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Definition equal_manager_kind {a b : Type}
  (ka : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager a)
  (kb : Tezos_raw_protocol_alpha.Alpha_context.Kind.manager b)
  : option (eq a b) :=
  match (ka, kb) with
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind,
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind) =>
    Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind, _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind,
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind) =>
    Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind, _) =>
    None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind,
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind) =>
    Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind, _) =>
    None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind,
      Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind) =>
    Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind, _) =>
    None
  end.

Module Encoding.
  Inductive case (kind : Type) : Type :=
  | Case : forall {a : Type},
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.case kind) ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
    (packed_contents_result -> option (contents_result kind)) ->
    (packed_contents_and_result ->
      option
        ((Tezos_raw_protocol_alpha.Alpha_context.contents kind) *
          (contents_result kind))) -> ((contents_result kind) -> a) ->
    (a -> contents_result kind) -> case kind.
  
  Arguments Case {_}.
  
  Definition tagged_case {A B : Type}
    (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
    (name : string)
    (args :
      Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding A)
    (proj : B -> option A) (inj : A -> B)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case B :=
    case (String.capitalize_ascii name) None tag
      (merge_objs (obj1 (req None None "kind" % string (constant name))) args)
      (fun x =>
        match proj x with
        | None => None
        | Some x => Some (tt, x)
        end)
      (fun function_parameter =>
        let '(tt, x) := function_parameter in
        inj x).
  
  Definition endorsement_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement :=
    Case
      {| op_case := Operation.Encoding.endorsement_case;
        encoding :=
          obj3
            (req None None "balance_updates" % string
              Delegate.balance_updates_encoding)
            (req None None "delegate" % string
              Signature.Public_key_hash.encoding)
            (req None None "slots" % string (list None uint8));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Endorsement_result _) as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Endorsement _) as op)
                res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let
              'Endorsement_result {|
                balance_updates := balance_updates;
                  delegate := delegate;
                  slots := slots
                  |} := function_parameter in
            (balance_updates, delegate, slots);
        inj :=
          fun function_parameter =>
            let '(balance_updates, delegate, slots) := function_parameter in
            Endorsement_result
              {| balance_updates := balance_updates; delegate := delegate;
                slots := slots |} |}.
  
  Definition seed_nonce_revelation_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.seed_nonce_revelation :=
    Case
      {| op_case := Operation.Encoding.seed_nonce_revelation_case;
        encoding :=
          obj1
            (req None None "balance_updates" % string
              Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Seed_nonce_revelation_result _) as op) =>
              Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _)
                  as op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Seed_nonce_revelation_result bus := function_parameter in
            bus; inj := fun bus => Seed_nonce_revelation_result bus |}.
  
  Definition double_endorsement_evidence_case
    : case
      Tezos_raw_protocol_alpha.Alpha_context.Kind.double_endorsement_evidence :=
    Case
      {| op_case := Operation.Encoding.double_endorsement_evidence_case;
        encoding :=
          obj1
            (req None None "balance_updates" % string
              Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Double_endorsement_evidence_result _) as op) =>
              Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence
                  _) as op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Double_endorsement_evidence_result bus := function_parameter in
            bus; inj := fun bus => Double_endorsement_evidence_result bus |}.
  
  Definition double_baking_evidence_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.double_baking_evidence :=
    Case
      {| op_case := Operation.Encoding.double_baking_evidence_case;
        encoding :=
          obj1
            (req None None "balance_updates" % string
              Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Double_baking_evidence_result _) as op) =>
              Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence
                  _) as op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Double_baking_evidence_result bus := function_parameter in
            bus; inj := fun bus => Double_baking_evidence_result bus |}.
  
  Definition activate_account_case
    : case Tezos_raw_protocol_alpha.Alpha_context.Kind.activate_account :=
    Case
      {| op_case := Operation.Encoding.activate_account_case;
        encoding :=
          obj1
            (req None None "balance_updates" % string
              Delegate.balance_updates_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result ((Activate_account_result _) as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Activate_account _) as
                  op) res => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Activate_account_result bus := function_parameter in
            bus; inj := fun bus => Activate_account_result bus |}.
  
  Definition proposals_case
    : case Tezos_raw_protocol_alpha__Alpha_context.Kind.proposals :=
    Case
      {| op_case := Operation.Encoding.proposals_case;
        encoding := Data_encoding.empty;
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result (Proposals_result as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Proposals _) as op) res
              => Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Proposals_result := function_parameter in
            tt;
        inj :=
          fun function_parameter =>
            let 'tt := function_parameter in
            Proposals_result |}.
  
  Definition ballot_case
    : case Tezos_raw_protocol_alpha__Alpha_context.Kind.ballot :=
    Case
      {| op_case := Operation.Encoding.ballot_case;
        encoding := Data_encoding.empty;
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents_result (Ballot_result as op) => Some op
            | _ => None
            end;
        mselect :=
          fun function_parameter =>
            match function_parameter with
            |
              Contents_and_result
                ((Tezos_raw_protocol_alpha.Alpha_context.Ballot _) as op) res =>
              Some (op, res)
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Ballot_result := function_parameter in
            tt;
        inj :=
          fun function_parameter =>
            let 'tt := function_parameter in
            Ballot_result |}.
  
  Definition make_manager_case {A : Type}
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.case
        (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
    : (Manager_result.case A) ->
      (packed_contents_and_result ->
        option
          ((Tezos_raw_protocol_alpha.Alpha_context.contents
            (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)) *
            (contents_result
              (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A)))) ->
        case (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A) :=
    let
      'Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case op_case :=
      function_parameter in
    fun function_parameter =>
      let 'Manager_result.MCase res_case := function_parameter in
      fun mselect =>
        Case
          {|
            op_case :=
              Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case
                op_case;
            encoding :=
              obj3
                (req None None "balance_updates" % string
                  Delegate.balance_updates_encoding)
                (req None None "operation_result" % string (t res_case))
                (dft None None "internal_operation_results" % string
                  (list None internal_operation_result_encoding) []);
            select :=
              fun function_parameter =>
                match function_parameter with
                |
                  Contents_result
                    (Manager_operation_result
                      ({| operation_result := Applied res |} as op)) =>
                  match (select res_case) (Successful_manager_result res) with
                  | Some res =>
                    Some
                      (Manager_operation_result
                        (* ❌ Record substitution not handled *)
                        record_substitution)
                  | None => None
                  end
                |
                  Contents_result
                    (Manager_operation_result
                      ({| operation_result := Backtracked res errs |} as op)) =>
                  match (select res_case) (Successful_manager_result res) with
                  | Some res =>
                    Some
                      (Manager_operation_result
                        (* ❌ Record substitution not handled *)
                        record_substitution)
                  | None => None
                  end
                |
                  Contents_result
                    (Manager_operation_result
                      ({| operation_result := Skipped kind |} as op)) =>
                  match equal_manager_kind kind (kind res_case) with
                  | None => None
                  | Some Eq =>
                    Some
                      (Manager_operation_result
                        (* ❌ Record substitution not handled *)
                        record_substitution)
                  end
                |
                  Contents_result
                    (Manager_operation_result
                      ({| operation_result := Failed kind errs |} as op)) =>
                  match equal_manager_kind kind (kind res_case) with
                  | None => None
                  | Some Eq =>
                    Some
                      (Manager_operation_result
                        (* ❌ Record substitution not handled *)
                        record_substitution)
                  end
                | Contents_result Ballot_result => None
                | Contents_result (Endorsement_result _) => None
                | Contents_result (Seed_nonce_revelation_result _) => None
                | Contents_result (Double_endorsement_evidence_result _) => None
                | Contents_result (Double_baking_evidence_result _) => None
                | Contents_result (Activate_account_result _) => None
                | Contents_result Proposals_result => None
                end; mselect := mselect;
            proj :=
              fun function_parameter =>
                let
                  'Manager_operation_result {|
                    balance_updates := bus;
                      operation_result := r;
                      internal_operation_results := rs
                      |} := function_parameter in
                (bus, r, rs);
            inj :=
              fun function_parameter =>
                let '(bus, r, rs) := function_parameter in
                Manager_operation_result
                  {| balance_updates := bus; operation_result := r;
                    internal_operation_results := rs |} |}.
  
  Definition reveal_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.reveal) :=
    make_manager_case Operation.Encoding.reveal_case Manager_result.reveal_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
  
  Definition transaction_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.transaction) :=
    make_manager_case Operation.Encoding.transaction_case
      Manager_result.transaction_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
  
  Definition origination_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.origination) :=
    make_manager_case Operation.Encoding.origination_case
      Manager_result.origination_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
  
  Definition delegation_case
    : case
      (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager
        Tezos_raw_protocol_alpha.Alpha_context.Kind.delegation) :=
    make_manager_case Operation.Encoding.delegation_case
      Manager_result.delegation_case
      (fun function_parameter =>
        match function_parameter with
        |
          Contents_and_result
            ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
              operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _
                |}) as op) res => Some (op, res)
        | _ => None
        end).
End Encoding.

Definition contents_result_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_result :=
  let make {A : Type} (function_parameter : Encoding.case A)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      packed_contents_result :=
    let
      'Encoding.Case {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case {|
            tag := tag; name := name |};
          encoding := encoding;
          select := select;
          mselect := _;
          proj := proj;
          inj := inj
          |} := function_parameter in
    let proj (x : packed_contents_result) : option op_dollarCase_'a :=
      match select x with
      | None => None
      | Some x => Some (proj x)
      end in
    let inj (x : op_dollarCase_'a) : packed_contents_result :=
      Contents_result (inj x) in
    tagged_case
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag) name
      encoding proj inj in
  op_atat
    (let arg := def "operation.alpha.contents_result" % string in
    fun eta => arg None None eta)
    (union None
      (cons (make endorsement_case)
        (cons (make seed_nonce_revelation_case)
          (cons (make double_endorsement_evidence_case)
            (cons (make double_baking_evidence_case)
              (cons (make activate_account_case)
                (cons (make proposals_case)
                  (cons (make ballot_case)
                    (cons (make reveal_case)
                      (cons (make transaction_case)
                        (cons (make origination_case)
                          (cons (make delegation_case) [])))))))))))).

Definition contents_and_result_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_and_result :=
  let make {A : Type} (function_parameter : Encoding.case A)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
      packed_contents_and_result :=
    let
      'Encoding.Case {|
        op_case :=
          Tezos_raw_protocol_alpha.Alpha_context.Operation.Encoding.Case {|
            tag := tag;
              name := name;
              encoding := encoding;
              proj := proj;
              inj := inj
              |};
          encoding := meta_encoding;
          mselect := mselect;
          proj := meta_proj;
          inj := meta_inj
          |} := function_parameter in
    let proj (c : packed_contents_and_result)
      : option (op_dollarCase_'a1 * op_dollarCase_'a) :=
      match mselect c with
      | Some (op, res) => Some ((proj op), (meta_proj res))
      | _ => None
      end in
    let inj (function_parameter : op_dollarCase_'a1 * op_dollarCase_'a)
      : packed_contents_and_result :=
      let '(op, res) := function_parameter in
      Contents_and_result (inj op) (meta_inj res) in
    let encoding :=
      merge_objs encoding
        (obj1 (req None None "metadata" % string meta_encoding)) in
    tagged_case
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag) name
      encoding proj inj in
  op_atat
    (let arg := def "operation.alpha.operation_contents_and_result" % string in
    fun eta => arg None None eta)
    (union None
      (cons (make endorsement_case)
        (cons (make seed_nonce_revelation_case)
          (cons (make double_endorsement_evidence_case)
            (cons (make double_baking_evidence_case)
              (cons (make activate_account_case)
                (cons (make proposals_case)
                  (cons (make ballot_case)
                    (cons (make reveal_case)
                      (cons (make transaction_case)
                        (cons (make origination_case)
                          (cons (make delegation_case) [])))))))))))).

Inductive contents_result_list : forall (kind : Type), Type :=
| Single_result : forall {kind : Type}, (contents_result kind) ->
  contents_result_list kind
| Cons_result : forall {kind rest : Type},
  (contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  ->
  (contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
  contents_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).

Inductive packed_contents_result_list : Type :=
| Contents_result_list : forall {kind : Type}, (contents_result_list kind) ->
  packed_contents_result_list.

Definition contents_result_list_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_result_list :=
  let fix to_list (function_parameter : packed_contents_result_list)
    : list packed_contents_result :=
    match function_parameter with
    | Contents_result_list (Single_result o) => cons (Contents_result o) []
    | Contents_result_list (Cons_result o os) =>
      cons (Contents_result o) (to_list (Contents_result_list os))
    end in
  let fix of_list (function_parameter : list packed_contents_result)
    : packed_contents_result_list :=
    match function_parameter with
    | [] => Pervasives.failwith "cannot decode empty operation result" % string
    | cons (Contents_result o) [] => Contents_result_list (Single_result o)
    | cons (Contents_result o) os =>
      let 'Contents_result_list os := of_list os in
      match (o, os) with
      | (Manager_operation_result _, Single_result (Manager_operation_result _))
        => Contents_result_list (Cons_result o os)
      | (Manager_operation_result _, Cons_result _ _) =>
        Contents_result_list (Cons_result o os)
      | _ =>
        Pervasives.failwith "cannot decode ill-formed operation result" % string
      end
    end in
  op_atat
    (let arg := def "operation.alpha.contents_list_result" % string in
    fun eta => arg None None eta)
    (conv to_list of_list None (list None contents_result_encoding)).

Inductive contents_and_result_list : forall (kind : Type), Type :=
| Single_and_result : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.contents kind) ->
  (contents_result kind) -> contents_and_result_list kind
| Cons_and_result : forall {kind rest : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.contents
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind)) ->
  (contents_result (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
  ->
  (contents_and_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager rest)) ->
  contents_and_result_list
    (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager (kind * rest)).

Inductive packed_contents_and_result_list : Type :=
| Contents_and_result_list : forall {kind : Type},
  (contents_and_result_list kind) -> packed_contents_and_result_list.

Definition contents_and_result_list_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_and_result_list :=
  let fix to_list (function_parameter : packed_contents_and_result_list)
    : list packed_contents_and_result :=
    match function_parameter with
    | Contents_and_result_list (Single_and_result op res) =>
      cons (Contents_and_result op res) []
    | Contents_and_result_list (Cons_and_result op res rest) =>
      cons (Contents_and_result op res)
        (to_list (Contents_and_result_list rest))
    end in
  let fix of_list (function_parameter : list packed_contents_and_result)
    : packed_contents_and_result_list :=
    match function_parameter with
    | [] =>
      Pervasives.failwith
        "cannot decode empty combined operation result" % string
    | cons (Contents_and_result op res) [] =>
      Contents_and_result_list (Single_and_result op res)
    | cons (Contents_and_result op res) rest =>
      let 'Contents_and_result_list rest := of_list rest in
      match (op, rest) with
      |
        (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _,
          Single_and_result
            (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) _) =>
        Contents_and_result_list (Cons_and_result op res rest)
      |
        (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _,
          Cons_and_result _ _ _) =>
        Contents_and_result_list (Cons_and_result op res rest)
      | _ =>
        Pervasives.failwith
          "cannot decode ill-formed combined operation result" % string
      end
    end in
  conv to_list of_list None (Variable.list None contents_and_result_encoding).

Record operation_metadata {kind : Type} := {
  contents : contents_result_list kind }.
Arguments operation_metadata : clear implicits.

Inductive packed_operation_metadata : Type :=
| Operation_metadata : forall {kind : Type}, (operation_metadata kind) ->
  packed_operation_metadata
| No_operation_metadata : packed_operation_metadata.

Definition operation_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_operation_metadata :=
  op_atat
    (let arg := def "operation.alpha.result" % string in
    fun eta => arg None None eta)
    (union None
      (cons
        (case "Operation_metadata" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
          contents_result_list_encoding
          (fun function_parameter =>
            match function_parameter with
            | Operation_metadata {| contents := contents |} =>
              Some (Contents_result_list contents)
            | _ => None
            end)
          (fun function_parameter =>
            let 'Contents_result_list contents := function_parameter in
            Operation_metadata {| contents := contents |}))
        (cons
          (case "No_operation_metadata" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
            empty
            (fun function_parameter =>
              match function_parameter with
              | No_operation_metadata => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              No_operation_metadata)) []))).

Definition kind_equal {kind kind2 : Type}
  (op : Tezos_raw_protocol_alpha.Alpha_context.contents kind)
  (res : contents_result kind2) : option (eq kind kind2) :=
  match (op, res) with
  | (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _, Endorsement_result _)
    => Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _, _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _,
      Seed_nonce_revelation_result _) => Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _, _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _,
      Double_endorsement_evidence_result _) => Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _, _) =>
    None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _,
      Double_baking_evidence_result _) => Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _, _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _,
      Activate_account_result _) => Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _, _) => None
  | (Tezos_raw_protocol_alpha.Alpha_context.Proposals _, Proposals_result) =>
    Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Proposals _, _) => None
  | (Tezos_raw_protocol_alpha.Alpha_context.Ballot _, Ballot_result) => Some Eq
  | (Tezos_raw_protocol_alpha.Alpha_context.Ballot _, _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
      Manager_operation_result {|
        operation_result := Applied (Reveal_result _) |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Reveal_result _) _ |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
      Manager_operation_result {|
        operation_result :=
          Failed Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind
            _
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |},
      Manager_operation_result {|
        operation_result :=
          Skipped
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Reveal_manager_kind
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Reveal _ |}, _) =>
    None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
      Manager_operation_result {|
        operation_result := Applied (Transaction_result _) |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Transaction_result _) _ |}) =>
    Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
      Manager_operation_result {|
        operation_result :=
          Failed
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind
            _
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
      Manager_operation_result {|
        operation_result :=
          Skipped
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Transaction_manager_kind
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Transaction _ |},
      _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
      Manager_operation_result {|
        operation_result := Applied (Origination_result _) |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Origination_result _) _ |}) =>
    Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
      Manager_operation_result {|
        operation_result :=
          Failed
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind
            _
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
      Manager_operation_result {|
        operation_result :=
          Skipped
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Origination_manager_kind
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Origination _ |},
      _) => None
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
      Manager_operation_result {|
        operation_result := Applied (Delegation_result _) |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
      Manager_operation_result {|
        operation_result := Backtracked (Delegation_result _) _ |}) =>
    Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
      Manager_operation_result {|
        operation_result :=
          Failed
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind
            _
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |},
      Manager_operation_result {|
        operation_result :=
          Skipped
            Tezos_raw_protocol_alpha.Alpha_context.Kind.Delegation_manager_kind
          |}) => Some Eq
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
      operation := Tezos_raw_protocol_alpha.Alpha_context.Delegation _ |}, _)
    => None
  end.

Fixpoint kind_equal_list {kind kind2 : Type}
  (contents : Tezos_raw_protocol_alpha.Alpha_context.contents_list kind)
  (res : contents_result_list kind2) : option (eq kind kind2) :=
  match (contents, res) with
  | (Tezos_raw_protocol_alpha.Alpha_context.Single op, Single_result res) =>
    match kind_equal op res with
    | None => None
    | Some Eq => Some Eq
    end
  | (Tezos_raw_protocol_alpha.Alpha_context.Cons op ops, Cons_result res ress)
    =>
    match kind_equal op res with
    | None => None
    | Some Eq =>
      match kind_equal_list ops ress with
      | None => None
      | Some Eq => Some Eq
      end
    end
  | _ => None
  end.

Fixpoint pack_contents_list {kind : Type}
  (contents : Tezos_raw_protocol_alpha.Alpha_context.contents_list kind)
  (res : contents_result_list kind) : contents_and_result_list kind :=
  match (contents, res) with
  | (Tezos_raw_protocol_alpha.Alpha_context.Single op, Single_result res) =>
    Single_and_result op res
  | (Tezos_raw_protocol_alpha.Alpha_context.Cons op ops, Cons_result res ress)
    => Cons_and_result op res (pack_contents_list ops ress)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _),
      Cons_result (Manager_operation_result _) (Single_result _)) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Failed _ _ |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Skipped _ |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Applied _ |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons _ _,
      Single_result
        (Manager_operation_result {| operation_result := Backtracked _ _ |})) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  | (Tezos_raw_protocol_alpha.Alpha_context.Single _, Cons_result _ _) =>
    (* ❌ Unreachable expressions are not supported *)
    unreachable
  end.

Fixpoint unpack_contents_list {kind : Type}
  (function_parameter : contents_and_result_list kind)
  : (Tezos_raw_protocol_alpha.Alpha_context.contents_list kind) *
    (contents_result_list kind) :=
  match function_parameter with
  | Single_and_result op res =>
    ((Tezos_raw_protocol_alpha.Alpha_context.Single op), (Single_result res))
  | Cons_and_result op res rest =>
    let '(ops, ress) := unpack_contents_list rest in
    ((Tezos_raw_protocol_alpha.Alpha_context.Cons op ops),
      (Cons_result res ress))
  end.

Fixpoint to_list (function_parameter : packed_contents_result_list)
  : list packed_contents_result :=
  match function_parameter with
  | Contents_result_list (Single_result o) => cons (Contents_result o) []
  | Contents_result_list (Cons_result o os) =>
    cons (Contents_result o) (to_list (Contents_result_list os))
  end.

Fixpoint of_list (function_parameter : list packed_contents_result)
  : packed_contents_result_list :=
  match function_parameter with
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Contents_result o) [] => Contents_result_list (Single_result o)
  | cons (Contents_result o) os =>
    let 'Contents_result_list os := of_list os in
    match (o, os) with
    | (Manager_operation_result _, Single_result (Manager_operation_result _))
      => Contents_result_list (Cons_result o os)
    | (Manager_operation_result _, Cons_result _ _) =>
      Contents_result_list (Cons_result o os)
    | _ =>
      Pervasives.failwith
        "Operation result list of length > 1 should only contains manager operations result."
          % string
    end
  end.

Definition operation_data_and_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data *
      packed_operation_metadata) :=
  op_atat
    (let arg := def "operation.alpha.operation_with_metadata" % string in
    fun eta => arg None None eta)
    (union None
      (cons
        (case "Operation_with_metadata" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
          (obj2
            (req None None "contents" % string
              (dynamic_size None contents_and_result_list_encoding))
            (opt None None "signature" % string Signature.encoding))
          (fun function_parameter =>
            match function_parameter with
            |
              (Tezos_raw_protocol_alpha.Alpha_context.Operation_data _,
                No_operation_metadata) => None
            |
              (Tezos_raw_protocol_alpha.Alpha_context.Operation_data op,
                Operation_metadata res) =>
              match kind_equal_list (contents op) (contents res) with
              | None =>
                Pervasives.failwith
                  "cannot decode inconsistent combined operation result" %
                    string
              | Some Eq =>
                Some
                  ((Contents_and_result_list
                    (pack_contents_list (contents op) (contents res))),
                    (signature op))
              end
            end)
          (fun function_parameter =>
            let '(Contents_and_result_list contents, signature) :=
              function_parameter in
            let '(op_contents, res_contents) := unpack_contents_list contents in
            ((Tezos_raw_protocol_alpha.Alpha_context.Operation_data
              {| contents := op_contents; signature := signature |}),
              (Operation_metadata {| contents := res_contents |}))))
        (cons
          (case "Operation_without_metadata" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
            (obj2
              (req None None "contents" % string
                (dynamic_size None Operation.contents_list_encoding))
              (opt None None "signature" % string Signature.encoding))
            (fun function_parameter =>
              match function_parameter with
              |
                (Tezos_raw_protocol_alpha.Alpha_context.Operation_data op,
                  No_operation_metadata) =>
                Some
                  ((Tezos_raw_protocol_alpha.Alpha_context.Contents_list
                    (contents op)), (signature op))
              |
                (Tezos_raw_protocol_alpha.Alpha_context.Operation_data _,
                  Operation_metadata _) => None
              end)
            (fun function_parameter =>
              let
                '(Tezos_raw_protocol_alpha.Alpha_context.Contents_list contents,
                  signature) := function_parameter in
              ((Tezos_raw_protocol_alpha.Alpha_context.Operation_data
                {| contents := contents; signature := signature |}),
                No_operation_metadata))) []))).

Record block_metadata := {
  baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  level : Tezos_raw_protocol_alpha.Alpha_context.Level.t;
  voting_period_kind : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind;
  nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t;
  consumed_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
  deactivated :
    list
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  balance_updates :
    Tezos_raw_protocol_alpha.Alpha_context.Delegate.balance_updates }.

Definition block_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    block_metadata :=
  op_atat
    (let arg := def "block_header.alpha.metadata" % string in
    fun eta => arg None None eta)
    (conv
      (fun function_parameter =>
        let '{|
          baker := baker;
            level := level;
            voting_period_kind := voting_period_kind;
            nonce_hash := nonce_hash;
            consumed_gas := consumed_gas;
            deactivated := deactivated;
            balance_updates := balance_updates
            |} := function_parameter in
        (baker, level, voting_period_kind, nonce_hash, consumed_gas,
          deactivated, balance_updates))
      (fun function_parameter =>
        let
          '(baker, level, voting_period_kind, nonce_hash, consumed_gas,
            deactivated, balance_updates) := function_parameter in
        {| baker := baker; level := level;
          voting_period_kind := voting_period_kind; nonce_hash := nonce_hash;
          consumed_gas := consumed_gas; deactivated := deactivated;
          balance_updates := balance_updates |}) None
      (obj7 (req None None "baker" % string Signature.Public_key_hash.encoding)
        (req None None "level" % string Level.encoding)
        (req None None "voting_period_kind" % string Voting_period.kind_encoding)
        (req None None "nonce_hash" % string (option Nonce_hash.encoding))
        (req None None "consumed_gas" % string (check_size 10 n))
        (req None None "deactivated" % string
          (list None Signature.Public_key_hash.encoding))
        (req None None "balance_updates" % string
          Delegate.balance_updates_encoding))).

src/proto_alpha/lib_protocol/baking.ml 113 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Misc

type error += Invalid_fitness_gap of int64 * int64 (* `Permanent *)

type error += Timestamp_too_early of Timestamp.t * Timestamp.t

(* `Permanent *)

type error += Unexpected_endorsement (* `Permanent *)

type error +=
  | Invalid_block_signature of Block_hash.t * Signature.Public_key_hash.t

(* `Permanent *)

type error += Invalid_signature (* `Permanent *)

type error += Invalid_stamp (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"baking.timestamp_too_early"
    ~title:"Block forged too early"
    ~description:
      "The block timestamp is before the first slot for this baker at this \
       level"
    ~pp:(fun ppf (r, p) ->
      Format.fprintf
        ppf
        "Block forged too early (%a is before %a)"
        Time.pp_hum
        p
        Time.pp_hum
        r)
    Data_encoding.(
      obj2 (req "minimum" Time.encoding) (req "provided" Time.encoding))
    (function Timestamp_too_early (r, p) -> Some (r, p) | _ -> None)
    (fun (r, p) -> Timestamp_too_early (r, p)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_fitness_gap"
    ~title:"Invalid fitness gap"
    ~description:"The gap of fitness is out of bounds"
    ~pp:(fun ppf (m, g) ->
      Format.fprintf ppf "The gap of fitness %Ld is not between 0 and %Ld" g m)
    Data_encoding.(obj2 (req "maximum" int64) (req "provided" int64))
    (function Invalid_fitness_gap (m, g) -> Some (m, g) | _ -> None)
    (fun (m, g) -> Invalid_fitness_gap (m, g)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_block_signature"
    ~title:"Invalid block signature"
    ~description:"A block was not signed with the expected private key."
    ~pp:(fun ppf (block, pkh) ->
      Format.fprintf
        ppf
        "Invalid signature for block %a. Expected: %a."
        Block_hash.pp_short
        block
        Signature.Public_key_hash.pp_short
        pkh)
    Data_encoding.(
      obj2
        (req "block" Block_hash.encoding)
        (req "expected" Signature.Public_key_hash.encoding))
    (function
      | Invalid_block_signature (block, pkh) -> Some (block, pkh) | _ -> None)
    (fun (block, pkh) -> Invalid_block_signature (block, pkh)) ;
  register_error_kind
    `Permanent
    ~id:"baking.invalid_signature"
    ~title:"Invalid block signature"
    ~description:"The block's signature is invalid"
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid block signature")
    Data_encoding.empty
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature) ;
  register_error_kind
    `Permanent
    ~id:"baking.insufficient_proof_of_work"
    ~title:"Insufficient block proof-of-work stamp"
    ~description:"The block's proof-of-work stamp is insufficient"
    ~pp:(fun ppf () -> Format.fprintf ppf "Insufficient proof-of-work stamp")
    Data_encoding.empty
    (function Invalid_stamp -> Some () | _ -> None)
    (fun () -> Invalid_stamp) ;
  register_error_kind
    `Permanent
    ~id:"baking.unexpected_endorsement"
    ~title:"Endorsement from unexpected delegate"
    ~description:
      "The operation is signed by a delegate without endorsement rights."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The endorsement is signed by a delegate without endorsement rights.")
    Data_encoding.unit
    (function Unexpected_endorsement -> Some () | _ -> None)
    (fun () -> Unexpected_endorsement)

let minimal_time c priority pred_timestamp =
  let priority = Int32.of_int priority in
  let rec cumsum_time_between_blocks acc durations p =
    if Compare.Int32.( <= ) p 0l then ok acc
    else
      match durations with
      | [] ->
          cumsum_time_between_blocks acc [Period.one_minute] p
      | [last] ->
          Period.mult p last >>? fun period -> Timestamp.(acc +? period)
      | first :: durations ->
          Timestamp.(acc +? first)
          >>? fun acc ->
          let p = Int32.pred p in
          cumsum_time_between_blocks acc durations p
  in
  Lwt.return
    (cumsum_time_between_blocks
       pred_timestamp
       (Constants.time_between_blocks c)
       (Int32.succ priority))

let earlier_predecessor_timestamp ctxt level =
  let current = Level.current ctxt in
  let current_timestamp = Timestamp.current ctxt in
  let gap = Level.diff level current in
  let step = List.hd (Constants.time_between_blocks ctxt) in
  if Compare.Int32.(gap < 1l) then
    failwith "Baking.earlier_block_timestamp: past block."
  else
    Lwt.return (Period.mult (Int32.pred gap) step)
    >>=? fun delay ->
    Lwt.return Timestamp.(current_timestamp +? delay)
    >>=? fun result -> return result

let check_timestamp c priority pred_timestamp =
  minimal_time c priority pred_timestamp
  >>=? fun minimal_time ->
  let timestamp = Alpha_context.Timestamp.current c in
  Lwt.return
    (record_trace
       (Timestamp_too_early (minimal_time, timestamp))
       Timestamp.(timestamp -? minimal_time))

let check_baking_rights c {Block_header.priority; _} pred_timestamp =
  let level = Level.current c in
  Roll.baking_rights_owner c level ~priority
  >>=? fun delegate ->
  check_timestamp c priority pred_timestamp
  >>=? fun block_delay -> return (delegate, block_delay)

type error += Incorrect_priority (* `Permanent *)

type error += Incorrect_number_of_endorsements (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"incorrect_priority"
    ~title:"Incorrect priority"
    ~description:"Block priority must be non-negative."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The block priority must be non-negative.")
    Data_encoding.unit
    (function Incorrect_priority -> Some () | _ -> None)
    (fun () -> Incorrect_priority)

let () =
  let description =
    "The number of endorsements must be non-negative and at most the \
     endosers_per_block constant."
  in
  register_error_kind
    `Permanent
    ~id:"incorrect_number_of_endorsements"
    ~title:"Incorrect number of endorsements"
    ~description
    ~pp:(fun ppf () -> Format.fprintf ppf "%s" description)
    Data_encoding.unit
    (function Incorrect_number_of_endorsements -> Some () | _ -> None)
    (fun () -> Incorrect_number_of_endorsements)

let baking_reward ctxt ~block_priority:prio ~included_endorsements:num_endo =
  fail_unless Compare.Int.(prio >= 0) Incorrect_priority
  >>=? fun () ->
  let max_endorsements = Constants.endorsers_per_block ctxt in
  fail_unless
    Compare.Int.(num_endo >= 0 && num_endo <= max_endorsements)
    Incorrect_number_of_endorsements
  >>=? fun () ->
  let prio_factor_denominator = Int64.(succ (of_int prio)) in
  let endo_factor_numerator =
    Int64.of_int (8 + (2 * num_endo / max_endorsements))
  in
  let endo_factor_denominator = 10L in
  Lwt.return
    Tez.(
      Constants.block_reward ctxt *? endo_factor_numerator
      >>? fun val1 ->
      val1 /? endo_factor_denominator
      >>? fun val2 -> val2 /? prio_factor_denominator)

let endorsing_reward ctxt ~block_priority:prio n =
  if Compare.Int.(prio >= 0) then
    Lwt.return
      Tez.(Constants.endorsement_reward ctxt /? Int64.(succ (of_int prio)))
    >>=? fun tez -> Lwt.return Tez.(tez *? Int64.of_int n)
  else fail Incorrect_priority

let baking_priorities c level =
  let rec f priority =
    Roll.baking_rights_owner c level ~priority
    >>=? fun delegate -> return (LCons (delegate, fun () -> f (succ priority)))
  in
  f 0

let endorsement_rights c level =
  fold_left_s
    (fun acc slot ->
      Roll.endorsement_rights_owner c level ~slot
      >>=? fun pk ->
      let pkh = Signature.Public_key.hash pk in
      let right =
        match Signature.Public_key_hash.Map.find_opt pkh acc with
        | None ->
            (pk, [slot], false)
        | Some (pk, slots, used) ->
            (pk, slot :: slots, used)
      in
      return (Signature.Public_key_hash.Map.add pkh right acc))
    Signature.Public_key_hash.Map.empty
    (0 --> (Constants.endorsers_per_block c - 1))

let check_endorsement_rights ctxt chain_id (op : Kind.endorsement Operation.t)
    =
  let current_level = Level.current ctxt in
  let (Single (Endorsement {level; _})) = op.protocol_data.contents in
  ( if Raw_level.(succ level = current_level.level) then
    return (Alpha_context.allowed_endorsements ctxt)
  else endorsement_rights ctxt (Level.from_raw ctxt level) )
  >>=? fun endorsements ->
  match
    Signature.Public_key_hash.Map.fold (* no find_first *)
      (fun pkh (pk, slots, used) acc ->
        match Operation.check_signature_sync pk chain_id op with
        | Error _ ->
            acc
        | Ok () ->
            Some (pkh, slots, used))
      endorsements
      None
  with
  | None ->
      fail Unexpected_endorsement
  | Some v ->
      return v

let select_delegate delegate delegate_list max_priority =
  let rec loop acc l n =
    if Compare.Int.(n >= max_priority) then return (List.rev acc)
    else
      let (LCons (pk, t)) = l in
      let acc =
        if
          Signature.Public_key_hash.equal
            delegate
            (Signature.Public_key.hash pk)
        then n :: acc
        else acc
      in
      t () >>=? fun t -> loop acc t (succ n)
  in
  loop [] delegate_list 0

let first_baking_priorities ctxt ?(max_priority = 32) delegate level =
  baking_priorities ctxt level
  >>=? fun delegate_list -> select_delegate delegate delegate_list max_priority

let check_hash hash stamp_threshold =
  let bytes = Block_hash.to_bytes hash in
  let word = MBytes.get_int64 bytes 0 in
  Compare.Uint64.(word <= stamp_threshold)

let check_header_proof_of_work_stamp shell contents stamp_threshold =
  let hash =
    Block_header.hash
      {shell; protocol_data = {contents; signature = Signature.zero}}
  in
  check_hash hash stamp_threshold

let check_proof_of_work_stamp ctxt block =
  let proof_of_work_threshold = Constants.proof_of_work_threshold ctxt in
  if
    check_header_proof_of_work_stamp
      block.Block_header.shell
      block.protocol_data.contents
      proof_of_work_threshold
  then return_unit
  else fail Invalid_stamp

let check_signature block chain_id key =
  let check_signature key
      {Block_header.shell; protocol_data = {contents; signature}} =
    let unsigned_header =
      Data_encoding.Binary.to_bytes_exn
        Block_header.unsigned_encoding
        (shell, contents)
    in
    Signature.check
      ~watermark:(Block_header chain_id)
      key
      signature
      unsigned_header
  in
  if check_signature key block then return_unit
  else
    fail
      (Invalid_block_signature
         (Block_header.hash block, Signature.Public_key.hash key))

let max_fitness_gap _ctxt = 1L

let check_fitness_gap ctxt (block : Block_header.t) =
  let current_fitness = Fitness.current ctxt in
  Lwt.return (Fitness.to_int64 block.shell.fitness)
  >>=? fun announced_fitness ->
  let gap = Int64.sub announced_fitness current_fitness in
  if Compare.Int64.(gap <= 0L || max_fitness_gap ctxt < gap) then
    fail (Invalid_fitness_gap (max_fitness_gap ctxt, gap))
  else return_unit

let last_of_a_cycle ctxt l =
  Compare.Int32.(
    Int32.succ l.Level.cycle_position = Constants.blocks_per_cycle ctxt)

let dawn_of_a_new_cycle ctxt =
  let level = Level.current ctxt in
  if last_of_a_cycle ctxt level then return_some level.cycle else return_none

let minimum_allowed_endorsements ctxt ~block_delay =
  let minimum = Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement =
    Int64.to_int
      (Period.to_seconds (Constants.delay_per_missing_endorsement ctxt))
  in
  let reduced_time_constraint =
    let delay = Int64.to_int (Period.to_seconds block_delay) in
    if Compare.Int.(delay_per_missing_endorsement = 0) then delay
    else delay / delay_per_missing_endorsement
  in
  Compare.Int.max 0 (minimum - reduced_time_constraint)

let minimal_valid_time ctxt ~priority ~endorsing_power =
  let predecessor_timestamp = Timestamp.current ctxt in
  minimal_time ctxt priority predecessor_timestamp
  >>=? fun minimal_time ->
  let minimal_required_endorsements = Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement =
    Constants.delay_per_missing_endorsement ctxt
  in
  let missing_endorsements =
    Compare.Int.max 0 (minimal_required_endorsements - endorsing_power)
  in
  match
    Period.mult
      (Int32.of_int missing_endorsements)
      delay_per_missing_endorsement
  with
  | Ok delay ->
      return (Time.add minimal_time (Period.to_seconds delay))
  | Error _ as err ->
      Lwt.return err
src/proto_alpha/lib_protocol/baking.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Misc.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition minimal_time
  (c : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
  (pred_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) :=
  let priority := Int32.of_int priority in
  let fix cumsum_time_between_blocks
    (acc : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) (durations :
    list Tezos_raw_protocol_alpha.Alpha_context.Period.period) (p :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
        p
        (* ❌ Constant of type int32 is converted to int *)
        0 then
      ok acc
    else
      match durations with
      | [] => cumsum_time_between_blocks acc (cons Period.one_minute []) p
      | cons last [] =>
        op_gtgtquestion (Period.mult p last)
          (fun period => op_plusquestion acc period)
      | cons first durations =>
        op_gtgtquestion (op_plusquestion acc first)
          (fun acc =>
            let p := Int32.pred p in
            cumsum_time_between_blocks acc durations p)
      end in
  Lwt._return
    (cumsum_time_between_blocks pred_timestamp (Constants.time_between_blocks c)
      (Int32.succ priority)).

Definition earlier_predecessor_timestamp
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Level.level)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time) :=
  let current := Level.current ctxt in
  let current_timestamp := Timestamp.current ctxt in
  let gap := Level.diff level current in
  let step := List.hd (Constants.time_between_blocks ctxt) in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      gap
      (* ❌ Constant of type int32 is converted to int *)
      1 then
    failwith "Baking.earlier_block_timestamp: past block." % string
  else
    op_gtgteqquestion (Lwt._return (Period.mult (Int32.pred gap) step))
      (fun delay =>
        op_gtgteqquestion
          (Lwt._return (op_plusquestion current_timestamp delay))
          (fun result => _return result)).

Definition check_timestamp
  (c : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
  (pred_timestamp : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.Period.t) :=
  op_gtgteqquestion (minimal_time c priority pred_timestamp)
    (fun minimal_time =>
      let timestamp := Alpha_context.Timestamp.current c in
      Lwt._return
        (record_trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Timestamp_too_early
            minimal_time timestamp) (op_minusquestion timestamp minimal_time))).

Definition check_baking_rights
  (c : Tezos_raw_protocol_alpha__Alpha_context.context)
  (function_parameter :
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  : Tezos_raw_protocol_alpha.Alpha_context.Timestamp.time ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha__Alpha_context.public_key *
          Tezos_raw_protocol_alpha__Alpha_context.Period.t)) :=
  let '{| Block_header.priority := priority |} := function_parameter in
  fun pred_timestamp =>
    let level := Level.current c in
    op_gtgteqquestion (Roll.baking_rights_owner c level priority)
      (fun delegate =>
        op_gtgteqquestion (check_timestamp c priority pred_timestamp)
          (fun block_delay => _return (delegate, block_delay))).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension





Definition baking_reward
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (prio :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (num_endo :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.tez) :=
  op_gtgteqquestion
    (fail_unless
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
        prio 0)
      Tezos_protocol_environment_alpha__Environment.Error_monad.Incorrect_priority)
    (fun function_parameter =>
      let 'tt := function_parameter in
      let max_endorsements := Constants.endorsers_per_block ctxt in
      op_gtgteqquestion
        (fail_unless
          (op_andand
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
              num_endo 0)
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
              num_endo max_endorsements))
          Tezos_protocol_environment_alpha__Environment.Error_monad.Incorrect_number_of_endorsements)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let prio_factor_denominator := succ (of_int prio) in
          let endo_factor_numerator :=
            Int64.of_int
              (op_plus 8 (op_div (op_star 2 num_endo) max_endorsements)) in
          let endo_factor_denominator :=
            (* ❌ Constant of type int64 is converted to int *)
            10 in
          Lwt._return
            (op_gtgtquestion
              (op_starquestion (Constants.block_reward ctxt)
                endo_factor_numerator)
              (fun val1 =>
                op_gtgtquestion (op_divquestion val1 endo_factor_denominator)
                  (fun val2 => op_divquestion val2 prio_factor_denominator))))).

Definition endorsing_reward
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (prio :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (n : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.tez) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      prio 0 then
    op_gtgteqquestion
      (Lwt._return
        (op_divquestion (Constants.endorsement_reward ctxt) (succ (of_int prio))))
      (fun tez => Lwt._return (op_starquestion tez (Int64.of_int n)))
  else
    fail
      Tezos_protocol_environment_alpha__Environment.Error_monad.Incorrect_priority.

Definition baking_priorities
  (c : Tezos_raw_protocol_alpha__Alpha_context.context)
  (level : Tezos_raw_protocol_alpha__Alpha_context.Level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Misc.lazy_list_t
        Tezos_raw_protocol_alpha__Alpha_context.public_key)) :=
  let fix f (priority : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Misc.lazy_list_t
          Tezos_raw_protocol_alpha__Alpha_context.public_key)) :=
    op_gtgteqquestion (Roll.baking_rights_owner c level priority)
      (fun delegate =>
        _return
          (Tezos_raw_protocol_alpha.Misc.LCons delegate
            (fun function_parameter =>
              let 'tt := function_parameter in
              f (succ priority)))) in
  f 0.

Definition endorsement_rights
  (c : Tezos_raw_protocol_alpha__Alpha_context.context)
  (level : Tezos_raw_protocol_alpha__Alpha_context.Level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
        (Tezos_raw_protocol_alpha__Alpha_context.public_key * (list Z) * bool))) :=
  fold_left_s
    (fun acc =>
      fun slot =>
        op_gtgteqquestion (Roll.endorsement_rights_owner c level slot)
          (fun pk =>
            let pkh := Signature.Public_key.hash pk in
            let right :=
              match Signature.Public_key_hash.Map.find_opt pkh acc with
              | None => (pk, (cons slot []), false)
              | Some (pk, slots, used) => (pk, (cons slot slots), used)
              end in
            _return (Signature.Public_key_hash.Map.add pkh right acc)))
    Signature.Public_key_hash.Map.empty
    (op_minusminusgt 0 (op_minus (Constants.endorsers_per_block c) 1)).

Definition check_endorsement_rights
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (op :
    Tezos_raw_protocol_alpha.Alpha_context.Operation.t
      Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key
        * (list Z) * bool)) :=
  let current_level := Level.current ctxt in
  let
    'Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Endorsement {| level := level |}) :=
    contents (protocol_data op) in
  op_gtgteqquestion
    (if op_eq (succ level) (level current_level) then
      _return (Alpha_context.allowed_endorsements ctxt)
    else
      endorsement_rights ctxt (Level.from_raw ctxt None level))
    (fun endorsements =>
      match
        Signature.Public_key_hash.Map.fold
          (fun pkh =>
            fun function_parameter =>
              let '(pk, slots, used) := function_parameter in
              fun acc =>
                match Operation.check_signature_sync pk chain_id op with
                |
                  Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                    _ => acc
                | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt
                  => Some (pkh, slots, used)
                end) endorsements None with
      | None =>
        fail
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_endorsement
      | Some v => _return v
      end).

Definition select_delegate
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (delegate_list :
    Tezos_raw_protocol_alpha.Misc.lazy_list_t
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (max_priority :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
  let fix loop
    (acc :
    list
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (l :
    Tezos_raw_protocol_alpha.Misc.lazy_list_t
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
        n max_priority then
      _return (List.rev acc)
    else
      let 'Tezos_raw_protocol_alpha.Misc.LCons pk t := l in
      let acc :=
        if
          Signature.Public_key_hash.equal delegate
            (Signature.Public_key.hash pk) then
          cons n acc
        else
          acc in
      op_gtgteqquestion (t tt) (fun t => loop acc t (succ n)) in
  loop [] delegate_list 0.

Definition first_baking_priorities
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (op_staroptstar :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
    Tezos_raw_protocol_alpha__Alpha_context.Level.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))) :=
  let max_priority :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 32
    end in
  fun delegate =>
    fun level =>
      op_gtgteqquestion (baking_priorities ctxt level)
        (fun delegate_list =>
          select_delegate delegate delegate_list max_priority).

Definition check_hash
  (hash :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (stamp_threshold :
    Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : bool :=
  let bytes :=
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.to_bytes)
      hash in
  let word := MBytes.get_int64 string 0 in
  Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
    word stamp_threshold.

Definition check_header_proof_of_work_stamp
  (shell :
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
  (contents : Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents)
  (stamp_threshold :
    Tezos_protocol_environment_alpha__Environment.Compare.Uint64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : bool :=
  let hash :=
    Block_header.hash
      {| shell := shell;
        protocol_data := {| contents := contents; signature := Signature.zero |}
        |} in
  check_hash hash stamp_threshold.

Definition check_proof_of_work_stamp
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let proof_of_work_threshold := Constants.proof_of_work_threshold ctxt in
  if
    check_header_proof_of_work_stamp (Block_header.shell block)
      (contents (protocol_data block)) proof_of_work_threshold then
    return_unit
  else
    fail Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_stamp.

Definition check_signature
  (block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let check_signature
    (key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
    (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
    : bool :=
    let '{|
      Block_header.shell := shell;
        Block_header.protocol_data := {|
          contents := contents; signature := signature |}
        |} := function_parameter in
    let unsigned_header :=
      Data_encoding.Binary.to_bytes_exn Block_header.unsigned_encoding
        (shell, contents) in
    Signature.check
      (Some
        (Tezos_protocol_environment_alpha__Environment.Signature.Block_header
          chain_id)) key signature unsigned_header in
  if check_signature key block then
    return_unit
  else
    fail
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_block_signature
        (Block_header.hash block) (Signature.Public_key.hash key)).

Definition max_fitness_gap {A : Type} (_ctxt : A) : int64 :=
  (* ❌ Constant of type int64 is converted to int *)
  1.

Definition check_fitness_gap
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (block : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let current_fitness := Fitness.current ctxt in
  op_gtgteqquestion (Lwt._return (Fitness.to_int64 (fitness (shell block))))
    (fun announced_fitness =>
      let gap := Int64.sub announced_fitness current_fitness in
      if
        op_pipepipe
          (Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
            gap
            (* ❌ Constant of type int64 is converted to int *)
            0)
          (Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
            (max_fitness_gap ctxt) gap) then
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_fitness_gap
            (max_fitness_gap ctxt) gap)
      else
        return_unit).

Definition last_of_a_cycle
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (l : Tezos_raw_protocol_alpha.Alpha_context.Level.t) : bool :=
  Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
    (Int32.succ (Level.cycle_position l)) (Constants.blocks_per_cycle ctxt).

Definition dawn_of_a_new_cycle
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha__Alpha_context.Cycle.t)) :=
  let level := Level.current ctxt in
  if last_of_a_cycle ctxt level then
    return_some (cycle level)
  else
    return_none.

Definition minimum_allowed_endorsements
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.period)
  : Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  let minimum := Constants.initial_endorsers ctxt in
  let delay_per_missing_endorsement :=
    Int64.to_int
      (Period.to_seconds (Constants.delay_per_missing_endorsement ctxt)) in
  let reduced_time_constraint :=
    let delay := Int64.to_int (Period.to_seconds block_delay) in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        delay_per_missing_endorsement 0 then
      delay
    else
      op_div delay delay_per_missing_endorsement in
  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
    0 (op_minus minimum reduced_time_constraint).

Definition minimal_valid_time
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (priority : Z)
  (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Time.t) :=
  let predecessor_timestamp := Timestamp.current ctxt in
  op_gtgteqquestion (minimal_time ctxt priority predecessor_timestamp)
    (fun minimal_time =>
      let minimal_required_endorsements := Constants.initial_endorsers ctxt in
      let delay_per_missing_endorsement :=
        Constants.delay_per_missing_endorsement ctxt in
      let missing_endorsements :=
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
          0 (op_minus minimal_required_endorsements endorsing_power) in
      match
        Period.mult (Int32.of_int missing_endorsements)
          delay_per_missing_endorsement with
      | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok delay =>
        _return (Time.add minimal_time (Period.to_seconds delay))
      |
        (Tezos_protocol_environment_alpha__Environment.Pervasives.Error _) as
          err => Lwt._return err
      end).

src/proto_alpha/lib_protocol/blinded_public_key_hash.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module H =
  Blake2B.Make
    (Base58)
    (struct
      let name = "Blinded public key hash"

      let title = "A blinded public key hash"

      let b58check_prefix = "\001\002\049\223"

      let size = Some Ed25519.Public_key_hash.size
    end)

include H

let () = Base58.check_encoded_prefix b58check_encoding "btz1" 37

let of_ed25519_pkh activation_code pkh =
  hash_bytes ~key:activation_code [Ed25519.Public_key_hash.to_bytes pkh]

type activation_code = MBytes.t

let activation_code_size = Ed25519.Public_key_hash.size

let activation_code_encoding = Data_encoding.Fixed.bytes activation_code_size

let activation_code_of_hex h =
  if Compare.Int.(String.length h <> activation_code_size * 2) then
    invalid_arg "Blinded_public_key_hash.activation_code_of_hex" ;
  MBytes.of_hex (`Hex h)

module Index = H
src/proto_alpha/lib_protocol/blinded_public_key_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Structure item `include` not handled. *)
include



Definition of_ed25519_pkh
  (activation_code : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (pkh : Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t)
  : t :=
  hash_bytes (Some activation_code)
    (cons (Ed25519.Public_key_hash.to_bytes pkh) []).

Definition activation_code :=
  Tezos_protocol_environment_alpha__Environment.MBytes.t.

Definition activation_code_size : Z := Ed25519.Public_key_hash.size.

Definition activation_code_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  Data_encoding.Fixed.bytes activation_code_size.

Definition activation_code_of_hex (h : string)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
        (String.length h) (op_star activation_code_size 2) then
      invalid_arg "Blinded_public_key_hash.activation_code_of_hex" % string
    else
      tt in
  MBytes.of_hex
    (* ❌ Variants not supported *)
    variant.

(* ❌ This kind of module is not handled. *)
unhandled_module

src/proto_alpha/lib_protocol/block_header_repr.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Block header *)

type t = {shell : Block_header.shell_header; protocol_data : protocol_data}

and protocol_data = {contents : contents; signature : Signature.t}

and contents = {
  priority : int;
  seed_nonce_hash : Nonce_hash.t option;
  proof_of_work_nonce : MBytes.t;
}

type block_header = t

type raw = Block_header.t

type shell_header = Block_header.shell_header

let raw_encoding = Block_header.encoding

let shell_header_encoding = Block_header.shell_header_encoding

let contents_encoding =
  let open Data_encoding in
  def "block_header.alpha.unsigned_contents"
  @@ conv
       (fun {priority; seed_nonce_hash; proof_of_work_nonce} ->
         (priority, proof_of_work_nonce, seed_nonce_hash))
       (fun (priority, proof_of_work_nonce, seed_nonce_hash) ->
         {priority; seed_nonce_hash; proof_of_work_nonce})
       (obj3
          (req "priority" uint16)
          (req
             "proof_of_work_nonce"
             (Fixed.bytes Constants_repr.proof_of_work_nonce_size))
          (opt "seed_nonce_hash" Nonce_hash.encoding))

let protocol_data_encoding =
  let open Data_encoding in
  def "block_header.alpha.signed_contents"
  @@ conv
       (fun {contents; signature} -> (contents, signature))
       (fun (contents, signature) -> {contents; signature})
       (merge_objs
          contents_encoding
          (obj1 (req "signature" Signature.encoding)))

let raw {shell; protocol_data} =
  let protocol_data =
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
  in
  {Block_header.shell; protocol_data}

let unsigned_encoding =
  let open Data_encoding in
  merge_objs Block_header.shell_header_encoding contents_encoding

let encoding =
  let open Data_encoding in
  def "block_header.alpha.full_header"
  @@ conv
       (fun {shell; protocol_data} -> (shell, protocol_data))
       (fun (shell, protocol_data) -> {shell; protocol_data})
       (merge_objs Block_header.shell_header_encoding protocol_data_encoding)

(** Constants *)

let max_header_length =
  let fake_shell =
    {
      Block_header.level = 0l;
      proto_level = 0;
      predecessor = Block_hash.zero;
      timestamp = Time.of_seconds 0L;
      validation_passes = 0;
      operations_hash = Operation_list_list_hash.zero;
      fitness = Fitness_repr.from_int64 0L;
      context = Context_hash.zero;
    }
  and fake_contents =
    {
      priority = 0;
      proof_of_work_nonce =
        MBytes.create Constants_repr.proof_of_work_nonce_size;
      seed_nonce_hash = Some Nonce_hash.zero;
    }
  in
  Data_encoding.Binary.length
    encoding
    {
      shell = fake_shell;
      protocol_data = {contents = fake_contents; signature = Signature.zero};
    }

(** Header parsing entry point  *)

let hash_raw = Block_header.hash

let hash {shell; protocol_data} =
  Block_header.hash
    {
      shell;
      protocol_data =
        Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data;
    }
src/proto_alpha/lib_protocol/block_header_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

.

Definition block_header := t.

Definition raw := Tezos_protocol_environment_alpha__Environment.Block_header.t.

Definition shell_header :=
  Tezos_protocol_environment_alpha__Environment.Block_header.shell_header.

Definition raw_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_protocol_environment_alpha__Environment.Block_header.t :=
  Block_header.encoding.

Definition shell_header_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header :=
  Block_header.shell_header_encoding.

Definition contents_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    contents :=
  op_atat
    (let arg := def "block_header.alpha.unsigned_contents" % string in
    fun eta => arg None None eta)
    (conv
      (fun function_parameter =>
        let '{|
          priority := priority;
            seed_nonce_hash := seed_nonce_hash;
            proof_of_work_nonce := proof_of_work_nonce
            |} := function_parameter in
        (priority, proof_of_work_nonce, seed_nonce_hash))
      (fun function_parameter =>
        let '(priority, proof_of_work_nonce, seed_nonce_hash) :=
          function_parameter in
        {| priority := priority; seed_nonce_hash := seed_nonce_hash;
          proof_of_work_nonce := proof_of_work_nonce |}) None
      (obj3 (req None None "priority" % string uint16)
        (req None None "proof_of_work_nonce" % string
          (Fixed.bytes Constants_repr.proof_of_work_nonce_size))
        (opt None None "seed_nonce_hash" % string Nonce_hash.encoding))).

Definition protocol_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    protocol_data :=
  op_atat
    (let arg := def "block_header.alpha.signed_contents" % string in
    fun eta => arg None None eta)
    (conv
      (fun function_parameter =>
        let '{| contents := contents; signature := signature |} :=
          function_parameter in
        (contents, signature))
      (fun function_parameter =>
        let '(contents, signature) := function_parameter in
        {| contents := contents; signature := signature |}) None
      (merge_objs contents_encoding
        (obj1 (req None None "signature" % string Signature.encoding)))).

Definition raw (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Block_header.t :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  let protocol_data :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data in
  {| Block_header.shell := shell; Block_header.protocol_data := protocol_data |}.

Definition unsigned_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Block_header.shell_header *
      contents) :=
  merge_objs Block_header.shell_header_encoding contents_encoding.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  op_atat
    (let arg := def "block_header.alpha.full_header" % string in
    fun eta => arg None None eta)
    (conv
      (fun function_parameter =>
        let '{| shell := shell; protocol_data := protocol_data |} :=
          function_parameter in
        (shell, protocol_data))
      (fun function_parameter =>
        let '(shell, protocol_data) := function_parameter in
        {| shell := shell; protocol_data := protocol_data |}) None
      (merge_objs Block_header.shell_header_encoding protocol_data_encoding)).

Definition max_header_length : Z :=
  let fake_shell
    : Tezos_protocol_environment_alpha__Environment.Block_header.shell_header :=
    {|
      Block_header.level :=
        (* ❌ Constant of type int32 is converted to int *)
        0; Block_header.proto_level := 0;
      Block_header.predecessor :=
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero);
      Block_header.timestamp :=
        Time.of_seconds
          (* ❌ Constant of type int64 is converted to int *)
          0; Block_header.validation_passes := 0;
      Block_header.operations_hash :=
        Tezos_protocol_environment_alpha__Environment.Operation_list_list_hash.(Tezos_protocol_environment_alpha__Environment.MERKLE_TREE.S.zero);
      Block_header.fitness :=
        Fitness_repr.from_int64
          (* ❌ Constant of type int64 is converted to int *)
          0;
      Block_header.context :=
        Tezos_protocol_environment_alpha__Environment.Context_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
      |}
  with fake_contents : contents :=
    {| priority := 0; seed_nonce_hash := Some Nonce_hash.zero;
      proof_of_work_nonce :=
        MBytes.create Constants_repr.proof_of_work_nonce_size |} in
  Data_encoding.Binary.length encoding
    {| shell := fake_shell;
      protocol_data :=
        {| contents := fake_contents; signature := Signature.zero |} |}.

Definition hash_raw
  : Tezos_protocol_environment_alpha__Environment.Block_header.t ->
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  Block_header.hash.

Definition hash (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  Block_header.hash
    {| shell := shell;
      protocol_data :=
        Data_encoding.Binary.to_bytes_exn protocol_data_encoding protocol_data
      |}.

src/proto_alpha/lib_protocol/bootstrap_storage.ml 24 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

let init_account ctxt
    ({public_key_hash; public_key; amount} : Parameters_repr.bootstrap_account)
    =
  let contract = Contract_repr.implicit_contract public_key_hash in
  Contract_storage.credit ctxt contract amount
  >>=? fun ctxt ->
  match public_key with
  | Some public_key ->
      Contract_storage.reveal_manager_key ctxt public_key_hash public_key
      >>=? fun ctxt ->
      Delegate_storage.set ctxt contract (Some public_key_hash)
      >>=? fun ctxt -> return ctxt
  | None ->
      return ctxt

let init_contract ~typecheck ctxt
    ({delegate; amount; script} : Parameters_repr.bootstrap_contract) =
  Contract_storage.fresh_contract_from_current_nonce ctxt
  >>=? fun (ctxt, contract) ->
  typecheck ctxt script
  >>=? fun (script, ctxt) ->
  Contract_storage.originate
    ctxt
    contract
    ~balance:amount
    ~prepaid_bootstrap_storage:true
    ~script
    ~delegate:(Some delegate)
  >>=? fun ctxt -> return ctxt

let init ctxt ~typecheck ?ramp_up_cycles ?no_reward_cycles accounts contracts =
  let nonce =
    Operation_hash.hash_bytes [MBytes.of_string "Un festival de GADT."]
  in
  let ctxt = Raw_context.init_origination_nonce ctxt nonce in
  fold_left_s init_account ctxt accounts
  >>=? fun ctxt ->
  fold_left_s (init_contract ~typecheck) ctxt contracts
  >>=? fun ctxt ->
  ( match no_reward_cycles with
  | None ->
      return ctxt
  | Some cycles ->
      (* Store pending ramp ups. *)
      let constants = Raw_context.constants ctxt in
      (* Start without reward *)
      Raw_context.patch_constants ctxt (fun c ->
          {
            c with
            block_reward = Tez_repr.zero;
            endorsement_reward = Tez_repr.zero;
          })
      >>= fun ctxt ->
      (* Store the final reward. *)
      Storage.Ramp_up.Rewards.init
        ctxt
        (Cycle_repr.of_int32_exn (Int32.of_int cycles))
        (constants.block_reward, constants.endorsement_reward) )
  >>=? fun ctxt ->
  match ramp_up_cycles with
  | None ->
      return ctxt
  | Some cycles ->
      (* Store pending ramp ups. *)
      let constants = Raw_context.constants ctxt in
      Lwt.return
        Tez_repr.(constants.block_security_deposit /? Int64.of_int cycles)
      >>=? fun block_step ->
      Lwt.return
        Tez_repr.(
          constants.endorsement_security_deposit /? Int64.of_int cycles)
      >>=? fun endorsement_step ->
      (* Start without security_deposit *)
      Raw_context.patch_constants ctxt (fun c ->
          {
            c with
            block_security_deposit = Tez_repr.zero;
            endorsement_security_deposit = Tez_repr.zero;
          })
      >>= fun ctxt ->
      fold_left_s
        (fun ctxt cycle ->
          Lwt.return Tez_repr.(block_step *? Int64.of_int cycle)
          >>=? fun block_security_deposit ->
          Lwt.return Tez_repr.(endorsement_step *? Int64.of_int cycle)
          >>=? fun endorsement_security_deposit ->
          let cycle = Cycle_repr.of_int32_exn (Int32.of_int cycle) in
          Storage.Ramp_up.Security_deposits.init
            ctxt
            cycle
            (block_security_deposit, endorsement_security_deposit))
        ctxt
        (1 --> (cycles - 1))
      >>=? fun ctxt ->
      (* Store the final security deposits. *)
      Storage.Ramp_up.Security_deposits.init
        ctxt
        (Cycle_repr.of_int32_exn (Int32.of_int cycles))
        ( constants.block_security_deposit,
          constants.endorsement_security_deposit )
      >>=? fun ctxt -> return ctxt

let cycle_end ctxt last_cycle =
  let next_cycle = Cycle_repr.succ last_cycle in
  Storage.Ramp_up.Rewards.get_option ctxt next_cycle
  >>=? (function
         | None ->
             return ctxt
         | Some (block_reward, endorsement_reward) ->
             Storage.Ramp_up.Rewards.delete ctxt next_cycle
             >>=? fun ctxt ->
             Raw_context.patch_constants ctxt (fun c ->
                 {c with block_reward; endorsement_reward})
             >>= fun ctxt -> return ctxt)
  >>=? fun ctxt ->
  Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle
  >>=? function
  | None ->
      return ctxt
  | Some (block_security_deposit, endorsement_security_deposit) ->
      Storage.Ramp_up.Security_deposits.delete ctxt next_cycle
      >>=? fun ctxt ->
      Raw_context.patch_constants ctxt (fun c ->
          {c with block_security_deposit; endorsement_security_deposit})
      >>= fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/bootstrap_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Misc.

Definition init_account
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (function_parameter :
    Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let '{|
    public_key_hash := public_key_hash;
      public_key := public_key;
      amount := amount
      |} := function_parameter in
  let contract := Contract_repr.implicit_contract public_key_hash in
  op_gtgteqquestion (Contract_storage.credit ctxt contract amount)
    (fun ctxt =>
      match public_key with
      | Some public_key =>
        op_gtgteqquestion
          (Contract_storage.reveal_manager_key ctxt public_key_hash public_key)
          (fun ctxt =>
            op_gtgteqquestion
              (Delegate_storage.set ctxt contract (Some public_key_hash))
              (fun ctxt => _return ctxt))
      | None => _return ctxt
      end).

Definition init_contract
  (typecheck :
    Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t)))
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (function_parameter :
    Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let '{| delegate := delegate; amount := amount; script := script |} :=
    function_parameter in
  op_gtgteqquestion (Contract_storage.fresh_contract_from_current_nonce ctxt)
    (fun function_parameter =>
      let '(ctxt, contract) := function_parameter in
      op_gtgteqquestion (typecheck ctxt script)
        (fun function_parameter =>
          let '(script, ctxt) := function_parameter in
          op_gtgteqquestion
            (Contract_storage.originate ctxt (Some true) contract amount script
              (Some delegate)) (fun ctxt => _return ctxt))).

Definition init
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (typecheck :
    Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t)))
  (ramp_up_cycles : option Z) (no_reward_cycles : option Z)
  (accounts : list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_account)
  (contracts : list Tezos_raw_protocol_alpha.Parameters_repr.bootstrap_contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let nonce :=
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.hash_bytes)
      None (cons (MBytes.of_string "Un festival de GADT." % string) []) in
  let ctxt := Raw_context.init_origination_nonce ctxt nonce in
  op_gtgteqquestion (fold_left_s init_account ctxt accounts)
    (fun ctxt =>
      op_gtgteqquestion (fold_left_s (init_contract typecheck) ctxt contracts)
        (fun ctxt =>
          op_gtgteqquestion
            match no_reward_cycles with
            | None => _return ctxt
            | Some cycles =>
              let constants := Raw_context.constants ctxt in
              op_gtgteq
                (Raw_context.patch_constants ctxt
                  (fun c =>
                    (* ❌ Record substitution not handled *)
                    record_substitution))
                (fun ctxt =>
                  Storage.Ramp_up.Rewards.init ctxt
                    (Cycle_repr.of_int32_exn (Int32.of_int cycles))
                    ((block_reward constants), (endorsement_reward constants)))
            end
            (fun ctxt =>
              match ramp_up_cycles with
              | None => _return ctxt
              | Some cycles =>
                let constants := Raw_context.constants ctxt in
                op_gtgteqquestion
                  (Lwt._return
                    (op_divquestion (block_security_deposit constants)
                      (Int64.of_int cycles)))
                  (fun block_step =>
                    op_gtgteqquestion
                      (Lwt._return
                        (op_divquestion (endorsement_security_deposit constants)
                          (Int64.of_int cycles)))
                      (fun endorsement_step =>
                        op_gtgteq
                          (Raw_context.patch_constants ctxt
                            (fun c =>
                              (* ❌ Record substitution not handled *)
                              record_substitution))
                          (fun ctxt =>
                            op_gtgteqquestion
                              (fold_left_s
                                (fun ctxt =>
                                  fun cycle =>
                                    op_gtgteqquestion
                                      (Lwt._return
                                        (op_starquestion block_step
                                          (Int64.of_int cycle)))
                                      (fun block_security_deposit =>
                                        op_gtgteqquestion
                                          (Lwt._return
                                            (op_starquestion endorsement_step
                                              (Int64.of_int cycle)))
                                          (fun endorsement_security_deposit =>
                                            let cycle :=
                                              Cycle_repr.of_int32_exn
                                                (Int32.of_int cycle) in
                                            Storage.Ramp_up.Security_deposits.init
                                              ctxt cycle
                                              (block_security_deposit,
                                                endorsement_security_deposit))))
                                ctxt (op_minusminusgt 1 (op_minus cycles 1)))
                              (fun ctxt =>
                                op_gtgteqquestion
                                  (Storage.Ramp_up.Security_deposits.init ctxt
                                    (Cycle_repr.of_int32_exn
                                      (Int32.of_int cycles))
                                    ((block_security_deposit constants),
                                      (endorsement_security_deposit constants)))
                                  (fun ctxt => _return ctxt)))))
              end))).

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Ramp_up.Rewards.context) :=
  let next_cycle := Cycle_repr.succ last_cycle in
  op_gtgteqquestion
    (op_gtgteqquestion (Storage.Ramp_up.Rewards.get_option ctxt next_cycle)
      (fun function_parameter =>
        match function_parameter with
        | None => _return ctxt
        | Some (block_reward, endorsement_reward) =>
          op_gtgteqquestion (Storage.Ramp_up.Rewards.delete ctxt next_cycle)
            (fun ctxt =>
              op_gtgteq
                (Raw_context.patch_constants ctxt
                  (fun c =>
                    (* ❌ Record substitution not handled *)
                    record_substitution)) (fun ctxt => _return ctxt))
        end))
    (fun ctxt =>
      op_gtgteqquestion
        (Storage.Ramp_up.Security_deposits.get_option ctxt next_cycle)
        (fun function_parameter =>
          match function_parameter with
          | None => _return ctxt
          | Some (block_security_deposit, endorsement_security_deposit) =>
            op_gtgteqquestion
              (Storage.Ramp_up.Security_deposits.delete ctxt next_cycle)
              (fun ctxt =>
                op_gtgteq
                  (Raw_context.patch_constants ctxt
                    (fun c =>
                      (* ❌ Record substitution not handled *)
                      record_substitution)) (fun ctxt => _return ctxt))
          end)).

src/proto_alpha/lib_protocol/commitment_repr.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  blinded_public_key_hash : Blinded_public_key_hash.t;
  amount : Tez_repr.t;
}

let encoding =
  let open Data_encoding in
  conv
    (fun {blinded_public_key_hash; amount} ->
      (blinded_public_key_hash, amount))
    (fun (blinded_public_key_hash, amount) ->
      {blinded_public_key_hash; amount})
    (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding)
src/proto_alpha/lib_protocol/commitment_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  blinded_public_key_hash : Tezos_raw_protocol_alpha.Blinded_public_key_hash.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  conv
    (fun function_parameter =>
      let '{|
        blinded_public_key_hash := blinded_public_key_hash;
          amount := amount
          |} := function_parameter in
      (blinded_public_key_hash, amount))
    (fun function_parameter =>
      let '(blinded_public_key_hash, amount) := function_parameter in
      {| blinded_public_key_hash := blinded_public_key_hash; amount := amount |})
    None (tup2 Blinded_public_key_hash.encoding Tez_repr.encoding).

src/proto_alpha/lib_protocol/commitment_storage.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let get_opt = Storage.Commitments.get_option

let delete = Storage.Commitments.delete

let init ctxt commitments =
  let init_commitment ctxt Commitment_repr.{blinded_public_key_hash; amount} =
    Storage.Commitments.init ctxt blinded_public_key_hash amount
  in
  fold_left_s init_commitment ctxt commitments >>=? fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/commitment_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition get_opt
  : Tezos_raw_protocol_alpha.Storage.Commitments.context ->
    Tezos_raw_protocol_alpha.Storage.Commitments.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option Tezos_raw_protocol_alpha.Storage.Commitments.value)) :=
  Storage.Commitments.get_option.

Definition delete
  : Tezos_raw_protocol_alpha.Storage.Commitments.context ->
    Tezos_raw_protocol_alpha.Storage.Commitments.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) := Storage.Commitments.delete.

Definition init
  (ctxt : Tezos_raw_protocol_alpha.Storage.Commitments.context)
  (commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Commitments.context) :=
  let init_commitment
    (ctxt : Tezos_raw_protocol_alpha.Storage.Commitments.context)
    (function_parameter : Tezos_raw_protocol_alpha.Commitment_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let '{|
      blinded_public_key_hash := blinded_public_key_hash;
        amount := amount
        |} := function_parameter in
    Storage.Commitments.init ctxt blinded_public_key_hash amount in
  op_gtgteqquestion (fold_left_s init_commitment ctxt commitments)
    (fun ctxt => _return ctxt).

src/proto_alpha/lib_protocol/constants_repr.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let version_number_004 = "\000"

let version_number = "\001"

let proof_of_work_nonce_size = 8

let nonce_length = 32

let max_revelations_per_block = 32

let max_proposals_per_delegate = 20

let max_operation_data_length = 16 * 1024 (* 16kB *)

type fixed = {
  proof_of_work_nonce_size : int;
  nonce_length : int;
  max_revelations_per_block : int;
  max_operation_data_length : int;
  max_proposals_per_delegate : int;
}

let fixed_encoding =
  let open Data_encoding in
  conv
    (fun c ->
      ( c.proof_of_work_nonce_size,
        c.nonce_length,
        c.max_revelations_per_block,
        c.max_operation_data_length,
        c.max_proposals_per_delegate ))
    (fun ( proof_of_work_nonce_size,
           nonce_length,
           max_revelations_per_block,
           max_operation_data_length,
           max_proposals_per_delegate ) ->
      {
        proof_of_work_nonce_size;
        nonce_length;
        max_revelations_per_block;
        max_operation_data_length;
        max_proposals_per_delegate;
      })
    (obj5
       (req "proof_of_work_nonce_size" uint8)
       (req "nonce_length" uint8)
       (req "max_revelations_per_block" uint8)
       (req "max_operation_data_length" int31)
       (req "max_proposals_per_delegate" uint8))

let fixed =
  {
    proof_of_work_nonce_size;
    nonce_length;
    max_revelations_per_block;
    max_operation_data_length;
    max_proposals_per_delegate;
  }

type parametric = {
  preserved_cycles : int;
  blocks_per_cycle : int32;
  blocks_per_commitment : int32;
  blocks_per_roll_snapshot : int32;
  blocks_per_voting_period : int32;
  time_between_blocks : Period_repr.t list;
  endorsers_per_block : int;
  hard_gas_limit_per_operation : Z.t;
  hard_gas_limit_per_block : Z.t;
  proof_of_work_threshold : int64;
  tokens_per_roll : Tez_repr.t;
  michelson_maximum_type_size : int;
  seed_nonce_revelation_tip : Tez_repr.t;
  origination_size : int;
  block_security_deposit : Tez_repr.t;
  endorsement_security_deposit : Tez_repr.t;
  block_reward : Tez_repr.t;
  endorsement_reward : Tez_repr.t;
  cost_per_byte : Tez_repr.t;
  hard_storage_limit_per_operation : Z.t;
  test_chain_duration : int64;
  (* in seconds *)
  quorum_min : int32;
  quorum_max : int32;
  min_proposal_quorum : int32;
  initial_endorsers : int;
  delay_per_missing_endorsement : Period_repr.t;
}

let parametric_encoding =
  let open Data_encoding in
  conv
    (fun c ->
      ( ( c.preserved_cycles,
          c.blocks_per_cycle,
          c.blocks_per_commitment,
          c.blocks_per_roll_snapshot,
          c.blocks_per_voting_period,
          c.time_between_blocks,
          c.endorsers_per_block,
          c.hard_gas_limit_per_operation,
          c.hard_gas_limit_per_block ),
        ( ( c.proof_of_work_threshold,
            c.tokens_per_roll,
            c.michelson_maximum_type_size,
            c.seed_nonce_revelation_tip,
            c.origination_size,
            c.block_security_deposit,
            c.endorsement_security_deposit,
            c.block_reward ),
          ( c.endorsement_reward,
            c.cost_per_byte,
            c.hard_storage_limit_per_operation,
            c.test_chain_duration,
            c.quorum_min,
            c.quorum_max,
            c.min_proposal_quorum,
            c.initial_endorsers,
            c.delay_per_missing_endorsement ) ) ))
    (fun ( ( preserved_cycles,
             blocks_per_cycle,
             blocks_per_commitment,
             blocks_per_roll_snapshot,
             blocks_per_voting_period,
             time_between_blocks,
             endorsers_per_block,
             hard_gas_limit_per_operation,
             hard_gas_limit_per_block ),
           ( ( proof_of_work_threshold,
               tokens_per_roll,
               michelson_maximum_type_size,
               seed_nonce_revelation_tip,
               origination_size,
               block_security_deposit,
               endorsement_security_deposit,
               block_reward ),
             ( endorsement_reward,
               cost_per_byte,
               hard_storage_limit_per_operation,
               test_chain_duration,
               quorum_min,
               quorum_max,
               min_proposal_quorum,
               initial_endorsers,
               delay_per_missing_endorsement ) ) ) ->
      {
        preserved_cycles;
        blocks_per_cycle;
        blocks_per_commitment;
        blocks_per_roll_snapshot;
        blocks_per_voting_period;
        time_between_blocks;
        endorsers_per_block;
        hard_gas_limit_per_operation;
        hard_gas_limit_per_block;
        proof_of_work_threshold;
        tokens_per_roll;
        michelson_maximum_type_size;
        seed_nonce_revelation_tip;
        origination_size;
        block_security_deposit;
        endorsement_security_deposit;
        block_reward;
        endorsement_reward;
        cost_per_byte;
        hard_storage_limit_per_operation;
        test_chain_duration;
        quorum_min;
        quorum_max;
        min_proposal_quorum;
        initial_endorsers;
        delay_per_missing_endorsement;
      })
    (merge_objs
       (obj9
          (req "preserved_cycles" uint8)
          (req "blocks_per_cycle" int32)
          (req "blocks_per_commitment" int32)
          (req "blocks_per_roll_snapshot" int32)
          (req "blocks_per_voting_period" int32)
          (req "time_between_blocks" (list Period_repr.encoding))
          (req "endorsers_per_block" uint16)
          (req "hard_gas_limit_per_operation" z)
          (req "hard_gas_limit_per_block" z))
       (merge_objs
          (obj8
             (req "proof_of_work_threshold" int64)
             (req "tokens_per_roll" Tez_repr.encoding)
             (req "michelson_maximum_type_size" uint16)
             (req "seed_nonce_revelation_tip" Tez_repr.encoding)
             (req "origination_size" int31)
             (req "block_security_deposit" Tez_repr.encoding)
             (req "endorsement_security_deposit" Tez_repr.encoding)
             (req "block_reward" Tez_repr.encoding))
          (obj9
             (req "endorsement_reward" Tez_repr.encoding)
             (req "cost_per_byte" Tez_repr.encoding)
             (req "hard_storage_limit_per_operation" z)
             (req "test_chain_duration" int64)
             (req "quorum_min" int32)
             (req "quorum_max" int32)
             (req "min_proposal_quorum" int32)
             (req "initial_endorsers" uint16)
             (req "delay_per_missing_endorsement" Period_repr.encoding))))

type t = {fixed : fixed; parametric : parametric}

let encoding =
  let open Data_encoding in
  conv
    (fun {fixed; parametric} -> (fixed, parametric))
    (fun (fixed, parametric) -> {fixed; parametric})
    (merge_objs fixed_encoding parametric_encoding)
src/proto_alpha/lib_protocol/constants_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition version_number_004 : string := "" % string.

Definition version_number : string := "" % string.

Definition proof_of_work_nonce_size : Z := 8.

Definition nonce_length : Z := 32.

Definition max_revelations_per_block : Z := 32.

Definition max_proposals_per_delegate : Z := 20.

Definition max_operation_data_length : Z := op_star 16 1024.

Record fixed := {
  proof_of_work_nonce_size : Z;
  nonce_length : Z;
  max_revelations_per_block : Z;
  max_operation_data_length : Z;
  max_proposals_per_delegate : Z }.

Definition fixed_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding fixed :=
  conv
    (fun c =>
      ((proof_of_work_nonce_size c), (nonce_length c),
        (max_revelations_per_block c), (max_operation_data_length c),
        (max_proposals_per_delegate c)))
    (fun function_parameter =>
      let
        '(proof_of_work_nonce_size, nonce_length, max_revelations_per_block,
          max_operation_data_length, max_proposals_per_delegate) :=
        function_parameter in
      {| proof_of_work_nonce_size := proof_of_work_nonce_size;
        nonce_length := nonce_length;
        max_revelations_per_block := max_revelations_per_block;
        max_operation_data_length := max_operation_data_length;
        max_proposals_per_delegate := max_proposals_per_delegate |}) None
    (obj5 (req None None "proof_of_work_nonce_size" % string uint8)
      (req None None "nonce_length" % string uint8)
      (req None None "max_revelations_per_block" % string uint8)
      (req None None "max_operation_data_length" % string int31)
      (req None None "max_proposals_per_delegate" % string uint8)).

Definition fixed : fixed :=
  {| proof_of_work_nonce_size := proof_of_work_nonce_size;
    nonce_length := nonce_length;
    max_revelations_per_block := max_revelations_per_block;
    max_operation_data_length := max_operation_data_length;
    max_proposals_per_delegate := max_proposals_per_delegate |}.

Record parametric := {
  preserved_cycles : Z;
  blocks_per_cycle : int32;
  blocks_per_commitment : int32;
  blocks_per_roll_snapshot : int32;
  blocks_per_voting_period : int32;
  time_between_blocks : list Tezos_raw_protocol_alpha.Period_repr.t;
  endorsers_per_block : Z;
  hard_gas_limit_per_operation :
    Tezos_protocol_environment_alpha__Environment.Z.t;
  hard_gas_limit_per_block : Tezos_protocol_environment_alpha__Environment.Z.t;
  proof_of_work_threshold : int64;
  tokens_per_roll : Tezos_raw_protocol_alpha.Tez_repr.t;
  michelson_maximum_type_size : Z;
  seed_nonce_revelation_tip : Tezos_raw_protocol_alpha.Tez_repr.t;
  origination_size : Z;
  block_security_deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  endorsement_security_deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  block_reward : Tezos_raw_protocol_alpha.Tez_repr.t;
  endorsement_reward : Tezos_raw_protocol_alpha.Tez_repr.t;
  cost_per_byte : Tezos_raw_protocol_alpha.Tez_repr.t;
  hard_storage_limit_per_operation :
    Tezos_protocol_environment_alpha__Environment.Z.t;
  test_chain_duration : int64;
  quorum_min : int32;
  quorum_max : int32;
  min_proposal_quorum : int32;
  initial_endorsers : Z;
  delay_per_missing_endorsement : Tezos_raw_protocol_alpha.Period_repr.t }.

Definition parametric_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    parametric :=
  conv
    (fun c =>
      (((preserved_cycles c), (blocks_per_cycle c), (blocks_per_commitment c),
        (blocks_per_roll_snapshot c), (blocks_per_voting_period c),
        (time_between_blocks c), (endorsers_per_block c),
        (hard_gas_limit_per_operation c), (hard_gas_limit_per_block c)),
        (((proof_of_work_threshold c), (tokens_per_roll c),
          (michelson_maximum_type_size c), (seed_nonce_revelation_tip c),
          (origination_size c), (block_security_deposit c),
          (endorsement_security_deposit c), (block_reward c)),
          ((endorsement_reward c), (cost_per_byte c),
            (hard_storage_limit_per_operation c), (test_chain_duration c),
            (quorum_min c), (quorum_max c), (min_proposal_quorum c),
            (initial_endorsers c), (delay_per_missing_endorsement c)))))
    (fun function_parameter =>
      let
        '((preserved_cycles, blocks_per_cycle, blocks_per_commitment,
          blocks_per_roll_snapshot, blocks_per_voting_period,
          time_between_blocks, endorsers_per_block,
          hard_gas_limit_per_operation, hard_gas_limit_per_block),
          ((proof_of_work_threshold, tokens_per_roll,
            michelson_maximum_type_size, seed_nonce_revelation_tip,
            origination_size, block_security_deposit,
            endorsement_security_deposit, block_reward),
            (endorsement_reward, cost_per_byte,
              hard_storage_limit_per_operation, test_chain_duration, quorum_min,
              quorum_max, min_proposal_quorum, initial_endorsers,
              delay_per_missing_endorsement))) := function_parameter in
      {| preserved_cycles := preserved_cycles;
        blocks_per_cycle := blocks_per_cycle;
        blocks_per_commitment := blocks_per_commitment;
        blocks_per_roll_snapshot := blocks_per_roll_snapshot;
        blocks_per_voting_period := blocks_per_voting_period;
        time_between_blocks := time_between_blocks;
        endorsers_per_block := endorsers_per_block;
        hard_gas_limit_per_operation := hard_gas_limit_per_operation;
        hard_gas_limit_per_block := hard_gas_limit_per_block;
        proof_of_work_threshold := proof_of_work_threshold;
        tokens_per_roll := tokens_per_roll;
        michelson_maximum_type_size := michelson_maximum_type_size;
        seed_nonce_revelation_tip := seed_nonce_revelation_tip;
        origination_size := origination_size;
        block_security_deposit := block_security_deposit;
        endorsement_security_deposit := endorsement_security_deposit;
        block_reward := block_reward; endorsement_reward := endorsement_reward;
        cost_per_byte := cost_per_byte;
        hard_storage_limit_per_operation := hard_storage_limit_per_operation;
        test_chain_duration := test_chain_duration; quorum_min := quorum_min;
        quorum_max := quorum_max; min_proposal_quorum := min_proposal_quorum;
        initial_endorsers := initial_endorsers;
        delay_per_missing_endorsement := delay_per_missing_endorsement |}) None
    (merge_objs
      (obj9 (req None None "preserved_cycles" % string uint8)
        (req None None "blocks_per_cycle" % string int32)
        (req None None "blocks_per_commitment" % string int32)
        (req None None "blocks_per_roll_snapshot" % string int32)
        (req None None "blocks_per_voting_period" % string int32)
        (req None None "time_between_blocks" % string
          (list None Period_repr.encoding))
        (req None None "endorsers_per_block" % string uint16)
        (req None None "hard_gas_limit_per_operation" % string z)
        (req None None "hard_gas_limit_per_block" % string z))
      (merge_objs
        (obj8 (req None None "proof_of_work_threshold" % string int64)
          (req None None "tokens_per_roll" % string Tez_repr.encoding)
          (req None None "michelson_maximum_type_size" % string uint16)
          (req None None "seed_nonce_revelation_tip" % string Tez_repr.encoding)
          (req None None "origination_size" % string int31)
          (req None None "block_security_deposit" % string Tez_repr.encoding)
          (req None None "endorsement_security_deposit" % string
            Tez_repr.encoding)
          (req None None "block_reward" % string Tez_repr.encoding))
        (obj9 (req None None "endorsement_reward" % string Tez_repr.encoding)
          (req None None "cost_per_byte" % string Tez_repr.encoding)
          (req None None "hard_storage_limit_per_operation" % string z)
          (req None None "test_chain_duration" % string int64)
          (req None None "quorum_min" % string int32)
          (req None None "quorum_max" % string int32)
          (req None None "min_proposal_quorum" % string int32)
          (req None None "initial_endorsers" % string uint16)
          (req None None "delay_per_missing_endorsement" % string
            Period_repr.encoding)))).

Record t := {
  fixed : fixed;
  parametric : parametric }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  conv
    (fun function_parameter =>
      let '{| fixed := fixed; parametric := parametric |} := function_parameter
        in
      (fixed, parametric))
    (fun function_parameter =>
      let '(fixed, parametric) := function_parameter in
      {| fixed := fixed; parametric := parametric |}) None
    (merge_objs fixed_encoding parametric_encoding).

src/proto_alpha/lib_protocol/constants_services.ml 35 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root =
  ( RPC_path.(open_root / "context" / "constants")
    : RPC_context.t RPC_path.context )

module S = struct
  open Data_encoding

  let errors =
    RPC_service.get_service
      ~description:"Schema for all the RPC errors from this protocol version"
      ~query:RPC_query.empty
      ~output:json_schema
      RPC_path.(custom_root / "errors")

  let all =
    RPC_service.get_service
      ~description:"All constants"
      ~query:RPC_query.empty
      ~output:Alpha_context.Constants.encoding
      custom_root
end

let register () =
  let open Services_registration in
  register0_noctxt S.errors (fun () () ->
      return Data_encoding.Json.(schema error_encoding)) ;
  register0 S.all (fun ctxt () () ->
      let open Constants in
      return {fixed; parametric = parametric ctxt})

let errors ctxt block = RPC_context.make_call0 S.errors ctxt block () ()

let all ctxt block = RPC_context.make_call0 S.all ctxt block () ()
src/proto_alpha/lib_protocol/constants_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Definition custom_root
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context
    Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
  op_div (op_div open_root "context" % string) "constants" % string.

Module S.
  Import Data_encoding.
  
  Definition errors
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
      Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema :=
    RPC_service.get_service
      (Some "Schema for all the RPC errors from this protocol version" % string)
      RPC_query.empty json_schema (op_div custom_root "errors" % string).
  
  Definition all
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t :=
    RPC_service.get_service (Some "All constants" % string) RPC_query.empty
      Alpha_context.Constants.encoding custom_root.
End S.

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0_noctxt S.errors
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return (schema None error_encoding)) in
  register0 S.all
    (fun ctxt =>
      fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          _return {| fixed := fixed; parametric := parametric ctxt |}).

Definition errors {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Data_encoding.json_schema) :=
  RPC_context.make_call0 S.errors ctxt block tt tt.

Definition all {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
  RPC_context.make_call0 S.all ctxt block tt tt.

src/proto_alpha/lib_protocol/constants_storage.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let preserved_cycles c =
  let constants = Raw_context.constants c in
  constants.preserved_cycles

let blocks_per_cycle c =
  let constants = Raw_context.constants c in
  constants.blocks_per_cycle

let blocks_per_commitment c =
  let constants = Raw_context.constants c in
  constants.blocks_per_commitment

let blocks_per_roll_snapshot c =
  let constants = Raw_context.constants c in
  constants.blocks_per_roll_snapshot

let blocks_per_voting_period c =
  let constants = Raw_context.constants c in
  constants.blocks_per_voting_period

let time_between_blocks c =
  let constants = Raw_context.constants c in
  constants.time_between_blocks

let endorsers_per_block c =
  let constants = Raw_context.constants c in
  constants.endorsers_per_block

let initial_endorsers c =
  let constants = Raw_context.constants c in
  constants.initial_endorsers

let delay_per_missing_endorsement c =
  let constants = Raw_context.constants c in
  constants.delay_per_missing_endorsement

let hard_gas_limit_per_operation c =
  let constants = Raw_context.constants c in
  constants.hard_gas_limit_per_operation

let hard_gas_limit_per_block c =
  let constants = Raw_context.constants c in
  constants.hard_gas_limit_per_block

let cost_per_byte c =
  let constants = Raw_context.constants c in
  constants.cost_per_byte

let hard_storage_limit_per_operation c =
  let constants = Raw_context.constants c in
  constants.hard_storage_limit_per_operation

let proof_of_work_threshold c =
  let constants = Raw_context.constants c in
  constants.proof_of_work_threshold

let tokens_per_roll c =
  let constants = Raw_context.constants c in
  constants.tokens_per_roll

let michelson_maximum_type_size c =
  let constants = Raw_context.constants c in
  constants.michelson_maximum_type_size

let seed_nonce_revelation_tip c =
  let constants = Raw_context.constants c in
  constants.seed_nonce_revelation_tip

let origination_size c =
  let constants = Raw_context.constants c in
  constants.origination_size

let block_security_deposit c =
  let constants = Raw_context.constants c in
  constants.block_security_deposit

let endorsement_security_deposit c =
  let constants = Raw_context.constants c in
  constants.endorsement_security_deposit

let block_reward c =
  let constants = Raw_context.constants c in
  constants.block_reward

let endorsement_reward c =
  let constants = Raw_context.constants c in
  constants.endorsement_reward

let test_chain_duration c =
  let constants = Raw_context.constants c in
  constants.test_chain_duration

let quorum_min c =
  let constants = Raw_context.constants c in
  constants.quorum_min

let quorum_max c =
  let constants = Raw_context.constants c in
  constants.quorum_max

let min_proposal_quorum c =
  let constants = Raw_context.constants c in
  constants.min_proposal_quorum

let parametric c = Raw_context.constants c
src/proto_alpha/lib_protocol/constants_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition preserved_cycles (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Z :=
  let constants := Raw_context.constants c in
  preserved_cycles constants.

Definition blocks_per_cycle (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : int32 :=
  let constants := Raw_context.constants c in
  blocks_per_cycle constants.

Definition blocks_per_commitment
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  blocks_per_commitment constants.

Definition blocks_per_roll_snapshot
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  blocks_per_roll_snapshot constants.

Definition blocks_per_voting_period
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  blocks_per_voting_period constants.

Definition time_between_blocks
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : list Tezos_raw_protocol_alpha.Period_repr.t :=
  let constants := Raw_context.constants c in
  time_between_blocks constants.

Definition endorsers_per_block
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  endorsers_per_block constants.

Definition initial_endorsers (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Z :=
  let constants := Raw_context.constants c in
  initial_endorsers constants.

Definition delay_per_missing_endorsement
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Period_repr.t :=
  let constants := Raw_context.constants c in
  delay_per_missing_endorsement constants.

Definition hard_gas_limit_per_operation
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  let constants := Raw_context.constants c in
  hard_gas_limit_per_operation constants.

Definition hard_gas_limit_per_block
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  let constants := Raw_context.constants c in
  hard_gas_limit_per_block constants.

Definition cost_per_byte (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  cost_per_byte constants.

Definition hard_storage_limit_per_operation
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  let constants := Raw_context.constants c in
  hard_storage_limit_per_operation constants.

Definition proof_of_work_threshold
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int64 :=
  let constants := Raw_context.constants c in
  proof_of_work_threshold constants.

Definition tokens_per_roll (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  tokens_per_roll constants.

Definition michelson_maximum_type_size
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : Z :=
  let constants := Raw_context.constants c in
  michelson_maximum_type_size constants.

Definition seed_nonce_revelation_tip
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  seed_nonce_revelation_tip constants.

Definition origination_size (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Z :=
  let constants := Raw_context.constants c in
  origination_size constants.

Definition block_security_deposit
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  block_security_deposit constants.

Definition endorsement_security_deposit
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  endorsement_security_deposit constants.

Definition block_reward (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  block_reward constants.

Definition endorsement_reward (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Tez_repr.t :=
  let constants := Raw_context.constants c in
  endorsement_reward constants.

Definition test_chain_duration
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int64 :=
  let constants := Raw_context.constants c in
  test_chain_duration constants.

Definition quorum_min (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : int32 :=
  let constants := Raw_context.constants c in
  quorum_min constants.

Definition quorum_max (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : int32 :=
  let constants := Raw_context.constants c in
  quorum_max constants.

Definition min_proposal_quorum
  (c : Tezos_raw_protocol_alpha.Raw_context.context) : int32 :=
  let constants := Raw_context.constants c in
  min_proposal_quorum constants.

Definition parametric (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Constants_repr.parametric :=
  Raw_context.constants c.

src/proto_alpha/lib_protocol/contract_hash.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* 20 *)
let contract_hash = "\002\090\121" (* KT1(36) *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "Contract_hash"

            let title = "A contract ID"

            let b58check_prefix = contract_hash

            let size = Some 20
          end)

let () = Base58.check_encoded_prefix b58check_encoding "KT1" 36
src/proto_alpha/lib_protocol/contract_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition contract_hash : string := "Zy" % string.

(* ❌ Structure item `include` not handled. *)
include



src/proto_alpha/lib_protocol/contract_repr.ml 38 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t =
  | Implicit of Signature.Public_key_hash.t
  | Originated of Contract_hash.t

include Compare.Make (struct
  type nonrec t = t

  let compare l1 l2 =
    match (l1, l2) with
    | (Implicit pkh1, Implicit pkh2) ->
        Signature.Public_key_hash.compare pkh1 pkh2
    | (Originated h1, Originated h2) ->
        Contract_hash.compare h1 h2
    | (Implicit _, Originated _) ->
        -1
    | (Originated _, Implicit _) ->
        1
end)

type contract = t

type error += Invalid_contract_notation of string (* `Permanent *)

let to_b58check = function
  | Implicit pbk ->
      Signature.Public_key_hash.to_b58check pbk
  | Originated h ->
      Contract_hash.to_b58check h

let of_b58check s =
  match Base58.decode s with
  | Some (Ed25519.Public_key_hash.Data h) ->
      ok (Implicit (Signature.Ed25519 h))
  | Some (Secp256k1.Public_key_hash.Data h) ->
      ok (Implicit (Signature.Secp256k1 h))
  | Some (P256.Public_key_hash.Data h) ->
      ok (Implicit (Signature.P256 h))
  | Some (Contract_hash.Data h) ->
      ok (Originated h)
  | _ ->
      error (Invalid_contract_notation s)

let pp ppf = function
  | Implicit pbk ->
      Signature.Public_key_hash.pp ppf pbk
  | Originated h ->
      Contract_hash.pp ppf h

let pp_short ppf = function
  | Implicit pbk ->
      Signature.Public_key_hash.pp_short ppf pbk
  | Originated h ->
      Contract_hash.pp_short ppf h

let encoding =
  let open Data_encoding in
  def
    "contract_id"
    ~title:"A contract handle"
    ~description:
      "A contract notation as given to an RPC or inside scripts. Can be a \
       base58 implicit contract hash or a base58 originated contract hash."
  @@ splitted
       ~binary:
         (union
            ~tag_size:`Uint8
            [ case
                (Tag 0)
                ~title:"Implicit"
                Signature.Public_key_hash.encoding
                (function Implicit k -> Some k | _ -> None)
                (fun k -> Implicit k);
              case
                (Tag 1)
                (Fixed.add_padding Contract_hash.encoding 1)
                ~title:"Originated"
                (function Originated k -> Some k | _ -> None)
                (fun k -> Originated k) ])
       ~json:
         (conv
            to_b58check
            (fun s ->
              match of_b58check s with
              | Ok s ->
                  s
              | Error _ ->
                  Json.cannot_destruct "Invalid contract notation.")
            string)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"contract.invalid_contract_notation"
    ~title:"Invalid contract notation"
    ~pp:(fun ppf x -> Format.fprintf ppf "Invalid contract notation %S" x)
    ~description:
      "A malformed contract notation was given to an RPC or in a script."
    (obj1 (req "notation" string))
    (function Invalid_contract_notation loc -> Some loc | _ -> None)
    (fun loc -> Invalid_contract_notation loc)

let implicit_contract id = Implicit id

let is_implicit = function Implicit m -> Some m | Originated _ -> None

let is_originated = function Implicit _ -> None | Originated h -> Some h

type origination_nonce = {
  operation_hash : Operation_hash.t;
  origination_index : int32;
}

let origination_nonce_encoding =
  let open Data_encoding in
  conv
    (fun {operation_hash; origination_index} ->
      (operation_hash, origination_index))
    (fun (operation_hash, origination_index) ->
      {operation_hash; origination_index})
  @@ obj2 (req "operation" Operation_hash.encoding) (dft "index" int32 0l)

let originated_contract nonce =
  let data =
    Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
  in
  Originated (Contract_hash.hash_bytes [data])

let originated_contracts
    ~since:{origination_index = first; operation_hash = first_hash}
    ~until:( {origination_index = last; operation_hash = last_hash} as
           origination_nonce ) =
  assert (Operation_hash.equal first_hash last_hash) ;
  let rec contracts acc origination_index =
    if Compare.Int32.(origination_index < first) then acc
    else
      let origination_nonce = {origination_nonce with origination_index} in
      let acc = originated_contract origination_nonce :: acc in
      contracts acc (Int32.pred origination_index)
  in
  contracts [] (Int32.pred last)

let initial_origination_nonce operation_hash =
  {operation_hash; origination_index = 0l}

let incr_origination_nonce nonce =
  let origination_index = Int32.succ nonce.origination_index in
  {nonce with origination_index}

let rpc_arg =
  let construct = to_b58check in
  let destruct hash =
    match of_b58check hash with
    | Error _ ->
        Error "Cannot parse contract id"
    | Ok contract ->
        Ok contract
  in
  RPC_arg.make
    ~descr:"A contract identifier encoded in b58check."
    ~name:"contract_id"
    ~construct
    ~destruct
    ()

module Index = struct
  type t = contract

  let path_length = 7

  let to_path c l =
    let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
    let (`Hex key) = MBytes.to_hex raw_key in
    let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
    String.sub index_key 0 2 :: String.sub index_key 2 2
    :: String.sub index_key 4 2 :: String.sub index_key 6 2
    :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: key :: l

  let of_path = function
    | []
    | [_]
    | [_; _]
    | [_; _; _]
    | [_; _; _; _]
    | [_; _; _; _; _]
    | [_; _; _; _; _; _]
    | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
        None
    | [index1; index2; index3; index4; index5; index6; key] ->
        let raw_key = MBytes.of_hex (`Hex key) in
        let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
        assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
        assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
        assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
        assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
        assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
        assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
        Data_encoding.Binary.of_bytes encoding raw_key

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/contract_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Implicit :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t -> t
| Originated : Tezos_raw_protocol_alpha.Contract_hash.t -> t.

(* ❌ Structure item `include` not handled. *)
include

Definition contract := t.

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition to_b58check (function_parameter : t) : string :=
  match function_parameter with
  | Implicit pbk => Signature.Public_key_hash.to_b58check pbk
  | Originated h => Contract_hash.to_b58check h
  end.

Definition of_b58check (s : string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
  match Base58.decode s with
  | Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
    ok
      (Implicit
        (Tezos_protocol_environment_alpha__Environment.Signature.Ed25519 h))
  | Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
    ok
      (Implicit
        (Tezos_protocol_environment_alpha__Environment.Signature.Secp256k1 h))
  | Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
    ok
      (Implicit (Tezos_protocol_environment_alpha__Environment.Signature.P256 h))
  | Some (Tezos_protocol_environment_alpha__Environment.Base58.Data h) =>
    ok (Originated h)
  | _ =>
    error
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract_notation
        s)
  end.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | Implicit pbk => Signature.Public_key_hash.pp ppf pbk
  | Originated h => Contract_hash.pp ppf h
  end.

Definition pp_short
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | Implicit pbk => Signature.Public_key_hash.pp_short ppf pbk
  | Originated h => Contract_hash.pp_short ppf h
  end.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  op_atat
    (def "contract_id" % string (Some "A contract handle" % string)
      (Some
        "A contract notation as given to an RPC or inside scripts. Can be a base58 implicit contract hash or a base58 originated contract hash."
          % string))
    (splitted
      (conv to_b58check
        (fun s =>
          match of_b58check s with
          | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok s => s
          | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
            Json.cannot_destruct
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                  "Invalid contract notation." % string
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
                "Invalid contract notation." % string)
          end) None string)
      (union
        (Some
          (* ❌ Variants not supported *)
          variant)
        (cons
          (case "Implicit" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
            Signature.Public_key_hash.encoding
            (fun function_parameter =>
              match function_parameter with
              | Implicit k => Some k
              | _ => None
              end) (fun k => Implicit k))
          (cons
            (case "Originated" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
              (Fixed.add_padding Contract_hash.encoding 1)
              (fun function_parameter =>
                match function_parameter with
                | Originated k => Some k
                | _ => None
                end) (fun k => Originated k)) [])))).



Definition implicit_contract
  (id :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : t := Implicit id.

Definition is_implicit (function_parameter : t)
  : option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
  match function_parameter with
  | Implicit m => Some m
  | Originated _ => None
  end.

Definition is_originated (function_parameter : t)
  : option Tezos_raw_protocol_alpha.Contract_hash.t :=
  match function_parameter with
  | Implicit _ => None
  | Originated h => Some h
  end.

Record origination_nonce := {
  operation_hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  origination_index : int32 }.

Definition origination_nonce_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    origination_nonce :=
  op_atat
    (let arg :=
      conv
        (fun function_parameter =>
          let '{|
            operation_hash := operation_hash;
              origination_index := origination_index
              |} := function_parameter in
          (operation_hash, origination_index))
        (fun function_parameter =>
          let '(operation_hash, origination_index) := function_parameter in
          {| operation_hash := operation_hash;
            origination_index := origination_index |}) in
    fun eta => arg None eta)
    (obj2
      (req None None "operation" % string
        Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
      (dft None None "index" % string int32
        (* ❌ Constant of type int32 is converted to int *)
        0)).

Definition originated_contract (nonce : origination_nonce) : t :=
  let data := Data_encoding.Binary.to_bytes_exn origination_nonce_encoding nonce
    in
  Originated (Contract_hash.hash_bytes None (cons data [])).

Definition originated_contracts (function_parameter : origination_nonce)
  : origination_nonce -> list t :=
  let '{| operation_hash := first_hash; origination_index := first |} :=
    function_parameter in
  fun function_parameter =>
    let
      '{| operation_hash := last_hash; origination_index := last |} as
        origination_nonce := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      (* ❌ Assert instruction is not handled. *)
      assert
        (Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
          first_hash last_hash) in
    let fix contracts
      (acc : list t) (origination_index :
      Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list t :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
          origination_index first then
        acc
      else
        let origination_nonce :=
          (* ❌ Record substitution not handled *)
          record_substitution in
        let acc := cons (originated_contract origination_nonce) acc in
        contracts acc (Int32.pred origination_index) in
    contracts [] (Int32.pred last).

Definition initial_origination_nonce
  (operation_hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : origination_nonce :=
  {| operation_hash := operation_hash;
    origination_index :=
      (* ❌ Constant of type int32 is converted to int *)
      0 |}.

Definition incr_origination_nonce (nonce : origination_nonce)
  : origination_nonce :=
  let origination_index := Int32.succ (origination_index nonce) in
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg t :=
  let construct := to_b58check in
  let destruct (hash : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result t string :=
    match of_b58check hash with
    | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.Error
        "Cannot parse contract id" % string
    | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok contract =>
      Tezos_protocol_environment_alpha__Environment.Pervasives.Ok contract
    end in
  RPC_arg.make (Some "A contract identifier encoded in b58check." % string)
    "contract_id" % string destruct construct tt.

Module Index.
  Definition t := contract.
  
  Definition path_length : Z := 7.
  
  Definition to_path (c : t) (l : list string) : list string :=
    let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
    let 'Hex key := MBytes.to_hex raw_key in
    let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
    cons (String.sub index_key 0 2)
      (cons (String.sub index_key 2 2)
        (cons (String.sub index_key 4 2)
          (cons (String.sub index_key 6 2)
            (cons (String.sub index_key 8 2)
              (cons (String.sub index_key 10 2) (cons key l)))))).
  
  Definition of_path
    (function_parameter :
      list
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : option t :=
    match function_parameter with
    |
      [] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
        cons _ (cons _ (cons _ (cons _ []))) |
        cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
        cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
        cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _)))))))
      => None
    |
      cons index1
        (cons index2
          (cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
      =>
      let raw_key :=
        MBytes.of_hex
          (* ❌ Variants not supported *)
          variant in
      let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.sub index_key 0 2) index1) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.sub index_key 2 2) index2) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.sub index_key 4 2) index3) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.sub index_key 6 2) index4) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.sub index_key 8 2) index5) in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert
          (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.sub index_key 10 2) index6) in
      Data_encoding.Binary.of_bytes encoding raw_key
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg t := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

src/proto_alpha/lib_protocol/contract_services.ml 332 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

let custom_root =
  ( RPC_path.(open_root / "context" / "contracts")
    : RPC_context.t RPC_path.context )

let big_map_root =
  ( RPC_path.(open_root / "context" / "big_maps")
    : RPC_context.t RPC_path.context )

type info = {
  balance : Tez.t;
  delegate : public_key_hash option;
  counter : counter option;
  script : Script.t option;
}

let info_encoding =
  let open Data_encoding in
  conv
    (fun {balance; delegate; script; counter} ->
      (balance, delegate, script, counter))
    (fun (balance, delegate, script, counter) ->
      {balance; delegate; script; counter})
  @@ obj4
       (req "balance" Tez.encoding)
       (opt "delegate" Signature.Public_key_hash.encoding)
       (opt "script" Script.encoding)
       (opt "counter" n)

module S = struct
  open Data_encoding

  let balance =
    RPC_service.get_service
      ~description:"Access the balance of a contract."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "balance")

  let manager_key =
    RPC_service.get_service
      ~description:"Access the manager of a contract."
      ~query:RPC_query.empty
      ~output:(option Signature.Public_key.encoding)
      RPC_path.(custom_root /: Contract.rpc_arg / "manager_key")

  let delegate =
    RPC_service.get_service
      ~description:"Access the delegate of a contract, if any."
      ~query:RPC_query.empty
      ~output:Signature.Public_key_hash.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "delegate")

  let counter =
    RPC_service.get_service
      ~description:"Access the counter of a contract, if any."
      ~query:RPC_query.empty
      ~output:z
      RPC_path.(custom_root /: Contract.rpc_arg / "counter")

  let script =
    RPC_service.get_service
      ~description:"Access the code and data of the contract."
      ~query:RPC_query.empty
      ~output:Script.encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "script")

  let storage =
    RPC_service.get_service
      ~description:"Access the data of the contract."
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(custom_root /: Contract.rpc_arg / "storage")

  let entrypoint_type =
    RPC_service.get_service
      ~description:"Return the type of the given entrypoint of the contract"
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(
        custom_root /: Contract.rpc_arg / "entrypoints" /: RPC_arg.string)

  let list_entrypoints =
    RPC_service.get_service
      ~description:"Return the list of entrypoints of the contract"
      ~query:RPC_query.empty
      ~output:
        (obj2
           (dft
              "unreachable"
              (Data_encoding.list
                 (obj1
                    (req
                       "path"
                       (Data_encoding.list
                          Michelson_v1_primitives.prim_encoding))))
              [])
           (req "entrypoints" (assoc Script.expr_encoding)))
      RPC_path.(custom_root /: Contract.rpc_arg / "entrypoints")

  let contract_big_map_get_opt =
    RPC_service.post_service
      ~description:
        "Access the value associated with a key in a big map of the contract \
         (deprecated)."
      ~query:RPC_query.empty
      ~input:
        (obj2
           (req "key" Script.expr_encoding)
           (req "type" Script.expr_encoding))
      ~output:(option Script.expr_encoding)
      RPC_path.(custom_root /: Contract.rpc_arg / "big_map_get")

  let big_map_get =
    RPC_service.get_service
      ~description:"Access the value associated with a key in a big map."
      ~query:RPC_query.empty
      ~output:Script.expr_encoding
      RPC_path.(big_map_root /: Big_map.rpc_arg /: Script_expr_hash.rpc_arg)

  let info =
    RPC_service.get_service
      ~description:"Access the complete status of a contract."
      ~query:RPC_query.empty
      ~output:info_encoding
      RPC_path.(custom_root /: Contract.rpc_arg)

  let list =
    RPC_service.get_service
      ~description:
        "All existing contracts (including non-empty default contracts)."
      ~query:RPC_query.empty
      ~output:(list Contract.encoding)
      custom_root
end

let register () =
  let open Services_registration in
  register0 S.list (fun ctxt () () -> Contract.list ctxt >>= return) ;
  let register_field s f =
    register1 s (fun ctxt contract () () ->
        Contract.exists ctxt contract
        >>=? function true -> f ctxt contract | false -> raise Not_found)
  in
  let register_opt_field s f =
    register_field s (fun ctxt a1 ->
        f ctxt a1 >>=? function None -> raise Not_found | Some v -> return v)
  in
  let do_big_map_get ctxt id key =
    let open Script_ir_translator in
    let ctxt = Gas.set_unlimited ctxt in
    Big_map.exists ctxt id
    >>=? fun (ctxt, types) ->
    match types with
    | None ->
        raise Not_found
    | Some (_, value_type) -> (
        Lwt.return
          (parse_ty
             ctxt
             ~legacy:true
             ~allow_big_map:false
             ~allow_operation:false
             ~allow_contract:true
             (Micheline.root value_type))
        >>=? fun (Ex_ty value_type, ctxt) ->
        Big_map.get_opt ctxt id key
        >>=? fun (_ctxt, value) ->
        match value with
        | None ->
            raise Not_found
        | Some value ->
            parse_data ctxt ~legacy:true value_type (Micheline.root value)
            >>=? fun (value, ctxt) ->
            unparse_data ctxt Readable value_type value
            >>=? fun (value, _ctxt) -> return (Micheline.strip_locations value)
        )
  in
  register_field S.balance Contract.get_balance ;
  register1 S.manager_key (fun ctxt contract () () ->
      match Contract.is_implicit contract with
      | None ->
          raise Not_found
      | Some mgr -> (
          Contract.is_manager_key_revealed ctxt mgr
          >>=? function
          | false ->
              return_none
          | true ->
              Contract.get_manager_key ctxt mgr >>=? return_some )) ;
  register_opt_field S.delegate Delegate.get ;
  register1 S.counter (fun ctxt contract () () ->
      match Contract.is_implicit contract with
      | None ->
          raise Not_found
      | Some mgr ->
          Contract.get_counter ctxt mgr) ;
  register_opt_field S.script (fun c v ->
      Contract.get_script c v >>=? fun (_, v) -> return v) ;
  register_opt_field S.storage (fun ctxt contract ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      match script with
      | None ->
          return_none
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          unparse_script ctxt Readable script
          >>=? fun (script, ctxt) ->
          Script.force_decode ctxt script.storage
          >>=? fun (storage, _ctxt) -> return_some storage) ;
  register2 S.entrypoint_type (fun ctxt v entrypoint () () ->
      Contract.get_script_code ctxt v
      >>=? fun (_, expr) ->
      match expr with
      | None ->
          raise Not_found
      | Some expr -> (
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = true in
          let open Script_ir_translator in
          Script.force_decode ctxt expr
          >>=? fun (expr, _) ->
          Lwt.return
            ( parse_toplevel ~legacy expr
            >>? fun (arg_type, _, _, root_name) ->
            parse_ty
              ctxt
              ~legacy
              ~allow_big_map:true
              ~allow_operation:false
              ~allow_contract:true
              arg_type
            >>? fun (Ex_ty arg_type, _) ->
            Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
            )
          >>= function
          | Ok (_f, Ex_ty ty) ->
              unparse_ty ctxt ty
              >>=? fun (ty_node, _) ->
              return (Micheline.strip_locations ty_node)
          | Error _ ->
              raise Not_found )) ;
  register1 S.list_entrypoints (fun ctxt v () () ->
      Contract.get_script_code ctxt v
      >>=? fun (_, expr) ->
      match expr with
      | None ->
          raise Not_found
      | Some expr ->
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = true in
          let open Script_ir_translator in
          Script.force_decode ctxt expr
          >>=? fun (expr, _) ->
          Lwt.return
            ( parse_toplevel ~legacy expr
            >>? fun (arg_type, _, _, root_name) ->
            parse_ty
              ctxt
              ~legacy
              ~allow_big_map:true
              ~allow_operation:false
              ~allow_contract:true
              arg_type
            >>? fun (Ex_ty arg_type, _) ->
            Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
          >>=? fun (unreachable_entrypoint, map) ->
          return
            ( unreachable_entrypoint,
              Entrypoints_map.fold
                (fun entry (_, ty) acc ->
                  (entry, Micheline.strip_locations ty) :: acc)
                map
                [] )) ;
  register1 S.contract_big_map_get_opt (fun ctxt contract () (key, key_type) ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      Lwt.return
        (Script_ir_translator.parse_packable_ty
           ctxt
           ~legacy:true
           (Micheline.root key_type))
      >>=? fun (Ex_ty key_type, ctxt) ->
      Script_ir_translator.parse_data
        ctxt
        ~legacy:true
        key_type
        (Micheline.root key)
      >>=? fun (key, ctxt) ->
      Script_ir_translator.hash_data ctxt key_type key
      >>=? fun (key, ctxt) ->
      match script with
      | None ->
          raise Not_found
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          Script_ir_translator.collect_big_maps
            ctxt
            script.storage_type
            script.storage
          >>=? fun (ids, _ctxt) ->
          let ids = Script_ir_translator.list_of_big_map_ids ids in
          let rec find = function
            | [] ->
                return_none
            | (id : Z.t) :: ids -> (
              try do_big_map_get ctxt id key >>=? return_some
              with Not_found -> find ids )
          in
          find ids) ;
  register2 S.big_map_get (fun ctxt id key () () -> do_big_map_get ctxt id key) ;
  register_field S.info (fun ctxt contract ->
      Contract.get_balance ctxt contract
      >>=? fun balance ->
      Delegate.get ctxt contract
      >>=? fun delegate ->
      ( match Contract.is_implicit contract with
      | Some manager ->
          Contract.get_counter ctxt manager
          >>=? fun counter -> return_some counter
      | None ->
          return None )
      >>=? fun counter ->
      Contract.get_script ctxt contract
      >>=? fun (ctxt, script) ->
      ( match script with
      | None ->
          return (None, ctxt)
      | Some script ->
          let ctxt = Gas.set_unlimited ctxt in
          let open Script_ir_translator in
          parse_script ctxt ~legacy:true script
          >>=? fun (Ex_script script, ctxt) ->
          unparse_script ctxt Readable script
          >>=? fun (script, ctxt) -> return (Some script, ctxt) )
      >>=? fun (script, _ctxt) -> return {balance; delegate; script; counter})

let list ctxt block = RPC_context.make_call0 S.list ctxt block () ()

let info ctxt block contract =
  RPC_context.make_call1 S.info ctxt block contract () ()

let balance ctxt block contract =
  RPC_context.make_call1 S.balance ctxt block contract () ()

let manager_key ctxt block mgr =
  RPC_context.make_call1
    S.manager_key
    ctxt
    block
    (Contract.implicit_contract mgr)
    ()
    ()

let delegate ctxt block contract =
  RPC_context.make_call1 S.delegate ctxt block contract () ()

let delegate_opt ctxt block contract =
  RPC_context.make_opt_call1 S.delegate ctxt block contract () ()

let counter ctxt block mgr =
  RPC_context.make_call1
    S.counter
    ctxt
    block
    (Contract.implicit_contract mgr)
    ()
    ()

let script ctxt block contract =
  RPC_context.make_call1 S.script ctxt block contract () ()

let script_opt ctxt block contract =
  RPC_context.make_opt_call1 S.script ctxt block contract () ()

let storage ctxt block contract =
  RPC_context.make_call1 S.storage ctxt block contract () ()

let entrypoint_type ctxt block contract entrypoint =
  RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint () ()

let list_entrypoints ctxt block contract =
  RPC_context.make_call1 S.list_entrypoints ctxt block contract () ()

let storage_opt ctxt block contract =
  RPC_context.make_opt_call1 S.storage ctxt block contract () ()

let big_map_get ctxt block id key =
  RPC_context.make_call2 S.big_map_get ctxt block id key () ()

let contract_big_map_get_opt ctxt block contract key =
  RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract () key
src/proto_alpha/lib_protocol/contract_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Definition custom_root
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context
    Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
  op_div (op_div open_root "context" % string) "contracts" % string.

Definition big_map_root
  : Tezos_protocol_environment_alpha__Environment.RPC_path.context
    Tezos_protocol_environment_alpha__Environment.RPC_context.t :=
  op_div (op_div open_root "context" % string) "big_maps" % string.

Record info := {
  balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  delegate : option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash;
  counter : option Tezos_raw_protocol_alpha.Alpha_context.counter;
  script : option Tezos_raw_protocol_alpha.Alpha_context.Script.t }.

Definition info_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
  op_atat
    (let arg :=
      conv
        (fun function_parameter =>
          let '{|
            balance := balance;
              delegate := delegate;
              counter := counter;
              script := script
              |} := function_parameter in
          (balance, delegate, script, counter))
        (fun function_parameter =>
          let '(balance, delegate, script, counter) := function_parameter in
          {| balance := balance; delegate := delegate; counter := counter;
            script := script |}) in
    fun eta => arg None eta)
    (obj4 (req None None "balance" % string Tez.encoding)
      (opt None None "delegate" % string Signature.Public_key_hash.encoding)
      (opt None None "script" % string Script.encoding)
      (opt None None "counter" % string n)).

Module S.
  Import Data_encoding.
  
  Definition balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    RPC_service.get_service (Some "Access the balance of a contract." % string)
      RPC_query.empty Tez.encoding
      (op_div (op_divcolon custom_root Contract.rpc_arg) "balance" % string).
  
  Definition manager_key
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
    RPC_service.get_service (Some "Access the manager of a contract." % string)
      RPC_query.empty (option Signature.Public_key.encoding)
      (op_div (op_divcolon custom_root Contract.rpc_arg) "manager_key" % string).
  
  Definition delegate
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
    RPC_service.get_service
      (Some "Access the delegate of a contract, if any." % string)
      RPC_query.empty Signature.Public_key_hash.encoding
      (op_div (op_divcolon custom_root Contract.rpc_arg) "delegate" % string).
  
  Definition counter
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    RPC_service.get_service
      (Some "Access the counter of a contract, if any." % string)
      RPC_query.empty z
      (op_div (op_divcolon custom_root Contract.rpc_arg) "counter" % string).
  
  Definition script
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Script.t :=
    RPC_service.get_service
      (Some "Access the code and data of the contract." % string)
      RPC_query.empty Script.encoding
      (op_div (op_divcolon custom_root Contract.rpc_arg) "script" % string).
  
  Definition storage
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
    RPC_service.get_service (Some "Access the data of the contract." % string)
      RPC_query.empty Script.expr_encoding
      (op_div (op_divcolon custom_root Contract.rpc_arg) "storage" % string).
  
  Definition entrypoint_type
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) * string) unit
      unit Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
    RPC_service.get_service
      (Some "Return the type of the given entrypoint of the contract" % string)
      RPC_query.empty Script.expr_encoding
      (op_divcolon
        (op_div (op_divcolon custom_root Contract.rpc_arg)
          "entrypoints" % string) RPC_arg.string).
  
  Definition list_entrypoints
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit
      ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
        (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
    RPC_service.get_service
      (Some "Return the list of entrypoints of the contract" % string)
      RPC_query.empty
      (obj2
        (dft None None "unreachable" % string
          (Data_encoding.list None
            (obj1
              (req None None "path" % string
                (Data_encoding.list None Michelson_v1_primitives.prim_encoding))))
          [])
        (req None None "entrypoints" % string (assoc Script.expr_encoding)))
      (op_div (op_divcolon custom_root Contract.rpc_arg) "entrypoints" % string).
  
  Definition contract_big_map_get_opt
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
    RPC_service.post_service
      (Some
        "Access the value associated with a key in a big map of the contract (deprecated)."
          % string) RPC_query.empty
      (obj2 (req None None "key" % string Script.expr_encoding)
        (req None None "type" % string Script.expr_encoding))
      (option Script.expr_encoding)
      (op_div (op_divcolon custom_root Contract.rpc_arg) "big_map_get" % string).
  
  Definition big_map_get
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      ((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Big_map.id) *
        Tezos_raw_protocol_alpha.Script_expr_hash.t) unit unit
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
    RPC_service.get_service
      (Some "Access the value associated with a key in a big map." % string)
      RPC_query.empty Script.expr_encoding
      (op_divcolon (op_divcolon big_map_root Big_map.rpc_arg)
        Script_expr_hash.rpc_arg).
  
  Definition info
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      (Tezos_protocol_environment_alpha__Environment.RPC_context.t *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit info :=
    RPC_service.get_service
      (Some "Access the complete status of a contract." % string)
      RPC_query.empty info_encoding (op_divcolon custom_root Contract.rpc_arg).
  
  Definition list
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t unit unit
      (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t) :=
    RPC_service.get_service
      (Some
        "All existing contracts (including non-empty default contracts)." %
          string) RPC_query.empty (list None Contract.encoding) custom_root.
End S.

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.list
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Contract.list ctxt) _return) in
  let register_field {A : Type}
    (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit A)
    (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      Tezos_raw_protocol_alpha.Alpha_context.Contract.contract ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A))
    : unit :=
    register1 s
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (Contract._exists ctxt contract)
                (fun function_parameter =>
                  match function_parameter with
                  | true => f ctxt contract
                  | false => raise OCaml.Not_found
                  end)) in
  let register_opt_field {A : Type}
    (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_raw_protocol_alpha.Alpha_context.Contract.contract) unit unit A)
    (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      Tezos_raw_protocol_alpha.Alpha_context.Contract.contract ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (option A))) : unit :=
    register_field s
      (fun ctxt =>
        fun a1 =>
          op_gtgteqquestion (f ctxt a1)
            (fun function_parameter =>
              match function_parameter with
              | None => raise OCaml.Not_found
              | Some v => _return v
              end)) in
  let do_big_map_get
    (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (id :
    Tezos_raw_protocol_alpha.Alpha_context.Big_map.id) (key :
    Tezos_raw_protocol_alpha.Script_expr_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
          Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) :=
    let ctxt := Gas.set_unlimited ctxt in
    op_gtgteqquestion (Big_map._exists ctxt id)
      (fun function_parameter =>
        let '(ctxt, types) := function_parameter in
        match types with
        | None => raise OCaml.Not_found
        | Some (_, value_type) =>
          op_gtgteqquestion
            (Lwt._return
              (parse_ty ctxt true false false true (Micheline.root value_type)))
            (fun function_parameter =>
              let
                '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty value_type,
                  ctxt) := function_parameter in
              op_gtgteqquestion (Big_map.get_opt ctxt id key)
                (fun function_parameter =>
                  let '(_ctxt, value) := function_parameter in
                  match value with
                  | None => raise OCaml.Not_found
                  | Some value =>
                    op_gtgteqquestion
                      (parse_data None ctxt true value_type
                        (Micheline.root value))
                      (fun function_parameter =>
                        let '(value, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (unparse_data ctxt
                            Tezos_raw_protocol_alpha.Script_ir_translator.Readable
                            value_type value)
                          (fun function_parameter =>
                            let '(value, _ctxt) := function_parameter in
                            _return (Micheline.strip_locations value)))
                  end))
        end) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := register_field S.balance Contract.get_balance in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.manager_key
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              match Contract.is_implicit contract with
              | None => raise OCaml.Not_found
              | Some mgr =>
                op_gtgteqquestion (Contract.is_manager_key_revealed ctxt mgr)
                  (fun function_parameter =>
                    match function_parameter with
                    | false => return_none
                    | true =>
                      op_gtgteqquestion (Contract.get_manager_key ctxt mgr)
                        return_some
                    end)
              end) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := register_opt_field S.delegate Delegate.get in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.counter
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              match Contract.is_implicit contract with
              | None => raise OCaml.Not_found
              | Some mgr => Contract.get_counter ctxt mgr
              end) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register_opt_field S.script
      (fun c =>
        fun v =>
          op_gtgteqquestion (Contract.get_script c v)
            (fun function_parameter =>
              let '(_, v) := function_parameter in
              _return v)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register_opt_field S.storage
      (fun ctxt =>
        fun contract =>
          op_gtgteqquestion (Contract.get_script ctxt contract)
            (fun function_parameter =>
              let '(ctxt, script) := function_parameter in
              match script with
              | None => return_none
              | Some script =>
                let ctxt := Gas.set_unlimited ctxt in
                op_gtgteqquestion (parse_script None ctxt true script)
                  (fun function_parameter =>
                    let
                      '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
                        script, ctxt) := function_parameter in
                    op_gtgteqquestion
                      (unparse_script ctxt
                        Tezos_raw_protocol_alpha.Script_ir_translator.Readable
                        script)
                      (fun function_parameter =>
                        let '(script, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (Script.force_decode ctxt (storage script))
                          (fun function_parameter =>
                            let '(storage, _ctxt) := function_parameter in
                            return_some storage)))
              end)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register2 S.entrypoint_type
      (fun ctxt =>
        fun v =>
          fun entrypoint =>
            fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (Contract.get_script_code ctxt v)
                  (fun function_parameter =>
                    let '(_, expr) := function_parameter in
                    match expr with
                    | None => raise OCaml.Not_found
                    | Some expr =>
                      let ctxt := Gas.set_unlimited ctxt in
                      let legacy := true in
                      op_gtgteqquestion (Script.force_decode ctxt expr)
                        (fun function_parameter =>
                          let '(expr, _) := function_parameter in
                          op_gtgteq
                            (Lwt._return
                              (op_gtgtquestion (parse_toplevel legacy expr)
                                (fun function_parameter =>
                                  let '(arg_type, _, _, root_name) :=
                                    function_parameter in
                                  op_gtgtquestion
                                    (parse_ty ctxt legacy true false true
                                      arg_type)
                                    (fun function_parameter =>
                                      let
                                        '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
                                          arg_type, _) := function_parameter in
                                      Script_ir_translator.find_entrypoint
                                        arg_type root_name entrypoint))))
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                  (_f,
                                    Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
                                      ty) =>
                                op_gtgteqquestion (unparse_ty ctxt ty)
                                  (fun function_parameter =>
                                    let '(ty_node, _) := function_parameter in
                                    _return (Micheline.strip_locations ty_node))
                              |
                                Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                  _ => raise OCaml.Not_found
                              end))
                    end)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.list_entrypoints
      (fun ctxt =>
        fun v =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (Contract.get_script_code ctxt v)
                (fun function_parameter =>
                  let '(_, expr) := function_parameter in
                  match expr with
                  | None => raise OCaml.Not_found
                  | Some expr =>
                    let ctxt := Gas.set_unlimited ctxt in
                    let legacy := true in
                    op_gtgteqquestion (Script.force_decode ctxt expr)
                      (fun function_parameter =>
                        let '(expr, _) := function_parameter in
                        op_gtgteqquestion
                          (Lwt._return
                            (op_gtgtquestion (parse_toplevel legacy expr)
                              (fun function_parameter =>
                                let '(arg_type, _, _, root_name) :=
                                  function_parameter in
                                op_gtgtquestion
                                  (parse_ty ctxt legacy true false true arg_type)
                                  (fun function_parameter =>
                                    let
                                      '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
                                        arg_type, _) := function_parameter in
                                    Script_ir_translator.list_entrypoints
                                      arg_type ctxt root_name))))
                          (fun function_parameter =>
                            let '(unreachable_entrypoint, map) :=
                              function_parameter in
                            _return
                              (unreachable_entrypoint,
                                (Entrypoints_map.fold
                                  (fun entry =>
                                    fun function_parameter =>
                                      let '(_, ty) := function_parameter in
                                      fun acc =>
                                        cons
                                          (entry, (Micheline.strip_locations ty))
                                          acc) map []))))
                  end)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.contract_big_map_get_opt
      (fun ctxt =>
        fun contract =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(key, key_type) := function_parameter in
              op_gtgteqquestion (Contract.get_script ctxt contract)
                (fun function_parameter =>
                  let '(ctxt, script) := function_parameter in
                  op_gtgteqquestion
                    (Lwt._return
                      (Script_ir_translator.parse_packable_ty ctxt true
                        (Micheline.root key_type)))
                    (fun function_parameter =>
                      let
                        '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
                          key_type, ctxt) := function_parameter in
                      op_gtgteqquestion
                        (Script_ir_translator.parse_data None ctxt true key_type
                          (Micheline.root key))
                        (fun function_parameter =>
                          let '(key, ctxt) := function_parameter in
                          op_gtgteqquestion
                            (Script_ir_translator.hash_data ctxt key_type key)
                            (fun function_parameter =>
                              let '(key, ctxt) := function_parameter in
                              match script with
                              | None => raise OCaml.Not_found
                              | Some script =>
                                let ctxt := Gas.set_unlimited ctxt in
                                op_gtgteqquestion
                                  (parse_script None ctxt true script)
                                  (fun function_parameter =>
                                    let
                                      '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
                                        script, ctxt) := function_parameter in
                                    op_gtgteqquestion
                                      (Script_ir_translator.collect_big_maps
                                        ctxt (storage_type script)
                                        (storage script))
                                      (fun function_parameter =>
                                        let '(ids, _ctxt) := function_parameter
                                          in
                                        let ids :=
                                          Script_ir_translator.list_of_big_map_ids
                                            ids in
                                        let fix find
                                          (function_parameter :
                                          list
                                            Tezos_protocol_environment_alpha__Environment.Z.t)
                                          : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                              (option
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.prim))) :=
                                          match function_parameter with
                                          | [] => return_none
                                          | cons (_ as id) ids =>
                                            (* ❌ Try-with are not handled *)
                                            try
                                              (op_gtgteqquestion
                                                (do_big_map_get ctxt id key)
                                                return_some)
                                          end in
                                        find ids))
                              end))))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register2 S.big_map_get
      (fun ctxt =>
        fun id =>
          fun key =>
            fun function_parameter =>
              let 'tt := function_parameter in
              fun function_parameter =>
                let 'tt := function_parameter in
                do_big_map_get ctxt id key) in
  register_field S.info
    (fun ctxt =>
      fun contract =>
        op_gtgteqquestion (Contract.get_balance ctxt contract)
          (fun balance =>
            op_gtgteqquestion (Delegate.get ctxt contract)
              (fun delegate =>
                op_gtgteqquestion
                  match Contract.is_implicit contract with
                  | Some manager =>
                    op_gtgteqquestion (Contract.get_counter ctxt manager)
                      (fun counter => return_some counter)
                  | None => _return None
                  end
                  (fun counter =>
                    op_gtgteqquestion (Contract.get_script ctxt contract)
                      (fun function_parameter =>
                        let '(ctxt, script) := function_parameter in
                        op_gtgteqquestion
                          match script with
                          | None => _return (None, ctxt)
                          | Some script =>
                            let ctxt := Gas.set_unlimited ctxt in
                            op_gtgteqquestion
                              (parse_script None ctxt true script)
                              (fun function_parameter =>
                                let
                                  '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
                                    script, ctxt) := function_parameter in
                                op_gtgteqquestion
                                  (unparse_script ctxt
                                    Tezos_raw_protocol_alpha.Script_ir_translator.Readable
                                    script)
                                  (fun function_parameter =>
                                    let '(script, ctxt) := function_parameter in
                                    _return ((Some script), ctxt)))
                          end
                          (fun function_parameter =>
                            let '(script, _ctxt) := function_parameter in
                            _return
                              {| balance := balance; delegate := delegate;
                                counter := counter; script := script |})))))).

Definition list {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list Tezos_raw_protocol_alpha.Alpha_context.Contract.t)) :=
  RPC_context.make_call0 S.list ctxt block tt tt.

Definition info {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      info) := RPC_context.make_call1 S.info ctxt block contract tt tt.

Definition balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.balance ctxt block contract tt tt.

Definition manager_key {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (mgr : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)) :=
  RPC_context.make_call1 S.manager_key ctxt block
    (Contract.implicit_contract mgr) tt tt.

Definition delegate {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
  RPC_context.make_call1 S.delegate ctxt block contract tt tt.

Definition delegate_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  RPC_context.make_opt_call1 S.delegate ctxt block contract tt tt.

Definition counter {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (mgr : Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  RPC_context.make_call1 S.counter ctxt block (Contract.implicit_contract mgr)
    tt tt.

Definition script {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.t) :=
  RPC_context.make_call1 S.script ctxt block contract tt tt.

Definition script_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.t)) :=
  RPC_context.make_opt_call1 S.script ctxt block contract tt tt.

Definition storage {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  RPC_context.make_call1 S.storage ctxt block contract tt tt.

Definition entrypoint_type {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  (entrypoint : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  RPC_context.make_call2 S.entrypoint_type ctxt block contract entrypoint tt tt.

Definition list_entrypoints {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
        (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
  RPC_context.make_call1 S.list_entrypoints ctxt block contract tt tt.

Definition storage_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  RPC_context.make_opt_call1 S.storage ctxt block contract tt tt.

Definition big_map_get {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (id : Tezos_raw_protocol_alpha.Alpha_context.Big_map.id)
  (key : Tezos_raw_protocol_alpha.Script_expr_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
  RPC_context.make_call2 S.big_map_get ctxt block id key tt tt.

Definition contract_big_map_get_opt {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
  (key :
    Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr)) :=
  RPC_context.make_call1 S.contract_big_map_get_opt ctxt block contract tt key.

src/proto_alpha/lib_protocol/contract_storage.ml 213 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error +=
  | Balance_too_low of Contract_repr.contract * Tez_repr.t * Tez_repr.t
  | (* `Temporary *)
      Counter_in_the_past of Contract_repr.contract * Z.t * Z.t
  | (* `Branch *)
      Counter_in_the_future of Contract_repr.contract * Z.t * Z.t
  | (* `Temporary *)
      Unspendable_contract of Contract_repr.contract
  | (* `Permanent *)
      Non_existing_contract of Contract_repr.contract
  | (* `Temporary *)
      Empty_implicit_contract of Signature.Public_key_hash.t
  | (* `Temporary *)
      Empty_transaction of Contract_repr.t (* `Temporary *)
  | Inconsistent_hash of
      Signature.Public_key.t
      * Signature.Public_key_hash.t
      * Signature.Public_key_hash.t
  | (* `Permanent *)
      Inconsistent_public_key of
      Signature.Public_key.t * Signature.Public_key.t
  | (* `Permanent *)
      Failure of string (* `Permanent *)
  | Previously_revealed_key of Contract_repr.t (* `Permanent *)
  | Unrevealed_manager_key of Contract_repr.t

(* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"contract.unspendable_contract"
    ~title:"Unspendable contract"
    ~description:
      "An operation tried to spend tokens from an unspendable contract"
    ~pp:(fun ppf c ->
      Format.fprintf
        ppf
        "The tokens of contract %a can only be spent by its script"
        Contract_repr.pp
        c)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Unspendable_contract c -> Some c | _ -> None)
    (fun c -> Unspendable_contract c) ;
  register_error_kind
    `Temporary
    ~id:"contract.balance_too_low"
    ~title:"Balance too low"
    ~description:
      "An operation tried to spend more tokens than the contract has"
    ~pp:(fun ppf (c, b, a) ->
      Format.fprintf
        ppf
        "Balance of contract %a too low (%a) to spend %a"
        Contract_repr.pp
        c
        Tez_repr.pp
        b
        Tez_repr.pp
        a)
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "balance" Tez_repr.encoding)
        (req "amount" Tez_repr.encoding))
    (function Balance_too_low (c, b, a) -> Some (c, b, a) | _ -> None)
    (fun (c, b, a) -> Balance_too_low (c, b, a)) ;
  register_error_kind
    `Temporary
    ~id:"contract.counter_in_the_future"
    ~title:"Invalid counter (not yet reached) in a manager operation"
    ~description:"An operation assumed a contract counter in the future"
    ~pp:(fun ppf (contract, exp, found) ->
      Format.fprintf
        ppf
        "Counter %s not yet reached for contract %a (expected %s)"
        (Z.to_string found)
        Contract_repr.pp
        contract
        (Z.to_string exp))
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "expected" z)
        (req "found" z))
    (function Counter_in_the_future (c, x, y) -> Some (c, x, y) | _ -> None)
    (fun (c, x, y) -> Counter_in_the_future (c, x, y)) ;
  register_error_kind
    `Branch
    ~id:"contract.counter_in_the_past"
    ~title:"Invalid counter (already used) in a manager operation"
    ~description:"An operation assumed a contract counter in the past"
    ~pp:(fun ppf (contract, exp, found) ->
      Format.fprintf
        ppf
        "Counter %s already used for contract %a (expected %s)"
        (Z.to_string found)
        Contract_repr.pp
        contract
        (Z.to_string exp))
    Data_encoding.(
      obj3
        (req "contract" Contract_repr.encoding)
        (req "expected" z)
        (req "found" z))
    (function Counter_in_the_past (c, x, y) -> Some (c, x, y) | _ -> None)
    (fun (c, x, y) -> Counter_in_the_past (c, x, y)) ;
  register_error_kind
    `Temporary
    ~id:"contract.non_existing_contract"
    ~title:"Non existing contract"
    ~description:
      "A contract handle is not present in the context (either it never was \
       or it has been destroyed)"
    ~pp:(fun ppf contract ->
      Format.fprintf ppf "Contract %a does not exist" Contract_repr.pp contract)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Non_existing_contract c -> Some c | _ -> None)
    (fun c -> Non_existing_contract c) ;
  register_error_kind
    `Permanent
    ~id:"contract.manager.inconsistent_hash"
    ~title:"Inconsistent public key hash"
    ~description:
      "A revealed manager public key is inconsistent with the announced hash"
    ~pp:(fun ppf (k, eh, ph) ->
      Format.fprintf
        ppf
        "The hash of the manager public key %s is not %a as announced but %a"
        (Signature.Public_key.to_b58check k)
        Signature.Public_key_hash.pp
        ph
        Signature.Public_key_hash.pp
        eh)
    Data_encoding.(
      obj3
        (req "public_key" Signature.Public_key.encoding)
        (req "expected_hash" Signature.Public_key_hash.encoding)
        (req "provided_hash" Signature.Public_key_hash.encoding))
    (function Inconsistent_hash (k, eh, ph) -> Some (k, eh, ph) | _ -> None)
    (fun (k, eh, ph) -> Inconsistent_hash (k, eh, ph)) ;
  register_error_kind
    `Permanent
    ~id:"contract.manager.inconsistent_public_key"
    ~title:"Inconsistent public key"
    ~description:
      "A provided manager public key is different with the public key stored \
       in the contract"
    ~pp:(fun ppf (eh, ph) ->
      Format.fprintf
        ppf
        "Expected manager public key %s but %s was provided"
        (Signature.Public_key.to_b58check ph)
        (Signature.Public_key.to_b58check eh))
    Data_encoding.(
      obj2
        (req "public_key" Signature.Public_key.encoding)
        (req "expected_public_key" Signature.Public_key.encoding))
    (function Inconsistent_public_key (eh, ph) -> Some (eh, ph) | _ -> None)
    (fun (eh, ph) -> Inconsistent_public_key (eh, ph)) ;
  register_error_kind
    `Permanent
    ~id:"contract.failure"
    ~title:"Contract storage failure"
    ~description:"Unexpected contract storage error"
    ~pp:(fun ppf s -> Format.fprintf ppf "Contract_storage.Failure %S" s)
    Data_encoding.(obj1 (req "message" string))
    (function Failure s -> Some s | _ -> None)
    (fun s -> Failure s) ;
  register_error_kind
    `Branch
    ~id:"contract.unrevealed_key"
    ~title:"Manager operation precedes key revelation"
    ~description:
      "One tried to apply a manager operation without revealing the manager \
       public key"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Unrevealed manager key for contract %a."
        Contract_repr.pp
        s)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Unrevealed_manager_key s -> Some s | _ -> None)
    (fun s -> Unrevealed_manager_key s) ;
  register_error_kind
    `Branch
    ~id:"contract.previously_revealed_key"
    ~title:"Manager operation already revealed"
    ~description:"One tried to revealed twice a manager public key"
    ~pp:(fun ppf s ->
      Format.fprintf
        ppf
        "Previously revealed manager key for contract %a."
        Contract_repr.pp
        s)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Previously_revealed_key s -> Some s | _ -> None)
    (fun s -> Previously_revealed_key s) ;
  register_error_kind
    `Branch
    ~id:"implicit.empty_implicit_contract"
    ~title:"Empty implicit contract"
    ~description:
      "No manager operations are allowed on an empty implicit contract."
    ~pp:(fun ppf implicit ->
      Format.fprintf
        ppf
        "Empty implicit contract (%a)"
        Signature.Public_key_hash.pp
        implicit)
    Data_encoding.(obj1 (req "implicit" Signature.Public_key_hash.encoding))
    (function Empty_implicit_contract c -> Some c | _ -> None)
    (fun c -> Empty_implicit_contract c) ;
  register_error_kind
    `Branch
    ~id:"contract.empty_transaction"
    ~title:"Empty transaction"
    ~description:"Forbidden to credit 0ꜩ to a contract without code."
    ~pp:(fun ppf contract ->
      Format.fprintf
        ppf
        "Transaction of 0ꜩ towards a contract without code are forbidden \
         (%a)."
        Contract_repr.pp
        contract)
    Data_encoding.(obj1 (req "contract" Contract_repr.encoding))
    (function Empty_transaction c -> Some c | _ -> None)
    (fun c -> Empty_transaction c)

let failwith msg = fail (Failure msg)

type big_map_diff_item =
  | Update of {
      big_map : Z.t;
      diff_key : Script_repr.expr;
      diff_key_hash : Script_expr_hash.t;
      diff_value : Script_repr.expr option;
    }
  | Clear of Z.t
  | Copy of Z.t * Z.t
  | Alloc of {
      big_map : Z.t;
      key_type : Script_repr.expr;
      value_type : Script_repr.expr;
    }

type big_map_diff = big_map_diff_item list

let big_map_diff_item_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"update"
        (obj5
           (req "action" (constant "update"))
           (req "big_map" z)
           (req "key_hash" Script_expr_hash.encoding)
           (req "key" Script_repr.expr_encoding)
           (opt "value" Script_repr.expr_encoding))
        (function
          | Update {big_map; diff_key_hash; diff_key; diff_value} ->
              Some ((), big_map, diff_key_hash, diff_key, diff_value)
          | _ ->
              None)
        (fun ((), big_map, diff_key_hash, diff_key, diff_value) ->
          Update {big_map; diff_key_hash; diff_key; diff_value});
      case
        (Tag 1)
        ~title:"remove"
        (obj2 (req "action" (constant "remove")) (req "big_map" z))
        (function Clear big_map -> Some ((), big_map) | _ -> None)
        (fun ((), big_map) -> Clear big_map);
      case
        (Tag 2)
        ~title:"copy"
        (obj3
           (req "action" (constant "copy"))
           (req "source_big_map" z)
           (req "destination_big_map" z))
        (function Copy (src, dst) -> Some ((), src, dst) | _ -> None)
        (fun ((), src, dst) -> Copy (src, dst));
      case
        (Tag 3)
        ~title:"alloc"
        (obj4
           (req "action" (constant "alloc"))
           (req "big_map" z)
           (req "key_type" Script_repr.expr_encoding)
           (req "value_type" Script_repr.expr_encoding))
        (function
          | Alloc {big_map; key_type; value_type} ->
              Some ((), big_map, key_type, value_type)
          | _ ->
              None)
        (fun ((), big_map, key_type, value_type) ->
          Alloc {big_map; key_type; value_type}) ]

let big_map_diff_encoding =
  let open Data_encoding in
  def "contract.big_map_diff" @@ list big_map_diff_item_encoding

let big_map_key_cost = 65

let big_map_cost = 33

let update_script_big_map c = function
  | None ->
      return (c, Z.zero)
  | Some diff ->
      fold_left_s
        (fun (c, total) -> function Clear id ->
              Storage.Big_map.Total_bytes.get c id
              >>=? fun size ->
              Storage.Big_map.remove_rec c id
              >>= fun c ->
              if Compare.Z.(id < Z.zero) then return (c, total)
              else return (c, Z.sub (Z.sub total size) (Z.of_int big_map_cost))
          | Copy (from, to_) ->
              Storage.Big_map.copy c ~from ~to_
              >>=? fun c ->
              if Compare.Z.(to_ < Z.zero) then return (c, total)
              else
                Storage.Big_map.Total_bytes.get c from
                >>=? fun size ->
                return (c, Z.add (Z.add total size) (Z.of_int big_map_cost))
          | Alloc {big_map; key_type; value_type} ->
              Storage.Big_map.Total_bytes.init c big_map Z.zero
              >>=? fun c ->
              (* Annotations are erased to allow sharing on
                 [Copy]. The types from the contract code are used,
                 these ones are only used to make sure they are
                 compatible during transmissions between contracts,
                 and only need to be compatible, annotations
                 nonwhistanding. *)
              let key_type =
                Micheline.strip_locations
                  (Script_repr.strip_annotations (Micheline.root key_type))
              in
              let value_type =
                Micheline.strip_locations
                  (Script_repr.strip_annotations (Micheline.root value_type))
              in
              Storage.Big_map.Key_type.init c big_map key_type
              >>=? fun c ->
              Storage.Big_map.Value_type.init c big_map value_type
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.add total (Z.of_int big_map_cost))
          | Update {big_map; diff_key_hash; diff_value = None} ->
              Storage.Big_map.Contents.remove (c, big_map) diff_key_hash
              >>=? fun (c, freed, existed) ->
              let freed =
                if existed then freed + big_map_key_cost else freed
              in
              Storage.Big_map.Total_bytes.get c big_map
              >>=? fun size ->
              Storage.Big_map.Total_bytes.set
                c
                big_map
                (Z.sub size (Z.of_int freed))
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.sub total (Z.of_int freed))
          | Update {big_map; diff_key_hash; diff_value = Some v} ->
              Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v
              >>=? fun (c, size_diff, existed) ->
              let size_diff =
                if existed then size_diff else size_diff + big_map_key_cost
              in
              Storage.Big_map.Total_bytes.get c big_map
              >>=? fun size ->
              Storage.Big_map.Total_bytes.set
                c
                big_map
                (Z.add size (Z.of_int size_diff))
              >>=? fun c ->
              if Compare.Z.(big_map < Z.zero) then return (c, total)
              else return (c, Z.add total (Z.of_int size_diff)))
        (c, Z.zero)
        diff

let create_base c ?(prepaid_bootstrap_storage = false)
    (* Free space for bootstrap contracts *)
    contract ~balance ~manager ~delegate ?script () =
  ( match Contract_repr.is_implicit contract with
  | None ->
      return c
  | Some _ ->
      Storage.Contract.Global_counter.get c
      >>=? fun counter -> Storage.Contract.Counter.init c contract counter )
  >>=? fun c ->
  Storage.Contract.Balance.init c contract balance
  >>=? fun c ->
  ( match manager with
  | Some manager ->
      Storage.Contract.Manager.init c contract (Manager_repr.Hash manager)
  | None ->
      return c )
  >>=? fun c ->
  ( match delegate with
  | None ->
      return c
  | Some delegate ->
      Delegate_storage.init c contract delegate )
  >>=? fun c ->
  match script with
  | Some ({Script_repr.code; storage}, big_map_diff) ->
      Storage.Contract.Code.init c contract code
      >>=? fun (c, code_size) ->
      Storage.Contract.Storage.init c contract storage
      >>=? fun (c, storage_size) ->
      update_script_big_map c big_map_diff
      >>=? fun (c, big_map_size) ->
      let total_size =
        Z.add (Z.add (Z.of_int code_size) (Z.of_int storage_size)) big_map_size
      in
      assert (Compare.Z.(total_size >= Z.zero)) ;
      let prepaid_bootstrap_storage =
        if prepaid_bootstrap_storage then total_size else Z.zero
      in
      Storage.Contract.Paid_storage_space.init
        c
        contract
        prepaid_bootstrap_storage
      >>=? fun c ->
      Storage.Contract.Used_storage_space.init c contract total_size
  | None ->
      return c

let originate c ?prepaid_bootstrap_storage contract ~balance ~script ~delegate
    =
  create_base
    c
    ?prepaid_bootstrap_storage
    contract
    ~balance
    ~manager:None
    ~delegate
    ~script
    ()

let create_implicit c manager ~balance =
  create_base
    c
    (Contract_repr.implicit_contract manager)
    ~balance
    ~manager:(Some manager)
    ?script:None
    ~delegate:None
    ()

let delete c contract =
  match Contract_repr.is_implicit contract with
  | None ->
      (* For non implicit contract Big_map should be cleared *)
      failwith "Non implicit contracts cannot be removed"
  | Some _ ->
      Delegate_storage.remove c contract
      >>=? fun c ->
      Storage.Contract.Balance.delete c contract
      >>=? fun c ->
      Storage.Contract.Manager.delete c contract
      >>=? fun c ->
      Storage.Contract.Counter.delete c contract
      >>=? fun c ->
      Storage.Contract.Code.remove c contract
      >>=? fun (c, _, _) ->
      Storage.Contract.Storage.remove c contract
      >>=? fun (c, _, _) ->
      Storage.Contract.Paid_storage_space.remove c contract
      >>= fun c ->
      Storage.Contract.Used_storage_space.remove c contract
      >>= fun c -> return c

let allocated c contract =
  Storage.Contract.Balance.get_option c contract
  >>=? function None -> return_false | Some _ -> return_true

let exists c contract =
  match Contract_repr.is_implicit contract with
  | Some _ ->
      return_true
  | None ->
      allocated c contract

let must_exist c contract =
  exists c contract
  >>=? function
  | true -> return_unit | false -> fail (Non_existing_contract contract)

let must_be_allocated c contract =
  allocated c contract
  >>=? function
  | true ->
      return_unit
  | false -> (
    match Contract_repr.is_implicit contract with
    | Some pkh ->
        fail (Empty_implicit_contract pkh)
    | None ->
        fail (Non_existing_contract contract) )

let list c = Storage.Contract.list c

let fresh_contract_from_current_nonce c =
  Lwt.return (Raw_context.increment_origination_nonce c)
  >>=? fun (c, nonce) -> return (c, Contract_repr.originated_contract nonce)

let originated_from_current_nonce ~since:ctxt_since ~until:ctxt_until =
  Lwt.return (Raw_context.origination_nonce ctxt_since)
  >>=? fun since ->
  Lwt.return (Raw_context.origination_nonce ctxt_until)
  >>=? fun until ->
  filter_map_s
    (fun contract ->
      exists ctxt_until contract
      >>=? function true -> return_some contract | false -> return_none)
    (Contract_repr.originated_contracts ~since ~until)

let check_counter_increment c manager counter =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Counter.get c contract
  >>=? fun contract_counter ->
  let expected = Z.succ contract_counter in
  if Compare.Z.(expected = counter) then return_unit
  else if Compare.Z.(expected > counter) then
    fail (Counter_in_the_past (contract, expected, counter))
  else fail (Counter_in_the_future (contract, expected, counter))

let increment_counter c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Global_counter.get c
  >>=? fun global_counter ->
  Storage.Contract.Global_counter.set c (Z.succ global_counter)
  >>=? fun c ->
  Storage.Contract.Counter.get c contract
  >>=? fun contract_counter ->
  Storage.Contract.Counter.set c contract (Z.succ contract_counter)

let get_script_code c contract = Storage.Contract.Code.get_option c contract

let get_script c contract =
  Storage.Contract.Code.get_option c contract
  >>=? fun (c, code) ->
  Storage.Contract.Storage.get_option c contract
  >>=? fun (c, storage) ->
  match (code, storage) with
  | (None, None) ->
      return (c, None)
  | (Some code, Some storage) ->
      return (c, Some {Script_repr.code; storage})
  | (None, Some _) | (Some _, None) ->
      failwith "get_script"

let get_storage ctxt contract =
  Storage.Contract.Storage.get_option ctxt contract
  >>=? function
  | (ctxt, None) ->
      return (ctxt, None)
  | (ctxt, Some storage) ->
      Lwt.return (Script_repr.force_decode storage)
      >>=? fun (storage, cost) ->
      Lwt.return (Raw_context.consume_gas ctxt cost)
      >>=? fun ctxt -> return (ctxt, Some storage)

let get_counter c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Counter.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | Some _ ->
        Storage.Contract.Global_counter.get c
    | None ->
        failwith "get_counter" )
  | Some v ->
      return v

let get_manager_key c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get_option c contract
  >>=? function
  | None ->
      failwith "get_manager_key"
  | Some (Manager_repr.Hash _) ->
      fail (Unrevealed_manager_key contract)
  | Some (Manager_repr.Public_key v) ->
      return v

let is_manager_key_revealed c manager =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get_option c contract
  >>=? function
  | None ->
      return_false
  | Some (Manager_repr.Hash _) ->
      return_false
  | Some (Manager_repr.Public_key _) ->
      return_true

let reveal_manager_key c manager public_key =
  let contract = Contract_repr.implicit_contract manager in
  Storage.Contract.Manager.get c contract
  >>=? function
  | Public_key _ ->
      fail (Previously_revealed_key contract)
  | Hash v ->
      let actual_hash = Signature.Public_key.hash public_key in
      if Signature.Public_key_hash.equal actual_hash v then
        let v = Manager_repr.Public_key public_key in
        Storage.Contract.Manager.set c contract v >>=? fun c -> return c
      else fail (Inconsistent_hash (public_key, v, actual_hash))

let get_balance c contract =
  Storage.Contract.Balance.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | Some _ ->
        return Tez_repr.zero
    | None ->
        failwith "get_balance" )
  | Some v ->
      return v

let update_script_storage c contract storage big_map_diff =
  let storage = Script_repr.lazy_expr storage in
  update_script_big_map c big_map_diff
  >>=? fun (c, big_map_size_diff) ->
  Storage.Contract.Storage.set c contract storage
  >>=? fun (c, size_diff) ->
  Storage.Contract.Used_storage_space.get c contract
  >>=? fun previous_size ->
  let new_size =
    Z.add previous_size (Z.add big_map_size_diff (Z.of_int size_diff))
  in
  Storage.Contract.Used_storage_space.set c contract new_size

let spend c contract amount =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  match Tez_repr.(balance -? amount) with
  | Error _ ->
      fail (Balance_too_low (contract, balance, amount))
  | Ok new_balance -> (
      Storage.Contract.Balance.set c contract new_balance
      >>=? fun c ->
      Roll_storage.Contract.remove_amount c contract amount
      >>=? fun c ->
      if Tez_repr.(new_balance > Tez_repr.zero) then return c
      else
        match Contract_repr.is_implicit contract with
        | None ->
            return c (* Never delete originated contracts *)
        | Some pkh -> (
            Delegate_storage.get c contract
            >>=? function
            | Some pkh' ->
                (* Don't delete "delegate" contract *)
                assert (Signature.Public_key_hash.equal pkh pkh') ;
                return c
            | None ->
                (* Delete empty implicit contract *)
                delete c contract ) )

let credit c contract amount =
  ( if Tez_repr.(amount <> Tez_repr.zero) then return c
  else
    Storage.Contract.Code.mem c contract
    >>=? fun (c, target_has_code) ->
    fail_unless target_has_code (Empty_transaction contract)
    >>=? fun () -> return c )
  >>=? fun c ->
  Storage.Contract.Balance.get_option c contract
  >>=? function
  | None -> (
    match Contract_repr.is_implicit contract with
    | None ->
        fail (Non_existing_contract contract)
    | Some manager ->
        create_implicit c manager ~balance:amount )
  | Some balance ->
      Lwt.return Tez_repr.(amount +? balance)
      >>=? fun balance ->
      Storage.Contract.Balance.set c contract balance
      >>=? fun c -> Roll_storage.Contract.add_amount c contract amount

let init c = Storage.Contract.Global_counter.init c Z.zero

let used_storage_space c contract =
  Storage.Contract.Used_storage_space.get_option c contract
  >>=? function None -> return Z.zero | Some fees -> return fees

let paid_storage_space c contract =
  Storage.Contract.Paid_storage_space.get_option c contract
  >>=? function None -> return Z.zero | Some paid_space -> return paid_space

let set_paid_storage_space_and_return_fees_to_pay c contract new_storage_space
    =
  Storage.Contract.Paid_storage_space.get c contract
  >>=? fun already_paid_space ->
  if Compare.Z.(already_paid_space >= new_storage_space) then return (Z.zero, c)
  else
    let to_pay = Z.sub new_storage_space already_paid_space in
    Storage.Contract.Paid_storage_space.set c contract new_storage_space
    >>=? fun c -> return (to_pay, c)
src/proto_alpha/lib_protocol/contract_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition failwith {A : Type} (msg : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  fail (Tezos_protocol_environment_alpha__Environment.Error_monad.Failure msg).

Inductive big_map_diff_item : Type :=
| Update : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Script_repr.expr ->
  Tezos_raw_protocol_alpha.Script_expr_hash.t ->
  (option Tezos_raw_protocol_alpha.Script_repr.expr) -> big_map_diff_item
| Clear : Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Copy : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t -> big_map_diff_item
| Alloc : Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_raw_protocol_alpha.Script_repr.expr ->
  Tezos_raw_protocol_alpha.Script_repr.expr -> big_map_diff_item.

Definition big_map_diff := list big_map_diff_item.

Definition big_map_diff_item_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    big_map_diff_item :=
  union None
    (cons
      (case "update" % string None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
        (obj5 (req None None "action" % string (constant "update" % string))
          (req None None "big_map" % string z)
          (req None None "key_hash" % string Script_expr_hash.encoding)
          (req None None "key" % string Script_repr.expr_encoding)
          (opt None None "value" % string Script_repr.expr_encoding))
        (fun function_parameter =>
          match function_parameter with
          |
            Update {|
              big_map := big_map;
                diff_key := diff_key;
                diff_key_hash := diff_key_hash;
                diff_value := diff_value
                |} => Some (tt, big_map, diff_key_hash, diff_key, diff_value)
          | _ => None
          end)
        (fun function_parameter =>
          let '(tt, big_map, diff_key_hash, diff_key, diff_value) :=
            function_parameter in
          Update
            {| big_map := big_map; diff_key := diff_key;
              diff_key_hash := diff_key_hash; diff_value := diff_value |}))
      (cons
        (case "remove" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
          (obj2 (req None None "action" % string (constant "remove" % string))
            (req None None "big_map" % string z))
          (fun function_parameter =>
            match function_parameter with
            | Clear big_map => Some (tt, big_map)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, big_map) := function_parameter in
            Clear big_map))
        (cons
          (case "copy" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
            (obj3 (req None None "action" % string (constant "copy" % string))
              (req None None "source_big_map" % string z)
              (req None None "destination_big_map" % string z))
            (fun function_parameter =>
              match function_parameter with
              | Copy src dst => Some (tt, src, dst)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, src, dst) := function_parameter in
              Copy src dst))
          (cons
            (case "alloc" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 3)
              (obj4
                (req None None "action" % string (constant "alloc" % string))
                (req None None "big_map" % string z)
                (req None None "key_type" % string Script_repr.expr_encoding)
                (req None None "value_type" % string Script_repr.expr_encoding))
              (fun function_parameter =>
                match function_parameter with
                |
                  Alloc {|
                    big_map := big_map;
                      key_type := key_type;
                      value_type := value_type
                      |} => Some (tt, big_map, key_type, value_type)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, big_map, key_type, value_type) := function_parameter
                  in
                Alloc
                  {| big_map := big_map; key_type := key_type;
                    value_type := value_type |})) [])))).

Definition big_map_diff_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list big_map_diff_item) :=
  op_atat
    (let arg := def "contract.big_map_diff" % string in
    fun eta => arg None None eta) (list None big_map_diff_item_encoding).

Definition big_map_key_cost : Z := 65.

Definition big_map_cost : Z := 33.

Definition update_script_big_map
  (c : Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context)
  (function_parameter : option (list big_map_diff_item))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context *
        Tezos_protocol_environment_alpha__Environment.Z.t)) :=
  match function_parameter with
  | None => _return (c, Z.zero)
  | Some diff =>
    fold_left_s
      (fun function_parameter =>
        let '(c, total) := function_parameter in
        fun function_parameter =>
          match function_parameter with
          | Clear id =>
            op_gtgteqquestion (Storage.Big_map.Total_bytes.get c id)
              (fun size =>
                op_gtgteq (Storage.Big_map.remove_rec c id)
                  (fun c =>
                    if
                      Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                        id Z.zero then
                      _return (c, total)
                    else
                      _return
                        (c, (Z.sub (Z.sub total size) (Z.of_int big_map_cost)))))
          | Copy from to_ =>
            op_gtgteqquestion (Storage.Big_map.copy c from to_)
              (fun c =>
                if
                  Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                    to_ Z.zero then
                  _return (c, total)
                else
                  op_gtgteqquestion (Storage.Big_map.Total_bytes.get c from)
                    (fun size =>
                      _return
                        (c, (Z.add (Z.add total size) (Z.of_int big_map_cost)))))
          |
            Alloc {|
              big_map := big_map;
                key_type := key_type;
                value_type := value_type
                |} =>
            op_gtgteqquestion
              (Storage.Big_map.Total_bytes.init c big_map Z.zero)
              (fun c =>
                let key_type :=
                  Micheline.strip_locations
                    (Script_repr.strip_annotations (Micheline.root key_type)) in
                let value_type :=
                  Micheline.strip_locations
                    (Script_repr.strip_annotations (Micheline.root value_type))
                  in
                op_gtgteqquestion
                  (Storage.Big_map.Key_type.init c big_map key_type)
                  (fun c =>
                    op_gtgteqquestion
                      (Storage.Big_map.Value_type.init c big_map value_type)
                      (fun c =>
                        if
                          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                            big_map Z.zero then
                          _return (c, total)
                        else
                          _return (c, (Z.add total (Z.of_int big_map_cost))))))
          |
            Update {|
              big_map := big_map;
                diff_key_hash := diff_key_hash;
                diff_value := None
                |} =>
            op_gtgteqquestion
              (Storage.Big_map.Contents.remove (c, big_map) diff_key_hash)
              (fun function_parameter =>
                let '(c, freed, existed) := function_parameter in
                let freed :=
                  if existed then
                    op_plus freed big_map_key_cost
                  else
                    freed in
                op_gtgteqquestion (Storage.Big_map.Total_bytes.get c big_map)
                  (fun size =>
                    op_gtgteqquestion
                      (Storage.Big_map.Total_bytes.set c big_map
                        (Z.sub size (Z.of_int freed)))
                      (fun c =>
                        if
                          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                            big_map Z.zero then
                          _return (c, total)
                        else
                          _return (c, (Z.sub total (Z.of_int freed))))))
          |
            Update {|
              big_map := big_map;
                diff_key_hash := diff_key_hash;
                diff_value := Some v
                |} =>
            op_gtgteqquestion
              (Storage.Big_map.Contents.init_set (c, big_map) diff_key_hash v)
              (fun function_parameter =>
                let '(c, size_diff, existed) := function_parameter in
                let size_diff :=
                  if existed then
                    size_diff
                  else
                    op_plus size_diff big_map_key_cost in
                op_gtgteqquestion (Storage.Big_map.Total_bytes.get c big_map)
                  (fun size =>
                    op_gtgteqquestion
                      (Storage.Big_map.Total_bytes.set c big_map
                        (Z.add size (Z.of_int size_diff)))
                      (fun c =>
                        if
                          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                            big_map Z.zero then
                          _return (c, total)
                        else
                          _return (c, (Z.add total (Z.of_int size_diff))))))
          end) (c, Z.zero) diff
  end.

Definition create_base
  (c : Tezos_raw_protocol_alpha.Raw_context.t) (op_staroptstar : option bool)
  : Tezos_raw_protocol_alpha.Contract_repr.contract ->
    Tezos_raw_protocol_alpha.Storage.Contract.Balance.value ->
      (option
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
        ->
        (option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
          ->
          (option
            (Tezos_raw_protocol_alpha.Script_repr.t *
              (option (list big_map_diff_item)))) ->
            unit ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  Tezos_raw_protocol_alpha.Raw_context.t) :=
  let prepaid_bootstrap_storage :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun contract =>
    fun balance =>
      fun manager =>
        fun delegate =>
          fun script =>
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                match Contract_repr.is_implicit contract with
                | None => _return c
                | Some _ =>
                  op_gtgteqquestion (Storage.Contract.Global_counter.get c)
                    (fun counter =>
                      Storage.Contract.Counter.init c contract counter)
                end
                (fun c =>
                  op_gtgteqquestion
                    (Storage.Contract.Balance.init c contract balance)
                    (fun c =>
                      op_gtgteqquestion
                        match manager with
                        | Some manager =>
                          Storage.Contract.Manager.init c contract
                            (Tezos_raw_protocol_alpha.Manager_repr.Hash manager)
                        | None => _return c
                        end
                        (fun c =>
                          op_gtgteqquestion
                            match delegate with
                            | None => _return c
                            | Some delegate =>
                              Delegate_storage.init c contract delegate
                            end
                            (fun c =>
                              match script with
                              |
                                Some
                                  ({|
                                    Script_repr.code := code;
                                      Script_repr.storage := storage
                                      |}, big_map_diff) =>
                                op_gtgteqquestion
                                  (Storage.Contract.Code.init c contract code)
                                  (fun function_parameter =>
                                    let '(c, code_size) := function_parameter in
                                    op_gtgteqquestion
                                      (Storage.Contract.Storage.init c contract
                                        storage)
                                      (fun function_parameter =>
                                        let '(c, storage_size) :=
                                          function_parameter in
                                        op_gtgteqquestion
                                          (update_script_big_map c big_map_diff)
                                          (fun function_parameter =>
                                            let '(c, big_map_size) :=
                                              function_parameter in
                                            let total_size :=
                                              Z.add
                                                (Z.add (Z.of_int code_size)
                                                  (Z.of_int storage_size))
                                                big_map_size in
                                            (* ❌ Sequences of instructions are not handled (operator ";") *)
                                            let _ :=
                                              (* ❌ Assert instruction is not handled. *)
                                              assert
                                                (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
                                                  total_size Z.zero) in
                                            let prepaid_bootstrap_storage :=
                                              if prepaid_bootstrap_storage then
                                                total_size
                                              else
                                                Z.zero in
                                            op_gtgteqquestion
                                              (Storage.Contract.Paid_storage_space.init
                                                c contract
                                                prepaid_bootstrap_storage)
                                              (fun c =>
                                                Storage.Contract.Used_storage_space.init
                                                  c contract total_size))))
                              | None => _return c
                              end)))).

Definition originate
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (prepaid_bootstrap_storage : option bool)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  (balance : Tezos_raw_protocol_alpha.Storage.Contract.Balance.value)
  (script :
    Tezos_raw_protocol_alpha.Script_repr.t * (option (list big_map_diff_item)))
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  create_base c prepaid_bootstrap_storage contract balance None delegate
    (Some script) tt.

Definition create_implicit
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (balance : Tezos_raw_protocol_alpha.Storage.Contract.Balance.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  create_base c None (Contract_repr.implicit_contract manager) balance
    (Some manager) None None tt.

Definition delete
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match Contract_repr.is_implicit contract with
  | None => failwith "Non implicit contracts cannot be removed" % string
  | Some _ =>
    op_gtgteqquestion (Delegate_storage.remove c contract)
      (fun c =>
        op_gtgteqquestion (Storage.Contract.Balance.delete c contract)
          (fun c =>
            op_gtgteqquestion (Storage.Contract.Manager.delete c contract)
              (fun c =>
                op_gtgteqquestion (Storage.Contract.Counter.delete c contract)
                  (fun c =>
                    op_gtgteqquestion (Storage.Contract.Code.remove c contract)
                      (fun function_parameter =>
                        let '(c, _, _) := function_parameter in
                        op_gtgteqquestion
                          (Storage.Contract.Storage.remove c contract)
                          (fun function_parameter =>
                            let '(c, _, _) := function_parameter in
                            op_gtgteq
                              (Storage.Contract.Paid_storage_space.remove c
                                contract)
                              (fun c =>
                                op_gtgteq
                                  (Storage.Contract.Used_storage_space.remove c
                                    contract) (fun c => _return c))))))))
  end.

Definition allocated
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => return_false
      | Some _ => return_true
      end).

Definition _exists
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  match Contract_repr.is_implicit contract with
  | Some _ => return_true
  | None => allocated c contract
  end.

Definition must_exist
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.contract)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  op_gtgteqquestion (_exists c contract)
    (fun function_parameter =>
      match function_parameter with
      | true => return_unit
      | false =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Non_existing_contract
            contract)
      end).

Definition must_be_allocated
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  op_gtgteqquestion (allocated c contract)
    (fun function_parameter =>
      match function_parameter with
      | true => return_unit
      | false =>
        match Contract_repr.is_implicit contract with
        | Some pkh =>
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
              pkh)
        | None =>
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Non_existing_contract
              contract)
        end
      end).

Definition list (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_raw_protocol_alpha.Contract_repr.t) := Storage.Contract.list c.

Definition fresh_contract_from_current_nonce
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
  op_gtgteqquestion (Lwt._return (Raw_context.increment_origination_nonce c))
    (fun function_parameter =>
      let '(c, nonce) := function_parameter in
      _return (c, (Contract_repr.originated_contract nonce))).

Definition originated_from_current_nonce
  (ctxt_since : Tezos_raw_protocol_alpha.Raw_context.t)
  (ctxt_until : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
  op_gtgteqquestion (Lwt._return (Raw_context.origination_nonce ctxt_since))
    (fun since =>
      op_gtgteqquestion (Lwt._return (Raw_context.origination_nonce ctxt_until))
        (fun until =>
          filter_map_s
            (fun contract =>
              op_gtgteqquestion (_exists ctxt_until contract)
                (fun function_parameter =>
                  match function_parameter with
                  | true => return_some contract
                  | false => return_none
                  end)) (Contract_repr.originated_contracts since until))).

Definition check_counter_increment
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Counter.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (counter :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let contract := Contract_repr.implicit_contract manager in
  op_gtgteqquestion (Storage.Contract.Counter.get c contract)
    (fun contract_counter =>
      let expected := Z.succ contract_counter in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
          expected counter then
        return_unit
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
            expected counter then
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
              contract expected counter)
        else
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_future
              contract expected counter)).

Definition increment_counter
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract manager in
  op_gtgteqquestion (Storage.Contract.Global_counter.get c)
    (fun global_counter =>
      op_gtgteqquestion
        (Storage.Contract.Global_counter.set c (Z.succ global_counter))
        (fun c =>
          op_gtgteqquestion (Storage.Contract.Counter.get c contract)
            (fun contract_counter =>
              Storage.Contract.Counter.set c contract (Z.succ contract_counter)))).

Definition get_script_code
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (option Tezos_raw_protocol_alpha.Storage.Contract.Code.value))) :=
  Storage.Contract.Code.get_option c contract.

Definition get_script
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (option Tezos_raw_protocol_alpha.Script_repr.t))) :=
  op_gtgteqquestion (Storage.Contract.Code.get_option c contract)
    (fun function_parameter =>
      let '(c, code) := function_parameter in
      op_gtgteqquestion (Storage.Contract.Storage.get_option c contract)
        (fun function_parameter =>
          let '(c, storage) := function_parameter in
          match (code, storage) with
          | (None, None) => _return (c, None)
          | (Some code, Some storage) =>
            _return
              (c,
                (Some
                  {| Script_repr.code := code; Script_repr.storage := storage |}))
          | (None, Some _) | (Some _, None) => failwith "get_script" % string
          end)).

Definition get_storage
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Storage.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Storage.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (option Tezos_raw_protocol_alpha.Script_repr.expr))) :=
  op_gtgteqquestion (Storage.Contract.Storage.get_option ctxt contract)
    (fun function_parameter =>
      match function_parameter with
      | (ctxt, None) => _return (ctxt, None)
      | (ctxt, Some storage) =>
        op_gtgteqquestion (Lwt._return (Script_repr.force_decode storage))
          (fun function_parameter =>
            let '(storage, cost) := function_parameter in
            op_gtgteqquestion (Lwt._return (Raw_context.consume_gas ctxt cost))
              (fun ctxt => _return (ctxt, (Some storage))))
      end).

Definition get_counter
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Counter.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  let contract := Contract_repr.implicit_contract manager in
  op_gtgteqquestion (Storage.Contract.Counter.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        match Contract_repr.is_implicit contract with
        | Some _ => Storage.Contract.Global_counter.get c
        | None => failwith "get_counter" % string
        end
      | Some v => _return v
      end).

Definition get_manager_key
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
  let contract := Contract_repr.implicit_contract manager in
  op_gtgteqquestion (Storage.Contract.Manager.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => failwith "get_manager_key" % string
      | Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unrevealed_manager_key
            contract)
      | Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key v) => _return v
      end).

Definition is_manager_key_revealed
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  let contract := Contract_repr.implicit_contract manager in
  op_gtgteqquestion (Storage.Contract.Manager.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => return_false
      | Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) => return_false
      | Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key _) => return_true
      end).

Definition reveal_manager_key
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (manager :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (public_key :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract manager in
  op_gtgteqquestion (Storage.Contract.Manager.get c contract)
    (fun function_parameter =>
      match function_parameter with
      | Tezos_raw_protocol_alpha.Manager_repr.Public_key _ =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Previously_revealed_key
            contract)
      | Tezos_raw_protocol_alpha.Manager_repr.Hash v =>
        let actual_hash := Signature.Public_key.hash public_key in
        if Signature.Public_key_hash.equal actual_hash v then
          let v := Tezos_raw_protocol_alpha.Manager_repr.Public_key public_key
            in
          op_gtgteqquestion (Storage.Contract.Manager.set c contract v)
            (fun c => _return c)
        else
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_hash
              public_key v actual_hash)
      end).

Definition get_balance
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        match Contract_repr.is_implicit contract with
        | Some _ => _return Tez_repr.zero
        | None => failwith "get_balance" % string
        end
      | Some v => _return v
      end).

Definition update_script_storage
  (c : Tezos_raw_protocol_alpha.Storage.Big_map.Total_bytes.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Storage.key)
  (storage : Tezos_raw_protocol_alpha.Script_repr.expr)
  (big_map_diff : option (list big_map_diff_item))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let storage := Script_repr.lazy_expr storage in
  op_gtgteqquestion (update_script_big_map c big_map_diff)
    (fun function_parameter =>
      let '(c, big_map_size_diff) := function_parameter in
      op_gtgteqquestion (Storage.Contract.Storage.set c contract storage)
        (fun function_parameter =>
          let '(c, size_diff) := function_parameter in
          op_gtgteqquestion (Storage.Contract.Used_storage_space.get c contract)
            (fun previous_size =>
              let new_size :=
                Z.add previous_size
                  (Z.add big_map_size_diff (Z.of_int size_diff)) in
              Storage.Contract.Used_storage_space.set c contract new_size))).

Definition spend
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (Storage.Contract.Balance.get c contract)
    (fun balance =>
      match op_minusquestion balance amount with
      | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
            contract balance amount)
      | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok new_balance
        =>
        op_gtgteqquestion (Storage.Contract.Balance.set c contract new_balance)
          (fun c =>
            op_gtgteqquestion
              (Roll_storage.Contract.remove_amount c contract amount)
              (fun c =>
                if op_gt new_balance Tez_repr.zero then
                  _return c
                else
                  match Contract_repr.is_implicit contract with
                  | None => _return c
                  | Some pkh =>
                    op_gtgteqquestion (Delegate_storage.get c contract)
                      (fun function_parameter =>
                        match function_parameter with
                        | Some pkh' =>
                          (* ❌ Sequences of instructions are not handled (operator ";") *)
                          let _ :=
                            (* ❌ Assert instruction is not handled. *)
                            assert (Signature.Public_key_hash.equal pkh pkh') in
                          _return c
                        | None => delete c contract
                        end)
                  end))
      end).

Definition credit
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Code.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Code.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion
    (if op_ltgt amount Tez_repr.zero then
      _return c
    else
      op_gtgteqquestion (Storage.Contract.Code.mem c contract)
        (fun function_parameter =>
          let '(c, target_has_code) := function_parameter in
          op_gtgteqquestion
            (fail_unless target_has_code
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_transaction
                contract))
            (fun function_parameter =>
              let 'tt := function_parameter in
              _return c)))
    (fun c =>
      op_gtgteqquestion (Storage.Contract.Balance.get_option c contract)
        (fun function_parameter =>
          match function_parameter with
          | None =>
            match Contract_repr.is_implicit contract with
            | None =>
              fail
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Non_existing_contract
                  contract)
            | Some manager => create_implicit c manager amount
            end
          | Some balance =>
            op_gtgteqquestion (Lwt._return (op_plusquestion amount balance))
              (fun balance =>
                op_gtgteqquestion
                  (Storage.Contract.Balance.set c contract balance)
                  (fun c => Roll_storage.Contract.add_amount c contract amount))
          end)).

Definition init (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Contract.Global_counter.init c Z.zero.

Definition used_storage_space
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Used_storage_space.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  op_gtgteqquestion (Storage.Contract.Used_storage_space.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => _return Z.zero
      | Some fees => _return fees
      end).

Definition paid_storage_space
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  op_gtgteqquestion (Storage.Contract.Paid_storage_space.get_option c contract)
    (fun function_parameter =>
      match function_parameter with
      | None => _return Z.zero
      | Some paid_space => _return paid_space
      end).

Definition set_paid_storage_space_and_return_fees_to_pay
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.key)
  (new_storage_space :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_raw_protocol_alpha.Storage.Contract.Paid_storage_space.context)) :=
  op_gtgteqquestion (Storage.Contract.Paid_storage_space.get c contract)
    (fun already_paid_space =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
          already_paid_space new_storage_space then
        _return (Z.zero, c)
      else
        let to_pay := Z.sub new_storage_space already_paid_space in
        op_gtgteqquestion
          (Storage.Contract.Paid_storage_space.set c contract new_storage_space)
          (fun c => _return (to_pay, c))).

src/proto_alpha/lib_protocol/cycle_repr.ml 17 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type cycle = t

let encoding = Data_encoding.int32

let rpc_arg =
  let construct = Int32.to_string in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse cycle"
    | cycle ->
        Ok cycle
  in
  RPC_arg.make
    ~descr:"A cycle integer"
    ~name:"block_cycle"
    ~construct
    ~destruct
    ()

let pp ppf cycle = Format.fprintf ppf "%ld" cycle

include (Compare.Int32 : Compare.S with type t := t)

module Map = Map.Make (Compare.Int32)

let root = 0l

let succ = Int32.succ

let pred = function 0l -> None | i -> Some (Int32.pred i)

let add c i =
  assert (Compare.Int.(i > 0)) ;
  Int32.add c (Int32.of_int i)

let sub c i =
  assert (Compare.Int.(i > 0)) ;
  let r = Int32.sub c (Int32.of_int i) in
  if Compare.Int32.(r < 0l) then None else Some r

let to_int32 i = i

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l
  else invalid_arg "Level_repr.Cycle.of_int32"

module Index = struct
  type t = cycle

  let path_length = 1

  let to_path c l = Int32.to_string (to_int32 c) :: l

  let of_path = function
    | [s] -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/cycle_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition cycle := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Data_encoding.int32.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  let construct := Int32.to_string in
  let destruct (str : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
      string :=
    let 'cycle := Int32.of_string str in
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok cycle in
  RPC_arg.make (Some "A cycle integer" % string) "block_cycle" % string destruct
    construct tt.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (cycle : int32) : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
      "%ld" % string) cycle.

(* ❌ Structure item `include` not handled. *)
include

(* ❌ Applications of functors are not handled. *)
functor_application

Definition root : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ : int32 -> int32 := Int32.succ.

Definition pred (function_parameter : int32) : option int32 :=
  match function_parameter with
  |
    (* ❌ Constant of type int32 is converted to int *)
    0 => None
  | i => Some (Int32.pred i)
  end.

Definition add
  (c : int32)
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : int32 :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        i 0) in
  Int32.add c (Int32.of_int i).

Definition sub
  (c : int32)
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : option int32 :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        i 0) in
  let r := Int32.sub c (Int32.of_int i) in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      r
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    None
  else
    Some r.

Definition to_int32 {A : Type} (i : A) : A := i.

Definition of_int32_exn
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    l
  else
    invalid_arg "Level_repr.Cycle.of_int32" % string.

Module Index.
  Definition t := cycle.
  
  Definition path_length : Z := 1.
  
  Definition to_path (c : int32) (l : list string) : list string :=
    cons (Int32.to_string (to_int32 c)) l.
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons s [] =>
      (* ❌ Try-with are not handled *)
      try (Some (Int32.of_string s))
    | _ => None
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

src/proto_alpha/lib_protocol/delegate_services.ml 334 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type info = {
  balance : Tez.t;
  frozen_balance : Tez.t;
  frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
  staking_balance : Tez.t;
  delegated_contracts : Contract_repr.t list;
  delegated_balance : Tez.t;
  deactivated : bool;
  grace_period : Cycle.t;
}

let info_encoding =
  let open Data_encoding in
  conv
    (fun { balance;
           frozen_balance;
           frozen_balance_by_cycle;
           staking_balance;
           delegated_contracts;
           delegated_balance;
           deactivated;
           grace_period } ->
      ( balance,
        frozen_balance,
        frozen_balance_by_cycle,
        staking_balance,
        delegated_contracts,
        delegated_balance,
        deactivated,
        grace_period ))
    (fun ( balance,
           frozen_balance,
           frozen_balance_by_cycle,
           staking_balance,
           delegated_contracts,
           delegated_balance,
           deactivated,
           grace_period ) ->
      {
        balance;
        frozen_balance;
        frozen_balance_by_cycle;
        staking_balance;
        delegated_contracts;
        delegated_balance;
        deactivated;
        grace_period;
      })
    (obj8
       (req "balance" Tez.encoding)
       (req "frozen_balance" Tez.encoding)
       (req "frozen_balance_by_cycle" Delegate.frozen_balance_by_cycle_encoding)
       (req "staking_balance" Tez.encoding)
       (req "delegated_contracts" (list Contract_repr.encoding))
       (req "delegated_balance" Tez.encoding)
       (req "deactivated" bool)
       (req "grace_period" Cycle.encoding))

module S = struct
  let path = RPC_path.(open_root / "context" / "delegates")

  open Data_encoding

  type list_query = {active : bool; inactive : bool}

  let list_query : list_query RPC_query.t =
    let open RPC_query in
    query (fun active inactive -> {active; inactive})
    |+ flag "active" (fun t -> t.active)
    |+ flag "inactive" (fun t -> t.inactive)
    |> seal

  let list_delegate =
    RPC_service.get_service
      ~description:"Lists all registered delegates."
      ~query:list_query
      ~output:(list Signature.Public_key_hash.encoding)
      path

  let path = RPC_path.(path /: Signature.Public_key_hash.rpc_arg)

  let info =
    RPC_service.get_service
      ~description:"Everything about a delegate."
      ~query:RPC_query.empty
      ~output:info_encoding
      path

  let balance =
    RPC_service.get_service
      ~description:
        "Returns the full balance of a given delegate, including the frozen \
         balances."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "balance")

  let frozen_balance =
    RPC_service.get_service
      ~description:
        "Returns the total frozen balances of a given delegate, this includes \
         the frozen deposits, rewards and fees."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "frozen_balance")

  let frozen_balance_by_cycle =
    RPC_service.get_service
      ~description:
        "Returns the frozen balances of a given delegate, indexed by the \
         cycle by which it will be unfrozen"
      ~query:RPC_query.empty
      ~output:Delegate.frozen_balance_by_cycle_encoding
      RPC_path.(path / "frozen_balance_by_cycle")

  let staking_balance =
    RPC_service.get_service
      ~description:
        "Returns the total amount of tokens delegated to a given delegate. \
         This includes the balances of all the contracts that delegate to it, \
         but also the balance of the delegate itself and its frozen fees and \
         deposits. The rewards do not count in the delegated balance until \
         they are unfrozen."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "staking_balance")

  let delegated_contracts =
    RPC_service.get_service
      ~description:
        "Returns the list of contracts that delegate to a given delegate."
      ~query:RPC_query.empty
      ~output:(list Contract_repr.encoding)
      RPC_path.(path / "delegated_contracts")

  let delegated_balance =
    RPC_service.get_service
      ~description:
        "Returns the balances of all the contracts that delegate to a given \
         delegate. This excludes the delegate's own balance and its frozen \
         balances."
      ~query:RPC_query.empty
      ~output:Tez.encoding
      RPC_path.(path / "delegated_balance")

  let deactivated =
    RPC_service.get_service
      ~description:
        "Tells whether the delegate is currently tagged as deactivated or not."
      ~query:RPC_query.empty
      ~output:bool
      RPC_path.(path / "deactivated")

  let grace_period =
    RPC_service.get_service
      ~description:
        "Returns the cycle by the end of which the delegate might be \
         deactivated if she fails to execute any delegate action. A \
         deactivated delegate might be reactivated (without loosing any \
         rolls) by simply re-registering as a delegate. For deactivated \
         delegates, this value contains the cycle by which they were \
         deactivated."
      ~query:RPC_query.empty
      ~output:Cycle.encoding
      RPC_path.(path / "grace_period")
end

let register () =
  let open Services_registration in
  register0 S.list_delegate (fun ctxt q () ->
      Delegate.list ctxt
      >>= fun delegates ->
      if q.active && q.inactive then return delegates
      else if q.active then
        filter_map_s
          (fun pkh ->
            Delegate.deactivated ctxt pkh
            >>=? function true -> return_none | false -> return_some pkh)
          delegates
      else if q.inactive then
        filter_map_s
          (fun pkh ->
            Delegate.deactivated ctxt pkh
            >>=? function false -> return_none | true -> return_some pkh)
          delegates
      else return_nil) ;
  register1 S.info (fun ctxt pkh () () ->
      Delegate.full_balance ctxt pkh
      >>=? fun balance ->
      Delegate.frozen_balance ctxt pkh
      >>=? fun frozen_balance ->
      Delegate.frozen_balance_by_cycle ctxt pkh
      >>= fun frozen_balance_by_cycle ->
      Delegate.staking_balance ctxt pkh
      >>=? fun staking_balance ->
      Delegate.delegated_contracts ctxt pkh
      >>= fun delegated_contracts ->
      Delegate.delegated_balance ctxt pkh
      >>=? fun delegated_balance ->
      Delegate.deactivated ctxt pkh
      >>=? fun deactivated ->
      Delegate.grace_period ctxt pkh
      >>=? fun grace_period ->
      return
        {
          balance;
          frozen_balance;
          frozen_balance_by_cycle;
          staking_balance;
          delegated_contracts;
          delegated_balance;
          deactivated;
          grace_period;
        }) ;
  register1 S.balance (fun ctxt pkh () () -> Delegate.full_balance ctxt pkh) ;
  register1 S.frozen_balance (fun ctxt pkh () () ->
      Delegate.frozen_balance ctxt pkh) ;
  register1 S.frozen_balance_by_cycle (fun ctxt pkh () () ->
      Delegate.frozen_balance_by_cycle ctxt pkh >>= return) ;
  register1 S.staking_balance (fun ctxt pkh () () ->
      Delegate.staking_balance ctxt pkh) ;
  register1 S.delegated_contracts (fun ctxt pkh () () ->
      Delegate.delegated_contracts ctxt pkh >>= return) ;
  register1 S.delegated_balance (fun ctxt pkh () () ->
      Delegate.delegated_balance ctxt pkh) ;
  register1 S.deactivated (fun ctxt pkh () () -> Delegate.deactivated ctxt pkh) ;
  register1 S.grace_period (fun ctxt pkh () () ->
      Delegate.grace_period ctxt pkh)

let list ctxt block ?(active = true) ?(inactive = false) () =
  RPC_context.make_call0 S.list_delegate ctxt block {active; inactive} ()

let info ctxt block pkh = RPC_context.make_call1 S.info ctxt block pkh () ()

let balance ctxt block pkh =
  RPC_context.make_call1 S.balance ctxt block pkh () ()

let frozen_balance ctxt block pkh =
  RPC_context.make_call1 S.frozen_balance ctxt block pkh () ()

let frozen_balance_by_cycle ctxt block pkh =
  RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh () ()

let staking_balance ctxt block pkh =
  RPC_context.make_call1 S.staking_balance ctxt block pkh () ()

let delegated_contracts ctxt block pkh =
  RPC_context.make_call1 S.delegated_contracts ctxt block pkh () ()

let delegated_balance ctxt block pkh =
  RPC_context.make_call1 S.delegated_balance ctxt block pkh () ()

let deactivated ctxt block pkh =
  RPC_context.make_call1 S.deactivated ctxt block pkh () ()

let grace_period ctxt block pkh =
  RPC_context.make_call1 S.grace_period ctxt block pkh () ()

let requested_levels ~default ctxt cycles levels =
  match (levels, cycles) with
  | ([], []) ->
      return [default]
  | (levels, cycles) ->
      (* explicitly fail when requested levels or cycle are in the past...
         or too far in the future... *)
      let levels =
        List.sort_uniq
          Level.compare
          (List.concat
             ( List.map (Level.from_raw ctxt) levels
             :: List.map (Level.levels_in_cycle ctxt) cycles ))
      in
      map_s
        (fun level ->
          let current_level = Level.current ctxt in
          if Level.(level <= current_level) then return (level, None)
          else
            Baking.earlier_predecessor_timestamp ctxt level
            >>=? fun timestamp -> return (level, Some timestamp))
        levels

module Baking_rights = struct
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    priority : int;
    timestamp : Timestamp.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {level; delegate; priority; timestamp} ->
        (level, delegate, priority, timestamp))
      (fun (level, delegate, priority, timestamp) ->
        {level; delegate; priority; timestamp})
      (obj4
         (req "level" Raw_level.encoding)
         (req "delegate" Signature.Public_key_hash.encoding)
         (req "priority" uint16)
         (opt "estimated_time" Timestamp.encoding))

  module S = struct
    open Data_encoding

    let custom_root = RPC_path.(open_root / "helpers" / "baking_rights")

    type baking_rights_query = {
      levels : Raw_level.t list;
      cycles : Cycle.t list;
      delegates : Signature.Public_key_hash.t list;
      max_priority : int option;
      all : bool;
    }

    let baking_rights_query =
      let open RPC_query in
      query (fun levels cycles delegates max_priority all ->
          {levels; cycles; delegates; max_priority; all})
      |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
      |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
      |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
             t.delegates)
      |+ opt_field "max_priority" RPC_arg.int (fun t -> t.max_priority)
      |+ flag "all" (fun t -> t.all)
      |> seal

    let baking_rights =
      RPC_service.get_service
        ~description:
          "Retrieves the list of delegates allowed to bake a block.\n\
           By default, it gives the best baking priorities for bakers that \
           have at least one opportunity below the 64th priority for the next \
           block.\n\
           Parameters `level` and `cycle` can be used to specify the (valid) \
           level(s) in the past or future at which the baking rights have to \
           be returned. Parameter `delegate` can be used to restrict the \
           results to the given delegates. If parameter `all` is set, all the \
           baking opportunities for each baker at each level are returned, \
           instead of just the first one.\n\
           Returns the list of baking slots. Also returns the minimal \
           timestamps that correspond to these slots. The timestamps are \
           omitted for levels in the past, and are only estimates for levels \
           later that the next block, based on the hypothesis that all \
           predecessor blocks were baked at the first priority."
        ~query:baking_rights_query
        ~output:(list encoding)
        custom_root
  end

  let baking_priorities ctxt max_prio (level, pred_timestamp) =
    Baking.baking_priorities ctxt level
    >>=? fun contract_list ->
    let rec loop l acc priority =
      if Compare.Int.(priority >= max_prio) then return (List.rev acc)
      else
        let (Misc.LCons (pk, next)) = l in
        let delegate = Signature.Public_key.hash pk in
        ( match pred_timestamp with
        | None ->
            return_none
        | Some pred_timestamp ->
            Baking.minimal_time ctxt priority pred_timestamp
            >>=? fun t -> return_some t )
        >>=? fun timestamp ->
        let acc =
          {level = level.level; delegate; priority; timestamp} :: acc
        in
        next () >>=? fun l -> loop l acc (priority + 1)
    in
    loop contract_list [] 0

  let remove_duplicated_delegates rights =
    List.rev @@ fst
    @@ List.fold_left
         (fun (acc, previous) r ->
           if Signature.Public_key_hash.Set.mem r.delegate previous then
             (acc, previous)
           else
             (r :: acc, Signature.Public_key_hash.Set.add r.delegate previous))
         ([], Signature.Public_key_hash.Set.empty)
         rights

  let register () =
    let open Services_registration in
    register0 S.baking_rights (fun ctxt q () ->
        requested_levels
          ~default:
            ( Level.succ ctxt (Level.current ctxt),
              Some (Timestamp.current ctxt) )
          ctxt
          q.cycles
          q.levels
        >>=? fun levels ->
        let max_priority =
          match q.max_priority with None -> 64 | Some max -> max
        in
        map_s (baking_priorities ctxt max_priority) levels
        >>=? fun rights ->
        let rights =
          if q.all then rights else List.map remove_duplicated_delegates rights
        in
        let rights = List.concat rights in
        match q.delegates with
        | [] ->
            return rights
        | _ :: _ as delegates ->
            let is_requested p =
              List.exists
                (Signature.Public_key_hash.equal p.delegate)
                delegates
            in
            return (List.filter is_requested rights))

  let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) ?(all = false)
      ?max_priority block =
    RPC_context.make_call0
      S.baking_rights
      ctxt
      block
      {levels; cycles; delegates; max_priority; all}
      ()
end

module Endorsing_rights = struct
  type t = {
    level : Raw_level.t;
    delegate : Signature.Public_key_hash.t;
    slots : int list;
    estimated_time : Time.t option;
  }

  let encoding =
    let open Data_encoding in
    conv
      (fun {level; delegate; slots; estimated_time} ->
        (level, delegate, slots, estimated_time))
      (fun (level, delegate, slots, estimated_time) ->
        {level; delegate; slots; estimated_time})
      (obj4
         (req "level" Raw_level.encoding)
         (req "delegate" Signature.Public_key_hash.encoding)
         (req "slots" (list uint16))
         (opt "estimated_time" Timestamp.encoding))

  module S = struct
    open Data_encoding

    let custom_root = RPC_path.(open_root / "helpers" / "endorsing_rights")

    type endorsing_rights_query = {
      levels : Raw_level.t list;
      cycles : Cycle.t list;
      delegates : Signature.Public_key_hash.t list;
    }

    let endorsing_rights_query =
      let open RPC_query in
      query (fun levels cycles delegates -> {levels; cycles; delegates})
      |+ multi_field "level" Raw_level.rpc_arg (fun t -> t.levels)
      |+ multi_field "cycle" Cycle.rpc_arg (fun t -> t.cycles)
      |+ multi_field "delegate" Signature.Public_key_hash.rpc_arg (fun t ->
             t.delegates)
      |> seal

    let endorsing_rights =
      RPC_service.get_service
        ~description:
          "Retrieves the delegates allowed to endorse a block.\n\
           By default, it gives the endorsement slots for delegates that have \
           at least one in the next block.\n\
           Parameters `level` and `cycle` can be used to specify the (valid) \
           level(s) in the past or future at which the endorsement rights \
           have to be returned. Parameter `delegate` can be used to restrict \
           the results to the given delegates.\n\
           Returns the list of endorsement slots. Also returns the minimal \
           timestamps that correspond to these slots. The timestamps are \
           omitted for levels in the past, and are only estimates for levels \
           later that the next block, based on the hypothesis that all \
           predecessor blocks were baked at the first priority."
        ~query:endorsing_rights_query
        ~output:(list encoding)
        custom_root
  end

  let endorsement_slots ctxt (level, estimated_time) =
    Baking.endorsement_rights ctxt level
    >>=? fun rights ->
    return
      (Signature.Public_key_hash.Map.fold
         (fun delegate (_, slots, _) acc ->
           {level = level.level; delegate; slots; estimated_time} :: acc)
         rights
         [])

  let register () =
    let open Services_registration in
    register0 S.endorsing_rights (fun ctxt q () ->
        requested_levels
          ~default:(Level.current ctxt, Some (Timestamp.current ctxt))
          ctxt
          q.cycles
          q.levels
        >>=? fun levels ->
        map_s (endorsement_slots ctxt) levels
        >>=? fun rights ->
        let rights = List.concat rights in
        match q.delegates with
        | [] ->
            return rights
        | _ :: _ as delegates ->
            let is_requested p =
              List.exists
                (Signature.Public_key_hash.equal p.delegate)
                delegates
            in
            return (List.filter is_requested rights))

  let get ctxt ?(levels = []) ?(cycles = []) ?(delegates = []) block =
    RPC_context.make_call0
      S.endorsing_rights
      ctxt
      block
      {levels; cycles; delegates}
      ()
end

module Endorsing_power = struct
  let endorsing_power ctxt (operation, chain_id) =
    let (Operation_data data) = operation.protocol_data in
    match data.contents with
    | Single (Endorsement _) ->
        Baking.check_endorsement_rights
          ctxt
          chain_id
          {shell = operation.shell; protocol_data = data}
        >>=? fun (_, slots, _) -> return (List.length slots)
    | _ ->
        failwith "Operation is not an endorsement"

  module S = struct
    let endorsing_power =
      let open Data_encoding in
      RPC_service.post_service
        ~description:
          "Get the endorsing power of an endorsement, that is, the number of \
           slots that the endorser has"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "endorsement_operation" Operation.encoding)
             (req "chain_id" Chain_id.encoding))
        ~output:int31
        RPC_path.(open_root / "endorsing_power")
  end

  let register () =
    let open Services_registration in
    register0 S.endorsing_power (fun ctxt () (op, chain_id) ->
        endorsing_power ctxt (op, chain_id))

  let get ctxt block op chain_id =
    RPC_context.make_call0 S.endorsing_power ctxt block () (op, chain_id)
end

module Required_endorsements = struct
  let required_endorsements ctxt block_delay =
    return (Baking.minimum_allowed_endorsements ctxt ~block_delay)

  module S = struct
    type t = {block_delay : Period.t}

    let required_endorsements_query =
      let open RPC_query in
      query (fun block_delay -> {block_delay})
      |+ field "block_delay" Period.rpc_arg Period.zero (fun t ->
             t.block_delay)
      |> seal

    let required_endorsements =
      let open Data_encoding in
      RPC_service.get_service
        ~description:
          "Minimum number of endorsements for a block to be valid, given a \
           delay of the block's timestamp with respect to the minimum time to \
           bake at the block's priority"
        ~query:required_endorsements_query
        ~output:int31
        RPC_path.(open_root / "required_endorsements")
  end

  let register () =
    let open Services_registration in
    register0 S.required_endorsements (fun ctxt {block_delay} () ->
        required_endorsements ctxt block_delay)

  let get ctxt block block_delay =
    RPC_context.make_call0 S.required_endorsements ctxt block {block_delay} ()
end

module Minimal_valid_time = struct
  let minimal_valid_time ctxt ~priority ~endorsing_power =
    Baking.minimal_valid_time ctxt ~priority ~endorsing_power

  module S = struct
    type t = {priority : int; endorsing_power : int}

    let minimal_valid_time_query =
      let open RPC_query in
      query (fun priority endorsing_power -> {priority; endorsing_power})
      |+ field "priority" RPC_arg.int 0 (fun t -> t.priority)
      |+ field "endorsing_power" RPC_arg.int 0 (fun t -> t.endorsing_power)
      |> seal

    let minimal_valid_time =
      RPC_service.get_service
        ~description:
          "Minimal valid time for a block given a priority and an endorsing \
           power."
        ~query:minimal_valid_time_query
        ~output:Time.encoding
        RPC_path.(open_root / "minimal_valid_time")
  end

  let register () =
    let open Services_registration in
    register0 S.minimal_valid_time (fun ctxt {priority; endorsing_power} () ->
        minimal_valid_time ctxt ~priority ~endorsing_power)

  let get ctxt block priority endorsing_power =
    RPC_context.make_call0
      S.minimal_valid_time
      ctxt
      block
      {priority; endorsing_power}
      ()
end

let register () =
  register () ;
  Baking_rights.register () ;
  Endorsing_rights.register () ;
  Endorsing_power.register () ;
  Required_endorsements.register () ;
  Minimal_valid_time.register ()

let endorsement_rights ctxt level =
  Endorsing_rights.endorsement_slots ctxt (level, None)
  >>=? fun l ->
  return (List.map (fun {Endorsing_rights.delegate; _} -> delegate) l)

let baking_rights ctxt max_priority =
  let max = match max_priority with None -> 64 | Some m -> m in
  let level = Level.current ctxt in
  Baking_rights.baking_priorities ctxt max (level, None)
  >>=? fun l ->
  return
    ( level.level,
      List.map
        (fun {Baking_rights.delegate; timestamp; _} -> (delegate, timestamp))
        l )

let endorsing_power ctxt operation =
  Endorsing_power.endorsing_power ctxt operation

let required_endorsements ctxt delay =
  Required_endorsements.required_endorsements ctxt delay

let minimal_valid_time ctxt priority endorsing_power =
  Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power
src/proto_alpha/lib_protocol/delegate_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Record info := {
  balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  frozen_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  frozen_balance_by_cycle :
    Tezos_raw_protocol_alpha.Alpha_context.Cycle.Map.t
      Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance;
  staking_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  delegated_contracts : list Tezos_raw_protocol_alpha.Contract_repr.t;
  delegated_balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  deactivated : bool;
  grace_period : Tezos_raw_protocol_alpha.Alpha_context.Cycle.t }.

Definition info_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding info :=
  conv
    (fun function_parameter =>
      let '{|
        balance := balance;
          frozen_balance := frozen_balance;
          frozen_balance_by_cycle := frozen_balance_by_cycle;
          staking_balance := staking_balance;
          delegated_contracts := delegated_contracts;
          delegated_balance := delegated_balance;
          deactivated := deactivated;
          grace_period := grace_period
          |} := function_parameter in
      (balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
        delegated_contracts, delegated_balance, deactivated, grace_period))
    (fun function_parameter =>
      let
        '(balance, frozen_balance, frozen_balance_by_cycle, staking_balance,
          delegated_contracts, delegated_balance, deactivated, grace_period) :=
        function_parameter in
      {| balance := balance; frozen_balance := frozen_balance;
        frozen_balance_by_cycle := frozen_balance_by_cycle;
        staking_balance := staking_balance;
        delegated_contracts := delegated_contracts;
        delegated_balance := delegated_balance; deactivated := deactivated;
        grace_period := grace_period |}) None
    (obj8 (req None None "balance" % string Tez.encoding)
      (req None None "frozen_balance" % string Tez.encoding)
      (req None None "frozen_balance_by_cycle" % string
        Delegate.frozen_balance_by_cycle_encoding)
      (req None None "staking_balance" % string Tez.encoding)
      (req None None "delegated_contracts" % string
        (list None Contract_repr.encoding))
      (req None None "delegated_balance" % string Tez.encoding)
      (req None None "deactivated" % string bool)
      (req None None "grace_period" % string Cycle.encoding)).

Module S.
  Definition path
    : Tezos_protocol_environment_alpha__Environment.RPC_path.path
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
    op_div (op_div open_root "context" % string) "delegates" % string.
  
  Import Data_encoding.
  
  Record list_query := {
    active : bool;
    inactive : bool }.
  
  Definition list_query
    : Tezos_protocol_environment_alpha__Environment.RPC_query.t list_query :=
    op_pipegt
      (op_pipeplus
        (op_pipeplus
          (query
            (fun active =>
              fun inactive => {| active := active; inactive := inactive |}))
          (flag None "active" % string (fun t => active t)))
        (flag None "inactive" % string (fun t => inactive t))) seal.
  
  Definition list_delegate
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      list_query unit
      (list
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
    RPC_service.get_service (Some "Lists all registered delegates." % string)
      list_query (list None Signature.Public_key_hash.encoding) path.
  
  Definition path
    : Tezos_protocol_environment_alpha__Environment.RPC_path.path
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t) :=
    op_divcolon path Signature.Public_key_hash.rpc_arg.
  
  Definition info
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit info :=
    RPC_service.get_service (Some "Everything about a delegate." % string)
      RPC_query.empty info_encoding path.
  
  Definition balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the full balance of a given delegate, including the frozen balances."
          % string) RPC_query.empty Tez.encoding
      (op_div path "balance" % string).
  
  Definition frozen_balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the total frozen balances of a given delegate, this includes the frozen deposits, rewards and fees."
          % string) RPC_query.empty Tez.encoding
      (op_div path "frozen_balance" % string).
  
  Definition frozen_balance_by_cycle
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit
      (Tezos_raw_protocol_alpha__Alpha_context.Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance) :=
    RPC_service.get_service
      (Some
        "Returns the frozen balances of a given delegate, indexed by the cycle by which it will be unfrozen"
          % string) RPC_query.empty Delegate.frozen_balance_by_cycle_encoding
      (op_div path "frozen_balance_by_cycle" % string).
  
  Definition staking_balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the total amount of tokens delegated to a given delegate. This includes the balances of all the contracts that delegate to it, but also the balance of the delegate itself and its frozen fees and deposits. The rewards do not count in the delegated balance until they are unfrozen."
          % string) RPC_query.empty Tez.encoding
      (op_div path "staking_balance" % string).
  
  Definition delegated_contracts
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit (list Tezos_raw_protocol_alpha.Contract_repr.contract) :=
    RPC_service.get_service
      (Some
        "Returns the list of contracts that delegate to a given delegate." %
          string) RPC_query.empty (list None Contract_repr.encoding)
      (op_div path "delegated_contracts" % string).
  
  Definition delegated_balance
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Tez.t :=
    RPC_service.get_service
      (Some
        "Returns the balances of all the contracts that delegate to a given delegate. This excludes the delegate's own balance and its frozen balances."
          % string) RPC_query.empty Tez.encoding
      (op_div path "delegated_balance" % string).
  
  Definition deactivated
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit bool :=
    RPC_service.get_service
      (Some
        "Tells whether the delegate is currently tagged as deactivated or not."
          % string) RPC_query.empty bool (op_div path "deactivated" % string).
  
  Definition grace_period
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context *
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      unit unit Tezos_raw_protocol_alpha.Alpha_context.Cycle.t :=
    RPC_service.get_service
      (Some
        "Returns the cycle by the end of which the delegate might be deactivated if she fails to execute any delegate action. A deactivated delegate might be reactivated (without loosing any rolls) by simply re-registering as a delegate. For deactivated delegates, this value contains the cycle by which they were deactivated."
          % string) RPC_query.empty Cycle.encoding
      (op_div path "grace_period" % string).
End S.

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.list_delegate
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteq (Delegate.list ctxt)
              (fun delegates =>
                if op_andand (active q) (inactive q) then
                  _return delegates
                else
                  if active q then
                    filter_map_s
                      (fun pkh =>
                        op_gtgteqquestion (Delegate.deactivated ctxt pkh)
                          (fun function_parameter =>
                            match function_parameter with
                            | true => return_none
                            | false => return_some pkh
                            end)) delegates
                  else
                    if inactive q then
                      filter_map_s
                        (fun pkh =>
                          op_gtgteqquestion (Delegate.deactivated ctxt pkh)
                            (fun function_parameter =>
                              match function_parameter with
                              | false => return_none
                              | true => return_some pkh
                              end)) delegates
                    else
                      return_nil)) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.info
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (Delegate.full_balance ctxt pkh)
                (fun balance =>
                  op_gtgteqquestion (Delegate.frozen_balance ctxt pkh)
                    (fun frozen_balance =>
                      op_gtgteq (Delegate.frozen_balance_by_cycle ctxt pkh)
                        (fun frozen_balance_by_cycle =>
                          op_gtgteqquestion (Delegate.staking_balance ctxt pkh)
                            (fun staking_balance =>
                              op_gtgteq (Delegate.delegated_contracts ctxt pkh)
                                (fun delegated_contracts =>
                                  op_gtgteqquestion
                                    (Delegate.delegated_balance ctxt pkh)
                                    (fun delegated_balance =>
                                      op_gtgteqquestion
                                        (Delegate.deactivated ctxt pkh)
                                        (fun deactivated =>
                                          op_gtgteqquestion
                                            (Delegate.grace_period ctxt pkh)
                                            (fun grace_period =>
                                              _return
                                                {| balance := balance;
                                                  frozen_balance :=
                                                    frozen_balance;
                                                  frozen_balance_by_cycle :=
                                                    frozen_balance_by_cycle;
                                                  staking_balance :=
                                                    staking_balance;
                                                  delegated_contracts :=
                                                    delegated_contracts;
                                                  delegated_balance :=
                                                    delegated_balance;
                                                  deactivated := deactivated;
                                                  grace_period := grace_period
                                                  |}))))))))) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              Delegate.full_balance ctxt pkh) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.frozen_balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              Delegate.frozen_balance ctxt pkh) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.frozen_balance_by_cycle
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Delegate.frozen_balance_by_cycle ctxt pkh) _return) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.staking_balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              Delegate.staking_balance ctxt pkh) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.delegated_contracts
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteq (Delegate.delegated_contracts ctxt pkh) _return) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.delegated_balance
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              Delegate.delegated_balance ctxt pkh) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register1 S.deactivated
      (fun ctxt =>
        fun pkh =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let 'tt := function_parameter in
              Delegate.deactivated ctxt pkh) in
  register1 S.grace_period
    (fun ctxt =>
      fun pkh =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            Delegate.grace_period ctxt pkh).

Definition list {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D) (op_staroptstar : option bool)
  : (option bool) ->
    unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (list
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  let active :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => true
    end in
  fun op_staroptstar =>
    let inactive :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun function_parameter =>
      let 'tt := function_parameter in
      RPC_context.make_call0 S.list_delegate ctxt block
        {| active := active; inactive := inactive |} tt.

Definition info {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      info) := RPC_context.make_call1 S.info ctxt block pkh tt tt.

Definition balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.balance ctxt block pkh tt tt.

Definition frozen_balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.frozen_balance ctxt block pkh tt tt.

Definition frozen_balance_by_cycle {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.Cycle.Map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        Tezos_raw_protocol_alpha.Alpha_context.Delegate.frozen_balance)) :=
  RPC_context.make_call1 S.frozen_balance_by_cycle ctxt block pkh tt tt.

Definition staking_balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.staking_balance ctxt block pkh tt tt.

Definition delegated_contracts {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list Tezos_raw_protocol_alpha.Contract_repr.contract)) :=
  RPC_context.make_call1 S.delegated_contracts ctxt block pkh tt tt.

Definition delegated_balance {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
  RPC_context.make_call1 S.delegated_balance ctxt block pkh tt tt.

Definition deactivated {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      bool) := RPC_context.make_call1 S.deactivated ctxt block pkh tt tt.

Definition grace_period {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  (pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Cycle.t) :=
  RPC_context.make_call1 S.grace_period ctxt block pkh tt tt.

Definition requested_levels
  (default :
    Tezos_raw_protocol_alpha.Alpha_context.Level.t *
      (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t))
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (cycles : list Tezos_raw_protocol_alpha__Alpha_context.Cycle.t)
  (levels : list Tezos_raw_protocol_alpha__Alpha_context.Raw_level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Level.t *
          (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)))) :=
  match (levels, cycles) with
  | ([], []) => _return (cons default [])
  | (levels, cycles) =>
    let levels :=
      List.sort_uniq Level.compare
        (List.concat
          (cons
            (List.map
              (let arg := Level.from_raw ctxt in
              fun eta => arg None eta) levels)
            (List.map (Level.levels_in_cycle ctxt) cycles))) in
    map_s
      (fun level =>
        let current_level := Level.current ctxt in
        if op_lteq level current_level then
          _return (level, None)
        else
          op_gtgteqquestion (Baking.earlier_predecessor_timestamp ctxt level)
            (fun timestamp => _return (level, (Some timestamp)))) levels
  end.

Module Baking_rights.
  Record t := {
    level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    priority : Z;
    timestamp : option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t }.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
    conv
      (fun function_parameter =>
        let '{|
          level := level;
            delegate := delegate;
            priority := priority;
            timestamp := timestamp
            |} := function_parameter in
        (level, delegate, priority, timestamp))
      (fun function_parameter =>
        let '(level, delegate, priority, timestamp) := function_parameter in
        {| level := level; delegate := delegate; priority := priority;
          timestamp := timestamp |}) None
      (obj4 (req None None "level" % string Raw_level.encoding)
        (req None None "delegate" % string Signature.Public_key_hash.encoding)
        (req None None "priority" % string uint16)
        (opt None None "estimated_time" % string Timestamp.encoding)).
  
  Module S.
    Import Data_encoding.
    
    Definition custom_root
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      op_div (op_div open_root "helpers" % string) "baking_rights" % string.
    
    Record baking_rights_query := {
      levels : list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
      cycles : list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t;
      delegates :
        list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
      max_priority : option Z;
      all : bool }.
    
    Definition baking_rights_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t
        baking_rights_query :=
      op_pipegt
        (op_pipeplus
          (op_pipeplus
            (op_pipeplus
              (op_pipeplus
                (op_pipeplus
                  (query
                    (fun levels =>
                      fun cycles =>
                        fun delegates =>
                          fun max_priority =>
                            fun all =>
                              {| levels := levels; cycles := cycles;
                                delegates := delegates;
                                max_priority := max_priority; all := all |}))
                  (multi_field None "level" % string Raw_level.rpc_arg
                    (fun t => levels t)))
                (multi_field None "cycle" % string Cycle.rpc_arg
                  (fun t => cycles t)))
              (multi_field None "delegate" % string
                Signature.Public_key_hash.rpc_arg (fun t => delegates t)))
            (opt_field None "max_priority" % string RPC_arg.int
              (fun t => max_priority t)))
          (flag None "all" % string (fun t => all t))) seal.
    
    Definition baking_rights
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        baking_rights_query unit (list t) :=
      RPC_service.get_service
        (Some
          "Retrieves the list of delegates allowed to bake a block.
By default, it gives the best baking priorities for bakers that have at least one opportunity below the 64th priority for the next block.
Parameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the baking rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates. If parameter `all` is set, all the baking opportunities for each baker at each level are returned, instead of just the first one.
Returns the list of baking slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority."
            % string) baking_rights_query (list None encoding) custom_root.
  End S.
  
  Definition baking_priorities
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (max_prio :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Level.t *
        (option Tezos_protocol_environment_alpha__Environment.Time.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list t)) :=
    let '(level, pred_timestamp) := function_parameter in
    op_gtgteqquestion (Baking.baking_priorities ctxt level)
      (fun contract_list =>
        let fix loop
          (l :
          Tezos_raw_protocol_alpha.Misc.lazy_list_t
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
          (acc : list t) (priority :
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (list t)) :=
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
              priority max_prio then
            _return (List.rev acc)
          else
            let 'Tezos_raw_protocol_alpha.Misc.LCons pk next := l in
            let delegate := Signature.Public_key.hash pk in
            op_gtgteqquestion
              match pred_timestamp with
              | None => return_none
              | Some pred_timestamp =>
                op_gtgteqquestion
                  (Baking.minimal_time ctxt priority pred_timestamp)
                  (fun t => return_some t)
              end
              (fun timestamp =>
                let acc :=
                  cons
                    {| level := level level; delegate := delegate;
                      priority := priority; timestamp := timestamp |} acc in
                op_gtgteqquestion (next tt)
                  (fun l => loop l acc (op_plus priority 1))) in
        loop contract_list [] 0).
  
  Definition remove_duplicated_delegates (rights : list t) : list t :=
    op_atat List.rev
      (op_atat fst
        (List.fold_left
          (fun function_parameter =>
            let '(acc, previous) := function_parameter in
            fun r =>
              if Signature.Public_key_hash.Set.mem (delegate r) previous then
                (acc, previous)
              else
                ((cons r acc),
                  (Signature.Public_key_hash.Set.add (delegate r) previous)))
          ([], Signature.Public_key_hash.Set.empty) rights)).
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    register0 S.baking_rights
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (requested_levels
                ((Level.succ ctxt (Level.current ctxt)),
                  (Some (Timestamp.current ctxt))) ctxt (cycles q) (levels q))
              (fun levels =>
                let max_priority :=
                  match max_priority q with
                  | None => 64
                  | Some max => max
                  end in
                op_gtgteqquestion
                  (map_s (baking_priorities ctxt max_priority) levels)
                  (fun rights =>
                    let rights :=
                      if all q then
                        rights
                      else
                        List.map remove_duplicated_delegates rights in
                    let rights := List.concat rights in
                    match delegates q with
                    | [] => _return rights
                    | (cons _ _) as delegates =>
                      let is_requested (p : t) : bool :=
                        List._exists
                          (Signature.Public_key_hash.equal (delegate p))
                          delegates in
                      _return (List.filter is_requested rights)
                    end))).
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (op_staroptstar :
      option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t))
    : (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
      (option
        (list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))
        ->
        (option bool) ->
          (option Z) ->
            D ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  (list t)) :=
    let levels :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun op_staroptstar =>
      let cycles :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => []
        end in
      fun op_staroptstar =>
        let delegates :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => []
          end in
        fun op_staroptstar =>
          let all :=
            match op_staroptstar with
            | Some op_starsthstar => op_starsthstar
            | None => false
            end in
          fun max_priority =>
            fun block =>
              RPC_context.make_call0 S.baking_rights ctxt block
                {| levels := levels; cycles := cycles; delegates := delegates;
                  max_priority := max_priority; all := all |} tt.
End Baking_rights.

Module Endorsing_rights.
  Record t := {
    level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    slots : list Z;
    estimated_time : option Tezos_protocol_environment_alpha__Environment.Time.t
    }.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
    conv
      (fun function_parameter =>
        let '{|
          level := level;
            delegate := delegate;
            slots := slots;
            estimated_time := estimated_time
            |} := function_parameter in
        (level, delegate, slots, estimated_time))
      (fun function_parameter =>
        let '(level, delegate, slots, estimated_time) := function_parameter in
        {| level := level; delegate := delegate; slots := slots;
          estimated_time := estimated_time |}) None
      (obj4 (req None None "level" % string Raw_level.encoding)
        (req None None "delegate" % string Signature.Public_key_hash.encoding)
        (req None None "slots" % string (list None uint16))
        (opt None None "estimated_time" % string Timestamp.encoding)).
  
  Module S.
    Import Data_encoding.
    
    Definition custom_root
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      op_div (op_div open_root "helpers" % string) "endorsing_rights" % string.
    
    Record endorsing_rights_query := {
      levels : list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t;
      cycles : list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t;
      delegates :
        list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
      }.
    
    Definition endorsing_rights_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t
        endorsing_rights_query :=
      op_pipegt
        (op_pipeplus
          (op_pipeplus
            (op_pipeplus
              (query
                (fun levels =>
                  fun cycles =>
                    fun delegates =>
                      {| levels := levels; cycles := cycles;
                        delegates := delegates |}))
              (multi_field None "level" % string Raw_level.rpc_arg
                (fun t => levels t)))
            (multi_field None "cycle" % string Cycle.rpc_arg (fun t => cycles t)))
          (multi_field None "delegate" % string
            Signature.Public_key_hash.rpc_arg (fun t => delegates t))) seal.
    
    Definition endorsing_rights
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        endorsing_rights_query unit (list t) :=
      RPC_service.get_service
        (Some
          "Retrieves the delegates allowed to endorse a block.
By default, it gives the endorsement slots for delegates that have at least one in the next block.
Parameters `level` and `cycle` can be used to specify the (valid) level(s) in the past or future at which the endorsement rights have to be returned. Parameter `delegate` can be used to restrict the results to the given delegates.
Returns the list of endorsement slots. Also returns the minimal timestamps that correspond to these slots. The timestamps are omitted for levels in the past, and are only estimates for levels later that the next block, based on the hypothesis that all predecessor blocks were baked at the first priority."
            % string) endorsing_rights_query (list None encoding) custom_root.
  End S.
  
  Definition endorsement_slots
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Level.t *
        (option Tezos_protocol_environment_alpha__Environment.Time.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list t)) :=
    let '(level, estimated_time) := function_parameter in
    op_gtgteqquestion (Baking.endorsement_rights ctxt level)
      (fun rights =>
        _return
          (Signature.Public_key_hash.Map.fold
            (fun delegate =>
              fun function_parameter =>
                let '(_, slots, _) := function_parameter in
                fun acc =>
                  cons
                    {| level := level level; delegate := delegate;
                      slots := slots; estimated_time := estimated_time |} acc)
            rights [])).
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    register0 S.endorsing_rights
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (requested_levels
                ((Level.current ctxt), (Some (Timestamp.current ctxt))) ctxt
                (cycles q) (levels q))
              (fun levels =>
                op_gtgteqquestion (map_s (endorsement_slots ctxt) levels)
                  (fun rights =>
                    let rights := List.concat rights in
                    match delegates q with
                    | [] => _return rights
                    | (cons _ _) as delegates =>
                      let is_requested (p : t) : bool :=
                        List._exists
                          (Signature.Public_key_hash.equal (delegate p))
                          delegates in
                      _return (List.filter is_requested rights)
                    end))).
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (op_staroptstar :
      option (list Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t))
    : (option (list Tezos_raw_protocol_alpha.Alpha_context.Cycle.t)) ->
      (option
        (list
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t))
        ->
        D ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
              (list t)) :=
    let levels :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => []
      end in
    fun op_staroptstar =>
      let cycles :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => []
        end in
      fun op_staroptstar =>
        let delegates :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => []
          end in
        fun block =>
          RPC_context.make_call0 S.endorsing_rights ctxt block
            {| levels := levels; cycles := cycles; delegates := delegates |} tt.
End Endorsing_rights.

Module Endorsing_power.
  Definition endorsing_power
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
    let '(operation, chain_id) := function_parameter in
    let 'Tezos_raw_protocol_alpha.Alpha_context.Operation_data data :=
      protocol_data operation in
    match contents data with
    |
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _) =>
      op_gtgteqquestion
        (Baking.check_endorsement_rights ctxt chain_id
          {| shell := shell operation; protocol_data := data |})
        (fun function_parameter =>
          let '(_, slots, _) := function_parameter in
          _return (List.length slots))
    | _ => failwith "Operation is not an endorsement" % string
    end.
  
  Module S.
    Definition endorsing_power
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
        Z :=
      RPC_service.post_service
        (Some
          "Get the endorsing power of an endorsement, that is, the number of slots that the endorser has"
            % string) RPC_query.empty
        (obj2
          (req None None "endorsement_operation" % string Operation.encoding)
          (req None None "chain_id" % string
            Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)))
        int31 (op_div open_root "endorsing_power" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    register0 S.endorsing_power
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let '(op, chain_id) := function_parameter in
            endorsing_power ctxt (op, chain_id)).
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (op : Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)
    (chain_id :
      Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Z) :=
    RPC_context.make_call0 S.endorsing_power ctxt block tt (op, chain_id).
End Endorsing_power.

Module Required_endorsements.
  Definition required_endorsements
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
    (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
    _return (Baking.minimum_allowed_endorsements ctxt block_delay).
  
  Module S.
    Record t := {
      block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t }.
    
    Definition required_endorsements_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t t :=
      op_pipegt
        (op_pipeplus
          (query (fun block_delay => {| block_delay := block_delay |}))
          (field None "block_delay" % string Period.rpc_arg Period.zero
            (fun t => block_delay t))) seal.
    
    Definition required_endorsements
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context t unit
        Z :=
      RPC_service.get_service
        (Some
          "Minimum number of endorsements for a block to be valid, given a delay of the block's timestamp with respect to the minimum time to bake at the block's priority"
            % string) required_endorsements_query int31
        (op_div open_root "required_endorsements" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    register0 S.required_endorsements
      (fun ctxt =>
        fun function_parameter =>
          let '{| block_delay := block_delay |} := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            required_endorsements ctxt block_delay).
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (block_delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Z) :=
    RPC_context.make_call0 S.required_endorsements ctxt block
      {| block_delay := block_delay |} tt.
End Required_endorsements.

Module Minimal_valid_time.
  Definition minimal_valid_time
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (priority : Z)
    (endorsing_power : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_protocol_environment_alpha__Environment.Time.t) :=
    Baking.minimal_valid_time ctxt priority endorsing_power.
  
  Module S.
    Record t := {
      priority : Z;
      endorsing_power : Z }.
    
    Definition minimal_valid_time_query
      : Tezos_protocol_environment_alpha__Environment.RPC_query.t t :=
      op_pipegt
        (op_pipeplus
          (op_pipeplus
            (query
              (fun priority =>
                fun endorsing_power =>
                  {| priority := priority; endorsing_power := endorsing_power |}))
            (field None "priority" % string RPC_arg.int 0 (fun t => priority t)))
          (field None "endorsing_power" % string RPC_arg.int 0
            (fun t => endorsing_power t))) seal.
    
    Definition minimal_valid_time
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context t unit
        Tezos_protocol_environment_alpha__Environment.Time.t :=
      RPC_service.get_service
        (Some
          "Minimal valid time for a block given a priority and an endorsing power."
            % string) minimal_valid_time_query Time.encoding
        (op_div open_root "minimal_valid_time" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    register0 S.minimal_valid_time
      (fun ctxt =>
        fun function_parameter =>
          let '{| priority := priority; endorsing_power := endorsing_power |} :=
            function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            minimal_valid_time ctxt priority endorsing_power).
  
  Definition get {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (priority : Z) (endorsing_power : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.Time.t) :=
    RPC_context.make_call0 S.minimal_valid_time ctxt block
      {| priority := priority; endorsing_power := endorsing_power |} tt.
End Minimal_valid_time.

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Baking_rights.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Endorsing_rights.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Endorsing_power.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Required_endorsements.register tt in
  Minimal_valid_time.register tt.

Definition endorsement_rights
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (level : Tezos_raw_protocol_alpha.Alpha_context.Level.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  op_gtgteqquestion (Endorsing_rights.endorsement_slots ctxt (level, None))
    (fun l =>
      _return
        (List.map
          (fun function_parameter =>
            let '{| Endorsing_rights.delegate := delegate |} :=
              function_parameter in
            delegate) l)).

Definition baking_rights
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (max_priority :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha__Alpha_context.Raw_level.t *
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * (option Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t))))) :=
  let max :=
    match max_priority with
    | None => 64
    | Some m => m
    end in
  let level := Level.current ctxt in
  op_gtgteqquestion (Baking_rights.baking_priorities ctxt max (level, None))
    (fun l =>
      _return
        ((level level),
          (List.map
            (fun function_parameter =>
              let '{|
                Baking_rights.delegate := delegate;
                  Baking_rights.timestamp := timestamp
                  |} := function_parameter in
              (delegate, timestamp)) l))).

Definition endorsing_power
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (operation :
    Tezos_raw_protocol_alpha.Alpha_context.packed_operation *
      Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  Endorsing_power.endorsing_power ctxt operation.

Definition required_endorsements
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (delay : Tezos_raw_protocol_alpha.Alpha_context.Period.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  Required_endorsements.required_endorsements ctxt delay.

Definition minimal_valid_time
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (priority : Z)
  (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Time.t) :=
  Minimal_valid_time.minimal_valid_time ctxt priority endorsing_power.

src/proto_alpha/lib_protocol/delegate_storage.ml 187 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type balance =
  | Contract of Contract_repr.t
  | Rewards of Signature.Public_key_hash.t * Cycle_repr.t
  | Fees of Signature.Public_key_hash.t * Cycle_repr.t
  | Deposits of Signature.Public_key_hash.t * Cycle_repr.t

let balance_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance"
  @@ union
       [ case
           (Tag 0)
           ~title:"Contract"
           (obj2
              (req "kind" (constant "contract"))
              (req "contract" Contract_repr.encoding))
           (function Contract c -> Some ((), c) | _ -> None)
           (fun ((), c) -> Contract c);
         case
           (Tag 1)
           ~title:"Rewards"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "rewards"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Rewards (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Rewards (d, l));
         case
           (Tag 2)
           ~title:"Fees"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "fees"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Fees (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Fees (d, l));
         case
           (Tag 3)
           ~title:"Deposits"
           (obj4
              (req "kind" (constant "freezer"))
              (req "category" (constant "deposits"))
              (req "delegate" Signature.Public_key_hash.encoding)
              (req "cycle" Cycle_repr.encoding))
           (function Deposits (d, l) -> Some ((), (), d, l) | _ -> None)
           (fun ((), (), d, l) -> Deposits (d, l)) ]

type balance_update = Debited of Tez_repr.t | Credited of Tez_repr.t

let balance_update_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance_update"
  @@ obj1
       (req
          "change"
          (conv
             (function
               | Credited v ->
                   Tez_repr.to_mutez v
               | Debited v ->
                   Int64.neg (Tez_repr.to_mutez v))
             ( Json.wrap_error
             @@ fun v ->
             if Compare.Int64.(v < 0L) then
               match Tez_repr.of_mutez (Int64.neg v) with
               | Some v ->
                   Debited v
               | None ->
                   failwith "Qty.of_mutez"
             else
               match Tez_repr.of_mutez v with
               | Some v ->
                   Credited v
               | None ->
                   failwith "Qty.of_mutez" )
             int64))

type balance_updates = (balance * balance_update) list

let balance_updates_encoding =
  let open Data_encoding in
  def "operation_metadata.alpha.balance_updates"
  @@ list (merge_objs balance_encoding balance_update_encoding)

let cleanup_balance_updates balance_updates =
  List.filter
    (fun (_, (Credited update | Debited update)) ->
      not (Tez_repr.equal update Tez_repr.zero))
    balance_updates

type frozen_balance = {
  deposit : Tez_repr.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
}

let frozen_balance_encoding =
  let open Data_encoding in
  conv
    (fun {deposit; fees; rewards} -> (deposit, fees, rewards))
    (fun (deposit, fees, rewards) -> {deposit; fees; rewards})
    (obj3
       (req "deposit" Tez_repr.encoding)
       (req "fees" Tez_repr.encoding)
       (req "rewards" Tez_repr.encoding))

type error +=
  | No_deletion of Signature.Public_key_hash.t (* `Permanent *)
  | Active_delegate (* `Temporary *)
  | Current_delegate (* `Temporary *)
  | Empty_delegate_account of Signature.Public_key_hash.t (* `Temporary *)
  | Balance_too_low_for_deposit of {
      delegate : Signature.Public_key_hash.t;
      deposit : Tez_repr.t;
      balance : Tez_repr.t;
    }

(* `Temporary *)

let () =
  register_error_kind
    `Permanent
    ~id:"delegate.no_deletion"
    ~title:"Forbidden delegate deletion"
    ~description:"Tried to unregister a delegate"
    ~pp:(fun ppf delegate ->
      Format.fprintf
        ppf
        "Delegate deletion is forbidden (%a)"
        Signature.Public_key_hash.pp
        delegate)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function No_deletion c -> Some c | _ -> None)
    (fun c -> No_deletion c) ;
  register_error_kind
    `Temporary
    ~id:"delegate.already_active"
    ~title:"Delegate already active"
    ~description:"Useless delegate reactivation"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "The delegate is still active, no need to refresh it")
    Data_encoding.empty
    (function Active_delegate -> Some () | _ -> None)
    (fun () -> Active_delegate) ;
  register_error_kind
    `Temporary
    ~id:"delegate.unchanged"
    ~title:"Unchanged delegated"
    ~description:"Contract already delegated to the given delegate"
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "The contract is already delegated to the same delegate")
    Data_encoding.empty
    (function Current_delegate -> Some () | _ -> None)
    (fun () -> Current_delegate) ;
  register_error_kind
    `Permanent
    ~id:"delegate.empty_delegate_account"
    ~title:"Empty delegate account"
    ~description:
      "Cannot register a delegate when its implicit account is empty"
    ~pp:(fun ppf delegate ->
      Format.fprintf
        ppf
        "Delegate registration is forbidden when the delegate\n\
        \           implicit account is empty (%a)"
        Signature.Public_key_hash.pp
        delegate)
    Data_encoding.(obj1 (req "delegate" Signature.Public_key_hash.encoding))
    (function Empty_delegate_account c -> Some c | _ -> None)
    (fun c -> Empty_delegate_account c) ;
  register_error_kind
    `Temporary
    ~id:"delegate.balance_too_low_for_deposit"
    ~title:"Balance too low for deposit"
    ~description:"Cannot freeze deposit when the balance is too low"
    ~pp:(fun ppf (delegate, balance, deposit) ->
      Format.fprintf
        ppf
        "Delegate %a has a too low balance (%a) to deposit %a"
        Signature.Public_key_hash.pp
        delegate
        Tez_repr.pp
        balance
        Tez_repr.pp
        deposit)
    Data_encoding.(
      obj3
        (req "delegate" Signature.Public_key_hash.encoding)
        (req "balance" Tez_repr.encoding)
        (req "deposit" Tez_repr.encoding))
    (function
      | Balance_too_low_for_deposit {delegate; balance; deposit} ->
          Some (delegate, balance, deposit)
      | _ ->
          None)
    (fun (delegate, balance, deposit) ->
      Balance_too_low_for_deposit {delegate; balance; deposit})

let link c contract delegate =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  Roll_storage.Delegate.add_amount c delegate balance
  >>=? fun c ->
  Storage.Contract.Delegated.add
    (c, Contract_repr.implicit_contract delegate)
    contract
  >>= fun c -> return c

let unlink c contract =
  Storage.Contract.Balance.get c contract
  >>=? fun balance ->
  Storage.Contract.Delegate.get_option c contract
  >>=? function
  | None ->
      return c
  | Some delegate ->
      (* Removes the balance of the contract from the delegate *)
      Roll_storage.Delegate.remove_amount c delegate balance
      >>=? fun c ->
      Storage.Contract.Delegated.del
        (c, Contract_repr.implicit_contract delegate)
        contract
      >>= fun c -> return c

let known c delegate =
  Storage.Contract.Manager.get_option
    c
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | None | Some (Manager_repr.Hash _) ->
      return_false
  | Some (Manager_repr.Public_key _) ->
      return_true

(* A delegate is registered if its "implicit account" delegates to itself. *)
let registered c delegate =
  Storage.Contract.Delegate.get_option
    c
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | Some current_delegate ->
      return @@ Signature.Public_key_hash.equal delegate current_delegate
  | None ->
      return_false

let init ctxt contract delegate =
  known ctxt delegate
  >>=? fun known_delegate ->
  fail_unless known_delegate (Roll_storage.Unregistered_delegate delegate)
  >>=? fun () ->
  registered ctxt delegate
  >>=? fun is_registered ->
  fail_unless is_registered (Roll_storage.Unregistered_delegate delegate)
  >>=? fun () ->
  Storage.Contract.Delegate.init ctxt contract delegate
  >>=? fun ctxt -> link ctxt contract delegate

let get = Roll_storage.get_contract_delegate

let set c contract delegate =
  match delegate with
  | None -> (
      let delete () =
        unlink c contract
        >>=? fun c ->
        Storage.Contract.Delegate.remove c contract >>= fun c -> return c
      in
      match Contract_repr.is_implicit contract with
      | Some pkh ->
          (* check if contract is a registered delegate *)
          registered c pkh
          >>=? fun is_registered ->
          if is_registered then fail (No_deletion pkh) else delete ()
      | None ->
          delete () )
  | Some delegate ->
      known c delegate
      >>=? fun known_delegate ->
      registered c delegate
      >>=? fun registered_delegate ->
      let self_delegation =
        match Contract_repr.is_implicit contract with
        | Some pkh ->
            Signature.Public_key_hash.equal pkh delegate
        | None ->
            false
      in
      if (not known_delegate) || not (registered_delegate || self_delegation)
      then fail (Roll_storage.Unregistered_delegate delegate)
      else
        Storage.Contract.Delegate.get_option c contract
        >>=? (function
               | Some current_delegate
                 when Signature.Public_key_hash.equal delegate current_delegate
                 ->
                   if self_delegation then
                     Roll_storage.Delegate.is_inactive c delegate
                     >>=? function
                     | true -> return_unit | false -> fail Active_delegate
                   else fail Current_delegate
               | None | Some _ ->
                   return_unit)
        >>=? fun () ->
        (* check if contract is a registered delegate *)
        ( match Contract_repr.is_implicit contract with
        | Some pkh ->
            registered c pkh
            >>=? fun is_registered ->
            (* allow self-delegation to re-activate *)
            if (not self_delegation) && is_registered then
              fail (No_deletion pkh)
            else return_unit
        | None ->
            return_unit )
        >>=? fun () ->
        Storage.Contract.Balance.mem c contract
        >>= fun exists ->
        fail_when
          (self_delegation && not exists)
          (Empty_delegate_account delegate)
        >>=? fun () ->
        unlink c contract
        >>=? fun c ->
        Storage.Contract.Delegate.init_set c contract delegate
        >>= fun c ->
        link c contract delegate
        >>=? fun c ->
        ( if self_delegation then
          Storage.Delegates.add c delegate
          >>= fun c ->
          Roll_storage.Delegate.set_active c delegate >>=? fun c -> return c
        else return c )
        >>=? fun c -> return c

let remove ctxt contract = unlink ctxt contract

let delegated_contracts ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegated.elements (ctxt, contract)

let get_frozen_deposit ctxt contract cycle =
  Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_deposit ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_deposit ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  Roll_storage.Delegate.set_active ctxt delegate
  >>=? fun ctxt ->
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance ->
  Lwt.return
    (record_trace
       (Balance_too_low_for_deposit {delegate; deposit = amount; balance})
       Tez_repr.(balance -? amount))
  >>=? fun new_balance ->
  Storage.Contract.Balance.set ctxt contract new_balance
  >>=? fun ctxt -> credit_frozen_deposit ctxt delegate cycle amount

let get_frozen_fees ctxt contract cycle =
  Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_fees ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_fees ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_fees ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  Roll_storage.Delegate.add_amount ctxt delegate amount
  >>=? fun ctxt -> credit_frozen_fees ctxt delegate cycle amount

let burn_fees ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_fees ctxt contract cycle
  >>=? fun old_amount ->
  ( match Tez_repr.(old_amount -? amount) with
  | Ok new_amount ->
      Roll_storage.Delegate.remove_amount ctxt delegate amount
      >>=? fun ctxt -> return (new_amount, ctxt)
  | Error _ ->
      Roll_storage.Delegate.remove_amount ctxt delegate old_amount
      >>=? fun ctxt -> return (Tez_repr.zero, ctxt) )
  >>=? fun (new_amount, ctxt) ->
  Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt -> return ctxt

let get_frozen_rewards ctxt contract cycle =
  Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle
  >>=? function None -> return Tez_repr.zero | Some frozen -> return frozen

let credit_frozen_rewards ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_rewards ctxt contract cycle
  >>=? fun old_amount ->
  Lwt.return Tez_repr.(old_amount +? amount)
  >>=? fun new_amount ->
  Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt ->
  Storage.Delegates_with_frozen_balance.add (ctxt, cycle) delegate
  >>= fun ctxt -> return ctxt

let freeze_rewards ctxt delegate amount =
  let {Level_repr.cycle; _} = Level_storage.current ctxt in
  credit_frozen_rewards ctxt delegate cycle amount

let burn_rewards ctxt delegate cycle amount =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_rewards ctxt contract cycle
  >>=? fun old_amount ->
  let new_amount =
    match Tez_repr.(old_amount -? amount) with
    | Error _ ->
        Tez_repr.zero
    | Ok new_amount ->
        new_amount
  in
  Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle new_amount
  >>= fun ctxt -> return ctxt

let unfreeze ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  get_frozen_fees ctxt contract cycle
  >>=? fun fees ->
  get_frozen_rewards ctxt contract cycle
  >>=? fun rewards ->
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance ->
  Lwt.return Tez_repr.(deposit +? fees)
  >>=? fun unfrozen_amount ->
  Lwt.return Tez_repr.(unfrozen_amount +? rewards)
  >>=? fun unfrozen_amount ->
  Lwt.return Tez_repr.(balance +? unfrozen_amount)
  >>=? fun balance ->
  Storage.Contract.Balance.set ctxt contract balance
  >>=? fun ctxt ->
  Roll_storage.Delegate.add_amount ctxt delegate rewards
  >>=? fun ctxt ->
  Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  return
    ( ctxt,
      cleanup_balance_updates
        [ (Deposits (delegate, cycle), Debited deposit);
          (Fees (delegate, cycle), Debited fees);
          (Rewards (delegate, cycle), Debited rewards);
          ( Contract (Contract_repr.implicit_contract delegate),
            Credited unfrozen_amount ) ] )

let cycle_end ctxt last_cycle unrevealed =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.pred last_cycle with
  | None ->
      return (ctxt, [])
  | Some revealed_cycle ->
      List.fold_left
        (fun acc (u : Nonce_storage.unrevealed) ->
          acc
          >>=? fun (ctxt, balance_updates) ->
          burn_fees ctxt u.delegate revealed_cycle u.fees
          >>=? fun ctxt ->
          burn_rewards ctxt u.delegate revealed_cycle u.rewards
          >>=? fun ctxt ->
          let bus =
            [ (Fees (u.delegate, revealed_cycle), Debited u.fees);
              (Rewards (u.delegate, revealed_cycle), Debited u.rewards) ]
          in
          return (ctxt, bus @ balance_updates))
        (return (ctxt, []))
        unrevealed )
  >>=? fun (ctxt, balance_updates) ->
  match Cycle_repr.sub last_cycle preserved with
  | None ->
      return (ctxt, balance_updates, [])
  | Some unfrozen_cycle ->
      Storage.Delegates_with_frozen_balance.fold
        (ctxt, unfrozen_cycle)
        ~init:(Ok (ctxt, balance_updates))
        ~f:(fun delegate acc ->
          Lwt.return acc
          >>=? fun (ctxt, bus) ->
          unfreeze ctxt delegate unfrozen_cycle
          >>=? fun (ctxt, balance_updates) ->
          return (ctxt, balance_updates @ bus))
      >>=? fun (ctxt, balance_updates) ->
      Storage.Delegates_with_frozen_balance.clear (ctxt, unfrozen_cycle)
      >>= fun ctxt ->
      Storage.Active_delegates_with_rolls.fold
        ctxt
        ~init:(Ok (ctxt, []))
        ~f:(fun delegate acc ->
          Lwt.return acc
          >>=? fun (ctxt, deactivated) ->
          Storage.Contract.Delegate_desactivation.get
            ctxt
            (Contract_repr.implicit_contract delegate)
          >>=? fun cycle ->
          if Cycle_repr.(cycle <= last_cycle) then
            Roll_storage.Delegate.set_inactive ctxt delegate
            >>=? fun ctxt -> return (ctxt, delegate :: deactivated)
          else return (ctxt, deactivated))
      >>=? fun (ctxt, deactivated) ->
      return (ctxt, balance_updates, deactivated)

let punish ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  get_frozen_fees ctxt contract cycle
  >>=? fun fees ->
  get_frozen_rewards ctxt contract cycle
  >>=? fun rewards ->
  Roll_storage.Delegate.remove_amount ctxt delegate deposit
  >>=? fun ctxt ->
  Roll_storage.Delegate.remove_amount ctxt delegate fees
  >>=? fun ctxt ->
  (* Rewards are not accounted in the delegate's rolls yet... *)
  Storage.Contract.Frozen_deposits.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_fees.remove (ctxt, contract) cycle
  >>= fun ctxt ->
  Storage.Contract.Frozen_rewards.remove (ctxt, contract) cycle
  >>= fun ctxt -> return (ctxt, {deposit; fees; rewards})

let has_frozen_balance ctxt delegate cycle =
  let contract = Contract_repr.implicit_contract delegate in
  get_frozen_deposit ctxt contract cycle
  >>=? fun deposit ->
  if Tez_repr.(deposit <> zero) then return_true
  else
    get_frozen_fees ctxt contract cycle
    >>=? fun fees ->
    if Tez_repr.(fees <> zero) then return_true
    else
      get_frozen_rewards ctxt contract cycle
      >>=? fun rewards -> return Tez_repr.(rewards <> zero)

let frozen_balance_by_cycle_encoding =
  let open Data_encoding in
  conv
    Cycle_repr.Map.bindings
    (List.fold_left
       (fun m (c, b) -> Cycle_repr.Map.add c b m)
       Cycle_repr.Map.empty)
    (list
       (merge_objs
          (obj1 (req "cycle" Cycle_repr.encoding))
          frozen_balance_encoding))

let empty_frozen_balance =
  {deposit = Tez_repr.zero; fees = Tez_repr.zero; rewards = Tez_repr.zero}

let frozen_balance_by_cycle ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  let map = Cycle_repr.Map.empty in
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      Lwt.return
        (Cycle_repr.Map.add
           cycle
           {empty_frozen_balance with deposit = amount}
           map))
  >>= fun map ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      let balance =
        match Cycle_repr.Map.find_opt cycle map with
        | None ->
            empty_frozen_balance
        | Some balance ->
            balance
      in
      Lwt.return (Cycle_repr.Map.add cycle {balance with fees = amount} map))
  >>= fun map ->
  Storage.Contract.Frozen_rewards.fold
    (ctxt, contract)
    ~init:map
    ~f:(fun cycle amount map ->
      let balance =
        match Cycle_repr.Map.find_opt cycle map with
        | None ->
            empty_frozen_balance
        | Some balance ->
            balance
      in
      Lwt.return (Cycle_repr.Map.add cycle {balance with rewards = amount} map))
  >>= fun map -> Lwt.return map

let frozen_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  let balance = Ok Tez_repr.zero in
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance ->
  Storage.Contract.Frozen_rewards.fold
    (ctxt, contract)
    ~init:balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun balance -> Lwt.return balance

let full_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  frozen_balance ctxt delegate
  >>=? fun frozen_balance ->
  Storage.Contract.Balance.get ctxt contract
  >>=? fun balance -> Lwt.return Tez_repr.(frozen_balance +? balance)

let deactivated = Roll_storage.Delegate.is_inactive

let grace_period ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegate_desactivation.get ctxt contract

let staking_balance ctxt delegate =
  let token_per_rolls = Constants_storage.tokens_per_roll ctxt in
  Roll_storage.get_rolls ctxt delegate
  >>=? fun rolls ->
  Roll_storage.get_change ctxt delegate
  >>=? fun change ->
  let rolls = Int64.of_int (List.length rolls) in
  Lwt.return Tez_repr.(token_per_rolls *? rolls)
  >>=? fun balance -> Lwt.return Tez_repr.(balance +? change)

let delegated_balance ctxt delegate =
  let contract = Contract_repr.implicit_contract delegate in
  staking_balance ctxt delegate
  >>=? fun staking_balance ->
  Storage.Contract.Balance.get ctxt contract
  >>= fun self_staking_balance ->
  Storage.Contract.Frozen_deposits.fold
    (ctxt, contract)
    ~init:self_staking_balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>= fun self_staking_balance ->
  Storage.Contract.Frozen_fees.fold
    (ctxt, contract)
    ~init:self_staking_balance
    ~f:(fun _cycle amount acc ->
      Lwt.return acc >>=? fun acc -> Lwt.return Tez_repr.(acc +? amount))
  >>=? fun self_staking_balance ->
  Lwt.return Tez_repr.(staking_balance -? self_staking_balance)

let fold = Storage.Delegates.fold

let list = Storage.Delegates.elements
src/proto_alpha/lib_protocol/delegate_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive balance : Type :=
| Contract : Tezos_raw_protocol_alpha.Contract_repr.t -> balance
| Rewards :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Fees :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance
| Deposits :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Cycle_repr.t -> balance.

Definition balance_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding balance :=
  op_atat
    (let arg := def "operation_metadata.alpha.balance" % string in
    fun eta => arg None None eta)
    (union None
      (cons
        (case "Contract" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
          (obj2 (req None None "kind" % string (constant "contract" % string))
            (req None None "contract" % string Contract_repr.encoding))
          (fun function_parameter =>
            match function_parameter with
            | Contract c => Some (tt, c)
            | _ => None
            end)
          (fun function_parameter =>
            let '(tt, c) := function_parameter in
            Contract c))
        (cons
          (case "Rewards" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
            (obj4 (req None None "kind" % string (constant "freezer" % string))
              (req None None "category" % string (constant "rewards" % string))
              (req None None "delegate" % string
                Signature.Public_key_hash.encoding)
              (req None None "cycle" % string Cycle_repr.encoding))
            (fun function_parameter =>
              match function_parameter with
              | Rewards d l => Some (tt, tt, d, l)
              | _ => None
              end)
            (fun function_parameter =>
              let '(tt, tt, d, l) := function_parameter in
              Rewards d l))
          (cons
            (case "Fees" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
              (obj4
                (req None None "kind" % string (constant "freezer" % string))
                (req None None "category" % string (constant "fees" % string))
                (req None None "delegate" % string
                  Signature.Public_key_hash.encoding)
                (req None None "cycle" % string Cycle_repr.encoding))
              (fun function_parameter =>
                match function_parameter with
                | Fees d l => Some (tt, tt, d, l)
                | _ => None
                end)
              (fun function_parameter =>
                let '(tt, tt, d, l) := function_parameter in
                Fees d l))
            (cons
              (case "Deposits" % string None
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
                  3)
                (obj4
                  (req None None "kind" % string (constant "freezer" % string))
                  (req None None "category" % string
                    (constant "deposits" % string))
                  (req None None "delegate" % string
                    Signature.Public_key_hash.encoding)
                  (req None None "cycle" % string Cycle_repr.encoding))
                (fun function_parameter =>
                  match function_parameter with
                  | Deposits d l => Some (tt, tt, d, l)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(tt, tt, d, l) := function_parameter in
                  Deposits d l)) []))))).

Inductive balance_update : Type :=
| Debited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update
| Credited : Tezos_raw_protocol_alpha.Tez_repr.t -> balance_update.

Definition balance_update_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    balance_update :=
  op_atat
    (let arg := def "operation_metadata.alpha.balance_update" % string in
    fun eta => arg None None eta)
    (obj1
      (req None None "change" % string
        (conv
          (fun function_parameter =>
            match function_parameter with
            | Credited v => Tez_repr.to_mutez v
            | Debited v => Int64.neg (Tez_repr.to_mutez v)
            end)
          (op_atat Json.wrap_error
            (fun v =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                  v
                  (* ❌ Constant of type int64 is converted to int *)
                  0 then
                match Tez_repr.of_mutez (Int64.neg v) with
                | Some v => Debited v
                | None => failwith "Qty.of_mutez" % string
                end
              else
                match Tez_repr.of_mutez v with
                | Some v => Credited v
                | None => failwith "Qty.of_mutez" % string
                end)) None int64))).

Definition balance_updates := list (balance * balance_update).

Definition balance_updates_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list (balance * balance_update)) :=
  op_atat
    (let arg := def "operation_metadata.alpha.balance_updates" % string in
    fun eta => arg None None eta)
    (list None (merge_objs balance_encoding balance_update_encoding)).

Definition cleanup_balance_updates {A : Type}
  (balance_updates : list (A * balance_update)) : list (A * balance_update) :=
  List.filter
    (fun function_parameter =>
      let '(_, Credited update | Debited update) := function_parameter in
      not (Tez_repr.equal update Tez_repr.zero)) balance_updates.

Record frozen_balance := {
  deposit : Tezos_raw_protocol_alpha.Tez_repr.t;
  fees : Tezos_raw_protocol_alpha.Tez_repr.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t }.

Definition frozen_balance_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    frozen_balance :=
  conv
    (fun function_parameter =>
      let '{| deposit := deposit; fees := fees; rewards := rewards |} :=
        function_parameter in
      (deposit, fees, rewards))
    (fun function_parameter =>
      let '(deposit, fees, rewards) := function_parameter in
      {| deposit := deposit; fees := fees; rewards := rewards |}) None
    (obj3 (req None None "deposit" % string Tez_repr.encoding)
      (req None None "fees" % string Tez_repr.encoding)
      (req None None "rewards" % string Tez_repr.encoding)).

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition link
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (Storage.Contract.Balance.get c contract)
    (fun balance =>
      op_gtgteqquestion (Roll_storage.Delegate.add_amount c delegate balance)
        (fun c =>
          op_gtgteq
            (Storage.Contract.Delegated.add
              (c, (Contract_repr.implicit_contract delegate)) contract)
            (fun c => _return c))).

Definition unlink
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Contract.Balance.context) :=
  op_gtgteqquestion (Storage.Contract.Balance.get c contract)
    (fun balance =>
      op_gtgteqquestion (Storage.Contract.Delegate.get_option c contract)
        (fun function_parameter =>
          match function_parameter with
          | None => _return c
          | Some delegate =>
            op_gtgteqquestion
              (Roll_storage.Delegate.remove_amount c delegate balance)
              (fun c =>
                op_gtgteq
                  (Storage.Contract.Delegated.del
                    (c, (Contract_repr.implicit_contract delegate)) contract)
                  (fun c => _return c))
          end)).

Definition known
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  op_gtgteqquestion
    (Storage.Contract.Manager.get_option c
      (Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) =>
        return_false
      | Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key _) => return_true
      end).

Definition registered
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  op_gtgteqquestion
    (Storage.Contract.Delegate.get_option c
      (Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | Some current_delegate =>
        op_atat _return
          (Signature.Public_key_hash.equal delegate current_delegate)
      | None => return_false
      end).

Definition init
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (known ctxt delegate)
    (fun known_delegate =>
      op_gtgteqquestion
        (fail_unless known_delegate
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
            delegate))
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion (registered ctxt delegate)
            (fun is_registered =>
              op_gtgteqquestion
                (fail_unless is_registered
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
                    delegate))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (Storage.Contract.Delegate.init ctxt contract delegate)
                    (fun ctxt => link ctxt contract delegate))))).

Definition get
  : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_raw_protocol_alpha.Contract_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option
            Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  Roll_storage.get_contract_delegate.

Definition set
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  match delegate with
  | None =>
    let delete (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      let 'tt := function_parameter in
      op_gtgteqquestion (unlink c contract)
        (fun c =>
          op_gtgteq (Storage.Contract.Delegate.remove c contract)
            (fun c => _return c)) in
    match Contract_repr.is_implicit contract with
    | Some pkh =>
      op_gtgteqquestion (registered c pkh)
        (fun is_registered =>
          if is_registered then
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.No_deletion
                pkh)
          else
            delete tt)
    | None => delete tt
    end
  | Some delegate =>
    op_gtgteqquestion (known c delegate)
      (fun known_delegate =>
        op_gtgteqquestion (registered c delegate)
          (fun registered_delegate =>
            let self_delegation :=
              match Contract_repr.is_implicit contract with
              | Some pkh => Signature.Public_key_hash.equal pkh delegate
              | None => false
              end in
            if
              op_pipepipe (not known_delegate)
                (not (op_pipepipe registered_delegate self_delegation)) then
              fail
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
                  delegate)
            else
              op_gtgteqquestion
                (op_gtgteqquestion
                  (Storage.Contract.Delegate.get_option c contract)
                  (fun function_parameter =>
                    match function_parameter with
                    | Some current_delegate =>
                      if self_delegation then
                        op_gtgteqquestion
                          (Roll_storage.Delegate.is_inactive c delegate)
                          (fun function_parameter =>
                            match function_parameter with
                            | true => return_unit
                            | false =>
                              fail
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
                            end)
                      else
                        fail
                          Tezos_protocol_environment_alpha__Environment.Error_monad.Current_delegate
                    | None | Some _ => return_unit
                    end))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    match Contract_repr.is_implicit contract with
                    | Some pkh =>
                      op_gtgteqquestion (registered c pkh)
                        (fun is_registered =>
                          if op_andand (not self_delegation) is_registered then
                            fail
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.No_deletion
                                pkh)
                          else
                            return_unit)
                    | None => return_unit
                    end
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteq (Storage.Contract.Balance.mem c contract)
                        (fun _exists =>
                          op_gtgteqquestion
                            (fail_when (op_andand self_delegation (not _exists))
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_delegate_account
                                delegate))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion (unlink c contract)
                                (fun c =>
                                  op_gtgteq
                                    (Storage.Contract.Delegate.init_set c
                                      contract delegate)
                                    (fun c =>
                                      op_gtgteqquestion
                                        (link c contract delegate)
                                        (fun c =>
                                          op_gtgteqquestion
                                            (if self_delegation then
                                              op_gtgteq
                                                (Storage.Delegates.add c
                                                  delegate)
                                                (fun c =>
                                                  op_gtgteqquestion
                                                    (Roll_storage.Delegate.set_active
                                                      c delegate)
                                                    (fun c => _return c))
                                            else
                                              _return c) (fun c => _return c))))))))))
  end.

Definition remove
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Balance.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Balance.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Contract.Balance.context) :=
  unlink ctxt contract.

Definition delegated_contracts
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_raw_protocol_alpha.Storage.Contract.Delegated.elt) :=
  let contract := Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegated.elements (ctxt, contract).

Definition get_frozen_deposit
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  op_gtgteqquestion
    (Storage.Contract.Frozen_deposits.get_option (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None => _return Tez_repr.zero
      | Some frozen => _return frozen
      end).

Definition credit_frozen_deposit
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun old_amount =>
      op_gtgteqquestion (Lwt._return (op_plusquestion old_amount amount))
        (fun new_amount =>
          op_gtgteq
            (Storage.Contract.Frozen_deposits.init_set (ctxt, contract) cycle
              new_amount)
            (fun ctxt =>
              op_gtgteq
                (Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
                  delegate) (fun ctxt => _return ctxt)))).

Definition freeze_deposit
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let '{| Level_repr.cycle := cycle |} := Level_storage.current ctxt in
  op_gtgteqquestion (Roll_storage.Delegate.set_active ctxt delegate)
    (fun ctxt =>
      let contract := Contract_repr.implicit_contract delegate in
      op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
        (fun balance =>
          op_gtgteqquestion
            (Lwt._return
              (record_trace
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low_for_deposit
                  {| delegate := delegate; deposit := amount; balance := balance
                    |}) (op_minusquestion balance amount)))
            (fun new_balance =>
              op_gtgteqquestion
                (Storage.Contract.Balance.set ctxt contract new_balance)
                (fun ctxt => credit_frozen_deposit ctxt delegate cycle amount)))).

Definition get_frozen_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  op_gtgteqquestion
    (Storage.Contract.Frozen_fees.get_option (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None => _return Tez_repr.zero
      | Some frozen => _return frozen
      end).

Definition credit_frozen_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
    (fun old_amount =>
      op_gtgteqquestion (Lwt._return (op_plusquestion old_amount amount))
        (fun new_amount =>
          op_gtgteq
            (Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle
              new_amount)
            (fun ctxt =>
              op_gtgteq
                (Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
                  delegate) (fun ctxt => _return ctxt)))).

Definition freeze_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let '{| Level_repr.cycle := cycle |} := Level_storage.current ctxt in
  op_gtgteqquestion (Roll_storage.Delegate.add_amount ctxt delegate amount)
    (fun ctxt => credit_frozen_fees ctxt delegate cycle amount).

Definition burn_fees
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_fees.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
    (fun old_amount =>
      op_gtgteqquestion
        match op_minusquestion old_amount amount with
        | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok new_amount
          =>
          op_gtgteqquestion
            (Roll_storage.Delegate.remove_amount ctxt delegate amount)
            (fun ctxt => _return (new_amount, ctxt))
        | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
          op_gtgteqquestion
            (Roll_storage.Delegate.remove_amount ctxt delegate old_amount)
            (fun ctxt => _return (Tez_repr.zero, ctxt))
        end
        (fun function_parameter =>
          let '(new_amount, ctxt) := function_parameter in
          op_gtgteq
            (Storage.Contract.Frozen_fees.init_set (ctxt, contract) cycle
              new_amount) (fun ctxt => _return ctxt))).

Definition get_frozen_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  op_gtgteqquestion
    (Storage.Contract.Frozen_rewards.get_option (ctxt, contract) cycle)
    (fun function_parameter =>
      match function_parameter with
      | None => _return Tez_repr.zero
      | Some frozen => _return frozen
      end).

Definition credit_frozen_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
    (fun old_amount =>
      op_gtgteqquestion (Lwt._return (op_plusquestion old_amount amount))
        (fun new_amount =>
          op_gtgteq
            (Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle
              new_amount)
            (fun ctxt =>
              op_gtgteq
                (Storage.Delegates_with_frozen_balance.add (ctxt, cycle)
                  delegate) (fun ctxt => _return ctxt)))).

Definition freeze_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let '{| Level_repr.cycle := cycle |} := Level_storage.current ctxt in
  credit_frozen_rewards ctxt delegate cycle amount.

Definition burn_rewards
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_rewards.key)
  (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
    (fun old_amount =>
      let new_amount :=
        match op_minusquestion old_amount amount with
        | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
          Tez_repr.zero
        | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok new_amount
          => new_amount
        end in
      op_gtgteq
        (Storage.Contract.Frozen_rewards.init_set (ctxt, contract) cycle
          new_amount) (fun ctxt => _return ctxt)).

Definition unfreeze
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (list (balance * balance_update)))) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
        (fun fees =>
          op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
            (fun rewards =>
              op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
                (fun balance =>
                  op_gtgteqquestion (Lwt._return (op_plusquestion deposit fees))
                    (fun unfrozen_amount =>
                      op_gtgteqquestion
                        (Lwt._return (op_plusquestion unfrozen_amount rewards))
                        (fun unfrozen_amount =>
                          op_gtgteqquestion
                            (Lwt._return
                              (op_plusquestion balance unfrozen_amount))
                            (fun balance =>
                              op_gtgteqquestion
                                (Storage.Contract.Balance.set ctxt contract
                                  balance)
                                (fun ctxt =>
                                  op_gtgteqquestion
                                    (Roll_storage.Delegate.add_amount ctxt
                                      delegate rewards)
                                    (fun ctxt =>
                                      op_gtgteq
                                        (Storage.Contract.Frozen_deposits.remove
                                          (ctxt, contract) cycle)
                                        (fun ctxt =>
                                          op_gtgteq
                                            (Storage.Contract.Frozen_fees.remove
                                              (ctxt, contract) cycle)
                                            (fun ctxt =>
                                              op_gtgteq
                                                (Storage.Contract.Frozen_rewards.remove
                                                  (ctxt, contract) cycle)
                                                (fun ctxt =>
                                                  _return
                                                    (ctxt,
                                                      (cleanup_balance_updates
                                                        (cons
                                                          ((Deposits delegate
                                                            cycle),
                                                            (Debited deposit))
                                                          (cons
                                                            ((Fees delegate
                                                              cycle),
                                                              (Debited fees))
                                                            (cons
                                                              ((Rewards delegate
                                                                cycle),
                                                                (Debited rewards))
                                                              (cons
                                                                ((Contract
                                                                  (Contract_repr.implicit_contract
                                                                    delegate)),
                                                                  (Credited
                                                                    unfrozen_amount))
                                                                [])))))))))))))))))).

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  (unrevealed : list Tezos_raw_protocol_alpha.Nonce_storage.unrevealed)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.context *
        (list (balance * balance_update)) *
        (list Tezos_raw_protocol_alpha.Storage.Active_delegates_with_rolls.elt))) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  op_gtgteqquestion
    match Cycle_repr.pred last_cycle with
    | None => _return (ctxt, [])
    | Some revealed_cycle =>
      List.fold_left
        (fun acc =>
          fun u =>
            op_gtgteqquestion acc
              (fun function_parameter =>
                let '(ctxt, balance_updates) := function_parameter in
                op_gtgteqquestion
                  (burn_fees ctxt (delegate u) revealed_cycle (fees u))
                  (fun ctxt =>
                    op_gtgteqquestion
                      (burn_rewards ctxt (delegate u) revealed_cycle (rewards u))
                      (fun ctxt =>
                        let bus :=
                          cons
                            ((Fees (delegate u) revealed_cycle),
                              (Debited (fees u)))
                            (cons
                              ((Rewards (delegate u) revealed_cycle),
                                (Debited (rewards u))) []) in
                        _return (ctxt, (op_at bus balance_updates))))))
        (_return (ctxt, [])) unrevealed
    end
    (fun function_parameter =>
      let '(ctxt, balance_updates) := function_parameter in
      match Cycle_repr.sub last_cycle preserved with
      | None => _return (ctxt, balance_updates, [])
      | Some unfrozen_cycle =>
        op_gtgteqquestion
          (Storage.Delegates_with_frozen_balance.fold (ctxt, unfrozen_cycle)
            (Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
              (ctxt, balance_updates))
            (fun delegate =>
              fun acc =>
                op_gtgteqquestion (Lwt._return acc)
                  (fun function_parameter =>
                    let '(ctxt, bus) := function_parameter in
                    op_gtgteqquestion (unfreeze ctxt delegate unfrozen_cycle)
                      (fun function_parameter =>
                        let '(ctxt, balance_updates) := function_parameter in
                        _return (ctxt, (op_at balance_updates bus))))))
          (fun function_parameter =>
            let '(ctxt, balance_updates) := function_parameter in
            op_gtgteq
              (Storage.Delegates_with_frozen_balance.clear
                (ctxt, unfrozen_cycle))
              (fun ctxt =>
                op_gtgteqquestion
                  (Storage.Active_delegates_with_rolls.fold ctxt
                    (Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                      (ctxt, []))
                    (fun delegate =>
                      fun acc =>
                        op_gtgteqquestion (Lwt._return acc)
                          (fun function_parameter =>
                            let '(ctxt, deactivated) := function_parameter in
                            op_gtgteqquestion
                              (Storage.Contract.Delegate_desactivation.get ctxt
                                (Contract_repr.implicit_contract delegate))
                              (fun cycle =>
                                if op_lteq cycle last_cycle then
                                  op_gtgteqquestion
                                    (Roll_storage.Delegate.set_inactive ctxt
                                      delegate)
                                    (fun ctxt =>
                                      _return
                                        (ctxt, (cons delegate deactivated)))
                                else
                                  _return (ctxt, deactivated)))))
                  (fun function_parameter =>
                    let '(ctxt, deactivated) := function_parameter in
                    _return (ctxt, balance_updates, deactivated))))
      end).

Definition punish
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t * frozen_balance)) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
        (fun fees =>
          op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
            (fun rewards =>
              op_gtgteqquestion
                (Roll_storage.Delegate.remove_amount ctxt delegate deposit)
                (fun ctxt =>
                  op_gtgteqquestion
                    (Roll_storage.Delegate.remove_amount ctxt delegate fees)
                    (fun ctxt =>
                      op_gtgteq
                        (Storage.Contract.Frozen_deposits.remove
                          (ctxt, contract) cycle)
                        (fun ctxt =>
                          op_gtgteq
                            (Storage.Contract.Frozen_fees.remove
                              (ctxt, contract) cycle)
                            (fun ctxt =>
                              op_gtgteq
                                (Storage.Contract.Frozen_rewards.remove
                                  (ctxt, contract) cycle)
                                (fun ctxt =>
                                  _return
                                    (ctxt,
                                      {| deposit := deposit; fees := fees;
                                        rewards := rewards |}))))))))).

Definition has_frozen_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (cycle : Tezos_raw_protocol_alpha.Storage.Contract.Frozen_deposits.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (get_frozen_deposit ctxt contract cycle)
    (fun deposit =>
      if op_ltgt deposit zero then
        return_true
      else
        op_gtgteqquestion (get_frozen_fees ctxt contract cycle)
          (fun fees =>
            if op_ltgt fees zero then
              return_true
            else
              op_gtgteqquestion (get_frozen_rewards ctxt contract cycle)
                (fun rewards => _return (op_ltgt rewards zero)))).

Definition frozen_balance_by_cycle_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance) :=
  conv Cycle_repr.Map.bindings
    (List.fold_left
      (fun m =>
        fun function_parameter =>
          let '(c, b) := function_parameter in
          Cycle_repr.Map.add c b m) Cycle_repr.Map.empty) None
    (list None
      (merge_objs (obj1 (req None None "cycle" % string Cycle_repr.encoding))
        frozen_balance_encoding)).

Definition empty_frozen_balance : frozen_balance :=
  {| deposit := Tez_repr.zero; fees := Tez_repr.zero; rewards := Tez_repr.zero
    |}.

Definition frozen_balance_by_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_raw_protocol_alpha.Cycle_repr.Map.t frozen_balance) :=
  let contract := Contract_repr.implicit_contract delegate in
  let map := Cycle_repr.Map.empty in
  op_gtgteq
    (Storage.Contract.Frozen_deposits.fold (ctxt, contract) map
      (fun cycle =>
        fun amount =>
          fun map =>
            Lwt._return
              (Cycle_repr.Map.add cycle
                (* ❌ Record substitution not handled *)
                record_substitution map)))
    (fun map =>
      op_gtgteq
        (Storage.Contract.Frozen_fees.fold (ctxt, contract) map
          (fun cycle =>
            fun amount =>
              fun map =>
                let balance :=
                  match Cycle_repr.Map.find_opt cycle map with
                  | None => empty_frozen_balance
                  | Some balance => balance
                  end in
                Lwt._return
                  (Cycle_repr.Map.add cycle
                    (* ❌ Record substitution not handled *)
                    record_substitution map)))
        (fun map =>
          op_gtgteq
            (Storage.Contract.Frozen_rewards.fold (ctxt, contract) map
              (fun cycle =>
                fun amount =>
                  fun map =>
                    let balance :=
                      match Cycle_repr.Map.find_opt cycle map with
                      | None => empty_frozen_balance
                      | Some balance => balance
                      end in
                    Lwt._return
                      (Cycle_repr.Map.add cycle
                        (* ❌ Record substitution not handled *)
                        record_substitution map))) (fun map => Lwt._return map))).

Definition frozen_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Pervasives.result
      Tezos_raw_protocol_alpha.Tez_repr.t
      (list Tezos_protocol_environment_alpha__Environment.Error_monad.error)) :=
  let contract := Contract_repr.implicit_contract delegate in
  let balance :=
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Tez_repr.zero in
  op_gtgteq
    (Storage.Contract.Frozen_deposits.fold (ctxt, contract) balance
      (fun _cycle =>
        fun amount =>
          fun acc =>
            op_gtgteqquestion (Lwt._return acc)
              (fun acc => Lwt._return (op_plusquestion acc amount))))
    (fun balance =>
      op_gtgteq
        (Storage.Contract.Frozen_fees.fold (ctxt, contract) balance
          (fun _cycle =>
            fun amount =>
              fun acc =>
                op_gtgteqquestion (Lwt._return acc)
                  (fun acc => Lwt._return (op_plusquestion acc amount))))
        (fun balance =>
          op_gtgteq
            (Storage.Contract.Frozen_rewards.fold (ctxt, contract) balance
              (fun _cycle =>
                fun amount =>
                  fun acc =>
                    op_gtgteqquestion (Lwt._return acc)
                      (fun acc => Lwt._return (op_plusquestion acc amount))))
            (fun balance => Lwt._return balance))).

Definition full_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (frozen_balance ctxt delegate)
    (fun frozen_balance =>
      op_gtgteqquestion (Storage.Contract.Balance.get ctxt contract)
        (fun balance => Lwt._return (op_plusquestion frozen_balance balance))).

Definition deactivated
  : Tezos_raw_protocol_alpha.Raw_context.t ->
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
  Roll_storage.Delegate.is_inactive.

Definition grace_period
  (ctxt :
    Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Contract.Delegate_desactivation.value) :=
  let contract := Contract_repr.implicit_contract delegate in
  Storage.Contract.Delegate_desactivation.get ctxt contract.

Definition staking_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  let token_per_rolls := Constants_storage.tokens_per_roll ctxt in
  op_gtgteqquestion (Roll_storage.get_rolls ctxt delegate)
    (fun rolls =>
      op_gtgteqquestion (Roll_storage.get_change ctxt delegate)
        (fun change =>
          let rolls := Int64.of_int (List.length rolls) in
          op_gtgteqquestion
            (Lwt._return (op_starquestion token_per_rolls rolls))
            (fun balance => Lwt._return (op_plusquestion balance change)))).

Definition delegated_balance
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  let contract := Contract_repr.implicit_contract delegate in
  op_gtgteqquestion (staking_balance ctxt delegate)
    (fun staking_balance =>
      op_gtgteq (Storage.Contract.Balance.get ctxt contract)
        (fun self_staking_balance =>
          op_gtgteq
            (Storage.Contract.Frozen_deposits.fold (ctxt, contract)
              self_staking_balance
              (fun _cycle =>
                fun amount =>
                  fun acc =>
                    op_gtgteqquestion (Lwt._return acc)
                      (fun acc => Lwt._return (op_plusquestion acc amount))))
            (fun self_staking_balance =>
              op_gtgteqquestion
                (Storage.Contract.Frozen_fees.fold (ctxt, contract)
                  self_staking_balance
                  (fun _cycle =>
                    fun amount =>
                      fun acc =>
                        op_gtgteqquestion (Lwt._return acc)
                          (fun acc => Lwt._return (op_plusquestion acc amount))))
                (fun self_staking_balance =>
                  Lwt._return
                    (op_minusquestion staking_balance self_staking_balance))))).

Definition fold {A : Type}
  : Tezos_raw_protocol_alpha.Storage.Delegates.context ->
    A ->
      (Tezos_raw_protocol_alpha.Storage.Delegates.elt ->
        A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  Storage.Delegates.fold.

Definition list
  : Tezos_raw_protocol_alpha.Storage.Delegates.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list Tezos_raw_protocol_alpha.Storage.Delegates.elt) :=
  Storage.Delegates.elements.

src/proto_alpha/lib_protocol/fees_storage.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Cannot_pay_storage_fee (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

type error += Storage_limit_too_high (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Temporary
    ~id:"contract.cannot_pay_storage_fee"
    ~title:"Cannot pay storage fee"
    ~description:"The storage fee is higher than the contract balance"
    ~pp:(fun ppf () -> Format.fprintf ppf "Cannot pay storage storage fee")
    Data_encoding.empty
    (function Cannot_pay_storage_fee -> Some () | _ -> None)
    (fun () -> Cannot_pay_storage_fee) ;
  register_error_kind
    `Temporary
    ~id:"storage_exhausted.operation"
    ~title:"Storage quota exceeded for the operation"
    ~description:
      "A script or one of its callee wrote more bytes than the operation said \
       it would"
    Data_encoding.empty
    (function Operation_quota_exceeded -> Some () | _ -> None)
    (fun () -> Operation_quota_exceeded) ;
  register_error_kind
    `Permanent
    ~id:"storage_limit_too_high"
    ~title:"Storage limit out of protocol hard bounds"
    ~description:"A transaction tried to exceed the hard limit on storage"
    empty
    (function Storage_limit_too_high -> Some () | _ -> None)
    (fun () -> Storage_limit_too_high)

let origination_burn c =
  let origination_size = Constants_storage.origination_size c in
  let cost_per_byte = Constants_storage.cost_per_byte c in
  (* the origination burn, measured in bytes *)
  Lwt.return Tez_repr.(cost_per_byte *? Int64.of_int origination_size)
  >>=? fun to_be_paid ->
  return (Raw_context.update_allocated_contracts_count c, to_be_paid)

let record_paid_storage_space c contract =
  Contract_storage.used_storage_space c contract
  >>=? fun size ->
  Contract_storage.set_paid_storage_space_and_return_fees_to_pay
    c
    contract
    size
  >>=? fun (to_be_paid, c) ->
  let c = Raw_context.update_storage_space_to_pay c to_be_paid in
  let cost_per_byte = Constants_storage.cost_per_byte c in
  Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 to_be_paid)
  >>=? fun to_burn -> return (c, size, to_be_paid, to_burn)

let burn_storage_fees c ~storage_limit ~payer =
  let origination_size = Constants_storage.origination_size c in
  let (c, storage_space_to_pay, allocated_contracts) =
    Raw_context.clear_storage_space_to_pay c
  in
  let storage_space_for_allocated_contracts =
    Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size)
  in
  let consumed =
    Z.add storage_space_to_pay storage_space_for_allocated_contracts
  in
  let remaining = Z.sub storage_limit consumed in
  if Compare.Z.(remaining < Z.zero) then fail Operation_quota_exceeded
  else
    let cost_per_byte = Constants_storage.cost_per_byte c in
    Lwt.return Tez_repr.(cost_per_byte *? Z.to_int64 consumed)
    >>=? fun to_burn ->
    (* Burning the fees... *)
    if Tez_repr.(to_burn = Tez_repr.zero) then
      (* If the payer was was deleted by transfering all its balance, and no space was used,
         burning zero would fail *)
      return c
    else
      trace
        Cannot_pay_storage_fee
        ( Contract_storage.must_exist c payer
        >>=? fun () -> Contract_storage.spend c payer to_burn )
      >>=? fun c -> return c

let check_storage_limit c ~storage_limit =
  if
    Compare.Z.(
      storage_limit
      > (Raw_context.constants c).hard_storage_limit_per_operation)
    || Compare.Z.(storage_limit < Z.zero)
  then error Storage_limit_too_high
  else ok ()

let start_counting_storage_fees c = Raw_context.init_storage_space_to_pay c
src/proto_alpha/lib_protocol/fees_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition origination_burn (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_raw_protocol_alpha.Tez_repr.t)) :=
  let origination_size := Constants_storage.origination_size c in
  let cost_per_byte := Constants_storage.cost_per_byte c in
  op_gtgteqquestion
    (Lwt._return (op_starquestion cost_per_byte (Int64.of_int origination_size)))
    (fun to_be_paid =>
      _return ((Raw_context.update_allocated_contracts_count c), to_be_paid)).

Definition record_paid_storage_space
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (contract : Tezos_raw_protocol_alpha.Contract_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_raw_protocol_alpha.Tez_repr.t)) :=
  op_gtgteqquestion (Contract_storage.used_storage_space c contract)
    (fun size =>
      op_gtgteqquestion
        (Contract_storage.set_paid_storage_space_and_return_fees_to_pay c
          contract size)
        (fun function_parameter =>
          let '(to_be_paid, c) := function_parameter in
          let c := Raw_context.update_storage_space_to_pay c to_be_paid in
          let cost_per_byte := Constants_storage.cost_per_byte c in
          op_gtgteqquestion
            (Lwt._return (op_starquestion cost_per_byte (Z.to_int64 to_be_paid)))
            (fun to_burn => _return (c, size, to_be_paid, to_burn)))).

Definition burn_storage_fees
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
  (payer : Tezos_raw_protocol_alpha.Contract_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let origination_size := Constants_storage.origination_size c in
  let '(c, storage_space_to_pay, allocated_contracts) :=
    Raw_context.clear_storage_space_to_pay c in
  let storage_space_for_allocated_contracts :=
    Z.mul (Z.of_int allocated_contracts) (Z.of_int origination_size) in
  let consumed :=
    Z.add storage_space_to_pay storage_space_for_allocated_contracts in
  let remaining := Z.sub storage_limit consumed in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      remaining Z.zero then
    fail
      Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded
  else
    let cost_per_byte := Constants_storage.cost_per_byte c in
    op_gtgteqquestion
      (Lwt._return (op_starquestion cost_per_byte (Z.to_int64 consumed)))
      (fun to_burn =>
        if op_eq to_burn Tez_repr.zero then
          _return c
        else
          op_gtgteqquestion
            (trace
              Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_pay_storage_fee
              (op_gtgteqquestion (Contract_storage.must_exist c payer)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  Contract_storage.spend c payer to_burn))) (fun c => _return c)).

Definition check_storage_limit
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (storage_limit :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  if
    op_pipepipe
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        storage_limit
        (hard_storage_limit_per_operation (Raw_context.constants c)))
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
        storage_limit Z.zero) then
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_limit_too_high
  else
    ok tt.

Definition start_counting_storage_fees
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_raw_protocol_alpha.Raw_context.t :=
  Raw_context.init_storage_space_to_pay c.

src/proto_alpha/lib_protocol/fitness_repr.ml 5 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Invalid_fitness (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_fitness"
    ~title:"Invalid fitness"
    ~description:"Fitness representation should be exactly 8 bytes long."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid fitness")
    Data_encoding.empty
    (function Invalid_fitness -> Some () | _ -> None)
    (fun () -> Invalid_fitness)

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i ; b

let int64_of_bytes b =
  if Compare.Int.(MBytes.length b <> 8) then error Invalid_fitness
  else ok (MBytes.get_int64 b 0)

let from_int64 fitness =
  [MBytes.of_string Constants_repr.version_number; int64_to_bytes fitness]

let to_int64 = function
  | [version; fitness]
    when Compare.String.(
           MBytes.to_string version = Constants_repr.version_number) ->
      int64_of_bytes fitness
  | [version; _fitness (* ignored since higher version takes priority *)]
    when Compare.String.(
           MBytes.to_string version = Constants_repr.version_number_004) ->
      ok 0L
  | [] ->
      ok 0L
  | _ ->
      error Invalid_fitness
src/proto_alpha/lib_protocol/fitness_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition int64_to_bytes (i : int64)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  let b := MBytes.create 8 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := MBytes.set_int64 b 0 i in
  b.

Definition int64_of_bytes
  (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
      (MBytes.length b) 8 then
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_fitness
  else
    ok (MBytes.get_int64 b 0).

Definition from_int64 (fitness : int64)
  : list Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  cons (MBytes.of_string Constants_repr.version_number)
    (cons (int64_to_bytes fitness) []).

Definition to_int64
  (function_parameter :
    list Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
  match function_parameter with
  | cons version (cons fitness []) => int64_of_bytes fitness
  | cons version (cons _fitness []) =>
    ok
      (* ❌ Constant of type int64 is converted to int *)
      0
  | [] =>
    ok
      (* ❌ Constant of type int64 is converted to int *)
      0
  | _ =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_fitness
  end.

src/proto_alpha/lib_protocol/fitness_storage.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let current = Raw_context.current_fitness

let increase ?(gap = 1) ctxt =
  let fitness = current ctxt in
  Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness)
src/proto_alpha/lib_protocol/fitness_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition current
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_protocol_environment_alpha__Environment.Int64.t :=
  Raw_context.current_fitness.

Definition increase (op_staroptstar : option Z)
  : Tezos_raw_protocol_alpha.Raw_context.context ->
    Tezos_raw_protocol_alpha.Raw_context.t :=
  let gap :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 1
    end in
  fun ctxt =>
    let fitness := current ctxt in
    Raw_context.set_current_fitness ctxt (Int64.add (Int64.of_int gap) fitness).

src/proto_alpha/lib_protocol/gas_limit_repr.ml 8 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Unaccounted | Limited of {remaining : Z.t}

type internal_gas = Z.t

type cost = {
  allocations : Z.t;
  steps : Z.t;
  reads : Z.t;
  writes : Z.t;
  bytes_read : Z.t;
  bytes_written : Z.t;
}

let encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Limited"
        z
        (function Limited {remaining} -> Some remaining | _ -> None)
        (fun remaining -> Limited {remaining});
      case
        (Tag 1)
        ~title:"Unaccounted"
        (constant "unaccounted")
        (function Unaccounted -> Some () | _ -> None)
        (fun () -> Unaccounted) ]

let pp ppf = function
  | Unaccounted ->
      Format.fprintf ppf "unaccounted"
  | Limited {remaining} ->
      Format.fprintf ppf "%s units remaining" (Z.to_string remaining)

let cost_encoding =
  let open Data_encoding in
  conv
    (fun {allocations; steps; reads; writes; bytes_read; bytes_written} ->
      (allocations, steps, reads, writes, bytes_read, bytes_written))
    (fun (allocations, steps, reads, writes, bytes_read, bytes_written) ->
      {allocations; steps; reads; writes; bytes_read; bytes_written})
    (obj6
       (req "allocations" z)
       (req "steps" z)
       (req "reads" z)
       (req "writes" z)
       (req "bytes_read" z)
       (req "bytes_written" z))

let pp_cost ppf {allocations; steps; reads; writes; bytes_read; bytes_written}
    =
  Format.fprintf
    ppf
    "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))"
    (Z.to_string steps)
    (Z.to_string allocations)
    (Z.to_string reads)
    (Z.to_string bytes_read)
    (Z.to_string writes)
    (Z.to_string bytes_written)

type error += Block_quota_exceeded (* `Temporary *)

type error += Operation_quota_exceeded (* `Temporary *)

let allocation_weight = Z.of_int 2

let step_weight = Z.of_int 1

let read_base_weight = Z.of_int 100

let write_base_weight = Z.of_int 160

let byte_read_weight = Z.of_int 10

let byte_written_weight = Z.of_int 15

let rescaling_bits = 7

let rescaling_mask = Z.sub (Z.shift_left Z.one rescaling_bits) Z.one

let scale (z : Z.t) = Z.shift_left z rescaling_bits

let rescale (z : Z.t) = Z.shift_right z rescaling_bits

let cost_to_internal_gas (cost : cost) : internal_gas =
  Z.add
    (Z.add
       (Z.mul cost.allocations allocation_weight)
       (Z.mul cost.steps step_weight))
    (Z.add
       (Z.add
          (Z.mul cost.reads read_base_weight)
          (Z.mul cost.writes write_base_weight))
       (Z.add
          (Z.mul cost.bytes_read byte_read_weight)
          (Z.mul cost.bytes_written byte_written_weight)))

let internal_gas_to_gas internal_gas : Z.t * internal_gas =
  let gas = rescale internal_gas in
  let rest = Z.logand internal_gas rescaling_mask in
  (gas, rest)

let consume block_gas operation_gas internal_gas cost =
  match operation_gas with
  | Unaccounted ->
      ok (block_gas, Unaccounted, internal_gas)
  | Limited {remaining} ->
      let cost_internal_gas = cost_to_internal_gas cost in
      let total_internal_gas = Z.add cost_internal_gas internal_gas in
      let (gas, rest) = internal_gas_to_gas total_internal_gas in
      if Compare.Z.(gas > Z.zero) then
        let remaining = Z.sub remaining gas in
        let block_remaining = Z.sub block_gas gas in
        if Compare.Z.(remaining < Z.zero) then error Operation_quota_exceeded
        else if Compare.Z.(block_remaining < Z.zero) then
          error Block_quota_exceeded
        else ok (block_remaining, Limited {remaining}, rest)
      else ok (block_gas, operation_gas, total_internal_gas)

let check_enough block_gas operation_gas internal_gas cost =
  consume block_gas operation_gas internal_gas cost
  >|? fun (_block_remainig, _remaining, _internal_gas) -> ()

let internal_gas_zero : internal_gas = Z.zero

let alloc_cost n =
  {
    allocations = scale (Z.of_int (n + 1));
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let alloc_bytes_cost n = alloc_cost ((n + 7) / 8)

let alloc_bits_cost n = alloc_cost ((n + 63) / 64)

let atomic_step_cost n =
  {
    allocations = Z.zero;
    steps = Z.of_int (2 * n);
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let step_cost n =
  {
    allocations = Z.zero;
    steps = scale (Z.of_int n);
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let free =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.zero;
    bytes_read = Z.zero;
    bytes_written = Z.zero;
  }

let read_bytes_cost n =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = scale Z.one;
    writes = Z.zero;
    bytes_read = scale n;
    bytes_written = Z.zero;
  }

let write_bytes_cost n =
  {
    allocations = Z.zero;
    steps = Z.zero;
    reads = Z.zero;
    writes = Z.one;
    bytes_read = Z.zero;
    bytes_written = scale n;
  }

let ( +@ ) x y =
  {
    allocations = Z.add x.allocations y.allocations;
    steps = Z.add x.steps y.steps;
    reads = Z.add x.reads y.reads;
    writes = Z.add x.writes y.writes;
    bytes_read = Z.add x.bytes_read y.bytes_read;
    bytes_written = Z.add x.bytes_written y.bytes_written;
  }

let ( *@ ) x y =
  {
    allocations = Z.mul (Z.of_int x) y.allocations;
    steps = Z.mul (Z.of_int x) y.steps;
    reads = Z.mul (Z.of_int x) y.reads;
    writes = Z.mul (Z.of_int x) y.writes;
    bytes_read = Z.mul (Z.of_int x) y.bytes_read;
    bytes_written = Z.mul (Z.of_int x) y.bytes_written;
  }

let alloc_mbytes_cost n = alloc_cost 12 +@ alloc_bytes_cost n

let () =
  let open Data_encoding in
  register_error_kind
    `Temporary
    ~id:"gas_exhausted.operation"
    ~title:"Gas quota exceeded for the operation"
    ~description:
      "A script or one of its callee took more time than the operation said \
       it would"
    empty
    (function Operation_quota_exceeded -> Some () | _ -> None)
    (fun () -> Operation_quota_exceeded) ;
  register_error_kind
    `Temporary
    ~id:"gas_exhausted.block"
    ~title:"Gas quota exceeded for the block"
    ~description:
      "The sum of gas consumed by all the operations in the block exceeds the \
       hard gas limit per block"
    empty
    (function Block_quota_exceeded -> Some () | _ -> None)
    (fun () -> Block_quota_exceeded)
src/proto_alpha/lib_protocol/gas_limit_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive t : Type :=
| Unaccounted : t
| Limited : Tezos_protocol_environment_alpha__Environment.Z.t -> t.

Definition internal_gas := Tezos_protocol_environment_alpha__Environment.Z.t.

Record cost := {
  allocations : Tezos_protocol_environment_alpha__Environment.Z.t;
  steps : Tezos_protocol_environment_alpha__Environment.Z.t;
  reads : Tezos_protocol_environment_alpha__Environment.Z.t;
  writes : Tezos_protocol_environment_alpha__Environment.Z.t;
  bytes_read : Tezos_protocol_environment_alpha__Environment.Z.t;
  bytes_written : Tezos_protocol_environment_alpha__Environment.Z.t }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  union None
    (cons
      (case "Limited" % string None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0) z
        (fun function_parameter =>
          match function_parameter with
          | Limited {| remaining := remaining |} => Some remaining
          | _ => None
          end) (fun remaining => Limited {| remaining := remaining |}))
      (cons
        (case "Unaccounted" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
          (constant "unaccounted" % string)
          (fun function_parameter =>
            match function_parameter with
            | Unaccounted => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Unaccounted)) [])).

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  match function_parameter with
  | Unaccounted =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "unaccounted" % string
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
        "unaccounted" % string)
  | Limited {| remaining := remaining |} =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
            " units remaining" % string
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
        "%s units remaining" % string) (Z.to_string remaining)
  end.

Definition cost_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding cost :=
  conv
    (fun function_parameter =>
      let '{|
        allocations := allocations;
          steps := steps;
          reads := reads;
          writes := writes;
          bytes_read := bytes_read;
          bytes_written := bytes_written
          |} := function_parameter in
      (allocations, steps, reads, writes, bytes_read, bytes_written))
    (fun function_parameter =>
      let '(allocations, steps, reads, writes, bytes_read, bytes_written) :=
        function_parameter in
      {| allocations := allocations; steps := steps; reads := reads;
        writes := writes; bytes_read := bytes_read;
        bytes_written := bytes_written |}) None
    (obj6 (req None None "allocations" % string z)
      (req None None "steps" % string z) (req None None "reads" % string z)
      (req None None "writes" % string z)
      (req None None "bytes_read" % string z)
      (req None None "bytes_written" % string z)).

Definition pp_cost
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : cost) : unit :=
  let '{|
    allocations := allocations;
      steps := steps;
      reads := reads;
      writes := writes;
      bytes_read := bytes_read;
      bytes_written := bytes_written
      |} := function_parameter in
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
        "(steps: " % string
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
            ", allocs: " % string
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                ", reads: " % string
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                    " (" % string
                    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                      Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                        " bytes), writes: " % string
                        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                            " (" % string
                            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                                " bytes))" % string
                                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))))))))))
      "(steps: %s, allocs: %s, reads: %s (%s bytes), writes: %s (%s bytes))" %
        string) (Z.to_string steps) (Z.to_string allocations)
    (Z.to_string reads) (Z.to_string bytes_read) (Z.to_string writes)
    (Z.to_string bytes_written).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Definition allocation_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 2.

Definition step_weight : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.of_int 1.

Definition read_base_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 100.

Definition write_base_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 160.

Definition byte_read_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 10.

Definition byte_written_weight
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int 15.

Definition rescaling_bits : Z := 7.

Definition rescaling_mask : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.sub (Z.shift_left Z.one rescaling_bits) Z.one.

Definition scale (z : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.shift_left z rescaling_bits.

Definition rescale (z : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.shift_right z rescaling_bits.

Definition cost_to_internal_gas (cost : cost) : internal_gas :=
  Z.add
    (Z.add (Z.mul (allocations cost) allocation_weight)
      (Z.mul (steps cost) step_weight))
    (Z.add
      (Z.add (Z.mul (reads cost) read_base_weight)
        (Z.mul (writes cost) write_base_weight))
      (Z.add (Z.mul (bytes_read cost) byte_read_weight)
        (Z.mul (bytes_written cost) byte_written_weight))).

Definition internal_gas_to_gas
  (internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t * internal_gas :=
  let gas := rescale internal_gas in
  let rest := Z.logand internal_gas rescaling_mask in
  (gas, rest).

Definition consume
  (block_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (operation_gas : t)
  (internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (cost : cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.Z.t * t *
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  match operation_gas with
  | Unaccounted => ok (block_gas, Unaccounted, internal_gas)
  | Limited {| remaining := remaining |} =>
    let cost_internal_gas := cost_to_internal_gas cost in
    let total_internal_gas := Z.add cost_internal_gas internal_gas in
    let '(gas, rest) := internal_gas_to_gas total_internal_gas in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        gas Z.zero then
      let remaining := Z.sub remaining gas in
      let block_remaining := Z.sub block_gas gas in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
          remaining Z.zero then
        error
          Tezos_protocol_environment_alpha__Environment.Error_monad.Operation_quota_exceeded
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
            block_remaining Z.zero then
          error
            Tezos_protocol_environment_alpha__Environment.Error_monad.Block_quota_exceeded
        else
          ok (block_remaining, (Limited {| remaining := remaining |}), rest)
    else
      ok (block_gas, operation_gas, total_internal_gas)
  end.

Definition check_enough
  (block_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (operation_gas : t)
  (internal_gas : Tezos_protocol_environment_alpha__Environment.Z.t)
  (cost : cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  op_gtpipequestion (consume block_gas operation_gas internal_gas cost)
    (fun function_parameter =>
      let '(_block_remainig, _remaining, _internal_gas) := function_parameter in
      tt).

Definition internal_gas_zero : internal_gas := Z.zero.

Definition alloc_cost (n : Z) : cost :=
  {| allocations := scale (Z.of_int (op_plus n 1)); steps := Z.zero;
    reads := Z.zero; writes := Z.zero; bytes_read := Z.zero;
    bytes_written := Z.zero |}.

Definition alloc_bytes_cost (n : Z) : cost :=
  alloc_cost (op_div (op_plus n 7) 8).

Definition alloc_bits_cost (n : Z) : cost :=
  alloc_cost (op_div (op_plus n 63) 64).

Definition atomic_step_cost (n : Z) : cost :=
  {| allocations := Z.zero; steps := Z.of_int (op_star 2 n); reads := Z.zero;
    writes := Z.zero; bytes_read := Z.zero; bytes_written := Z.zero |}.

Definition step_cost (n : Z) : cost :=
  {| allocations := Z.zero; steps := scale (Z.of_int n); reads := Z.zero;
    writes := Z.zero; bytes_read := Z.zero; bytes_written := Z.zero |}.

Definition free : cost :=
  {| allocations := Z.zero; steps := Z.zero; reads := Z.zero; writes := Z.zero;
    bytes_read := Z.zero; bytes_written := Z.zero |}.

Definition read_bytes_cost
  (n : Tezos_protocol_environment_alpha__Environment.Z.t) : cost :=
  {| allocations := Z.zero; steps := Z.zero; reads := scale Z.one;
    writes := Z.zero; bytes_read := scale n; bytes_written := Z.zero |}.

Definition write_bytes_cost
  (n : Tezos_protocol_environment_alpha__Environment.Z.t) : cost :=
  {| allocations := Z.zero; steps := Z.zero; reads := Z.zero; writes := Z.one;
    bytes_read := Z.zero; bytes_written := scale n |}.

Definition op_plusat (x : cost) (y : cost) : cost :=
  {| allocations := Z.add (allocations x) (allocations y);
    steps := Z.add (steps x) (steps y); reads := Z.add (reads x) (reads y);
    writes := Z.add (writes x) (writes y);
    bytes_read := Z.add (bytes_read x) (bytes_read y);
    bytes_written := Z.add (bytes_written x) (bytes_written y) |}.

Definition op_starat (x : Z) (y : cost) : cost :=
  {| allocations := Z.mul (Z.of_int x) (allocations y);
    steps := Z.mul (Z.of_int x) (steps y);
    reads := Z.mul (Z.of_int x) (reads y);
    writes := Z.mul (Z.of_int x) (writes y);
    bytes_read := Z.mul (Z.of_int x) (bytes_read y);
    bytes_written := Z.mul (Z.of_int x) (bytes_written y) |}.

Definition alloc_mbytes_cost (n : Z) : cost :=
  op_plusat (alloc_cost 12) (alloc_bytes_cost n).



src/proto_alpha/lib_protocol/helpers_services.ml 598 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type error += Cannot_parse_operation (* `Branch *)

let () =
  register_error_kind
    `Branch
    ~id:"operation.cannot_parse"
    ~title:"Cannot parse operation"
    ~description:"The operation is ill-formed or for another protocol version"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed")
    Data_encoding.unit
    (function Cannot_parse_operation -> Some () | _ -> None)
    (fun () -> Cannot_parse_operation)

let parse_operation (op : Operation.raw) =
  match
    Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto
  with
  | Some protocol_data ->
      ok {shell = op.shell; protocol_data}
  | None ->
      error Cannot_parse_operation

let path = RPC_path.(open_root / "helpers")

module Scripts = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "scripts")

    let run_code_input_encoding =
      obj9
        (req "script" Script.expr_encoding)
        (req "storage" Script.expr_encoding)
        (req "input" Script.expr_encoding)
        (req "amount" Tez.encoding)
        (req "chain_id" Chain_id.encoding)
        (opt "source" Contract.encoding)
        (opt "payer" Contract.encoding)
        (opt "gas" z)
        (dft "entrypoint" string "default")

    let trace_encoding =
      def "scripted.trace" @@ list
      @@ obj3
           (req "location" Script.location_encoding)
           (req "gas" Gas.encoding)
           (req
              "stack"
              (list
                 (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))

    let run_code =
      RPC_service.post_service
        ~description:"Run a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:run_code_input_encoding
        ~output:
          (obj3
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "run_code")

    let trace_code =
      RPC_service.post_service
        ~description:
          "Run a piece of code in the current context, keeping a trace"
        ~query:RPC_query.empty
        ~input:run_code_input_encoding
        ~output:
          (obj4
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (req "trace" trace_encoding)
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "trace_code")

    let typecheck_code =
      RPC_service.post_service
        ~description:"Typecheck a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:(obj2 (req "program" Script.expr_encoding) (opt "gas" z))
        ~output:
          (obj2
             (req "type_map" Script_tc_errors_registration.type_map_enc)
             (req "gas" Gas.encoding))
        RPC_path.(path / "typecheck_code")

    let typecheck_data =
      RPC_service.post_service
        ~description:
          "Check that some data expression is well formed and of a given type \
           in the current context"
        ~query:RPC_query.empty
        ~input:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~output:(obj1 (req "gas" Gas.encoding))
        RPC_path.(path / "typecheck_data")

    let pack_data =
      RPC_service.post_service
        ~description:
          "Computes the serialized version of some data expression using the \
           same algorithm as script instruction PACK"
        ~input:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding))
        ~query:RPC_query.empty
        RPC_path.(path / "pack_data")

    let run_operation =
      RPC_service.post_service
        ~description:"Run an operation without signature checks"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "operation" Operation.encoding)
             (req "chain_id" Chain_id.encoding))
        ~output:Apply_results.operation_data_and_metadata_encoding
        RPC_path.(path / "run_operation")

    let entrypoint_type =
      RPC_service.post_service
        ~description:"Return the type of the given entrypoint"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "script" Script.expr_encoding)
             (dft "entrypoint" string "default"))
        ~output:(obj1 (req "entrypoint_type" Script.expr_encoding))
        RPC_path.(path / "entrypoint")

    let list_entrypoints =
      RPC_service.post_service
        ~description:"Return the list of entrypoints of the given script"
        ~query:RPC_query.empty
        ~input:(obj1 (req "script" Script.expr_encoding))
        ~output:
          (obj2
             (dft
                "unreachable"
                (Data_encoding.list
                   (obj1
                      (req
                         "path"
                         (Data_encoding.list
                            Michelson_v1_primitives.prim_encoding))))
                [])
             (req "entrypoints" (assoc Script.expr_encoding)))
        RPC_path.(path / "entrypoints")
  end

  let register () =
    let open Services_registration in
    let originate_dummy_contract ctxt script =
      let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, dummy_contract) ->
      let balance =
        match Tez.of_mutez 4_000_000_000_000L with
        | Some balance ->
            balance
        | None ->
            assert false
      in
      Contract.originate
        ctxt
        dummy_contract
        ~balance
        ~delegate:None
        ~script:(script, None)
      >>=? fun ctxt -> return (ctxt, dummy_contract)
    in
    register0
      S.run_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) ->
              (source, payer)
          | (Some source, None) ->
              (source, source)
          | (None, Some payer) ->
              (payer, payer)
          | (None, None) ->
              (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas ->
              gas
          | None ->
              Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.execute
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun {Script_interpreter.storage; operations; big_map_diff; _} ->
        return (storage, operations, big_map_diff)) ;
    register0
      S.trace_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) ->
              (source, payer)
          | (Some source, None) ->
              (source, source)
          | (None, Some payer) ->
              (payer, payer)
          | (None, None) ->
              (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas ->
              gas
          | None ->
              Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.trace
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun ( {Script_interpreter.storage; operations; big_map_diff; _},
                   trace ) ->
        return (storage, operations, trace, big_map_diff)) ;
    register0 S.typecheck_code (fun ctxt () (expr, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_code ctxt expr
        >>=? fun (res, ctxt) -> return (res, Gas.level ctxt)) ;
    register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_data ctxt (data, ty)
        >>=? fun ctxt -> return (Gas.level ctxt)) ;
    register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) ->
        let open Script_ir_translator in
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ))
        >>=? fun (Ex_ty typ, ctxt) ->
        parse_data ctxt ~legacy:true typ (Micheline.root expr)
        >>=? fun (data, ctxt) ->
        Script_ir_translator.pack_data ctxt typ data
        >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt)) ;
    register0
      S.run_operation
      (fun ctxt
           ()
           ({shell; protocol_data = Operation_data protocol_data}, chain_id)
           ->
        (* this code is a duplicate of Apply without signature check *)
        let partial_precheck_manager_contents (type kind) ctxt
            (op : kind Kind.manager contents) : context tzresult Lwt.t =
          let (Manager_operation
                {source; fee; counter; operation; gas_limit; storage_limit}) =
            op
          in
          Lwt.return (Gas.check_limit ctxt gas_limit)
          >>=? fun () ->
          let ctxt = Gas.set_limit ctxt gas_limit in
          Lwt.return (Fees.check_storage_limit ctxt storage_limit)
          >>=? fun () ->
          Contract.must_be_allocated ctxt (Contract.implicit_contract source)
          >>=? fun () ->
          Contract.check_counter_increment ctxt source counter
          >>=? fun () ->
          ( match operation with
          | Reveal pk ->
              Contract.reveal_manager_key ctxt source pk
          | Transaction {parameters; _} ->
              (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
              let arg_bytes =
                Data_encoding.Binary.to_bytes_exn
                  Script.lazy_expr_encoding
                  parameters
              in
              let arg =
                match
                  Data_encoding.Binary.of_bytes
                    Script.lazy_expr_encoding
                    arg_bytes
                with
                | Some arg ->
                    arg
                | None ->
                    assert false
              in
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost arg)
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt arg
              >>|? fun (_arg, ctxt) -> ctxt
          | Origination {script; _} ->
              (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
              let script_bytes =
                Data_encoding.Binary.to_bytes_exn Script.encoding script
              in
              let script =
                match
                  Data_encoding.Binary.of_bytes Script.encoding script_bytes
                with
                | Some script ->
                    script
                | None ->
                    assert false
              in
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ ( Gas.consume
                     ctxt
                     (Script.minimal_deserialize_cost script.code)
                 >>? fun ctxt ->
                 Gas.check_enough
                   ctxt
                   (Script.minimal_deserialize_cost script.storage) )
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.code
              >>=? fun (_code, ctxt) ->
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.storage
              >>|? fun (_storage, ctxt) -> ctxt
          | _ ->
              return ctxt )
          >>=? fun ctxt ->
          Contract.get_manager_key ctxt source
          >>=? fun _public_key ->
          (* signature check unplugged from here *)
          Contract.increment_counter ctxt source
          >>=? fun ctxt ->
          Contract.spend ctxt (Contract.implicit_contract source) fee
          >>=? fun ctxt -> return ctxt
        in
        let rec partial_precheck_manager_contents_list :
            type kind.
            Alpha_context.t ->
            kind Kind.manager contents_list ->
            context tzresult Lwt.t =
         fun ctxt contents_list ->
          match contents_list with
          | Single (Manager_operation _ as op) ->
              partial_precheck_manager_contents ctxt op
          | Cons ((Manager_operation _ as op), rest) ->
              partial_precheck_manager_contents ctxt op
              >>=? fun ctxt -> partial_precheck_manager_contents_list ctxt rest
        in
        let return contents =
          return
            ( Operation_data protocol_data,
              Apply_results.Operation_metadata {contents} )
        in
        let operation : _ operation = {shell; protocol_data} in
        let hash = Operation.hash {shell; protocol_data} in
        let ctxt = Contract.init_origination_nonce ctxt hash in
        let baker = Signature.Public_key_hash.zero in
        match protocol_data.contents with
        | Single (Manager_operation _) as op ->
            partial_precheck_manager_contents_list ctxt op
            >>=? fun ctxt ->
            Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
            >>= fun (_ctxt, result) -> return result
        | Cons (Manager_operation _, _) as op ->
            partial_precheck_manager_contents_list ctxt op
            >>=? fun ctxt ->
            Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
            >>= fun (_ctxt, result) -> return result
        | _ ->
            Apply.apply_contents_list
              ctxt
              chain_id
              Optimized
              shell.branch
              baker
              operation
              operation.protocol_data.contents
            >>=? fun (_ctxt, result) -> return result) ;
    register0 S.entrypoint_type (fun ctxt () (expr, entrypoint) ->
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( parse_toplevel ~legacy expr
          >>? fun (arg_type, _, _, root_name) ->
          parse_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.find_entrypoint ~root_name arg_type entrypoint
          )
        >>=? fun (_f, Ex_ty ty) ->
        unparse_ty ctxt ty
        >>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node)) ;
    register0 S.list_entrypoints (fun ctxt () expr ->
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( parse_toplevel ~legacy expr
          >>? fun (arg_type, _, _, root_name) ->
          parse_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
        >>=? fun (unreachable_entrypoint, map) ->
        return
          ( unreachable_entrypoint,
            Entrypoints_map.fold
              (fun entry (_, ty) acc ->
                (entry, Micheline.strip_locations ty) :: acc)
              map
              [] ))

  let run_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.run_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let trace_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.trace_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let typecheck_code ctxt block =
    RPC_context.make_call0 S.typecheck_code ctxt block ()

  let typecheck_data ctxt block =
    RPC_context.make_call0 S.typecheck_data ctxt block ()

  let pack_data ctxt block = RPC_context.make_call0 S.pack_data ctxt block ()

  let run_operation ctxt block =
    RPC_context.make_call0 S.run_operation ctxt block ()

  let entrypoint_type ctxt block =
    RPC_context.make_call0 S.entrypoint_type ctxt block ()

  let list_entrypoints ctxt block =
    RPC_context.make_call0 S.list_entrypoints ctxt block ()
end

module Forge = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "forge")

    let operations =
      RPC_service.post_service
        ~description:"Forge an operation"
        ~query:RPC_query.empty
        ~input:Operation.unsigned_encoding
        ~output:bytes
        RPC_path.(path / "operations")

    let empty_proof_of_work_nonce =
      MBytes.of_string
        (String.make Constants_repr.proof_of_work_nonce_size '\000')

    let protocol_data =
      RPC_service.post_service
        ~description:"Forge the protocol-specific part of a block header"
        ~query:RPC_query.empty
        ~input:
          (obj3
             (req "priority" uint16)
             (opt "nonce_hash" Nonce_hash.encoding)
             (dft
                "proof_of_work_nonce"
                (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
                empty_proof_of_work_nonce))
        ~output:(obj1 (req "protocol_data" bytes))
        RPC_path.(path / "protocol_data")
  end

  let register () =
    let open Services_registration in
    register0_noctxt S.operations (fun () (shell, proto) ->
        return
          (Data_encoding.Binary.to_bytes_exn
             Operation.unsigned_encoding
             (shell, proto))) ;
    register0_noctxt
      S.protocol_data
      (fun () (priority, seed_nonce_hash, proof_of_work_nonce) ->
        return
          (Data_encoding.Binary.to_bytes_exn
             Block_header.contents_encoding
             {priority; seed_nonce_hash; proof_of_work_nonce}))

  module Manager = struct
    let operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
        ~gas_limit ~storage_limit operations =
      Contract_services.manager_key ctxt block source
      >>= function
      | Error _ as e ->
          Lwt.return e
      | Ok revealed ->
          let ops =
            List.map
              (fun (Manager operation) ->
                Contents
                  (Manager_operation
                     {
                       source;
                       counter;
                       operation;
                       fee;
                       gas_limit;
                       storage_limit;
                     }))
              operations
          in
          let ops =
            match (sourcePubKey, revealed) with
            | (None, _) | (_, Some _) ->
                ops
            | (Some pk, None) ->
                let operation = Reveal pk in
                Contents
                  (Manager_operation
                     {
                       source;
                       counter;
                       operation;
                       fee;
                       gas_limit;
                       storage_limit;
                     })
                :: ops
          in
          RPC_context.make_call0
            S.operations
            ctxt
            block
            ()
            ({branch}, Operation.of_list ops)

    let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () =
      operations
        ctxt
        block
        ~branch
        ~source
        ~sourcePubKey
        ~counter
        ~fee
        ~gas_limit:Z.zero
        ~storage_limit:Z.zero
        []

    let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount
        ~destination ?(entrypoint = "default") ?parameters ~gas_limit
        ~storage_limit ~fee () =
      let parameters =
        Option.unopt_map
          ~f:Script.lazy_expr
          ~default:Script.unit_parameter
          parameters
      in
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit
        ~storage_limit
        [Manager (Transaction {amount; parameters; destination; entrypoint})]

    let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance
        ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () =
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit
        ~storage_limit
        [ Manager
            (Origination
               {
                 delegate = delegatePubKey;
                 script;
                 credit = balance;
                 preorigination = None;
               }) ]

    let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
        delegate =
      operations
        ctxt
        block
        ~branch
        ~source
        ?sourcePubKey
        ~counter
        ~fee
        ~gas_limit:Z.zero
        ~storage_limit:Z.zero
        [Manager (Delegation delegate)]
  end

  let operation ctxt block ~branch operation =
    RPC_context.make_call0
      S.operations
      ctxt
      block
      ()
      ({branch}, Contents_list (Single operation))

  let endorsement ctxt b ~branch ~level () =
    operation ctxt b ~branch (Endorsement {level})

  let proposals ctxt b ~branch ~source ~period ~proposals () =
    operation ctxt b ~branch (Proposals {source; period; proposals})

  let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () =
    operation ctxt b ~branch (Ballot {source; period; proposal; ballot})

  let seed_nonce_revelation ctxt block ~branch ~level ~nonce () =
    operation ctxt block ~branch (Seed_nonce_revelation {level; nonce})

  let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () =
    operation ctxt block ~branch (Double_baking_evidence {bh1; bh2})

  let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 () =
    operation ctxt block ~branch (Double_endorsement_evidence {op1; op2})

  let empty_proof_of_work_nonce =
    MBytes.of_string
      (String.make Constants_repr.proof_of_work_nonce_size '\000')

  let protocol_data ctxt block ~priority ?seed_nonce_hash
      ?(proof_of_work_nonce = empty_proof_of_work_nonce) () =
    RPC_context.make_call0
      S.protocol_data
      ctxt
      block
      ()
      (priority, seed_nonce_hash, proof_of_work_nonce)
end

module Parse = struct
  module S = struct
    open Data_encoding

    let path = RPC_path.(path / "parse")

    let operations =
      RPC_service.post_service
        ~description:"Parse operations"
        ~query:RPC_query.empty
        ~input:
          (obj2
             (req "operations" (list (dynamic_size Operation.raw_encoding)))
             (opt "check_signature" bool))
        ~output:(list (dynamic_size Operation.encoding))
        RPC_path.(path / "operations")

    let block =
      RPC_service.post_service
        ~description:"Parse a block"
        ~query:RPC_query.empty
        ~input:Block_header.raw_encoding
        ~output:Block_header.protocol_data_encoding
        RPC_path.(path / "block")
  end

  let parse_protocol_data protocol_data =
    match
      Data_encoding.Binary.of_bytes
        Block_header.protocol_data_encoding
        protocol_data
    with
    | None ->
        failwith "Cant_parse_protocol_data"
    | Some protocol_data ->
        return protocol_data

  let register () =
    let open Services_registration in
    register0 S.operations (fun _ctxt () (operations, check) ->
        map_s
          (fun raw ->
            Lwt.return (parse_operation raw)
            >>=? fun op ->
            ( match check with
            | Some true ->
                return_unit (* FIXME *)
            (* I.check_signature ctxt *)
            (* op.protocol_data.signature op.shell op.protocol_data.contents *)
            | Some false | None ->
                return_unit )
            >>|? fun () -> op)
          operations) ;
    register0_noctxt S.block (fun () raw_block ->
        parse_protocol_data raw_block.protocol_data)

  let operations ctxt block ?check operations =
    RPC_context.make_call0 S.operations ctxt block () (operations, check)

  let block ctxt block shell protocol_data =
    RPC_context.make_call0
      S.block
      ctxt
      block
      ()
      ({shell; protocol_data} : Block_header.raw)
end

module S = struct
  open Data_encoding

  type level_query = {offset : int32}

  let level_query : level_query RPC_query.t =
    let open RPC_query in
    query (fun offset -> {offset})
    |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset)
    |> seal

  let current_level =
    RPC_service.get_service
      ~description:
        "Returns the level of the interrogated block, or the one of a block \
         located `offset` blocks after in the chain (or before when \
         negative). For instance, the next block if `offset` is 1."
      ~query:level_query
      ~output:Level.encoding
      RPC_path.(path / "current_level")

  let levels_in_current_cycle =
    RPC_service.get_service
      ~description:"Levels of a cycle"
      ~query:level_query
      ~output:
        (obj2 (req "first" Raw_level.encoding) (req "last" Raw_level.encoding))
      RPC_path.(path / "levels_in_current_cycle")
end

let register () =
  Scripts.register () ;
  Forge.register () ;
  Parse.register () ;
  let open Services_registration in
  register0 S.current_level (fun ctxt q () ->
      let level = Level.current ctxt in
      return (Level.from_raw ctxt ~offset:q.offset level.level)) ;
  register0 S.levels_in_current_cycle (fun ctxt q () ->
      let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in
      match levels with
      | [] ->
          raise Not_found
      | _ ->
          let first = List.hd (List.rev levels) in
          let last = List.hd levels in
          return (first.level, last.level))

let current_level ctxt ?(offset = 0l) block =
  RPC_context.make_call0 S.current_level ctxt block {offset} ()

let levels_in_current_cycle ctxt ?(offset = 0l) block =
  RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} ()
src/proto_alpha/lib_protocol/helpers_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition parse_operation
  (op : Tezos_raw_protocol_alpha.Alpha_context.Operation.raw)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Alpha_context.packed_operation :=
  match
    Data_encoding.Binary.of_bytes Operation.protocol_data_encoding (proto op)
    with
  | Some protocol_data =>
    ok {| shell := shell op; protocol_data := protocol_data |}
  | None =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_parse_operation
  end.

Definition path
  : Tezos_protocol_environment_alpha__Environment.RPC_path.path
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
  op_div open_root "helpers" % string.

Module Scripts.
  Module S.
    Import Data_encoding.
    
    Definition path
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      op_div path "scripts" % string.
    
    Definition run_code_input_encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string) :=
      obj9 (req None None "script" % string Script.expr_encoding)
        (req None None "storage" % string Script.expr_encoding)
        (req None None "input" % string Script.expr_encoding)
        (req None None "amount" % string Tez.encoding)
        (req None None "chain_id" % string
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
        (opt None None "source" % string Contract.encoding)
        (opt None None "payer" % string Contract.encoding)
        (opt None None "gas" % string z)
        (dft None None "entrypoint" % string string "default" % string).
    
    Definition trace_encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
            (list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (option string))))) :=
      op_atat
        (let arg := def "scripted.trace" % string in
        fun eta => arg None None eta)
        (op_atat
          (let arg := list in
          fun eta => arg None eta)
          (obj3 (req None None "location" % string Script.location_encoding)
            (req None None "gas" % string Gas.encoding)
            (req None None "stack" % string
              (list None
                (obj2 (req None None "item" % string Script.expr_encoding)
                  (opt None None "annot" % string string)))))).
    
    Definition run_code
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)) :=
      RPC_service.post_service
        (Some "Run a piece of code in the current context" % string)
        RPC_query.empty run_code_input_encoding
        (obj3 (req None None "storage" % string Script.expr_encoding)
          (req None None "operations" % string
            (list None Operation.internal_operation_encoding))
          (opt None None "big_map_diff" % string Contract.big_map_diff_encoding))
        (op_div path "run_code" % string).
    
    Definition trace_code
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
          * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
          (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (option string))))) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)) :=
      RPC_service.post_service
        (Some
          "Run a piece of code in the current context, keeping a trace" % string)
        RPC_query.empty run_code_input_encoding
        (obj4 (req None None "storage" % string Script.expr_encoding)
          (req None None "operations" % string
            (list None Operation.internal_operation_encoding))
          (req None None "trace" % string trace_encoding)
          (opt None None "big_map_diff" % string Contract.big_map_diff_encoding))
        (op_div path "trace_code" % string).
    
    Definition typecheck_code
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (option Tezos_protocol_environment_alpha__Environment.Z.t))
        ((list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            ((list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (list string))) *
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (list string)))))) *
          Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
      RPC_service.post_service
        (Some "Typecheck a piece of code in the current context" % string)
        RPC_query.empty
        (obj2 (req None None "program" % string Script.expr_encoding)
          (opt None None "gas" % string z))
        (obj2
          (req None None "type_map" % string
            Script_tc_errors_registration.type_map_enc)
          (req None None "gas" % string Gas.encoding))
        (op_div path "typecheck_code" % string).
    
    Definition typecheck_data
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (option Tezos_protocol_environment_alpha__Environment.Z.t))
        Tezos_raw_protocol_alpha.Alpha_context.Gas.t :=
      RPC_service.post_service
        (Some
          "Check that some data expression is well formed and of a given type in the current context"
            % string) RPC_query.empty
        (obj3 (req None None "data" % string Script.expr_encoding)
          (req None None "type" % string Script.expr_encoding)
          (opt None None "gas" % string z))
        (obj1 (req None None "gas" % string Gas.encoding))
        (op_div path "typecheck_data" % string).
    
    Definition pack_data
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (option Tezos_protocol_environment_alpha__Environment.Z.t))
        (Tezos_protocol_environment_alpha__Environment.MBytes.t *
          Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
      RPC_service.post_service
        (Some
          "Computes the serialized version of some data expression using the same algorithm as script instruction PACK"
            % string) RPC_query.empty
        (obj3 (req None None "data" % string Script.expr_encoding)
          (req None None "type" % string Script.expr_encoding)
          (opt None None "gas" % string z))
        (obj2 (req None None "packed" % string bytes)
          (req None None "gas" % string Gas.encoding))
        (op_div path "pack_data" % string).
    
    Definition run_operation
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
          Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
        (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
          Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata) :=
      RPC_service.post_service
        (Some "Run an operation without signature checks" % string)
        RPC_query.empty
        (obj2 (req None None "operation" % string Operation.encoding)
          (req None None "chain_id" % string
            Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)))
        Apply_results.operation_data_and_metadata_encoding
        (op_div path "run_operation" % string).
    
    Definition entrypoint_type
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string)
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr :=
      RPC_service.post_service
        (Some "Return the type of the given entrypoint" % string)
        RPC_query.empty
        (obj2 (req None None "script" % string Script.expr_encoding)
          (dft None None "entrypoint" % string string "default" % string))
        (obj1 (req None None "entrypoint_type" % string Script.expr_encoding))
        (op_div path "entrypoint" % string).
    
    Definition list_entrypoints
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr
        ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
          (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr))) :=
      RPC_service.post_service
        (Some "Return the list of entrypoints of the given script" % string)
        RPC_query.empty
        (obj1 (req None None "script" % string Script.expr_encoding))
        (obj2
          (dft None None "unreachable" % string
            (Data_encoding.list None
              (obj1
                (req None None "path" % string
                  (Data_encoding.list None Michelson_v1_primitives.prim_encoding))))
            [])
          (req None None "entrypoints" % string (assoc Script.expr_encoding)))
        (op_div path "entrypoints" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    let originate_dummy_contract
      (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (script :
      Tezos_raw_protocol_alpha__Alpha_context.Script.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha__Alpha_context.context *
            Tezos_raw_protocol_alpha.Alpha_context.Contract.t)) :=
      let ctxt :=
        Contract.init_origination_nonce ctxt
          Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
        in
      op_gtgteqquestion (Contract.fresh_contract_from_current_nonce ctxt)
        (fun function_parameter =>
          let '(ctxt, dummy_contract) := function_parameter in
          let balance :=
            match
              Tez.of_mutez
                (* ❌ Constant of type int64 is converted to int *)
                4000000000000 with
            | Some balance => balance
            | None =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            end in
          op_gtgteqquestion
            (Contract.originate ctxt dummy_contract balance (script, None) None)
            (fun ctxt => _return (ctxt, dummy_contract))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.run_code
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let
                '(code, storage, parameter, amount, chain_id, source, payer,
                  gas, entrypoint) := function_parameter in
              let storage := Script.lazy_expr storage in
              let code := Script.lazy_expr code in
              op_gtgteqquestion
                (originate_dummy_contract ctxt
                  {| code := code; storage := storage |})
                (fun function_parameter =>
                  let '(ctxt, dummy_contract) := function_parameter in
                  let '(source, payer) :=
                    match (source, payer) with
                    | (Some source, Some payer) => (source, payer)
                    | (Some source, None) => (source, source)
                    | (None, Some payer) => (payer, payer)
                    | (None, None) => (dummy_contract, dummy_contract)
                    end in
                  let gas :=
                    match gas with
                    | Some gas => gas
                    | None => Constants.hard_gas_limit_per_operation ctxt
                    end in
                  let ctxt := Gas.set_limit ctxt gas in
                  let step_constants :=
                    {| source := source; payer := payer; self := dummy_contract;
                      amount := amount; chain_id := chain_id |} in
                  op_gtgteqquestion
                    (Script_interpreter.execute ctxt
                      Tezos_raw_protocol_alpha.Script_ir_translator.Readable
                      step_constants {| code := code; storage := storage |}
                      entrypoint parameter)
                    (fun function_parameter =>
                      let '{|
                        Script_interpreter.storage := storage;
                          Script_interpreter.big_map_diff := big_map_diff;
                          Script_interpreter.operations := operations
                          |} := function_parameter in
                      _return (storage, operations, big_map_diff)))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.trace_code
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let
                '(code, storage, parameter, amount, chain_id, source, payer,
                  gas, entrypoint) := function_parameter in
              let storage := Script.lazy_expr storage in
              let code := Script.lazy_expr code in
              op_gtgteqquestion
                (originate_dummy_contract ctxt
                  {| code := code; storage := storage |})
                (fun function_parameter =>
                  let '(ctxt, dummy_contract) := function_parameter in
                  let '(source, payer) :=
                    match (source, payer) with
                    | (Some source, Some payer) => (source, payer)
                    | (Some source, None) => (source, source)
                    | (None, Some payer) => (payer, payer)
                    | (None, None) => (dummy_contract, dummy_contract)
                    end in
                  let gas :=
                    match gas with
                    | Some gas => gas
                    | None => Constants.hard_gas_limit_per_operation ctxt
                    end in
                  let ctxt := Gas.set_limit ctxt gas in
                  let step_constants :=
                    {| source := source; payer := payer; self := dummy_contract;
                      amount := amount; chain_id := chain_id |} in
                  op_gtgteqquestion
                    (Script_interpreter.trace ctxt
                      Tezos_raw_protocol_alpha.Script_ir_translator.Readable
                      step_constants {| code := code; storage := storage |}
                      entrypoint parameter)
                    (fun function_parameter =>
                      let
                        '({|
                          Script_interpreter.storage := storage;
                            Script_interpreter.big_map_diff := big_map_diff;
                            Script_interpreter.operations := operations
                            |}, trace) := function_parameter in
                      _return (storage, operations, trace, big_map_diff)))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.typecheck_code
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(expr, maybe_gas) := function_parameter in
              let ctxt :=
                match maybe_gas with
                | None => Gas.set_unlimited ctxt
                | Some gas => Gas.set_limit ctxt gas
                end in
              op_gtgteqquestion (Script_ir_translator.typecheck_code ctxt expr)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  _return (res, (Gas.level ctxt)))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.typecheck_data
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(data, ty, maybe_gas) := function_parameter in
              let ctxt :=
                match maybe_gas with
                | None => Gas.set_unlimited ctxt
                | Some gas => Gas.set_limit ctxt gas
                end in
              op_gtgteqquestion
                (Script_ir_translator.typecheck_data None ctxt (data, ty))
                (fun ctxt => _return (Gas.level ctxt))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.pack_data
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(expr, typ, maybe_gas) := function_parameter in
              let ctxt :=
                match maybe_gas with
                | None => Gas.set_unlimited ctxt
                | Some gas => Gas.set_limit ctxt gas
                end in
              op_gtgteqquestion
                (Lwt._return (parse_packable_ty ctxt true (Micheline.root typ)))
                (fun function_parameter =>
                  let
                    '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty typ,
                      ctxt) := function_parameter in
                  op_gtgteqquestion
                    (parse_data None ctxt true typ (Micheline.root expr))
                    (fun function_parameter =>
                      let '(data, ctxt) := function_parameter in
                      op_gtgteqquestion
                        (Script_ir_translator.pack_data ctxt typ data)
                        (fun function_parameter =>
                          let '(bytes, ctxt) := function_parameter in
                          _return (string, (Gas.level ctxt)))))) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.run_operation
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let
                '({|
                  shell := shell;
                    protocol_data :=
                      Tezos_raw_protocol_alpha.Alpha_context.Operation_data
                        protocol_data
                    |}, chain_id) := function_parameter in
              let partial_precheck_manager_contents {A : Type}
                (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (op :
                Tezos_raw_protocol_alpha.Alpha_context.contents
                  (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager A))
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    Tezos_raw_protocol_alpha.Alpha_context.context) :=
                let
                  'Tezos_raw_protocol_alpha.Alpha_context.Manager_operation {|
                    source := source;
                      fee := fee;
                      counter := counter;
                      operation := operation;
                      gas_limit := gas_limit;
                      storage_limit := storage_limit
                      |} := op in
                op_gtgteqquestion (Lwt._return (Gas.check_limit ctxt gas_limit))
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let ctxt := Gas.set_limit ctxt gas_limit in
                    op_gtgteqquestion
                      (Lwt._return (Fees.check_storage_limit ctxt storage_limit))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (Contract.must_be_allocated ctxt
                            (Contract.implicit_contract source))
                          (fun function_parameter =>
                            let 'tt := function_parameter in
                            op_gtgteqquestion
                              (Contract.check_counter_increment ctxt source
                                counter)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion
                                  match operation with
                                  |
                                    Tezos_raw_protocol_alpha.Alpha_context.Reveal
                                      pk =>
                                    Contract.reveal_manager_key ctxt source pk
                                  |
                                    Tezos_raw_protocol_alpha.Alpha_context.Transaction
                                      {| parameters := parameters |} =>
                                    let arg_bytes :=
                                      Data_encoding.Binary.to_bytes_exn
                                        Script.lazy_expr_encoding parameters in
                                    let arg :=
                                      match
                                        Data_encoding.Binary.of_bytes
                                          Script.lazy_expr_encoding arg_bytes
                                        with
                                      | Some arg => arg
                                      | None =>
                                        (* ❌ Assert instruction is not handled. *)
                                        assert false
                                      end in
                                    op_gtgteqquestion
                                      (op_atat Lwt._return
                                        (op_atat
                                          (record_trace
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                                          (Gas.check_enough ctxt
                                            (Script.minimal_deserialize_cost arg))))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgtpipequestion
                                          (op_atat
                                            (trace
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                                            (Script.force_decode ctxt arg))
                                          (fun function_parameter =>
                                            let '(_arg, ctxt) :=
                                              function_parameter in
                                            ctxt))
                                  |
                                    Tezos_raw_protocol_alpha.Alpha_context.Origination
                                      {| script := script |} =>
                                    let script_bytes :=
                                      Data_encoding.Binary.to_bytes_exn
                                        Script.encoding script in
                                    let script :=
                                      match
                                        Data_encoding.Binary.of_bytes
                                          Script.encoding script_bytes with
                                      | Some script => script
                                      | None =>
                                        (* ❌ Assert instruction is not handled. *)
                                        assert false
                                      end in
                                    op_gtgteqquestion
                                      (op_atat Lwt._return
                                        (op_atat
                                          (record_trace
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                                          (op_gtgtquestion
                                            (Gas.consume ctxt
                                              (Script.minimal_deserialize_cost
                                                (code script)))
                                            (fun ctxt =>
                                              Gas.check_enough ctxt
                                                (Script.minimal_deserialize_cost
                                                  (storage script))))))
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteqquestion
                                          (op_atat
                                            (trace
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                                            (Script.force_decode ctxt
                                              (code script)))
                                          (fun function_parameter =>
                                            let '(_code, ctxt) :=
                                              function_parameter in
                                            op_gtgtpipequestion
                                              (op_atat
                                                (trace
                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_quota_exceeded_init_deserialize)
                                                (Script.force_decode ctxt
                                                  (storage script)))
                                              (fun function_parameter =>
                                                let '(_storage, ctxt) :=
                                                  function_parameter in
                                                ctxt)))
                                  | _ => _return ctxt
                                  end
                                  (fun ctxt =>
                                    op_gtgteqquestion
                                      (Contract.get_manager_key ctxt source)
                                      (fun _public_key =>
                                        op_gtgteqquestion
                                          (Contract.increment_counter ctxt
                                            source)
                                          (fun ctxt =>
                                            op_gtgteqquestion
                                              (Contract.spend ctxt
                                                (Contract.implicit_contract
                                                  source) fee)
                                              (fun ctxt => _return ctxt))))))))
                in
              let fix partial_precheck_manager_contents_list {kind : Type}
                (ctxt : Tezos_raw_protocol_alpha.Alpha_context.t) (contents_list
                :
                Tezos_raw_protocol_alpha.Alpha_context.contents_list
                  (Tezos_raw_protocol_alpha.Alpha_context.Kind.manager kind))
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    Tezos_raw_protocol_alpha.Alpha_context.context) :=
                match contents_list with
                |
                  Tezos_raw_protocol_alpha.Alpha_context.Single
                    ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _)
                      as op) => partial_precheck_manager_contents ctxt op
                |
                  Tezos_raw_protocol_alpha.Alpha_context.Cons
                    ((Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _)
                      as op) rest =>
                  op_gtgteqquestion (partial_precheck_manager_contents ctxt op)
                    (fun ctxt =>
                      partial_precheck_manager_contents_list ctxt rest)
                end in
              let _return {A : Type}
                (contents :
                Tezos_raw_protocol_alpha.Apply_results.contents_result_list A)
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    (Tezos_raw_protocol_alpha.Alpha_context.packed_protocol_data
                      *
                      Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)) :=
                _return
                  ((Tezos_raw_protocol_alpha.Alpha_context.Operation_data
                    protocol_data),
                    (Tezos_raw_protocol_alpha.Apply_results.Operation_metadata
                      {| contents := contents |})) in
              let operation :=
                {| shell := shell; protocol_data := protocol_data |} in
              let hash :=
                Operation.hash
                  {| shell := shell; protocol_data := protocol_data |} in
              let ctxt := Contract.init_origination_nonce ctxt hash in
              let baker := Signature.Public_key_hash.zero in
              match contents protocol_data with
              |
                (Tezos_raw_protocol_alpha.Alpha_context.Single
                  (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _))
                  as op =>
                op_gtgteqquestion
                  (partial_precheck_manager_contents_list ctxt op)
                  (fun ctxt =>
                    op_gtgteq
                      (Apply.apply_manager_contents_list ctxt
                        Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                        baker chain_id op)
                      (fun function_parameter =>
                        let '(_ctxt, result) := function_parameter in
                        _return result))
              |
                (Tezos_raw_protocol_alpha.Alpha_context.Cons
                  (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation _) _)
                  as op =>
                op_gtgteqquestion
                  (partial_precheck_manager_contents_list ctxt op)
                  (fun ctxt =>
                    op_gtgteq
                      (Apply.apply_manager_contents_list ctxt
                        Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                        baker chain_id op)
                      (fun function_parameter =>
                        let '(_ctxt, result) := function_parameter in
                        _return result))
              | _ =>
                op_gtgteqquestion
                  (Apply.apply_contents_list ctxt chain_id
                    Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                    (branch shell) baker operation
                    (contents (protocol_data operation)))
                  (fun function_parameter =>
                    let '(_ctxt, result) := function_parameter in
                    _return result)
              end) in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.entrypoint_type
        (fun ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(expr, entrypoint) := function_parameter in
              let ctxt := Gas.set_unlimited ctxt in
              let legacy := false in
              op_gtgteqquestion
                (Lwt._return
                  (op_gtgtquestion (parse_toplevel legacy expr)
                    (fun function_parameter =>
                      let '(arg_type, _, _, root_name) := function_parameter in
                      op_gtgtquestion
                        (parse_ty ctxt legacy true false true arg_type)
                        (fun function_parameter =>
                          let
                            '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
                              arg_type, _) := function_parameter in
                          Script_ir_translator.find_entrypoint arg_type
                            root_name entrypoint))))
                (fun function_parameter =>
                  let
                    '(_f, Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty ty) :=
                    function_parameter in
                  op_gtgteqquestion (unparse_ty ctxt ty)
                    (fun function_parameter =>
                      let '(ty_node, _) := function_parameter in
                      _return (Micheline.strip_locations ty_node)))) in
    register0 S.list_entrypoints
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun expr =>
            let ctxt := Gas.set_unlimited ctxt in
            let legacy := false in
            op_gtgteqquestion
              (Lwt._return
                (op_gtgtquestion (parse_toplevel legacy expr)
                  (fun function_parameter =>
                    let '(arg_type, _, _, root_name) := function_parameter in
                    op_gtgtquestion
                      (parse_ty ctxt legacy true false true arg_type)
                      (fun function_parameter =>
                        let
                          '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_ty
                            arg_type, _) := function_parameter in
                        Script_ir_translator.list_entrypoints arg_type ctxt
                          root_name))))
              (fun function_parameter =>
                let '(unreachable_entrypoint, map) := function_parameter in
                _return
                  (unreachable_entrypoint,
                    (Entrypoints_map.fold
                      (fun entry =>
                        fun function_parameter =>
                          let '(_, ty) := function_parameter in
                          fun acc =>
                            cons (entry, (Micheline.strip_locations ty)) acc)
                      map [])))).
  
  Definition run_code {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
    let '(storage, input, amount, chain_id, source, payer, gas, entrypoint) :=
      function_parameter in
    RPC_context.make_call0 S.run_code ctxt block tt
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint).
  
  Definition trace_code {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
    (function_parameter :
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
        Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
        * (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.t) *
        (option Tezos_protocol_environment_alpha__Environment.Z.t) * string)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          (list
            Tezos_raw_protocol_alpha__Alpha_context.packed_internal_operation) *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
              (list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (option string))))) *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
    let '(storage, input, amount, chain_id, source, payer, gas, entrypoint) :=
      function_parameter in
    RPC_context.make_call0 S.trace_code ctxt block tt
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint).
  
  Definition typecheck_code {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          ((list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              ((list
                (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                  (list string))) *
                (list
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                    (list string)))))) *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
    RPC_context.make_call0 S.typecheck_code ctxt block tt.
  
  Definition typecheck_data {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Gas.t) :=
    RPC_context.make_call0 S.typecheck_data ctxt block tt.
  
  Definition pack_data {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      (option Tezos_protocol_environment_alpha__Environment.Z.t)) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (Tezos_protocol_environment_alpha__Environment.MBytes.t *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t)) :=
    RPC_context.make_call0 S.pack_data ctxt block tt.
  
  Definition run_operation {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed *
      Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data
            * Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata)) :=
    RPC_context.make_call0 S.run_operation ctxt block tt.
  
  Definition entrypoint_type {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * string) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_raw_protocol_alpha.Alpha_context.Script.expr) :=
    RPC_context.make_call0 S.entrypoint_type ctxt block tt.
  
  Definition list_entrypoints {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    : Tezos_raw_protocol_alpha.Alpha_context.Script.expr ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          ((list (list Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) *
            (list (string * Tezos_raw_protocol_alpha.Alpha_context.Script.expr)))) :=
    RPC_context.make_call0 S.list_entrypoints ctxt block tt.
End Scripts.

Module Forge.
  Module S.
    Import Data_encoding.
    
    Definition path
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      op_div path "forge" % string.
    
    Definition operations
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
          Tezos_raw_protocol_alpha__Alpha_context.packed_contents_list)
        Tezos_protocol_environment_alpha__Environment.MBytes.t :=
      RPC_service.post_service (Some "Forge an operation" % string)
        RPC_query.empty Operation.unsigned_encoding bytes
        (op_div path "operations" % string).
    
    Definition empty_proof_of_work_nonce
      : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
      MBytes.of_string
        (String.make Constants_repr.proof_of_work_nonce_size "000" % char).
    
    Definition protocol_data
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        (Z * (option Tezos_raw_protocol_alpha.Nonce_hash.t) *
          Tezos_protocol_environment_alpha__Environment.MBytes.t)
        Tezos_protocol_environment_alpha__Environment.MBytes.t :=
      RPC_service.post_service
        (Some "Forge the protocol-specific part of a block header" % string)
        RPC_query.empty
        (obj3 (req None None "priority" % string uint16)
          (opt None None "nonce_hash" % string Nonce_hash.encoding)
          (dft None None "proof_of_work_nonce" % string
            (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
            empty_proof_of_work_nonce))
        (obj1 (req None None "protocol_data" % string bytes))
        (op_div path "protocol_data" % string).
  End S.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0_noctxt S.operations
        (fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let '(shell, proto) := function_parameter in
            _return
              (Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding
                (shell, proto))) in
    register0_noctxt S.protocol_data
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let '(priority, seed_nonce_hash, proof_of_work_nonce) :=
            function_parameter in
          _return
            (Data_encoding.Binary.to_bytes_exn Block_header.contents_encoding
              {| priority := priority; seed_nonce_hash := seed_nonce_hash;
                proof_of_work_nonce := proof_of_work_nonce |})).
  
  Module Manager.
    Definition operations {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (gas_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (operations :
        list Tezos_raw_protocol_alpha.Alpha_context.packed_manager_operation)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      op_gtgteq (Contract_services.manager_key ctxt block source)
        (fun function_parameter =>
          match function_parameter with
          |
            (Tezos_protocol_environment_alpha__Environment.Pervasives.Error _)
              as e => Lwt._return e
          | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok revealed
            =>
            let ops :=
              List.map
                (fun function_parameter =>
                  let
                    'Tezos_raw_protocol_alpha.Alpha_context.Manager operation :=
                    function_parameter in
                  Tezos_raw_protocol_alpha.Alpha_context.Contents
                    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation
                      {| source := source; fee := fee; counter := counter;
                        operation := operation; gas_limit := gas_limit;
                        storage_limit := storage_limit |})) operations in
            let ops :=
              match (sourcePubKey, revealed) with
              | (None, _) | (_, Some _) => ops
              | (Some pk, None) =>
                let operation :=
                  Tezos_raw_protocol_alpha.Alpha_context.Reveal pk in
                cons
                  (Tezos_raw_protocol_alpha.Alpha_context.Contents
                    (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation
                      {| source := source; fee := fee; counter := counter;
                        operation := operation; gas_limit := gas_limit;
                        storage_limit := storage_limit |})) ops
              end in
            RPC_context.make_call0 S.operations ctxt block tt
              ({| branch := branch |}, (Operation.of_list ops))
          end).
    
    Definition reveal {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      let 'tt := function_parameter in
      operations ctxt block branch source (Some sourcePubKey) counter fee Z.zero
        Z.zero [].
    
    Definition transaction {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (destination : Tezos_raw_protocol_alpha.Alpha_context.Contract.contract)
      (op_staroptstar : option string)
      : (option Tezos_raw_protocol_alpha.Alpha_context.Script.expr) ->
        Tezos_protocol_environment_alpha__Environment.Z.t ->
          Tezos_protocol_environment_alpha__Environment.Z.t ->
            Tezos_raw_protocol_alpha.Alpha_context.Tez.tez ->
              unit ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Pervasives.result
                    Tezos_protocol_environment_alpha__Environment.MBytes.t
                    (list
                      Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      let entrypoint :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "default" % string
        end in
      fun parameters =>
        fun gas_limit =>
          fun storage_limit =>
            fun fee =>
              fun function_parameter =>
                let 'tt := function_parameter in
                let parameters :=
                  Option.unopt_map Script.lazy_expr Script.unit_parameter
                    parameters in
                operations ctxt block branch source sourcePubKey counter fee
                  gas_limit storage_limit
                  (cons
                    (Tezos_raw_protocol_alpha.Alpha_context.Manager
                      (Tezos_raw_protocol_alpha.Alpha_context.Transaction
                        {| amount := amount; parameters := parameters;
                          entrypoint := entrypoint; destination := destination
                          |})) []).
    
    Definition origination {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (balance : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (delegatePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      (script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
      (gas_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (storage_limit : Tezos_protocol_environment_alpha__Environment.Z.t)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      let 'tt := function_parameter in
      operations ctxt block branch source sourcePubKey counter fee gas_limit
        storage_limit
        (cons
          (Tezos_raw_protocol_alpha.Alpha_context.Manager
            (Tezos_raw_protocol_alpha.Alpha_context.Origination
              {| delegate := delegatePubKey; script := script;
                credit := balance; preorigination := None |})) []).
    
    Definition delegation {D E G I K L a b c i o q : Type}
      (ctxt :
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
          D ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (E * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q
            i o) ->
            D ->
              a ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (G * a * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) q i o) ->
              D ->
                a ->
                  b ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (I * a * b * q * i * o)) *
              ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
                variant
                Tezos_protocol_environment_alpha__Environment.RPC_context.t
                (((Tezos_protocol_environment_alpha__Environment.RPC_context.t *
                  a) * b) * c) q i o) ->
                D ->
                  a ->
                    b ->
                      c ->
                        q ->
                          i ->
                            Tezos_protocol_environment_alpha__Environment.Lwt.t
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                                o)) * (K * a * b * c * q * i * o)) * L)))) * L *
          D) (block : D)
      (branch :
        Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
      (source : Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)
      (sourcePubKey :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
      (counter : Tezos_raw_protocol_alpha.Alpha_context.counter)
      (fee : Tezos_raw_protocol_alpha.Alpha_context.Tez.tez)
      (delegate :
        option
          Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result
          Tezos_protocol_environment_alpha__Environment.MBytes.t
          (list
            Tezos_protocol_environment_alpha__Environment.Error_monad.shell_error)) :=
      operations ctxt block branch source sourcePubKey counter fee Z.zero Z.zero
        (cons
          (Tezos_raw_protocol_alpha.Alpha_context.Manager
            (Tezos_raw_protocol_alpha.Alpha_context.Delegation delegate)) []).
  End Manager.
  
  Definition operation {D E G I K L M a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (operation : Tezos_raw_protocol_alpha.Alpha_context.contents M)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    RPC_context.make_call0 S.operations ctxt block tt
      ({| branch := branch |},
        (Tezos_raw_protocol_alpha.Alpha_context.Contents_list
          (Tezos_raw_protocol_alpha.Alpha_context.Single operation))).
  
  Definition endorsement {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (b : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let 'tt := function_parameter in
    operation ctxt b branch
      (Tezos_raw_protocol_alpha.Alpha_context.Endorsement {| level := level |}).
  
  Definition proposals {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (b : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (source :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    (period : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t)
    (proposals :
      list
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let 'tt := function_parameter in
    operation ctxt b branch
      (Tezos_raw_protocol_alpha.Alpha_context.Proposals
        {| source := source; period := period; proposals := proposals |}).
  
  Definition ballot {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (b : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (source :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    (period : Tezos_raw_protocol_alpha.Alpha_context.Voting_period.t)
    (proposal :
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (ballot : Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let 'tt := function_parameter in
    operation ctxt b branch
      (Tezos_raw_protocol_alpha.Alpha_context.Ballot
        {| source := source; period := period; proposal := proposal;
          ballot := ballot |}).
  
  Definition seed_nonce_revelation {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (level : Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)
    (nonce : Tezos_raw_protocol_alpha.Alpha_context.Nonce.t)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let 'tt := function_parameter in
    operation ctxt block branch
      (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation
        {| level := level; nonce := nonce |}).
  
  Definition double_baking_evidence {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (bh1 : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
    (bh2 : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let 'tt := function_parameter in
    operation ctxt block branch
      (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence
        {| bh1 := bh1; bh2 := bh2 |}).
  
  Definition double_endorsement_evidence {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (branch :
      Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
    (op1 :
      Tezos_raw_protocol_alpha.Alpha_context.operation
        Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
    (op2 :
      Tezos_raw_protocol_alpha.Alpha_context.operation
        Tezos_raw_protocol_alpha.Alpha_context.Kind.endorsement)
    (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let 'tt := function_parameter in
    operation ctxt block branch
      (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence
        {| op1 := op1; op2 := op2 |}).
  
  Definition empty_proof_of_work_nonce
    : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
    MBytes.of_string
      (String.make Constants_repr.proof_of_work_nonce_size "000" % char).
  
  Definition protocol_data {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (priority : Z)
    (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
    (op_staroptstar :
      option Tezos_protocol_environment_alpha__Environment.MBytes.t)
    : unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
          Tezos_protocol_environment_alpha__Environment.MBytes.t) :=
    let proof_of_work_nonce :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => empty_proof_of_work_nonce
      end in
    fun function_parameter =>
      let 'tt := function_parameter in
      RPC_context.make_call0 S.protocol_data ctxt block tt
        (priority, seed_nonce_hash, proof_of_work_nonce).
End Forge.

Module Parse.
  Module S.
    Import Data_encoding.
    
    Definition path
      : Tezos_protocol_environment_alpha__Environment.RPC_path.path
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
      op_div path "parse" % string.
    
    Definition operations
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        ((list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw) *
          (option bool))
        (list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed) :=
      RPC_service.post_service (Some "Parse operations" % string)
        RPC_query.empty
        (obj2
          (req None None "operations" % string
            (list None (dynamic_size None Operation.raw_encoding)))
          (opt None None "check_signature" % string bool))
        (list None (dynamic_size None Operation.encoding))
        (op_div path "operations" % string).
    
    Definition block
      : Tezos_protocol_environment_alpha__Environment.RPC_service.service
        variant
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
        Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.raw
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data :=
      RPC_service.post_service (Some "Parse a block" % string) RPC_query.empty
        Block_header.raw_encoding Block_header.protocol_data_encoding
        (op_div path "block" % string).
  End S.
  
  Definition parse_protocol_data
    (protocol_data : Tezos_protocol_environment_alpha__Environment.MBytes.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data) :=
    match
      Data_encoding.Binary.of_bytes Block_header.protocol_data_encoding
        protocol_data with
    | None => failwith "Cant_parse_protocol_data" % string
    | Some protocol_data => _return protocol_data
    end.
  
  Definition register (function_parameter : unit) : unit :=
    let 'tt := function_parameter in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      register0 S.operations
        (fun _ctxt =>
          fun function_parameter =>
            let 'tt := function_parameter in
            fun function_parameter =>
              let '(operations, check) := function_parameter in
              map_s
                (fun raw =>
                  op_gtgteqquestion (Lwt._return (parse_operation raw))
                    (fun op =>
                      op_gtgtpipequestion
                        match check with
                        | Some true => return_unit
                        | Some false | None => return_unit
                        end
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op))) operations) in
    register0_noctxt S.block
      (fun function_parameter =>
        let 'tt := function_parameter in
        fun raw_block => parse_protocol_data (protocol_data raw_block)).
  
  Definition operations {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D) (check : option bool)
    (operations : list Tezos_raw_protocol_alpha.Alpha_context.Operation.raw)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list Tezos_raw_protocol_alpha.Alpha_context.Operation.packed)) :=
    RPC_context.make_call0 S.operations ctxt block tt (operations, check).
  
  Definition block {D E G I K L a b c i o q : Type}
    (ctxt :
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
        D ->
          q ->
            i ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                  o)) * (E * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i
          o) ->
          D ->
            a ->
              q ->
                i ->
                  Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                      o)) * (G * a * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) *
              b) q i o) ->
            D ->
              a ->
                b ->
                  q ->
                    i ->
                      Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                          o)) * (I * a * b * q * i * o)) *
            ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
              variant
              Tezos_protocol_environment_alpha__Environment.RPC_context.t
              (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
                * b) * c) q i o) ->
              D ->
                a ->
                  b ->
                    c ->
                      q ->
                        i ->
                          Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                              o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
    (block : D)
    (shell :
      Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
    (protocol_data : Tezos_protocol_environment_alpha__Environment.MBytes.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data) :=
    RPC_context.make_call0 S.block ctxt block tt
      {| shell := shell; protocol_data := protocol_data |}.
End Parse.

Module S.
  Import Data_encoding.
  
  Record level_query := {
    offset : int32 }.
  
  Definition level_query
    : Tezos_protocol_environment_alpha__Environment.RPC_query.t level_query :=
    op_pipegt
      (op_pipeplus (query (fun offset => {| offset := offset |}))
        (field None "offset" % string RPC_arg.int32
          (* ❌ Constant of type int32 is converted to int *)
          0 (fun t => offset t))) seal.
  
  Definition current_level
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      level_query unit Tezos_raw_protocol_alpha.Alpha_context.Level.t :=
    RPC_service.get_service
      (Some
        "Returns the level of the interrogated block, or the one of a block located `offset` blocks after in the chain (or before when negative). For instance, the next block if `offset` is 1."
          % string) level_query Level.encoding
      (op_div path "current_level" % string).
  
  Definition levels_in_current_cycle
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      level_query unit
      (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
        Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t) :=
    RPC_service.get_service (Some "Levels of a cycle" % string) level_query
      (obj2 (req None None "first" % string Raw_level.encoding)
        (req None None "last" % string Raw_level.encoding))
      (op_div path "levels_in_current_cycle" % string).
End S.

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Scripts.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Forge.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Parse.register tt in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.current_level
      (fun ctxt =>
        fun q =>
          fun function_parameter =>
            let 'tt := function_parameter in
            let level := Level.current ctxt in
            _return (Level.from_raw ctxt (Some (offset q)) (level level))) in
  register0 S.levels_in_current_cycle
    (fun ctxt =>
      fun q =>
        fun function_parameter =>
          let 'tt := function_parameter in
          let levels := Level.levels_in_current_cycle ctxt (Some (offset q)) tt
            in
          match levels with
          | [] => raise OCaml.Not_found
          | _ =>
            let first := List.hd (List.rev levels) in
            let last := List.hd levels in
            _return ((level first), (level last))
          end).

Definition current_level {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (op_staroptstar : option int32)
  : D ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Level.t) :=
  let offset :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int32 is converted to int *)
      0
    end in
  fun block =>
    RPC_context.make_call0 S.current_level ctxt block {| offset := offset |} tt.

Definition levels_in_current_cycle {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (op_staroptstar : option int32)
  : D ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t *
          Tezos_raw_protocol_alpha.Alpha_context.Raw_level.t)) :=
  let offset :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int32 is converted to int *)
      0
    end in
  fun block =>
    RPC_context.make_call0 S.levels_in_current_cycle ctxt block
      {| offset := offset |} tt.

src/proto_alpha/lib_protocol/init_storage.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* This is the genesis protocol: initialise the state *)
let prepare_first_block ctxt ~typecheck ~level ~timestamp ~fitness =
  Raw_context.prepare_first_block ~level ~timestamp ~fitness ctxt
  >>=? fun (previous_protocol, ctxt) ->
  Storage.Big_map.Next.init ctxt
  >>=? fun ctxt ->
  match previous_protocol with
  | Genesis param ->
      Commitment_storage.init ctxt param.commitments
      >>=? fun ctxt ->
      Roll_storage.init ctxt
      >>=? fun ctxt ->
      Seed_storage.init ctxt
      >>=? fun ctxt ->
      Contract_storage.init ctxt
      >>=? fun ctxt ->
      Bootstrap_storage.init
        ctxt
        ~typecheck
        ?ramp_up_cycles:param.security_deposit_ramp_up_cycles
        ?no_reward_cycles:param.no_reward_cycles
        param.bootstrap_accounts
        param.bootstrap_contracts
      >>=? fun ctxt ->
      Roll_storage.init_first_cycles ctxt
      >>=? fun ctxt ->
      Vote_storage.init ctxt
      >>=? fun ctxt ->
      Storage.Block_priority.init ctxt 0
      >>=? fun ctxt ->
      Vote_storage.freeze_listings ctxt >>=? fun ctxt -> return ctxt
  | Alpha_previous ->
      return ctxt

let prepare ctxt ~level ~predecessor_timestamp ~timestamp ~fitness =
  Raw_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
src/proto_alpha/lib_protocol/init_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition prepare_first_block
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (typecheck :
    Tezos_raw_protocol_alpha.Raw_context.t ->
      Tezos_raw_protocol_alpha.Script_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_repr.t *
              (option Tezos_raw_protocol_alpha.Contract_storage.big_map_diff)) *
              Tezos_raw_protocol_alpha.Raw_context.t))) (level : int32)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness :
    Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion
    (Raw_context.prepare_first_block level timestamp fitness ctxt)
    (fun function_parameter =>
      let '(previous_protocol, ctxt) := function_parameter in
      op_gtgteqquestion (Storage.Big_map.Next.init ctxt)
        (fun ctxt =>
          match previous_protocol with
          | Tezos_raw_protocol_alpha.Raw_context.Genesis param =>
            op_gtgteqquestion (Commitment_storage.init ctxt (commitments param))
              (fun ctxt =>
                op_gtgteqquestion (Roll_storage.init ctxt)
                  (fun ctxt =>
                    op_gtgteqquestion (Seed_storage.init ctxt)
                      (fun ctxt =>
                        op_gtgteqquestion (Contract_storage.init ctxt)
                          (fun ctxt =>
                            op_gtgteqquestion
                              (Bootstrap_storage.init ctxt typecheck
                                (security_deposit_ramp_up_cycles param)
                                (no_reward_cycles param)
                                (bootstrap_accounts param)
                                (bootstrap_contracts param))
                              (fun ctxt =>
                                op_gtgteqquestion
                                  (Roll_storage.init_first_cycles ctxt)
                                  (fun ctxt =>
                                    op_gtgteqquestion (Vote_storage.init ctxt)
                                      (fun ctxt =>
                                        op_gtgteqquestion
                                          (Storage.Block_priority.init ctxt 0)
                                          (fun ctxt =>
                                            op_gtgteqquestion
                                              (Vote_storage.freeze_listings ctxt)
                                              (fun ctxt => _return ctxt)))))))))
          | Tezos_raw_protocol_alpha.Raw_context.Alpha_previous => _return ctxt
          end)).

Definition prepare
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (level : Tezos_protocol_environment_alpha__Environment.Int32.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness :
    Tezos_protocol_environment_alpha__Environment.Fitness.(Tezos_protocol_environment_alpha__Environment.T.S.t))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.context) :=
  Raw_context.prepare level predecessor_timestamp timestamp fitness ctxt.

src/proto_alpha/lib_protocol/legacy_script_support_repr.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com>                *)
(* Copyright (c) 2019 Cryptium Labs <contact@cryptium-labs.com>              *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let manager_script_code : Script_repr.lazy_expr =
  let open Micheline in
  let open Michelson_v1_primitives in
  Script_repr.lazy_expr @@ strip_locations
  @@ Seq
       ( 0,
         [ Prim
             ( 0,
               K_parameter,
               [ Prim
                   ( 0,
                     T_or,
                     [ Prim
                         ( 0,
                           T_lambda,
                           [ Prim (0, T_unit, [], []);
                             Prim
                               (0, T_list, [Prim (0, T_operation, [], [])], [])
                           ],
                           ["%do"] );
                       Prim (0, T_unit, [], ["%default"]) ],
                     [] ) ],
               [] );
           Prim (0, K_storage, [Prim (0, T_key_hash, [], [])], []);
           Prim
             ( 0,
               K_code,
               [ Seq
                   ( 0,
                     [ Seq
                         ( 0,
                           [ Seq
                               ( 0,
                                 [ Prim (0, I_DUP, [], []);
                                   Prim (0, I_CAR, [], []);
                                   Prim
                                     ( 0,
                                       I_DIP,
                                       [Seq (0, [Prim (0, I_CDR, [], [])])],
                                       [] ) ] ) ] );
                       Prim
                         ( 0,
                           I_IF_LEFT,
                           [ Seq
                               ( 0,
                                 [ Prim
                                     ( 0,
                                       I_PUSH,
                                       [ Prim (0, T_mutez, [], []);
                                         Int (0, Z.zero) ],
                                       [] );
                                   Prim (0, I_AMOUNT, [], []);
                                   Seq
                                     ( 0,
                                       [ Seq
                                           ( 0,
                                             [ Prim (0, I_COMPARE, [], []);
                                               Prim (0, I_EQ, [], []) ] );
                                         Prim
                                           ( 0,
                                             I_IF,
                                             [ Seq (0, []);
                                               Seq
                                                 ( 0,
                                                   [ Seq
                                                       ( 0,
                                                         [ Prim
                                                             (0, I_UNIT, [], []);
                                                           Prim
                                                             ( 0,
                                                               I_FAILWITH,
                                                               [],
                                                               [] ) ] ) ] ) ],
                                             [] ) ] );
                                   Seq
                                     ( 0,
                                       [ Prim
                                           ( 0,
                                             I_DIP,
                                             [ Seq
                                                 (0, [Prim (0, I_DUP, [], [])])
                                             ],
                                             [] );
                                         Prim (0, I_SWAP, [], []) ] );
                                   Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                   Prim (0, I_ADDRESS, [], []);
                                   Prim (0, I_SENDER, [], []);
                                   Seq
                                     ( 0,
                                       [ Seq
                                           ( 0,
                                             [ Prim (0, I_COMPARE, [], []);
                                               Prim (0, I_EQ, [], []) ] );
                                         Prim
                                           ( 0,
                                             I_IF,
                                             [ Seq (0, []);
                                               Seq
                                                 ( 0,
                                                   [ Seq
                                                       ( 0,
                                                         [ Prim
                                                             (0, I_UNIT, [], []);
                                                           Prim
                                                             ( 0,
                                                               I_FAILWITH,
                                                               [],
                                                               [] ) ] ) ] ) ],
                                             [] ) ] );
                                   Prim (0, I_UNIT, [], []);
                                   Prim (0, I_EXEC, [], []);
                                   Prim (0, I_PAIR, [], []) ] );
                             Seq
                               ( 0,
                                 [ Prim (0, I_DROP, [], []);
                                   Prim
                                     ( 0,
                                       I_NIL,
                                       [Prim (0, T_operation, [], [])],
                                       [] );
                                   Prim (0, I_PAIR, [], []) ] ) ],
                           [] ) ] ) ],
               [] ) ] )

(* Find the toplevel expression with a given prim type from list,
   because they can be in arbitrary order. *)
let find_toplevel toplevel exprs =
  let open Micheline in
  let rec iter toplevel = function
    | (Prim (_, prim, _, _) as found) :: _
      when String.equal toplevel (Michelson_v1_primitives.string_of_prim prim)
      ->
        Some found
    | _ :: rest ->
        iter toplevel rest
    | [] ->
        None
  in
  iter (Michelson_v1_primitives.string_of_prim toplevel) exprs

let add_do :
    manager_pkh:Signature.Public_key_hash.t ->
    script_code:Script_repr.lazy_expr ->
    script_storage:Script_repr.lazy_expr ->
    (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
 fun ~manager_pkh ~script_code ~script_storage ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>=? fun (script_code_expr, _gas_cost) ->
  Lwt.return (Script_repr.force_decode script_storage)
  >>|? fun (script_storage_expr, _gas_cost) ->
  let storage_expr = root script_storage_expr in
  match root script_code_expr with
  | Seq (_, toplevel) -> (
    match
      ( find_toplevel K_parameter toplevel,
        find_toplevel K_storage toplevel,
        find_toplevel K_code toplevel )
    with
    | ( Some
          (Prim
            ( _,
              K_parameter,
              [Prim (_, parameter_type, parameter_expr, parameter_annot)],
              prim_param_annot )),
        Some
          (Prim
            ( _,
              K_storage,
              [ Prim
                  (_, code_storage_type, code_storage_expr, code_storage_annot)
              ],
              k_storage_annot )),
        Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
        (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
        let migrated_code =
          Seq
            ( 0,
              [ Prim
                  ( 0,
                    K_parameter,
                    [ Prim
                        ( 0,
                          T_or,
                          [ Prim
                              ( 0,
                                T_lambda,
                                [ Prim (0, T_unit, [], []);
                                  Prim
                                    ( 0,
                                      T_list,
                                      [Prim (0, T_operation, [], [])],
                                      [] ) ],
                                ["%do"] );
                            Prim
                              ( 0,
                                parameter_type,
                                parameter_expr,
                                "%default" :: parameter_annot ) ],
                          [] ) ],
                    prim_param_annot );
                Prim
                  ( 0,
                    K_storage,
                    [ Prim
                        ( 0,
                          T_pair,
                          [ Prim (0, T_key_hash, [], []);
                            Prim
                              ( 0,
                                code_storage_type,
                                code_storage_expr,
                                code_storage_annot ) ],
                          [] ) ],
                    k_storage_annot );
                Prim
                  ( 0,
                    K_code,
                    [ Seq
                        ( 0,
                          [ Prim (0, I_DUP, [], []);
                            Prim (0, I_CAR, [], []);
                            Prim
                              ( 0,
                                I_IF_LEFT,
                                [ Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_PUSH,
                                            [ Prim (0, T_mutez, [], []);
                                              Int (0, Z.zero) ],
                                            [] );
                                        Prim (0, I_AMOUNT, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_COMPARE, [], []);
                                                    Prim (0, I_EQ, [], []) ] );
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq (0, []);
                                                    Seq
                                                      ( 0,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_UNIT,
                                                                    [],
                                                                    [] );
                                                                Prim
                                                                  ( 0,
                                                                    I_FAILWITH,
                                                                    [],
                                                                    [] ) ] ) ]
                                                      ) ],
                                                  [] ) ] );
                                        Seq
                                          ( 0,
                                            [ Prim
                                                ( 0,
                                                  I_DIP,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_DUP, [], [])
                                                        ] ) ],
                                                  [] );
                                              Prim (0, I_SWAP, [], []) ] );
                                        Prim (0, I_CDR, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                        Prim (0, I_ADDRESS, [], []);
                                        Prim (0, I_SENDER, [], []);
                                        Seq
                                          ( 0,
                                            [ Prim (0, I_COMPARE, [], []);
                                              Prim (0, I_NEQ, [], []);
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_SENDER,
                                                              [],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_PUSH,
                                                              [ Prim
                                                                  ( 0,
                                                                    T_string,
                                                                    [],
                                                                    [] );
                                                                String
                                                                  ( 0,
                                                                    "Only the \
                                                                     owner \
                                                                     can \
                                                                     operate."
                                                                  ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_FAILWITH,
                                                              [],
                                                              [] ) ] );
                                                    Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_UNIT, [], []);
                                                          Prim
                                                            (0, I_EXEC, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_DIP,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_CDR,
                                                                          [],
                                                                          [] )
                                                                    ] ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], [])
                                                        ] ) ],
                                                  [] ) ] ) ] );
                                  Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_CDR, [], []);
                                                    Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CDR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []);
                                        code_expr;
                                        Prim (0, I_SWAP, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_SWAP, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CAR, [], []);
                                                    Prim
                                                      ( 0,
                                                        I_DIP,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_CDR,
                                                                    [],
                                                                    [] ) ] ) ],
                                                        [] ) ] ) ] );
                                        Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_SWAP, [], []);
                                                    Prim (0, I_PAIR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []) ] ) ],
                                [] ) ] ) ],
                    code_annot ) ] )
        in
        let migrated_storage =
          Prim
            ( 0,
              D_Pair,
              [ (* Instead of
                   `String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
                   the storage is written as unparsed with [Optimized] *)
                Bytes
                  ( 0,
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding
                      manager_pkh );
                storage_expr ],
              [] )
        in
        ( Script_repr.lazy_expr @@ strip_locations migrated_code,
          Script_repr.lazy_expr @@ strip_locations migrated_storage )
    | _ ->
        (script_code, script_storage) )
  | _ ->
      (script_code, script_storage)

let add_set_delegate :
    manager_pkh:Signature.Public_key_hash.t ->
    script_code:Script_repr.lazy_expr ->
    script_storage:Script_repr.lazy_expr ->
    (Script_repr.lazy_expr * Script_repr.lazy_expr) tzresult Lwt.t =
 fun ~manager_pkh ~script_code ~script_storage ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>=? fun (script_code_expr, _gas_cost) ->
  Lwt.return (Script_repr.force_decode script_storage)
  >>|? fun (script_storage_expr, _gas_cost) ->
  let storage_expr = root script_storage_expr in
  match root script_code_expr with
  | Seq (_, toplevel) -> (
    match
      ( find_toplevel K_parameter toplevel,
        find_toplevel K_storage toplevel,
        find_toplevel K_code toplevel )
    with
    | ( Some
          (Prim
            ( _,
              K_parameter,
              [Prim (_, parameter_type, parameter_expr, parameter_annot)],
              prim_param_annot )),
        Some
          (Prim
            ( _,
              K_storage,
              [ Prim
                  (_, code_storage_type, code_storage_expr, code_storage_annot)
              ],
              k_storage_annot )),
        Some (Prim (_, K_code, [code_expr], code_annot)) ) ->
        (* Note that we intentionally don't deal with potential duplicate entrypoints in this migration as there already might be some in contracts that we don't touch. *)
        let migrated_code =
          Seq
            ( 0,
              [ Prim
                  ( 0,
                    K_parameter,
                    [ Prim
                        ( 0,
                          T_or,
                          [ Prim
                              ( 0,
                                T_or,
                                [ Prim (0, T_key_hash, [], ["%set_delegate"]);
                                  Prim (0, T_unit, [], ["%remove_delegate"]) ],
                                [] );
                            Prim
                              ( 0,
                                parameter_type,
                                parameter_expr,
                                "%default" :: parameter_annot ) ],
                          [] ) ],
                    prim_param_annot );
                Prim
                  ( 0,
                    K_storage,
                    [ Prim
                        ( 0,
                          T_pair,
                          [ Prim (0, T_key_hash, [], []);
                            Prim
                              ( 0,
                                code_storage_type,
                                code_storage_expr,
                                code_storage_annot ) ],
                          [] ) ],
                    k_storage_annot );
                Prim
                  ( 0,
                    K_code,
                    [ Seq
                        ( 0,
                          [ Prim (0, I_DUP, [], []);
                            Prim (0, I_CAR, [], []);
                            Prim
                              ( 0,
                                I_IF_LEFT,
                                [ Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_PUSH,
                                            [ Prim (0, T_mutez, [], []);
                                              Int (0, Z.zero) ],
                                            [] );
                                        Prim (0, I_AMOUNT, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_COMPARE, [], []);
                                                    Prim (0, I_EQ, [], []) ] );
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq (0, []);
                                                    Seq
                                                      ( 0,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_UNIT,
                                                                    [],
                                                                    [] );
                                                                Prim
                                                                  ( 0,
                                                                    I_FAILWITH,
                                                                    [],
                                                                    [] ) ] ) ]
                                                      ) ],
                                                  [] ) ] );
                                        Seq
                                          ( 0,
                                            [ Prim
                                                ( 0,
                                                  I_DIP,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            (0, I_DUP, [], [])
                                                        ] ) ],
                                                  [] );
                                              Prim (0, I_SWAP, [], []) ] );
                                        Prim (0, I_CDR, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_IMPLICIT_ACCOUNT, [], []);
                                        Prim (0, I_ADDRESS, [], []);
                                        Prim (0, I_SENDER, [], []);
                                        Seq
                                          ( 0,
                                            [ Prim (0, I_COMPARE, [], []);
                                              Prim (0, I_NEQ, [], []);
                                              Prim
                                                ( 0,
                                                  I_IF,
                                                  [ Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_SENDER,
                                                              [],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_PUSH,
                                                              [ Prim
                                                                  ( 0,
                                                                    T_string,
                                                                    [],
                                                                    [] );
                                                                String
                                                                  ( 0,
                                                                    "Only the \
                                                                     owner \
                                                                     can \
                                                                     operate."
                                                                  ) ],
                                                              [] );
                                                          Prim
                                                            (0, I_PAIR, [], []);
                                                          Prim
                                                            ( 0,
                                                              I_FAILWITH,
                                                              [],
                                                              [] ) ] );
                                                    Seq
                                                      ( 0,
                                                        [ Prim
                                                            ( 0,
                                                              I_DIP,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_CDR,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_NIL,
                                                                          [ Prim
                                                                              ( 
                                                                              0,
                                                                               T_operation,
                                                                               [],
                                                                               []
                                                                              )
                                                                          ],
                                                                          [] )
                                                                    ] ) ],
                                                              [] );
                                                          Prim
                                                            ( 0,
                                                              I_IF_LEFT,
                                                              [ Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_SOME,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_SET_DELEGATE,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_CONS,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_PAIR,
                                                                          [],
                                                                          [] )
                                                                    ] );
                                                                Seq
                                                                  ( 0,
                                                                    [ Prim
                                                                        ( 0,
                                                                          I_DROP,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_NONE,
                                                                          [ Prim
                                                                              ( 
                                                                              0,
                                                                               T_key_hash,
                                                                               [],
                                                                               []
                                                                              )
                                                                          ],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_SET_DELEGATE,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_CONS,
                                                                          [],
                                                                          [] );
                                                                      Prim
                                                                        ( 0,
                                                                          I_PAIR,
                                                                          [],
                                                                          [] )
                                                                    ] ) ],
                                                              [] ) ] ) ],
                                                  [] ) ] ) ] );
                                  Seq
                                    ( 0,
                                      [ Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_CDR, [], []);
                                                    Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CDR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []);
                                        code_expr;
                                        Prim (0, I_SWAP, [], []);
                                        Prim (0, I_CAR, [], []);
                                        Prim (0, I_SWAP, [], []);
                                        Seq
                                          ( 0,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_DUP, [], []);
                                                    Prim (0, I_CAR, [], []);
                                                    Prim
                                                      ( 0,
                                                        I_DIP,
                                                        [ Seq
                                                            ( 0,
                                                              [ Prim
                                                                  ( 0,
                                                                    I_CDR,
                                                                    [],
                                                                    [] ) ] ) ],
                                                        [] ) ] ) ] );
                                        Prim
                                          ( 0,
                                            I_DIP,
                                            [ Seq
                                                ( 0,
                                                  [ Prim (0, I_SWAP, [], []);
                                                    Prim (0, I_PAIR, [], []) ]
                                                ) ],
                                            [] );
                                        Prim (0, I_PAIR, [], []) ] ) ],
                                [] ) ] ) ],
                    code_annot ) ] )
        in
        let migrated_storage =
          Prim
            ( 0,
              D_Pair,
              [ (* Instead of
                   `String (0, Signature.Public_key_hash.to_b58check manager_pkh)`
                   the storage is written as unparsed with [Optimized] *)
                Bytes
                  ( 0,
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding
                      manager_pkh );
                storage_expr ],
              [] )
        in
        ( Script_repr.lazy_expr @@ strip_locations migrated_code,
          Script_repr.lazy_expr @@ strip_locations migrated_storage )
    | _ ->
        (script_code, script_storage) )
  | _ ->
      (script_code, script_storage)

let has_default_entrypoint expr =
  let open Micheline in
  let open Michelson_v1_primitives in
  match Script_repr.force_decode expr with
  | Error _ ->
      false
  | Ok (expr, _) -> (
    match root expr with
    | Seq (_, toplevel) -> (
      match find_toplevel K_parameter toplevel with
      | Some (Prim (_, K_parameter, [_], ["%default"])) ->
          false
      | Some (Prim (_, K_parameter, [parameter_expr], _)) ->
          let rec has_default = function
            | Prim (_, T_or, [l; r], annots) ->
                List.exists (String.equal "%default") annots
                || has_default l || has_default r
            | Prim (_, _, _, annots) ->
                List.exists (String.equal "%default") annots
            | _ ->
                false
          in
          has_default parameter_expr
      | Some _ | None ->
          false )
    | _ ->
        false )

let add_root_entrypoint :
    script_code:Script_repr.lazy_expr -> Script_repr.lazy_expr tzresult Lwt.t =
 fun ~script_code ->
  let open Micheline in
  let open Michelson_v1_primitives in
  Lwt.return (Script_repr.force_decode script_code)
  >>|? fun (script_code_expr, _gas_cost) ->
  match root script_code_expr with
  | Seq (_, toplevel) ->
      let migrated_code =
        Seq
          ( 0,
            List.map
              (function
                | Prim (_, K_parameter, [parameter_expr], _) ->
                    Prim (0, K_parameter, [parameter_expr], ["%root"])
                | Prim (_, K_code, exprs, annots) ->
                    let rec rewrite_self = function
                      | ( Int _
                        | String _
                        | Bytes _
                        | Prim (_, I_CREATE_CONTRACT, _, _) ) as leaf ->
                          leaf
                      | Prim (_, I_SELF, [], annots) ->
                          Prim (0, I_SELF, [], "%root" :: annots)
                      | Prim (_, name, args, annots) ->
                          Prim (0, name, List.map rewrite_self args, annots)
                      | Seq (_, args) ->
                          Seq (0, List.map rewrite_self args)
                    in
                    Prim (0, K_code, List.map rewrite_self exprs, annots)
                | other ->
                    other)
              toplevel )
      in
      Script_repr.lazy_expr @@ strip_locations migrated_code
  | _ ->
      script_code
src/proto_alpha/lib_protocol/legacy_script_support_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition manager_script_code
  : Tezos_raw_protocol_alpha.Script_repr.lazy_expr :=
  op_atat Script_repr.lazy_expr
    (op_atat strip_locations
      (Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
        (cons
          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
            Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
            (cons
              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
                (cons
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    0 Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_lambda
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        0
                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
                        [] [])
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          0
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_list
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                              0
                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
                              [] []) []) []) [])) (cons "%do" % string []))
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                      0 Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
                      [] (cons "%default" % string [])) [])) []) []) [])
          (cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
              Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
              (cons
                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash []
                  []) []) [])
            (cons
              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                (cons
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                        0
                        (cons
                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                            0
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0
                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                [] [])
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                  [] [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                    (cons
                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                        0
                                        (cons
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                            0
                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                            [] []) [])) []) []) [])))) []))
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          0
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                              0
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
                                  (cons
                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                      0
                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_mutez
                                      [] [])
                                    (cons
                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Int
                                        0 Z.zero) [])) [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_AMOUNT
                                    [] [])
                                  (cons
                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                      0
                                      (cons
                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                          0
                                          (cons
                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                              0
                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
                                              [] [])
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                0
                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
                                                [] []) [])))
                                        (cons
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                            0
                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                0 [])
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                  0
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                      0
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
                                                            [] []) []))) [])) []))
                                            []) [])))
                                    (cons
                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                        0
                                        (cons
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                            0
                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                0
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                    0
                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                    [] []) [])) []) [])
                                          (cons
                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                              0
                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                              [] []) [])))
                                      (cons
                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                          0
                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
                                          [] [])
                                        (cons
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                            0
                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_ADDRESS
                                            [] [])
                                          (cons
                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                              0
                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
                                              [] [])
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                0
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                    0
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
                                                          [] []) [])))
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                      0
                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                          0 [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                0
                                                                (cons
                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                    0
                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
                                                                    [] [])
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
                                                                      [] []) [])))
                                                              [])) [])) []) [])))
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                  0
                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
                                                  [] [])
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                    0
                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EXEC
                                                    [] [])
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                      0
                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                      [] []) []))))))))))))
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                0
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DROP
                                    [] [])
                                  (cons
                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                      0
                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NIL
                                      (cons
                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                          0
                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
                                          [] []) []) [])
                                    (cons
                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                        0
                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                        [] []) [])))) [])) []) []))) []) []) []))))).

Definition find_toplevel {A : Type}
  (toplevel : Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
  (exprs :
    list
      (Tezos_protocol_environment_alpha__Environment.Micheline.node A
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
  : option
    (Tezos_protocol_environment_alpha__Environment.Micheline.node A
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
  let fix iter {B : Type}
    (toplevel : Tezos_protocol_environment_alpha__Environment.String.t)
    (function_parameter :
    list
      (Tezos_protocol_environment_alpha__Environment.Micheline.node B
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim))
    : option
      (Tezos_protocol_environment_alpha__Environment.Micheline.node B
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
    match function_parameter with
    |
      cons
        ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ prim _
          _) as found) _ => Some found
    | cons _ rest => iter toplevel rest
    | [] => None
    end in
  iter (Michelson_v1_primitives.string_of_prim toplevel) exprs.

Definition add_do
  (manager_pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  (script_storage : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
        Tezos_raw_protocol_alpha.Script_repr.lazy_expr)) :=
  op_gtgteqquestion (Lwt._return (Script_repr.force_decode script_code))
    (fun function_parameter =>
      let '(script_code_expr, _gas_cost) := function_parameter in
      op_gtgtpipequestion
        (Lwt._return (Script_repr.force_decode script_storage))
        (fun function_parameter =>
          let '(script_storage_expr, _gas_cost) := function_parameter in
          let storage_expr := root script_storage_expr in
          match root script_code_expr with
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Seq _
              toplevel =>
            match
              ((find_toplevel
                Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                toplevel),
                (find_toplevel
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
                  toplevel),
                (find_toplevel
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                  toplevel)) with
            |
              (Some
                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                      _ parameter_type parameter_expr parameter_annot) [])
                  prim_param_annot),
                Some
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    _ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        _ code_storage_type code_storage_expr code_storage_annot)
                      []) k_storage_annot),
                Some
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    _ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                    (cons code_expr []) code_annot)) =>
              let migrated_code :=
                Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                      0
                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          0
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                              0
                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_lambda
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
                                  [] [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_list
                                    (cons
                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                        0
                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
                                        [] []) []) []) []))
                              (cons "%do" % string []))
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0 parameter_type parameter_expr
                                (cons "%default" % string parameter_annot)) []))
                          []) []) prim_param_annot)
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        0
                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
                        (cons
                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                            0
                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_pair
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0
                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
                                [] [])
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0 code_storage_type code_storage_expr
                                  code_storage_annot) [])) []) [])
                        k_storage_annot)
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          0
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                              0
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                  [] [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                    [] [])
                                  (cons
                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                      0
                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
                                      (cons
                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                          0
                                          (cons
                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                              0
                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                  0
                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_mutez
                                                  [] [])
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Int
                                                    0 Z.zero) [])) [])
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                0
                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_AMOUNT
                                                [] [])
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                  0
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                      0
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
                                                            [] []) [])))
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0 [])
                                                          (cons
                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                              0
                                                              (cons
                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                  0
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
                                                                        [] [])
                                                                      []))) []))
                                                            [])) []) [])))
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                    0
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                0
                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                                [] []) [])) [])
                                                        [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                          [] []) [])))
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                      0
                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                      [] [])
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_ADDRESS
                                                            [] [])
                                                          (cons
                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                              0
                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
                                                              [] [])
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                0
                                                                (cons
                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                    0
                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
                                                                    [] [])
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NEQ
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
                                                                        (cons
                                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                            0
                                                                            (cons
                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                0
                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
                                                                                []
                                                                                [])
                                                                              (cons
                                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                  0
                                                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
                                                                                  (cons
                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                      0
                                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_string
                                                                                      []
                                                                                      [])
                                                                                    (cons
                                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.String
                                                                                        0
                                                                                        "Only the owner can operate."
                                                                                          %
                                                                                          string)
                                                                                      []))
                                                                                  [])
                                                                                (cons
                                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                    0
                                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                                    []
                                                                                    [])
                                                                                  (cons
                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                      0
                                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
                                                                                      []
                                                                                      [])
                                                                                    [])))))
                                                                          (cons
                                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                              0
                                                                              (cons
                                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                  0
                                                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
                                                                                  []
                                                                                  [])
                                                                                (cons
                                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                    0
                                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EXEC
                                                                                    []
                                                                                    [])
                                                                                  (cons
                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                      0
                                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                                                      (cons
                                                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                                          0
                                                                                          (cons
                                                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                              0
                                                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                                                              []
                                                                                              [])
                                                                                            []))
                                                                                        [])
                                                                                      [])
                                                                                    (cons
                                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                        0
                                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                                        []
                                                                                        [])
                                                                                      [])))))
                                                                            []))
                                                                        []) []))))
                                                              [])))))))))))
                                        (cons
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                            0
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                0
                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                    0
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                            [] []) [])))) []) [])
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                  0
                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                  [] [])
                                                (cons code_expr
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                      0
                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                      [] [])
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                0
                                                                (cons
                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                    0
                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                                    [] [])
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                                        (cons
                                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                            0
                                                                            (cons
                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                0
                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                                                []
                                                                                [])
                                                                              []))
                                                                          []) [])
                                                                      [])))) []))
                                                          (cons
                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                              0
                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                              (cons
                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                  0
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                        [] [])
                                                                      []))) [])
                                                              [])
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                0
                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                [] []) []))))))))))
                                          [])) []) [])))) []) code_annot) [])))
                in
              let migrated_storage :=
                Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Pair
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                      0
                      (Data_encoding.Binary.to_bytes_exn
                        Signature.Public_key_hash.encoding manager_pkh))
                    (cons storage_expr [])) [] in
              ((op_atat Script_repr.lazy_expr (strip_locations migrated_code)),
                (op_atat Script_repr.lazy_expr
                  (strip_locations migrated_storage)))
            | _ => (script_code, script_storage)
            end
          | _ => (script_code, script_storage)
          end)).

Definition add_set_delegate
  (manager_pkh :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  (script_storage : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_repr.lazy_expr *
        Tezos_raw_protocol_alpha.Script_repr.lazy_expr)) :=
  op_gtgteqquestion (Lwt._return (Script_repr.force_decode script_code))
    (fun function_parameter =>
      let '(script_code_expr, _gas_cost) := function_parameter in
      op_gtgtpipequestion
        (Lwt._return (Script_repr.force_decode script_storage))
        (fun function_parameter =>
          let '(script_storage_expr, _gas_cost) := function_parameter in
          let storage_expr := root script_storage_expr in
          match root script_code_expr with
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Seq _
              toplevel =>
            match
              ((find_toplevel
                Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                toplevel),
                (find_toplevel
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
                  toplevel),
                (find_toplevel
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                  toplevel)) with
            |
              (Some
                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                      _ parameter_type parameter_expr parameter_annot) [])
                  prim_param_annot),
                Some
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    _ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        _ code_storage_type code_storage_expr code_storage_annot)
                      []) k_storage_annot),
                Some
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    _ Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                    (cons code_expr []) code_annot)) =>
              let migrated_code :=
                Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                      0
                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          0
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                              0
                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
                                  [] (cons "%set_delegate" % string []))
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_unit
                                    [] (cons "%remove_delegate" % string [])) []))
                              [])
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0 parameter_type parameter_expr
                                (cons "%default" % string parameter_annot)) []))
                          []) []) prim_param_annot)
                    (cons
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        0
                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_storage
                        (cons
                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                            0
                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_pair
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0
                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
                                [] [])
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0 code_storage_type code_storage_expr
                                  code_storage_annot) [])) []) [])
                        k_storage_annot)
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          0
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                              0
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                  [] [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                    [] [])
                                  (cons
                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                      0
                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
                                      (cons
                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                          0
                                          (cons
                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                              0
                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                  0
                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_mutez
                                                  [] [])
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Int
                                                    0 Z.zero) [])) [])
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                0
                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_AMOUNT
                                                [] [])
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                  0
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                      0
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_EQ
                                                            [] []) [])))
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0 [])
                                                          (cons
                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                              0
                                                              (cons
                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                  0
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_UNIT
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
                                                                        [] [])
                                                                      []))) []))
                                                            [])) []) [])))
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                    0
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                0
                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                                [] []) [])) [])
                                                        [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                          [] []) [])))
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                      0
                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                      [] [])
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IMPLICIT_ACCOUNT
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_ADDRESS
                                                            [] [])
                                                          (cons
                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                              0
                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
                                                              [] [])
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                0
                                                                (cons
                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                    0
                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_COMPARE
                                                                    [] [])
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NEQ
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF
                                                                        (cons
                                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                            0
                                                                            (cons
                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                0
                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SENDER
                                                                                []
                                                                                [])
                                                                              (cons
                                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                  0
                                                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PUSH
                                                                                  (cons
                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                      0
                                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_string
                                                                                      []
                                                                                      [])
                                                                                    (cons
                                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.String
                                                                                        0
                                                                                        "Only the owner can operate."
                                                                                          %
                                                                                          string)
                                                                                      []))
                                                                                  [])
                                                                                (cons
                                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                    0
                                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                                    []
                                                                                    [])
                                                                                  (cons
                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                      0
                                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_FAILWITH
                                                                                      []
                                                                                      [])
                                                                                    [])))))
                                                                          (cons
                                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                              0
                                                                              (cons
                                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                  0
                                                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                                                  (cons
                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                                      0
                                                                                      (cons
                                                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                          0
                                                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                                                          []
                                                                                          [])
                                                                                        (cons
                                                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                            0
                                                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NIL
                                                                                            (cons
                                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                0
                                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_operation
                                                                                                []
                                                                                                [])
                                                                                              [])
                                                                                            [])
                                                                                          [])))
                                                                                    [])
                                                                                  [])
                                                                                (cons
                                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                    0
                                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_IF_LEFT
                                                                                    (cons
                                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                                        0
                                                                                        (cons
                                                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                            0
                                                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SOME
                                                                                            []
                                                                                            [])
                                                                                          (cons
                                                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                              0
                                                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SET_DELEGATE
                                                                                              []
                                                                                              [])
                                                                                            (cons
                                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                0
                                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CONS
                                                                                                []
                                                                                                [])
                                                                                              (cons
                                                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                  0
                                                                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                                                  []
                                                                                                  [])
                                                                                                [])))))
                                                                                      (cons
                                                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                                          0
                                                                                          (cons
                                                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                              0
                                                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DROP
                                                                                              []
                                                                                              [])
                                                                                            (cons
                                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                0
                                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_NONE
                                                                                                (cons
                                                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                    0
                                                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_key_hash
                                                                                                    []
                                                                                                    [])
                                                                                                  [])
                                                                                                [])
                                                                                              (cons
                                                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                  0
                                                                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SET_DELEGATE
                                                                                                  []
                                                                                                  [])
                                                                                                (cons
                                                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                    0
                                                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CONS
                                                                                                    []
                                                                                                    [])
                                                                                                  (cons
                                                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                                      0
                                                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                                                      []
                                                                                                      [])
                                                                                                    []))))))
                                                                                        []))
                                                                                    [])
                                                                                  [])))
                                                                            []))
                                                                        []) []))))
                                                              [])))))))))))
                                        (cons
                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                            0
                                            (cons
                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                0
                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                (cons
                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                    0
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                            0
                                                            Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                            [] []) [])))) []) [])
                                              (cons
                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                  0
                                                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                  [] [])
                                                (cons code_expr
                                                  (cons
                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                      0
                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                      [] [])
                                                    (cons
                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                        0
                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                                        [] [])
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                          0
                                                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                          [] [])
                                                        (cons
                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                            0
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                0
                                                                (cons
                                                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                    0
                                                                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DUP
                                                                    [] [])
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CAR
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                                        (cons
                                                                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                            0
                                                                            (cons
                                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                                0
                                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CDR
                                                                                []
                                                                                [])
                                                                              []))
                                                                          []) [])
                                                                      [])))) []))
                                                          (cons
                                                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                              0
                                                              Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_DIP
                                                              (cons
                                                                (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                                                                  0
                                                                  (cons
                                                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                      0
                                                                      Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SWAP
                                                                      [] [])
                                                                    (cons
                                                                      (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                        0
                                                                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                        [] [])
                                                                      []))) [])
                                                              [])
                                                            (cons
                                                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                                                0
                                                                Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_PAIR
                                                                [] []) []))))))))))
                                          [])) []) [])))) []) code_annot) [])))
                in
              let migrated_storage :=
                Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                  Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Pair
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                      0
                      (Data_encoding.Binary.to_bytes_exn
                        Signature.Public_key_hash.encoding manager_pkh))
                    (cons storage_expr [])) [] in
              ((op_atat Script_repr.lazy_expr (strip_locations migrated_code)),
                (op_atat Script_repr.lazy_expr
                  (strip_locations migrated_storage)))
            | _ => (script_code, script_storage)
            end
          | _ => (script_code, script_storage)
          end)).

Definition has_default_entrypoint
  (expr : Tezos_raw_protocol_alpha.Script_repr.lazy_expr) : bool :=
  match Script_repr.force_decode expr with
  | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ => false
  | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (expr, _) =>
    match root expr with
    | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ toplevel =>
      match
        find_toplevel
          Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter toplevel
        with
      |
        Some
          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
            Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
            (cons _ []) (cons "%default" % string [])) => false
      |
        Some
          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
            Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
            (cons parameter_expr []) _) =>
        let fix has_default {A : Type}
          (function_parameter :
          Tezos_protocol_environment_alpha__Environment.Micheline.node A
            Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) : bool :=
          match function_parameter with
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
              Tezos_raw_protocol_alpha.Michelson_v1_primitives.T_or
              (cons l (cons r [])) annots =>
            op_pipepipe (List._exists (String.equal "%default" % string) annots)
              (op_pipepipe (has_default l) (has_default r))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ _
              annots => List._exists (String.equal "%default" % string) annots
          | _ => false
          end in
        has_default parameter_expr
      | Some _ | None => false
      end
    | _ => false
    end
  end.

Definition add_root_entrypoint
  (script_code : Tezos_raw_protocol_alpha.Script_repr.lazy_expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Script_repr.lazy_expr) :=
  op_gtgtpipequestion (Lwt._return (Script_repr.force_decode script_code))
    (fun function_parameter =>
      let '(script_code_expr, _gas_cost) := function_parameter in
      match root script_code_expr with
      | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ toplevel
        =>
        let migrated_code :=
          Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
            (List.map
              (fun function_parameter =>
                match function_parameter with
                |
                  Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                    (cons parameter_expr []) _ =>
                  Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_parameter
                    (cons parameter_expr []) (cons "%root" % string [])
                |
                  Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                    exprs annots =>
                  let fix rewrite_self
                    (function_parameter :
                    Tezos_protocol_environment_alpha__Environment.Micheline.node
                      Z Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
                    : Tezos_protocol_environment_alpha__Environment.Micheline.node
                      Z Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim :=
                    match function_parameter with
                    |
                      (Tezos_protocol_environment_alpha__Environment.Micheline.Int
                        _ _ |
                        Tezos_protocol_environment_alpha__Environment.Micheline.String
                          _ _ |
                        Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                          _ _ |
                        Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          _
                          Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_CREATE_CONTRACT
                          _ _) as leaf => leaf
                    |
                      Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        _
                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SELF
                        [] annots =>
                      Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        0
                        Tezos_raw_protocol_alpha.Michelson_v1_primitives.I_SELF
                        [] (cons "%root" % string annots)
                    |
                      Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        _ name args annots =>
                      Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        0 name (List.map rewrite_self args) annots
                    |
                      Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                        _ args =>
                      Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                        0 (List.map rewrite_self args)
                    end in
                  Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                    Tezos_raw_protocol_alpha.Michelson_v1_primitives.K_code
                    (List.map rewrite_self exprs) annots
                | other => other
                end) toplevel) in
        op_atat Script_repr.lazy_expr (strip_locations migrated_code)
      | _ => script_code
      end).

src/proto_alpha/lib_protocol/level_repr.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = {
  level : Raw_level_repr.t;
  level_position : int32;
  cycle : Cycle_repr.t;
  cycle_position : int32;
  voting_period : Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool;
}

include Compare.Make (struct
  type nonrec t = t

  let compare {level = l1} {level = l2} = Raw_level_repr.compare l1 l2
end)

type level = t

let pp ppf {level} = Raw_level_repr.pp ppf level

let pp_full ppf l =
  Format.fprintf
    ppf
    "%a.%ld (cycle %a.%ld) (vote %a.%ld)"
    Raw_level_repr.pp
    l.level
    l.level_position
    Cycle_repr.pp
    l.cycle
    l.cycle_position
    Voting_period_repr.pp
    l.voting_period
    l.voting_period_position

let encoding =
  let open Data_encoding in
  conv
    (fun { level;
           level_position;
           cycle;
           cycle_position;
           voting_period;
           voting_period_position;
           expected_commitment } ->
      ( level,
        level_position,
        cycle,
        cycle_position,
        voting_period,
        voting_period_position,
        expected_commitment ))
    (fun ( level,
           level_position,
           cycle,
           cycle_position,
           voting_period,
           voting_period_position,
           expected_commitment ) ->
      {
        level;
        level_position;
        cycle;
        cycle_position;
        voting_period;
        voting_period_position;
        expected_commitment;
      })
    (obj7
       (req
          "level"
          ~description:
            "The level of the block relative to genesis. This is also the \
             Shell's notion of level"
          Raw_level_repr.encoding)
       (req
          "level_position"
          ~description:
            "The level of the block relative to the block that starts \
             protocol alpha. This is specific to the protocol alpha. Other \
             protocols might or might not include a similar notion."
          int32)
       (req
          "cycle"
          ~description:
            "The current cycle's number. Note that cycles are a \
             protocol-specific notion. As a result, the cycle number starts \
             at 0 with the first block of protocol alpha."
          Cycle_repr.encoding)
       (req
          "cycle_position"
          ~description:
            "The current level of the block relative to the first block of \
             the current cycle."
          int32)
       (req
          "voting_period"
          ~description:
            "The current voting period's index. Note that cycles are a \
             protocol-specific notion. As a result, the voting period index \
             starts at 0 with the first block of protocol alpha."
          Voting_period_repr.encoding)
       (req
          "voting_period_position"
          ~description:
            "The current level of the block relative to the first block of \
             the current voting period."
          int32)
       (req
          "expected_commitment"
          ~description:
            "Tells wether the baker of this block has to commit a seed nonce \
             hash."
          bool))

let root first_level =
  {
    level = first_level;
    level_position = 0l;
    cycle = Cycle_repr.root;
    cycle_position = 0l;
    voting_period = Voting_period_repr.root;
    voting_period_position = 0l;
    expected_commitment = false;
  }

let from_raw ~first_level ~blocks_per_cycle ~blocks_per_voting_period
    ~blocks_per_commitment level =
  let raw_level = Raw_level_repr.to_int32 level in
  let first_level = Raw_level_repr.to_int32 first_level in
  let level_position =
    Compare.Int32.max 0l (Int32.sub raw_level first_level)
  in
  let cycle =
    Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle)
  in
  let cycle_position = Int32.rem level_position blocks_per_cycle in
  let voting_period =
    Voting_period_repr.of_int32_exn
      (Int32.div level_position blocks_per_voting_period)
  in
  let voting_period_position =
    Int32.rem level_position blocks_per_voting_period
  in
  let expected_commitment =
    Compare.Int32.(
      Int32.rem cycle_position blocks_per_commitment
      = Int32.pred blocks_per_commitment)
  in
  {
    level;
    level_position;
    cycle;
    cycle_position;
    voting_period;
    voting_period_position;
    expected_commitment;
  }

let diff {level = l1; _} {level = l2; _} =
  Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2)
src/proto_alpha/lib_protocol/level_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record t := {
  level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
  level_position : int32;
  cycle : Tezos_raw_protocol_alpha.Cycle_repr.t;
  cycle_position : int32;
  voting_period : Tezos_raw_protocol_alpha.Voting_period_repr.t;
  voting_period_position : int32;
  expected_commitment : bool }.

(* ❌ Structure item `include` not handled. *)
include

Definition level := t.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : t) : unit :=
  let '{| level := level |} := function_parameter in
  Raw_level_repr.pp ppf level.

Definition pp_full
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter) (l : t)
  : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
          "." % char
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              " (cycle " % string
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
                  "." % char
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                      ") (vote " % string
                      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
                        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
                          "." % char
                          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
                            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
                              ")" % char
                              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))))))))))))
      "%a.%ld (cycle %a.%ld) (vote %a.%ld)" % string) Raw_level_repr.pp
    (level l) (level_position l) Cycle_repr.pp (cycle l) (cycle_position l)
    Voting_period_repr.pp (voting_period l) (voting_period_position l).

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  conv
    (fun function_parameter =>
      let '{|
        level := level;
          level_position := level_position;
          cycle := cycle;
          cycle_position := cycle_position;
          voting_period := voting_period;
          voting_period_position := voting_period_position;
          expected_commitment := expected_commitment
          |} := function_parameter in
      (level, level_position, cycle, cycle_position, voting_period,
        voting_period_position, expected_commitment))
    (fun function_parameter =>
      let
        '(level, level_position, cycle, cycle_position, voting_period,
          voting_period_position, expected_commitment) := function_parameter in
      {| level := level; level_position := level_position; cycle := cycle;
        cycle_position := cycle_position; voting_period := voting_period;
        voting_period_position := voting_period_position;
        expected_commitment := expected_commitment |}) None
    (obj7
      (req None
        (Some
          "The level of the block relative to genesis. This is also the Shell's notion of level"
            % string) "level" % string Raw_level_repr.encoding)
      (req None
        (Some
          "The level of the block relative to the block that starts protocol alpha. This is specific to the protocol alpha. Other protocols might or might not include a similar notion."
            % string) "level_position" % string int32)
      (req None
        (Some
          "The current cycle's number. Note that cycles are a protocol-specific notion. As a result, the cycle number starts at 0 with the first block of protocol alpha."
            % string) "cycle" % string Cycle_repr.encoding)
      (req None
        (Some
          "The current level of the block relative to the first block of the current cycle."
            % string) "cycle_position" % string int32)
      (req None
        (Some
          "The current voting period's index. Note that cycles are a protocol-specific notion. As a result, the voting period index starts at 0 with the first block of protocol alpha."
            % string) "voting_period" % string Voting_period_repr.encoding)
      (req None
        (Some
          "The current level of the block relative to the first block of the current voting period."
            % string) "voting_period_position" % string int32)
      (req None
        (Some
          "Tells wether the baker of this block has to commit a seed nonce hash."
            % string) "expected_commitment" % string bool)).

Definition root (first_level : Tezos_raw_protocol_alpha.Raw_level_repr.t) : t :=
  {| level := first_level;
    level_position :=
      (* ❌ Constant of type int32 is converted to int *)
      0; cycle := Cycle_repr.root;
    cycle_position :=
      (* ❌ Constant of type int32 is converted to int *)
      0; voting_period := Voting_period_repr.root;
    voting_period_position :=
      (* ❌ Constant of type int32 is converted to int *)
      0; expected_commitment := false |}.

Definition from_raw
  (first_level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
  (blocks_per_cycle : int32) (blocks_per_voting_period : int32)
  (blocks_per_commitment : int32)
  (level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level) : t :=
  let raw_level := Raw_level_repr.to_int32 level in
  let first_level := Raw_level_repr.to_int32 first_level in
  let level_position :=
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
      (* ❌ Constant of type int32 is converted to int *)
      0 (Int32.sub raw_level first_level) in
  let cycle :=
    Cycle_repr.of_int32_exn (Int32.div level_position blocks_per_cycle) in
  let cycle_position := Int32.rem level_position blocks_per_cycle in
  let voting_period :=
    Voting_period_repr.of_int32_exn
      (Int32.div level_position blocks_per_voting_period) in
  let voting_period_position :=
    Int32.rem level_position blocks_per_voting_period in
  let expected_commitment :=
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      (Int32.rem cycle_position blocks_per_commitment)
      (Int32.pred blocks_per_commitment) in
  {| level := level; level_position := level_position; cycle := cycle;
    cycle_position := cycle_position; voting_period := voting_period;
    voting_period_position := voting_period_position;
    expected_commitment := expected_commitment |}.

Definition diff (function_parameter : t) : t -> int32 :=
  let '{| level := l1 |} := function_parameter in
  fun function_parameter =>
    let '{| level := l2 |} := function_parameter in
    Int32.sub (Raw_level_repr.to_int32 l1) (Raw_level_repr.to_int32 l2).

src/proto_alpha/lib_protocol/level_storage.ml 4 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Level_repr

let from_raw c ?offset l =
  let l =
    match offset with
    | None ->
        l
    | Some o ->
        Raw_level_repr.(of_int32_exn (Int32.add (to_int32 l) o))
  in
  let constants = Raw_context.constants c in
  let first_level = Raw_context.first_level c in
  Level_repr.from_raw
    ~first_level
    ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
    ~blocks_per_voting_period:constants.Constants_repr.blocks_per_voting_period
    ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
    l

let root c = Level_repr.root (Raw_context.first_level c)

let succ c l = from_raw c (Raw_level_repr.succ l.level)

let pred c l =
  match Raw_level_repr.pred l.Level_repr.level with
  | None ->
      None
  | Some l ->
      Some (from_raw c l)

let current ctxt = Raw_context.current_level ctxt

let previous ctxt =
  let l = current ctxt in
  match pred ctxt l with
  | None ->
      assert false (* We never validate the Genesis... *)
  | Some p ->
      p

let first_level_in_cycle ctxt c =
  let constants = Raw_context.constants ctxt in
  let first_level = Raw_context.first_level ctxt in
  from_raw
    ctxt
    (Raw_level_repr.of_int32_exn
       (Int32.add
          (Raw_level_repr.to_int32 first_level)
          (Int32.mul
             constants.Constants_repr.blocks_per_cycle
             (Cycle_repr.to_int32 c))))

let last_level_in_cycle ctxt c =
  match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
  | None ->
      assert false
  | Some x ->
      x

let levels_in_cycle ctxt cycle =
  let first = first_level_in_cycle ctxt cycle in
  let rec loop n acc =
    if Cycle_repr.(n.cycle = first.cycle) then loop (succ ctxt n) (n :: acc)
    else acc
  in
  loop first []

let levels_in_current_cycle ctxt ?(offset = 0l) () =
  let current_cycle = Cycle_repr.to_int32 (current ctxt).cycle in
  let cycle = Int32.add current_cycle offset in
  if Compare.Int32.(cycle < 0l) then []
  else
    let cycle = Cycle_repr.of_int32_exn cycle in
    levels_in_cycle ctxt cycle

let levels_with_commitments_in_cycle ctxt c =
  let first = first_level_in_cycle ctxt c in
  let rec loop n acc =
    if Cycle_repr.(n.cycle = first.cycle) then
      if n.expected_commitment then loop (succ ctxt n) (n :: acc)
      else loop (succ ctxt n) acc
    else acc
  in
  loop first []

let last_allowed_fork_level c =
  let level = Raw_context.current_level c in
  let preserved_cycles = Constants_storage.preserved_cycles c in
  match Cycle_repr.sub level.cycle preserved_cycles with
  | None ->
      Raw_level_repr.root
  | Some cycle ->
      (first_level_in_cycle c cycle).level
src/proto_alpha/lib_protocol/level_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Level_repr.

Definition from_raw
  (c : Tezos_raw_protocol_alpha.Raw_context.context) (offset : option int32)
  (l : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  let l :=
    match offset with
    | None => l
    | Some o => of_int32_exn (Int32.add (to_int32 l) o)
    end in
  let constants := Raw_context.constants c in
  let first_level := Raw_context.first_level c in
  Level_repr.from_raw first_level (Constants_repr.blocks_per_cycle constants)
    (Constants_repr.blocks_per_voting_period constants)
    (Constants_repr.blocks_per_commitment constants) l.

Definition root (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  Level_repr.root (Raw_context.first_level c).

Definition succ
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (l : Tezos_raw_protocol_alpha.Level_repr.t)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  from_raw c None (Raw_level_repr.succ (level l)).

Definition pred
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  (l : Tezos_raw_protocol_alpha.Level_repr.t)
  : option Tezos_raw_protocol_alpha.Level_repr.level :=
  match Raw_level_repr.pred (Level_repr.level l) with
  | None => None
  | Some l => Some (from_raw c None l)
  end.

Definition current (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Level_repr.t := Raw_context.current_level ctxt.

Definition previous (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  let l := current ctxt in
  match pred ctxt l with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some p => p
  end.

Definition first_level_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  let constants := Raw_context.constants ctxt in
  let first_level := Raw_context.first_level ctxt in
  from_raw ctxt None
    (Raw_level_repr.of_int32_exn
      (Int32.add (Raw_level_repr.to_int32 first_level)
        (Int32.mul (Constants_repr.blocks_per_cycle constants)
          (Cycle_repr.to_int32 c)))).

Definition last_level_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_raw_protocol_alpha.Level_repr.level :=
  match pred ctxt (first_level_in_cycle ctxt (Cycle_repr.succ c)) with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some x => x
  end.

Definition levels_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : list Tezos_raw_protocol_alpha.Level_repr.t :=
  let first := first_level_in_cycle ctxt cycle in
  let fix loop
    (n : Tezos_raw_protocol_alpha.Level_repr.t) (acc :
    list Tezos_raw_protocol_alpha.Level_repr.t)
    : list Tezos_raw_protocol_alpha.Level_repr.t :=
    if op_eq (cycle n) (cycle first) then
      loop (succ ctxt n) (cons n acc)
    else
      acc in
  loop first [].

Definition levels_in_current_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (op_staroptstar : option int32)
  : unit -> list Tezos_raw_protocol_alpha.Level_repr.t :=
  let offset :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None =>
      (* ❌ Constant of type int32 is converted to int *)
      0
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    let current_cycle := Cycle_repr.to_int32 (cycle (current ctxt)) in
    let cycle := Int32.add current_cycle offset in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
        cycle
        (* ❌ Constant of type int32 is converted to int *)
        0 then
      []
    else
      let cycle := Cycle_repr.of_int32_exn cycle in
      levels_in_cycle ctxt cycle.

Definition levels_with_commitments_in_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (c : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : list Tezos_raw_protocol_alpha.Level_repr.t :=
  let first := first_level_in_cycle ctxt c in
  let fix loop
    (n : Tezos_raw_protocol_alpha.Level_repr.t) (acc :
    list Tezos_raw_protocol_alpha.Level_repr.t)
    : list Tezos_raw_protocol_alpha.Level_repr.t :=
    if op_eq (cycle n) (cycle first) then
      if expected_commitment n then
        loop (succ ctxt n) (cons n acc)
      else
        loop (succ ctxt n) acc
    else
      acc in
  loop first [].

Definition last_allowed_fork_level
  (c : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level :=
  let level := Raw_context.current_level c in
  let preserved_cycles := Constants_storage.preserved_cycles c in
  match Cycle_repr.sub (cycle level) preserved_cycles with
  | None => Raw_level_repr.root
  | Some cycle => level (first_level_in_cycle c cycle)
  end.

src/proto_alpha/lib_protocol/main.ml 52 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Protocol Signature Instance *)

type block_header_data = Alpha_context.Block_header.protocol_data

type block_header = Alpha_context.Block_header.t = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

let block_header_data_encoding =
  Alpha_context.Block_header.protocol_data_encoding

type block_header_metadata = Apply_results.block_metadata

let block_header_metadata_encoding = Apply_results.block_metadata_encoding

type operation_data = Alpha_context.packed_protocol_data =
  | Operation_data :
      'kind Alpha_context.Operation.protocol_data
      -> operation_data

let operation_data_encoding = Alpha_context.Operation.protocol_data_encoding

type operation_receipt = Apply_results.packed_operation_metadata =
  | Operation_metadata :
      'kind Apply_results.operation_metadata
      -> operation_receipt
  | No_operation_metadata : operation_receipt

let operation_receipt_encoding = Apply_results.operation_metadata_encoding

let operation_data_and_receipt_encoding =
  Apply_results.operation_data_and_metadata_encoding

type operation = Alpha_context.packed_operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let acceptable_passes = Alpha_context.Operation.acceptable_passes

let max_block_length = Alpha_context.Block_header.max_header_length

let max_operation_data_length =
  Alpha_context.Constants.max_operation_data_length

let validation_passes =
  let max_anonymous_operations =
    Alpha_context.Constants.max_revelations_per_block
    + (* allow 100 wallet activations or denunciations per block *) 100
  in
  Updater.
    [ {max_size = 32 * 1024; max_op = Some 32};
      (* 32 endorsements *)
      {max_size = 32 * 1024; max_op = None};
      (* 32k of voting operations *)
      {
        max_size = max_anonymous_operations * 1024;
        max_op = Some max_anonymous_operations;
      };
      {max_size = 512 * 1024; max_op = None} ]

(* 512kB *)

let rpc_services =
  Alpha_services.register () ;
  Services_registration.get_rpc_services ()

type validation_mode =
  | Application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_application of {
      block_header : Alpha_context.Block_header.t;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }
  | Partial_construction of {predecessor : Block_hash.t}
  | Full_construction of {
      predecessor : Block_hash.t;
      protocol_data : Alpha_context.Block_header.contents;
      baker : Alpha_context.public_key_hash;
      block_delay : Alpha_context.Period.t;
    }

type validation_state = {
  mode : validation_mode;
  chain_id : Chain_id.t;
  ctxt : Alpha_context.t;
  op_count : int;
}

let current_context {ctxt; _} = return (Alpha_context.finalize ctxt).context

let begin_partial_application ~chain_id ~ancestor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >>=? fun (ctxt, baker, block_delay) ->
  let mode =
    Partial_application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  return {mode; chain_id; ctxt; op_count = 0}

let begin_application ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_fitness
    (block_header : Alpha_context.Block_header.t) =
  let level = block_header.shell.level in
  let fitness = predecessor_fitness in
  let timestamp = block_header.shell.timestamp in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  Apply.begin_application ctxt chain_id block_header predecessor_timestamp
  >>=? fun (ctxt, baker, block_delay) ->
  let mode =
    Application
      {block_header; baker = Signature.Public_key.hash baker; block_delay}
  in
  return {mode; chain_id; ctxt; op_count = 0}

let begin_construction ~chain_id ~predecessor_context:ctxt
    ~predecessor_timestamp ~predecessor_level:pred_level
    ~predecessor_fitness:pred_fitness ~predecessor ~timestamp
    ?(protocol_data : block_header_data option) () =
  let level = Int32.succ pred_level in
  let fitness = pred_fitness in
  Alpha_context.prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt
  >>=? fun ctxt ->
  ( match protocol_data with
  | None ->
      Apply.begin_partial_construction ctxt
      >>=? fun ctxt ->
      let mode = Partial_construction {predecessor} in
      return (mode, ctxt)
  | Some proto_header ->
      Apply.begin_full_construction
        ctxt
        predecessor_timestamp
        proto_header.contents
      >>=? fun (ctxt, protocol_data, baker, block_delay) ->
      let mode =
        let baker = Signature.Public_key.hash baker in
        Full_construction {predecessor; baker; protocol_data; block_delay}
      in
      return (mode, ctxt) )
  >>=? fun (mode, ctxt) -> return {mode; chain_id; ctxt; op_count = 0}

let apply_operation ({mode; chain_id; ctxt; op_count; _} as data)
    (operation : Alpha_context.packed_operation) =
  match mode with
  | Partial_application _
    when not
           (List.exists
              (Compare.Int.equal 0)
              (Alpha_context.Operation.acceptable_passes operation)) ->
      (* Multipass validation only considers operations in pass 0. *)
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, No_operation_metadata)
  | _ ->
      let {shell; protocol_data = Operation_data protocol_data} = operation in
      let operation : _ Alpha_context.operation = {shell; protocol_data} in
      let (predecessor, baker) =
        match mode with
        | Partial_application
            {block_header = {shell = {predecessor; _}; _}; baker}
        | Application {block_header = {shell = {predecessor; _}; _}; baker}
        | Full_construction {predecessor; baker; _} ->
            (predecessor, baker)
        | Partial_construction {predecessor} ->
            (predecessor, Signature.Public_key_hash.zero)
      in
      Apply.apply_operation
        ctxt
        chain_id
        Optimized
        predecessor
        baker
        (Alpha_context.Operation.hash operation)
        operation
      >>=? fun (ctxt, result) ->
      let op_count = op_count + 1 in
      return ({data with ctxt; op_count}, Operation_metadata result)

let finalize_block {mode; ctxt; op_count} =
  match mode with
  | Partial_construction _ ->
      let level = Alpha_context.Level.current ctxt in
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let baker = Signature.Public_key_hash.zero in
      Signature.Public_key_hash.Map.fold
        (fun delegate deposit ctxt ->
          ctxt
          >>=? fun ctxt ->
          Alpha_context.Delegate.freeze_deposit ctxt delegate deposit)
        (Alpha_context.get_deposits ctxt)
        (return ctxt)
      >>=? fun ctxt ->
      let ctxt = Alpha_context.finalize ctxt in
      return
        ( ctxt,
          Apply_results.
            {
              baker;
              level;
              voting_period_kind;
              nonce_hash = None;
              consumed_gas = Z.zero;
              deactivated = [];
              balance_updates = [];
            } )
  | Partial_application {block_header; baker; block_delay} ->
      let level = Alpha_context.Level.current ctxt in
      let included_endorsements = Alpha_context.included_endorsements ctxt in
      Apply.check_minimum_endorsements
        ctxt
        block_header.protocol_data.contents
        block_delay
        included_endorsements
      >>=? fun () ->
      Alpha_context.Vote.get_current_period_kind ctxt
      >>=? fun voting_period_kind ->
      let ctxt = Alpha_context.finalize ctxt in
      return
        ( ctxt,
          Apply_results.
            {
              baker;
              level;
              voting_period_kind;
              nonce_hash = None;
              consumed_gas = Z.zero;
              deactivated = [];
              balance_updates = [];
            } )
  | Application
      { baker;
        block_delay;
        block_header = {protocol_data = {contents = protocol_data; _}; _} }
  | Full_construction {protocol_data; baker; block_delay; _} ->
      Apply.finalize_application ctxt protocol_data baker ~block_delay
      >>=? fun (ctxt, receipt) ->
      let level = Alpha_context.Level.current ctxt in
      let priority = protocol_data.priority in
      let raw_level = Alpha_context.Raw_level.to_int32 level.level in
      let fitness = Alpha_context.Fitness.current ctxt in
      let commit_message =
        Format.asprintf
          "lvl %ld, fit 1:%Ld, prio %d, %d ops"
          raw_level
          fitness
          priority
          op_count
      in
      let ctxt = Alpha_context.finalize ~commit_message ctxt in
      return (ctxt, receipt)

let compare_operations op1 op2 =
  let open Alpha_context in
  let (Operation_data op1) = op1.protocol_data in
  let (Operation_data op2) = op2.protocol_data in
  match (op1.contents, op2.contents) with
  | (Single (Endorsement _), Single (Endorsement _)) ->
      0
  | (_, Single (Endorsement _)) ->
      1
  | (Single (Endorsement _), _) ->
      -1
  | (Single (Seed_nonce_revelation _), Single (Seed_nonce_revelation _)) ->
      0
  | (_, Single (Seed_nonce_revelation _)) ->
      1
  | (Single (Seed_nonce_revelation _), _) ->
      -1
  | ( Single (Double_endorsement_evidence _),
      Single (Double_endorsement_evidence _) ) ->
      0
  | (_, Single (Double_endorsement_evidence _)) ->
      1
  | (Single (Double_endorsement_evidence _), _) ->
      -1
  | (Single (Double_baking_evidence _), Single (Double_baking_evidence _)) ->
      0
  | (_, Single (Double_baking_evidence _)) ->
      1
  | (Single (Double_baking_evidence _), _) ->
      -1
  | (Single (Activate_account _), Single (Activate_account _)) ->
      0
  | (_, Single (Activate_account _)) ->
      1
  | (Single (Activate_account _), _) ->
      -1
  | (Single (Proposals _), Single (Proposals _)) ->
      0
  | (_, Single (Proposals _)) ->
      1
  | (Single (Proposals _), _) ->
      -1
  | (Single (Ballot _), Single (Ballot _)) ->
      0
  | (_, Single (Ballot _)) ->
      1
  | (Single (Ballot _), _) ->
      -1
  (* Manager operations with smaller counter are pre-validated first. *)
  | (Single (Manager_operation op1), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Single (Manager_operation op2)) ->
      Z.compare op1.counter op2.counter
  | (Single (Manager_operation op1), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter
  | (Cons (Manager_operation op1, _), Cons (Manager_operation op2, _)) ->
      Z.compare op1.counter op2.counter

let init ctxt block_header =
  let level = block_header.Block_header.level in
  let fitness = block_header.fitness in
  let timestamp = block_header.timestamp in
  let typecheck (ctxt : Alpha_context.context)
      (script : Alpha_context.Script.t) =
    Script_ir_translator.parse_script ctxt ~legacy:false script
    >>=? fun (Ex_script parsed_script, ctxt) ->
    Script_ir_translator.extract_big_map_diff
      ctxt
      Optimized
      parsed_script.storage_type
      parsed_script.storage
      ~to_duplicate:Script_ir_translator.no_big_map_id
      ~to_update:Script_ir_translator.no_big_map_id
      ~temporary:false
    >>=? fun (storage, big_map_diff, ctxt) ->
    Script_ir_translator.unparse_data
      ctxt
      Optimized
      parsed_script.storage_type
      storage
    >>=? fun (storage, ctxt) ->
    let storage =
      Alpha_context.Script.lazy_expr (Micheline.strip_locations storage)
    in
    return (({script with storage}, big_map_diff), ctxt)
  in
  Alpha_context.prepare_first_block ~typecheck ~level ~timestamp ~fitness ctxt
  >>=? fun ctxt -> return (Alpha_context.finalize ctxt)

(* Vanity nonce: 313282890 *)
src/proto_alpha/lib_protocol/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition block_header_data :=
  Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data.

Record block_header := {
  shell :
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.protocol_data :=
  Alpha_context.Block_header.protocol_data_encoding.

Definition block_header_metadata :=
  Tezos_raw_protocol_alpha.Apply_results.block_metadata.

Definition block_header_metadata_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_raw_protocol_alpha.Apply_results.block_metadata :=
  Apply_results.block_metadata_encoding.

Inductive operation_data : Type :=
| Operation_data : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Alpha_context.Operation.protocol_data kind) ->
  operation_data.

Definition operation_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data :=
  Alpha_context.Operation.protocol_data_encoding.

Inductive operation_receipt : Type :=
| Operation_metadata : forall {kind : Type},
  (Tezos_raw_protocol_alpha.Apply_results.operation_metadata kind) ->
  operation_receipt
| No_operation_metadata : operation_receipt.

Definition operation_receipt_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata :=
  Apply_results.operation_metadata_encoding.

Definition operation_data_and_receipt_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    (Tezos_raw_protocol_alpha.Alpha_context.Operation.packed_protocol_data *
      Tezos_raw_protocol_alpha.Apply_results.packed_operation_metadata) :=
  Apply_results.operation_data_and_metadata_encoding.

Record operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : operation_data }.

Definition acceptable_passes
  : Tezos_raw_protocol_alpha__Alpha_context.packed_operation -> list Z :=
  Alpha_context.Operation.acceptable_passes.

Definition max_block_length : Z := Alpha_context.Block_header.max_header_length.

Definition max_operation_data_length : Z :=
  Alpha_context.Constants.max_operation_data_length.

Definition validation_passes
  : list Tezos_protocol_environment_alpha__Environment.Updater.quota :=
  let max_anonymous_operations :=
    op_plus Alpha_context.Constants.max_revelations_per_block 100 in
  cons {| max_size := op_star 32 1024; max_op := Some 32 |}
    (cons {| max_size := op_star 32 1024; max_op := None |}
      (cons
        {| max_size := op_star max_anonymous_operations 1024;
          max_op := Some max_anonymous_operations |}
        (cons {| max_size := op_star 512 1024; max_op := None |} []))).

Definition rpc_services
  : Tezos_protocol_environment_alpha__Environment.RPC_directory.directory
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Alpha_services.register tt in
  Services_registration.get_rpc_services tt.

Inductive validation_mode : Type :=
| Application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_application : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode
| Partial_construction :
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> validation_mode
| Full_construction :
  Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Tezos_raw_protocol_alpha.Alpha_context.Block_header.contents ->
  Tezos_raw_protocol_alpha.Alpha_context.public_key_hash ->
  Tezos_raw_protocol_alpha.Alpha_context.Period.t -> validation_mode.

Record validation_state := {
  mode : validation_mode;
  chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  ctxt : Tezos_raw_protocol_alpha.Alpha_context.t;
  op_count : Z }.

Definition current_context (function_parameter : validation_state)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Context.t) :=
  let '{| ctxt := ctxt |} := function_parameter in
  _return (context (Alpha_context.finalize None ctxt)).

Definition begin_partial_application
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (predecessor_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
  (block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      validation_state) :=
  let level := level (shell block_header) in
  let fitness := predecessor_fitness in
  let timestamp := timestamp (shell block_header) in
  op_gtgteqquestion
    (Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      op_gtgteqquestion
        (Apply.begin_application ctxt chain_id block_header
          predecessor_timestamp)
        (fun function_parameter =>
          let '(ctxt, baker, block_delay) := function_parameter in
          let mode :=
            Partial_application
              {| block_header := block_header;
                baker := Signature.Public_key.hash baker;
                block_delay := block_delay |} in
          _return
            {| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
              |})).

Definition begin_application
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (predecessor_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
  (block_header : Tezos_raw_protocol_alpha.Alpha_context.Block_header.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      validation_state) :=
  let level := level (shell block_header) in
  let fitness := predecessor_fitness in
  let timestamp := timestamp (shell block_header) in
  op_gtgteqquestion
    (Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      op_gtgteqquestion
        (Apply.begin_application ctxt chain_id block_header
          predecessor_timestamp)
        (fun function_parameter =>
          let '(ctxt, baker, block_delay) := function_parameter in
          let mode :=
            Application
              {| block_header := block_header;
                baker := Signature.Public_key.hash baker;
                block_delay := block_delay |} in
          _return
            {| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
              |})).

Definition begin_construction
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (pred_level : int32)
  (pred_fitness : Tezos_raw_protocol_alpha.Alpha_context.Fitness.t)
  (predecessor :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (protocol_data : option block_header_data) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      validation_state) :=
  let 'tt := function_parameter in
  let level := Int32.succ pred_level in
  let fitness := pred_fitness in
  op_gtgteqquestion
    (Alpha_context.prepare ctxt level predecessor_timestamp timestamp fitness)
    (fun ctxt =>
      op_gtgteqquestion
        match protocol_data with
        | None =>
          op_gtgteqquestion (Apply.begin_partial_construction ctxt)
            (fun ctxt =>
              let mode := Partial_construction {| predecessor := predecessor |}
                in
              _return (mode, ctxt))
        | Some proto_header =>
          op_gtgteqquestion
            (Apply.begin_full_construction ctxt predecessor_timestamp
              (contents proto_header))
            (fun function_parameter =>
              let '(ctxt, protocol_data, baker, block_delay) :=
                function_parameter in
              let mode :=
                let baker := Signature.Public_key.hash baker in
                Full_construction
                  {| predecessor := predecessor; protocol_data := protocol_data;
                    baker := baker; block_delay := block_delay |} in
              _return (mode, ctxt))
        end
        (fun function_parameter =>
          let '(mode, ctxt) := function_parameter in
          _return
            {| mode := mode; chain_id := chain_id; ctxt := ctxt; op_count := 0
              |})).

Definition apply_operation (function_parameter : validation_state)
  : Tezos_raw_protocol_alpha.Alpha_context.packed_operation ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (validation_state * operation_receipt)) :=
  let
    '{|
      mode := mode;
        chain_id := chain_id;
        ctxt := ctxt;
        op_count := op_count
        |} as data := function_parameter in
  fun operation =>
    match mode with
    | Partial_application _ =>
      let op_count := op_plus op_count 1 in
      _return
        ((* ❌ Record substitution not handled *)
        record_substitution, No_operation_metadata)
    | _ =>
      let '{|
        shell := shell; protocol_data := Operation_data protocol_data |} :=
        operation in
      let operation := {| shell := shell; protocol_data := protocol_data |} in
      let '(predecessor, baker) :=
        match mode with
        |
          Partial_application {|
            block_header := {| shell := {| predecessor := predecessor |} |};
              baker := baker
              |} |
            Application {|
              block_header := {| shell := {| predecessor := predecessor |} |};
                baker := baker
                |} |
            Full_construction {| predecessor := predecessor; baker := baker |}
          => (predecessor, baker)
        | Partial_construction {| predecessor := predecessor |} =>
          (predecessor, Signature.Public_key_hash.zero)
        end in
      op_gtgteqquestion
        (Apply.apply_operation ctxt chain_id
          Tezos_raw_protocol_alpha.Script_ir_translator.Optimized predecessor
          baker (Alpha_context.Operation.hash operation) operation)
        (fun function_parameter =>
          let '(ctxt, result) := function_parameter in
          let op_count := op_plus op_count 1 in
          _return
            ((* ❌ Record substitution not handled *)
            record_substitution, (Operation_metadata result)))
    end.

Definition finalize_block (function_parameter : validation_state)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Updater.validation_result *
        Tezos_raw_protocol_alpha.Apply_results.block_metadata)) :=
  let '{| mode := mode; ctxt := ctxt; op_count := op_count |} :=
    function_parameter in
  match mode with
  | Partial_construction _ =>
    let level := Alpha_context.Level.current ctxt in
    op_gtgteqquestion (Alpha_context.Vote.get_current_period_kind ctxt)
      (fun voting_period_kind =>
        let baker := Signature.Public_key_hash.zero in
        op_gtgteqquestion
          (Signature.Public_key_hash.Map.fold
            (fun delegate =>
              fun deposit =>
                fun ctxt =>
                  op_gtgteqquestion ctxt
                    (fun ctxt =>
                      Alpha_context.Delegate.freeze_deposit ctxt delegate
                        deposit)) (Alpha_context.get_deposits ctxt)
            (_return ctxt))
          (fun ctxt =>
            let ctxt := Alpha_context.finalize None ctxt in
            _return
              (ctxt,
                {| baker := baker; level := level;
                  voting_period_kind := voting_period_kind; nonce_hash := None;
                  consumed_gas := Z.zero; deactivated := [];
                  balance_updates := [] |})))
  |
    Partial_application {|
      block_header := block_header;
        baker := baker;
        block_delay := block_delay
        |} =>
    let level := Alpha_context.Level.current ctxt in
    let included_endorsements := Alpha_context.included_endorsements ctxt in
    op_gtgteqquestion
      (Apply.check_minimum_endorsements ctxt
        (contents (protocol_data block_header)) block_delay
        included_endorsements)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion (Alpha_context.Vote.get_current_period_kind ctxt)
          (fun voting_period_kind =>
            let ctxt := Alpha_context.finalize None ctxt in
            _return
              (ctxt,
                {| baker := baker; level := level;
                  voting_period_kind := voting_period_kind; nonce_hash := None;
                  consumed_gas := Z.zero; deactivated := [];
                  balance_updates := [] |})))
  |
    Application {|
      block_header := {| protocol_data := {| contents := protocol_data |} |};
        baker := baker;
        block_delay := block_delay
        |} |
      Full_construction {|
        protocol_data := protocol_data;
          baker := baker;
          block_delay := block_delay
          |} =>
    op_gtgteqquestion
      (Apply.finalize_application ctxt protocol_data baker block_delay)
      (fun function_parameter =>
        let '(ctxt, receipt) := function_parameter in
        let level := Alpha_context.Level.current ctxt in
        let priority := priority protocol_data in
        let raw_level := Alpha_context.Raw_level.to_int32 (level level) in
        let fitness := Alpha_context.Fitness.current ctxt in
        let commit_message :=
          Format.asprintf
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                "lvl " % string
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                    ", fit 1:" % string
                    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int64
                      Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                      Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                      Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                        ", prio " % string
                        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int
                          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                            ", " % string
                            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int
                              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                                " ops" % string
                                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))))))
              "lvl %ld, fit 1:%Ld, prio %d, %d ops" % string) raw_level fitness
            priority op_count in
        let ctxt := Alpha_context.finalize (Some commit_message) ctxt in
        _return (ctxt, receipt))
  end.

Definition compare_operations
  (op1 : Tezos_raw_protocol_alpha.Alpha_context.packed_operation)
  (op2 : Tezos_raw_protocol_alpha.Alpha_context.packed_operation) : Z :=
  let 'Tezos_raw_protocol_alpha.Alpha_context.Operation_data op1 :=
    protocol_data op1 in
  let 'Tezos_raw_protocol_alpha.Alpha_context.Operation_data op2 :=
    protocol_data op2 in
  match ((contents op1), (contents op2)) with
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _)) => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _)) => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Endorsement _), _) => (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _)) => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _)) => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Seed_nonce_revelation _), _) =>
    (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _))
    => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _))
    => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Double_endorsement_evidence _), _)
    => (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _)) => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _)) => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Double_baking_evidence _), _) =>
    (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _)) => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _)) => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Activate_account _), _) => (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Proposals _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Proposals _)) => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Proposals _)) => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Proposals _), _) => (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Ballot _),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Ballot _)) => 0
  |
    (_,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Ballot _)) => 1
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Ballot _), _) => (-1)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1),
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2)) =>
    Z.compare (counter op1) (counter op2)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1) _,
      Tezos_raw_protocol_alpha.Alpha_context.Single
        (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2)) =>
    Z.compare (counter op1) (counter op2)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Single
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1),
      Tezos_raw_protocol_alpha.Alpha_context.Cons
        (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2) _) =>
    Z.compare (counter op1) (counter op2)
  |
    (Tezos_raw_protocol_alpha.Alpha_context.Cons
      (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op1) _,
      Tezos_raw_protocol_alpha.Alpha_context.Cons
        (Tezos_raw_protocol_alpha.Alpha_context.Manager_operation op2) _) =>
    Z.compare (counter op1) (counter op2)
  end.

Definition init
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (block_header :
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Updater.validation_result) :=
  let level := Block_header.level block_header in
  let fitness := fitness block_header in
  let timestamp := timestamp block_header in
  let typecheck
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (script :
    Tezos_raw_protocol_alpha.Alpha_context.Script.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((Tezos_raw_protocol_alpha.Alpha_context.Script.t *
          (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))
          * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    op_gtgteqquestion (Script_ir_translator.parse_script None ctxt false script)
      (fun function_parameter =>
        let
          '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script
            parsed_script, ctxt) := function_parameter in
        op_gtgteqquestion
          (Script_ir_translator.extract_big_map_diff ctxt
            Tezos_raw_protocol_alpha.Script_ir_translator.Optimized false
            Script_ir_translator.no_big_map_id
            Script_ir_translator.no_big_map_id (storage_type parsed_script)
            (storage parsed_script))
          (fun function_parameter =>
            let '(storage, big_map_diff, ctxt) := function_parameter in
            op_gtgteqquestion
              (Script_ir_translator.unparse_data ctxt
                Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                (storage_type parsed_script) storage)
              (fun function_parameter =>
                let '(storage, ctxt) := function_parameter in
                let storage :=
                  Alpha_context.Script.lazy_expr
                    (Micheline.strip_locations storage) in
                _return
                  (((* ❌ Record substitution not handled *)
                  record_substitution, big_map_diff), ctxt)))) in
  op_gtgteqquestion
    (Alpha_context.prepare_first_block ctxt typecheck level timestamp fitness)
    (fun ctxt => _return (Alpha_context.finalize None ctxt)).

src/proto_alpha/lib_protocol/manager_repr.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Managers' keys *)

type manager_key =
  | Hash of Signature.Public_key_hash.t
  | Public_key of Signature.Public_key.t

type t = manager_key

open Data_encoding

let hash_case tag =
  case
    tag
    ~title:"Public_key_hash"
    Signature.Public_key_hash.encoding
    (function Hash hash -> Some hash | _ -> None)
    (fun hash -> Hash hash)

let pubkey_case tag =
  case
    tag
    ~title:"Public_key"
    Signature.Public_key.encoding
    (function Public_key hash -> Some hash | _ -> None)
    (fun hash -> Public_key hash)

let encoding = union [hash_case (Tag 0); pubkey_case (Tag 1)]
src/proto_alpha/lib_protocol/manager_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive manager_key : Type :=
| Hash :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  manager_key
| Public_key :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t ->
  manager_key.

Definition t := manager_key.

Import Data_encoding.

Definition hash_case
  (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.case manager_key :=
  case "Public_key_hash" % string None tag Signature.Public_key_hash.encoding
    (fun function_parameter =>
      match function_parameter with
      | Hash hash => Some hash
      | _ => None
      end) (fun hash => Hash hash).

Definition pubkey_case
  (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.case manager_key :=
  case "Public_key" % string None tag Signature.Public_key.encoding
    (fun function_parameter =>
      match function_parameter with
      | Public_key hash => Some hash
      | _ => None
      end) (fun hash => Public_key hash).

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    manager_key :=
  union None
    (cons
      (hash_case
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0))
      (cons
        (pubkey_case
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1))
        [])).

src/proto_alpha/lib_protocol/michelson_v1_gas.ml 489 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Gas

module Cost_of = struct
  let log2 =
    let rec help acc = function 0 -> acc | n -> help (acc + 1) (n / 2) in
    help 1

  let z_bytes (z : Z.t) =
    let bits = Z.numbits z in
    (7 + bits) / 8

  let int_bytes (z : 'a Script_int.num) = z_bytes (Script_int.to_zint z)

  let timestamp_bytes (t : Script_timestamp.t) =
    let z = Script_timestamp.to_zint t in
    z_bytes z

  (* For now, returns size in bytes, but this could get more complicated... *)
  let rec size_of_comparable :
      type a b. (a, b) Script_typed_ir.comparable_struct -> a -> int =
   fun wit v ->
    match wit with
    | Int_key _ ->
        int_bytes v
    | Nat_key _ ->
        int_bytes v
    | String_key _ ->
        String.length v
    | Bytes_key _ ->
        MBytes.length v
    | Bool_key _ ->
        8
    | Key_hash_key _ ->
        Signature.Public_key_hash.size
    | Timestamp_key _ ->
        timestamp_bytes v
    | Address_key _ ->
        Signature.Public_key_hash.size
    | Mutez_key _ ->
        8
    | Pair_key ((l, _), (r, _), _) ->
        let (lval, rval) = v in
        size_of_comparable l lval + size_of_comparable r rval

  let string length = alloc_bytes_cost length

  let bytes length = alloc_mbytes_cost length

  let manager_operation = step_cost 10_000

  module Legacy = struct
    let zint z = alloc_bits_cost (Z.numbits z)

    let set_to_list : type item. item Script_typed_ir.set -> cost =
     fun (module Box) -> alloc_cost @@ Pervasives.(Box.size * 2)

    let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
        =
     fun (module Box) ->
      let size = snd Box.boxed in
      3 *@ alloc_cost size

    let z_to_int64 = step_cost 2 +@ alloc_cost 1

    let hash data len = (10 *@ step_cost (MBytes.length data)) +@ bytes len

    let set_access : type elt. elt -> elt Script_typed_ir.set -> int =
     fun _key (module Box) -> log2 @@ Box.size

    let set_update key _presence set = set_access key set *@ alloc_cost 3
  end

  module Interpreter = struct
    let cycle = atomic_step_cost 10

    let nop = free

    let stack_op = atomic_step_cost 10

    let push = atomic_step_cost 10

    let wrap = atomic_step_cost 10

    let variant_no_data = atomic_step_cost 10

    let branch = atomic_step_cost 10

    let pair = atomic_step_cost 10

    let pair_access = atomic_step_cost 10

    let cons = atomic_step_cost 10

    let loop_size = atomic_step_cost 5

    let loop_cycle = atomic_step_cost 10

    let loop_iter = atomic_step_cost 20

    let loop_map = atomic_step_cost 30

    let empty_set = atomic_step_cost 10

    let set_to_list : type elt. elt Script_typed_ir.set -> cost =
     fun (module Box) -> atomic_step_cost (Box.size * 20)

    let set_mem : type elt. elt -> elt Script_typed_ir.set -> cost =
     fun elt (module Box) ->
      let elt_bytes = size_of_comparable Box.elt_ty elt in
      atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)

    let set_update : type elt. elt -> bool -> elt Script_typed_ir.set -> cost =
     fun elt _ (module Box) ->
      let elt_bytes = size_of_comparable Box.elt_ty elt in
      atomic_step_cost ((1 + (elt_bytes / 82)) * log2 Box.size)

    let set_size = atomic_step_cost 10

    let empty_map = atomic_step_cost 10

    let map_to_list : type key value. (key, value) Script_typed_ir.map -> cost
        =
     fun (module Box) ->
      let size = snd Box.boxed in
      atomic_step_cost (size * 20)

    let map_access :
        type key value. key -> (key, value) Script_typed_ir.map -> cost =
     fun key (module Box) ->
      let map_card = snd Box.boxed in
      let key_bytes = size_of_comparable Box.key_ty key in
      atomic_step_cost ((1 + (key_bytes / 70)) * log2 map_card)

    let map_mem = map_access

    let map_get = map_access

    let map_update :
        type key value.
        key -> value option -> (key, value) Script_typed_ir.map -> cost =
     fun key _value (module Box) ->
      let map_card = snd Box.boxed in
      let key_bytes = size_of_comparable Box.key_ty key in
      atomic_step_cost ((1 + (key_bytes / 38)) * log2 map_card)

    let map_size = atomic_step_cost 10

    let add_timestamp (t1 : Script_timestamp.t) (t2 : 'a Script_int.num) =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = int_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))

    let sub_timestamp = add_timestamp

    let diff_timestamps (t1 : Script_timestamp.t) (t2 : Script_timestamp.t) =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = timestamp_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 62))

    let rec concat_loop l acc =
      match l with [] -> 30 | _ :: tl -> concat_loop tl (acc + 30)

    let concat_string string_list =
      atomic_step_cost (concat_loop string_list 0)

    let slice_string string_length =
      atomic_step_cost (40 + (string_length / 70))

    let concat_bytes bytes_list = atomic_step_cost (concat_loop bytes_list 0)

    let int64_op = atomic_step_cost 61

    let z_to_int64 = atomic_step_cost 20

    let int64_to_z = atomic_step_cost 20

    let bool_binop _ _ = atomic_step_cost 10

    let bool_unop _ = atomic_step_cost 10

    let abs int = atomic_step_cost (61 + (int_bytes int / 70))

    let int _int = free

    let neg = abs

    let add i1 i2 =
      atomic_step_cost
        (51 + (Compare.Int.max (int_bytes i1) (int_bytes i2) / 62))

    let sub = add

    let mul i1 i2 =
      let bytes = Compare.Int.max (int_bytes i1) (int_bytes i2) in
      atomic_step_cost (51 + (bytes / 6 * log2 bytes))

    let indic_lt x y = if Compare.Int.(x < y) then 1 else 0

    let div i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      let cost = indic_lt bytes2 bytes1 * (bytes1 - bytes2) * bytes2 in
      atomic_step_cost (51 + (cost / 3151))

    let shift_left _i _shift_bits = atomic_step_cost 30

    let shift_right _i _shift_bits = atomic_step_cost 30

    let logor i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      atomic_step_cost (51 + (Compare.Int.max bytes1 bytes2 / 70))

    let logand i1 i2 =
      let bytes1 = int_bytes i1 in
      let bytes2 = int_bytes i2 in
      atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 70))

    let logxor = logor

    let lognot i = atomic_step_cost (51 + (int_bytes i / 20))

    let exec = atomic_step_cost 10

    let compare_bool _ _ = atomic_step_cost 30

    let compare_string s1 s2 =
      let bytes1 = String.length s1 in
      let bytes2 = String.length s2 in
      atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))

    let compare_bytes b1 b2 =
      let bytes1 = MBytes.length b1 in
      let bytes2 = MBytes.length b2 in
      atomic_step_cost (30 + (Compare.Int.min bytes1 bytes2 / 123))

    let compare_tez _ _ = atomic_step_cost 30

    let compare_zint i1 i2 =
      atomic_step_cost
        (51 + (Compare.Int.min (int_bytes i1) (int_bytes i2) / 82))

    let compare_key_hash _ _ = atomic_step_cost 92

    let compare_timestamp t1 t2 =
      let bytes1 = timestamp_bytes t1 in
      let bytes2 = timestamp_bytes t2 in
      atomic_step_cost (51 + (Compare.Int.min bytes1 bytes2 / 82))

    let compare_address _ _ = atomic_step_cost 92

    let compare_res = atomic_step_cost 30

    let unpack_failed bytes =
      (* We cannot instrument failed deserialization,
         so we take worst case fees: a set of size 1 bytes values. *)
      let len = MBytes.length bytes in
      (len *@ alloc_mbytes_cost 1)
      +@ (len *@ (log2 len *@ (alloc_cost 3 +@ step_cost 1)))

    let address = atomic_step_cost 10

    let contract = step_cost 10000

    let transfer = step_cost 10

    let create_account = step_cost 10

    let create_contract = step_cost 10

    let implicit_account = step_cost 10

    let set_delegate = step_cost 10 +@ write_bytes_cost (Z.of_int 32)

    let balance = atomic_step_cost 10

    let now = atomic_step_cost 10

    let check_signature_secp256k1 bytes = atomic_step_cost (10342 + (bytes / 5))

    let check_signature_ed25519 bytes = atomic_step_cost (36864 + (bytes / 5))

    let check_signature_p256 bytes = atomic_step_cost (36864 + (bytes / 5))

    let check_signature (pkey : Signature.public_key) bytes =
      match pkey with
      | Ed25519 _ ->
          check_signature_ed25519 (MBytes.length bytes)
      | Secp256k1 _ ->
          check_signature_secp256k1 (MBytes.length bytes)
      | P256 _ ->
          check_signature_p256 (MBytes.length bytes)

    let hash_key = atomic_step_cost 30

    let hash_blake2b b = atomic_step_cost (102 + (MBytes.length b / 5))

    let hash_sha256 b = atomic_step_cost (409 + MBytes.length b)

    let hash_sha512 b =
      let bytes = MBytes.length b in
      atomic_step_cost (409 + ((bytes lsr 1) + (bytes lsr 4)))

    let steps_to_quota = atomic_step_cost 10

    let source = atomic_step_cost 10

    let self = atomic_step_cost 10

    let amount = atomic_step_cost 10

    let chain_id = step_cost 1

    let stack_n_op n =
      atomic_step_cost (20 + ((n lsr 1) + (n lsr 2) + (n lsr 4)))

    let apply = alloc_cost 8 +@ step_cost 1

    let rec compare :
        type a s. (a, s) Script_typed_ir.comparable_struct -> a -> a -> cost =
     fun ty x y ->
      match ty with
      | Bool_key _ ->
          compare_bool x y
      | String_key _ ->
          compare_string x y
      | Bytes_key _ ->
          compare_bytes x y
      | Mutez_key _ ->
          compare_tez x y
      | Int_key _ ->
          compare_zint x y
      | Nat_key _ ->
          compare_zint x y
      | Key_hash_key _ ->
          compare_key_hash x y
      | Timestamp_key _ ->
          compare_timestamp x y
      | Address_key _ ->
          compare_address x y
      | Pair_key ((tl, _), (tr, _), _) ->
          (* Reasonable over-approximation of the cost of lexicographic comparison. *)
          let (xl, xr) = x and (yl, yr) = y in
          compare tl xl yl +@ compare tr xr yr
  end

  module Typechecking = struct
    let cycle = step_cost 1

    let bool = free

    let unit = free

    let string = string

    let bytes = bytes

    let z = Legacy.zint

    let int_of_string str =
      alloc_cost @@ Pervasives.( / ) (String.length str) 5

    let tez = step_cost 1 +@ alloc_cost 1

    let string_timestamp = step_cost 3 +@ alloc_cost 3

    let key = step_cost 3 +@ alloc_cost 3

    let key_hash = step_cost 1 +@ alloc_cost 1

    let signature = step_cost 1 +@ alloc_cost 1

    let chain_id = step_cost 1 +@ alloc_cost 1

    let contract = step_cost 5

    let get_script = step_cost 20 +@ alloc_cost 5

    let contract_exists = step_cost 15 +@ alloc_cost 5

    let pair = alloc_cost 2

    let union = alloc_cost 1

    let lambda = alloc_cost 5 +@ step_cost 3

    let some = alloc_cost 1

    let none = alloc_cost 0

    let list_element = alloc_cost 2 +@ step_cost 1

    let set_element size = log2 size *@ (alloc_cost 3 +@ step_cost 2)

    let map_element size = log2 size *@ (alloc_cost 4 +@ step_cost 2)

    let primitive_type = alloc_cost 1

    let one_arg_type = alloc_cost 2

    let two_arg_type = alloc_cost 3

    let operation b = bytes b

    let type_ nb_args = alloc_cost (nb_args + 1)

    (* Cost of parsing instruction, is cost of allocation of
       constructor + cost of contructor parameters + cost of
       allocation on the stack type *)
    let instr : type b a. (b, a) Script_typed_ir.instr -> cost =
     fun i ->
      let open Script_typed_ir in
      alloc_cost 1
      +@
      (* cost of allocation of constructor *)
      match i with
      | Drop ->
          alloc_cost 0
      | Dup ->
          alloc_cost 1
      | Swap ->
          alloc_cost 0
      | Const _ ->
          alloc_cost 1
      | Cons_pair ->
          alloc_cost 2
      | Car ->
          alloc_cost 1
      | Cdr ->
          alloc_cost 1
      | Cons_some ->
          alloc_cost 2
      | Cons_none _ ->
          alloc_cost 3
      | If_none _ ->
          alloc_cost 2
      | Left ->
          alloc_cost 3
      | Right ->
          alloc_cost 3
      | If_left _ ->
          alloc_cost 2
      | Cons_list ->
          alloc_cost 1
      | Nil ->
          alloc_cost 1
      | If_cons _ ->
          alloc_cost 2
      | List_map _ ->
          alloc_cost 5
      | List_iter _ ->
          alloc_cost 4
      | List_size ->
          alloc_cost 1
      | Empty_set _ ->
          alloc_cost 1
      | Set_iter _ ->
          alloc_cost 4
      | Set_mem ->
          alloc_cost 1
      | Set_update ->
          alloc_cost 1
      | Set_size ->
          alloc_cost 1
      | Empty_map _ ->
          alloc_cost 2
      | Map_map _ ->
          alloc_cost 5
      | Map_iter _ ->
          alloc_cost 4
      | Map_mem ->
          alloc_cost 1
      | Map_get ->
          alloc_cost 1
      | Map_update ->
          alloc_cost 1
      | Map_size ->
          alloc_cost 1
      | Empty_big_map _ ->
          alloc_cost 2
      | Big_map_mem ->
          alloc_cost 1
      | Big_map_get ->
          alloc_cost 1
      | Big_map_update ->
          alloc_cost 1
      | Concat_string ->
          alloc_cost 1
      | Concat_string_pair ->
          alloc_cost 1
      | Concat_bytes ->
          alloc_cost 1
      | Concat_bytes_pair ->
          alloc_cost 1
      | Slice_string ->
          alloc_cost 1
      | Slice_bytes ->
          alloc_cost 1
      | String_size ->
          alloc_cost 1
      | Bytes_size ->
          alloc_cost 1
      | Add_seconds_to_timestamp ->
          alloc_cost 1
      | Add_timestamp_to_seconds ->
          alloc_cost 1
      | Sub_timestamp_seconds ->
          alloc_cost 1
      | Diff_timestamps ->
          alloc_cost 1
      | Add_tez ->
          alloc_cost 1
      | Sub_tez ->
          alloc_cost 1
      | Mul_teznat ->
          alloc_cost 1
      | Mul_nattez ->
          alloc_cost 1
      | Ediv_teznat ->
          alloc_cost 1
      | Ediv_tez ->
          alloc_cost 1
      | Or ->
          alloc_cost 1
      | And ->
          alloc_cost 1
      | Xor ->
          alloc_cost 1
      | Not ->
          alloc_cost 1
      | Is_nat ->
          alloc_cost 1
      | Neg_nat ->
          alloc_cost 1
      | Neg_int ->
          alloc_cost 1
      | Abs_int ->
          alloc_cost 1
      | Int_nat ->
          alloc_cost 1
      | Add_intint ->
          alloc_cost 1
      | Add_intnat ->
          alloc_cost 1
      | Add_natint ->
          alloc_cost 1
      | Add_natnat ->
          alloc_cost 1
      | Sub_int ->
          alloc_cost 1
      | Mul_intint ->
          alloc_cost 1
      | Mul_intnat ->
          alloc_cost 1
      | Mul_natint ->
          alloc_cost 1
      | Mul_natnat ->
          alloc_cost 1
      | Ediv_intint ->
          alloc_cost 1
      | Ediv_intnat ->
          alloc_cost 1
      | Ediv_natint ->
          alloc_cost 1
      | Ediv_natnat ->
          alloc_cost 1
      | Lsl_nat ->
          alloc_cost 1
      | Lsr_nat ->
          alloc_cost 1
      | Or_nat ->
          alloc_cost 1
      | And_nat ->
          alloc_cost 1
      | And_int_nat ->
          alloc_cost 1
      | Xor_nat ->
          alloc_cost 1
      | Not_nat ->
          alloc_cost 1
      | Not_int ->
          alloc_cost 1
      | Seq _ ->
          alloc_cost 8
      | If _ ->
          alloc_cost 8
      | Loop _ ->
          alloc_cost 4
      | Loop_left _ ->
          alloc_cost 5
      | Dip _ ->
          alloc_cost 4
      | Exec ->
          alloc_cost 1
      | Apply _ ->
          alloc_cost 1
      | Lambda _ ->
          alloc_cost 2
      | Failwith _ ->
          alloc_cost 1
      | Nop ->
          alloc_cost 0
      | Compare _ ->
          alloc_cost 1
      | Eq ->
          alloc_cost 1
      | Neq ->
          alloc_cost 1
      | Lt ->
          alloc_cost 1
      | Gt ->
          alloc_cost 1
      | Le ->
          alloc_cost 1
      | Ge ->
          alloc_cost 1
      | Address ->
          alloc_cost 1
      | Contract _ ->
          alloc_cost 2
      | Transfer_tokens ->
          alloc_cost 1
      | Create_account ->
          alloc_cost 2
      | Implicit_account ->
          alloc_cost 1
      | Create_contract _ ->
          alloc_cost 8
      (* Deducted the cost of removed arguments manager, spendable and delegatable:
           - manager: key_hash = 1
           - spendable: bool = 0
           - delegatable: bool = 0
        *)
      | Create_contract_2 _ ->
          alloc_cost 7
      | Set_delegate ->
          alloc_cost 1
      | Now ->
          alloc_cost 1
      | Balance ->
          alloc_cost 1
      | Check_signature ->
          alloc_cost 1
      | Hash_key ->
          alloc_cost 1
      | Pack _ ->
          alloc_cost 2
      | Unpack _ ->
          alloc_cost 2
      | Blake2b ->
          alloc_cost 1
      | Sha256 ->
          alloc_cost 1
      | Sha512 ->
          alloc_cost 1
      | Steps_to_quota ->
          alloc_cost 1
      | Source ->
          alloc_cost 1
      | Sender ->
          alloc_cost 1
      | Self _ ->
          alloc_cost 2
      | Amount ->
          alloc_cost 1
      | Dig (n, _) ->
          n *@ alloc_cost 1 (* _ is a unary development of n *)
      | Dug (n, _) ->
          n *@ alloc_cost 1
      | Dipn (n, _, _) ->
          n *@ alloc_cost 1
      | Dropn (n, _) ->
          n *@ alloc_cost 1
      | ChainId ->
          alloc_cost 1
  end

  module Unparse = struct
    let prim_cost l annot = Script.prim_node_cost_nonrec_of_length l annot

    let seq_cost = Script.seq_node_cost_nonrec_of_length

    let string_cost length = Script.string_node_cost_of_length length

    let cycle = step_cost 1

    let bool = prim_cost 0 []

    let unit = prim_cost 0 []

    (* We count the length of strings and bytes to prevent hidden
       miscalculations due to non detectable expansion of sharing. *)
    let string s = Script.string_node_cost s

    let bytes s = Script.bytes_node_cost s

    let z i = Script.int_node_cost i

    let int i = Script.int_node_cost (Script_int.to_zint i)

    let tez = Script.int_node_cost_of_numbits 60 (* int64 bound *)

    let timestamp x = Script_timestamp.to_zint x |> Script_int.of_zint |> int

    let operation bytes = Script.bytes_node_cost bytes

    let chain_id bytes = Script.bytes_node_cost bytes

    let key = string_cost 54

    let key_hash = string_cost 36

    let signature = string_cost 128

    let contract = string_cost 36

    let pair = prim_cost 2 []

    let union = prim_cost 1 []

    let some = prim_cost 1 []

    let none = prim_cost 0 []

    let list_element = alloc_cost 2

    let set_element = alloc_cost 2

    let map_element = alloc_cost 2

    let one_arg_type = prim_cost 1

    let two_arg_type = prim_cost 2

    let set_to_list = Legacy.set_to_list

    let map_to_list = Legacy.map_to_list
  end
end
src/proto_alpha/lib_protocol/michelson_v1_gas.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Gas.

Module Cost_of.
  Definition log2 : Z -> Z :=
    let fix help (acc : Z) (function_parameter : Z) : Z :=
      match function_parameter with
      | 0 => acc
      | n => help (op_plus acc 1) (op_div n 2)
      end in
    help 1.
  
  Definition z_bytes (z : Tezos_protocol_environment_alpha__Environment.Z.t)
    : Z :=
    let bits := Z.numbits z in
    op_div (op_plus 7 bits) 8.
  
  Definition int_bytes {a : Type}
    (z : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a) : Z :=
    z_bytes (Script_int.to_zint z).
  
  Definition timestamp_bytes
    (t : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t) : Z :=
    let z := Script_timestamp.to_zint t in
    z_bytes z.
  
  Fixpoint size_of_comparable {a b : Type}
    (wit : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a b)
    (v : a) : Z :=
    match wit with
    | Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ => int_bytes v
    | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ => int_bytes v
    | Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ => String.length v
    | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ => MBytes.length v
    | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ => 8
    | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ =>
      Signature.Public_key_hash.size
    | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ =>
      timestamp_bytes v
    | Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ =>
      Signature.Public_key_hash.size
    | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ => 8
    | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (l, _) (r, _) _ =>
      let '(lval, rval) := v in
      op_plus (size_of_comparable l lval) (size_of_comparable r rval)
    end.
  
  Definition string (length : Z)
    : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := alloc_bytes_cost length.
  
  Definition bytes (length : Z)
    : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
    alloc_mbytes_cost length.
  
  Definition manager_operation
    : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10000.
  
  Module Legacy.
    Definition zint (z : Tezos_protocol_environment_alpha__Environment.Z.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_bits_cost (Z.numbits z).
    
    Definition set_to_list {item : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set item)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      op_atat alloc_cost
        (op_star Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size)
          2).
    
    Definition map_to_list {key value : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let size :=
        snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
      op_starat 3 (alloc_cost size).
    
    Definition z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 2) (alloc_cost 1).
    
    Definition hash
      (data : Tezos_protocol_environment_alpha__Environment.MBytes.t) (len : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (op_starat 10 (step_cost (MBytes.length data))) (string len).
    
    Definition set_access {elt : Type}
      (_key : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
      : Z :=
      let Box := projT2 Box in
      op_atat log2
        Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size).
    
    Definition set_update {A B : Type}
      (key : A) (_presence : B)
      (set : Tezos_raw_protocol_alpha.Script_typed_ir.set A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_starat (set_access key set) (alloc_cost 3).
  End Legacy.
  
  Module Interpreter.
    Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition nop : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
    
    Definition stack_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition push : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition wrap : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition variant_no_data
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 10.
    
    Definition branch : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition pair_access : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition cons : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition loop_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 5.
    
    Definition loop_cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition loop_iter : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 20.
    
    Definition loop_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 30.
    
    Definition empty_set : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition set_to_list {elt : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      atomic_step_cost
        (op_star Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size)
          20).
    
    Definition set_mem {elt : Type}
      (elt : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let elt_bytes :=
        size_of_comparable
          Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.elt_ty) elt
        in
      atomic_step_cost
        (op_star (op_plus 1 (op_div elt_bytes 82))
          (log2 Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size))).
    
    Definition set_update {elt : Type} (elt : elt) (function_parameter : bool)
      : (Tezos_raw_protocol_alpha.Script_typed_ir.set elt) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun Box =>
        let Box := projT2 Box in
        let elt_bytes :=
          size_of_comparable
            Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.elt_ty) elt
          in
        atomic_step_cost
          (op_star (op_plus 1 (op_div elt_bytes 82))
            (log2 Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_set.size))).
    
    Definition set_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition empty_map : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition map_to_list {key value : Type}
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let size :=
        snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
      atomic_step_cost (op_star size 20).
    
    Definition map_access {key value : Type}
      (key : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let map_card :=
        snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
      let key_bytes :=
        size_of_comparable
          Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.key_ty) key
        in
      atomic_step_cost
        (op_star (op_plus 1 (op_div key_bytes 70)) (log2 map_card)).
    
    Definition map_mem {A B : Type}
      : A ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := map_access.
    
    Definition map_get {A B : Type}
      : A ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := map_access.
    
    Definition map_update {key value : Type}
      (key : key) (_value : option value)
      (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let Box := projT2 Box in
      let map_card :=
        snd Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.boxed) in
      let key_bytes :=
        size_of_comparable
          Box.(Tezos_raw_protocol_alpha__Script_typed_ir.Boxed_map.key_ty) key
        in
      atomic_step_cost
        (op_star (op_plus 1 (op_div key_bytes 38)) (log2 map_card)).
    
    Definition map_size : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition add_timestamp {a : Type}
      (t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      (t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num a)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := int_bytes t2 in
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              bytes1 bytes2) 62)).
    
    Definition sub_timestamp {A : Type}
      : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := add_timestamp.
    
    Definition diff_timestamps
      (t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      (t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := timestamp_bytes t2 in
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              bytes1 bytes2) 62)).
    
    Fixpoint concat_loop {A : Type} (l : list A) (acc : Z) : Z :=
      match l with
      | [] => 30
      | cons _ tl => concat_loop tl (op_plus acc 30)
      end.
    
    Definition concat_string {A : Type} (string_list : list A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (concat_loop string_list 0).
    
    Definition slice_string (string_length : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 40 (op_div string_length 70)).
    
    Definition concat_bytes {A : Type} (bytes_list : list A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (concat_loop bytes_list 0).
    
    Definition int64_op : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 61.
    
    Definition z_to_int64 : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 20.
    
    Definition int64_to_z : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 20.
    
    Definition bool_binop {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        atomic_step_cost 10.
    
    Definition bool_unop {A : Type} (function_parameter : A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      atomic_step_cost 10.
    
    Definition abs {A : Type}
      (int : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 61 (op_div (int_bytes Z) 70)).
    
    Definition int {A : Type} (_int : A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
    
    Definition neg {A : Type}
      : (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := abs.
    
    Definition add {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              (int_bytes i1) (int_bytes i2)) 62)).
    
    Definition sub {A B : Type}
      : (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := add.
    
    Definition mul {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes :=
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
          (int_bytes i1) (int_bytes i2) in
      atomic_step_cost (op_plus 51 (op_star (op_div string 6) (log2 string))).
    
    Definition indic_lt
      (x :
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (y :
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : Z :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
          x y then
        1
      else
        0.
    
    Definition div {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      let cost :=
        op_star (op_star (indic_lt bytes2 bytes1) (op_minus bytes1 bytes2))
          bytes2 in
      atomic_step_cost (op_plus 51 (op_div cost 3151)).
    
    Definition shift_left {A B : Type} (_i : A) (_shift_bits : B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 30.
    
    Definition shift_right {A B : Type} (_i : A) (_shift_bits : B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 30.
    
    Definition logor {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
              bytes1 bytes2) 70)).
    
    Definition logand {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := int_bytes i1 in
      let bytes2 := int_bytes i2 in
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 70)).
    
    Definition logxor {A B : Type}
      : (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A) ->
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B) ->
          Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := logor.
    
    Definition lognot {A : Type}
      (i : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 51 (op_div (int_bytes i) 20)).
    
    Definition exec : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition compare_bool {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        atomic_step_cost 30.
    
    Definition compare_string (s1 : string) (s2 : string)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := String.length s1 in
      let bytes2 := String.length s2 in
      atomic_step_cost
        (op_plus 30
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 123)).
    
    Definition compare_bytes
      (b1 : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      (b2 : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := MBytes.length b1 in
      let bytes2 := MBytes.length b2 in
      atomic_step_cost
        (op_plus 30
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 123)).
    
    Definition compare_tez {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        atomic_step_cost 30.
    
    Definition compare_zint {A B : Type}
      (i1 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      (i2 : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num B)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              (int_bytes i1) (int_bytes i2)) 82)).
    
    Definition compare_key_hash {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        atomic_step_cost 92.
    
    Definition compare_timestamp
      (t1 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      (t2 : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes1 := timestamp_bytes t1 in
      let bytes2 := timestamp_bytes t2 in
      atomic_step_cost
        (op_plus 51
          (op_div
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.min)
              bytes1 bytes2) 82)).
    
    Definition compare_address {A B : Type} (function_parameter : A)
      : B -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let '_ := function_parameter in
      fun function_parameter =>
        let '_ := function_parameter in
        atomic_step_cost 92.
    
    Definition compare_res : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 30.
    
    Definition unpack_failed
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let len := MBytes.length string in
      op_plusat (op_starat len (alloc_mbytes_cost 1))
        (op_starat len
          (op_starat (log2 len) (op_plusat (alloc_cost 3) (step_cost 1)))).
    
    Definition address : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      step_cost 10000.
    
    Definition transfer : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      step_cost 10.
    
    Definition create_account
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10.
    
    Definition create_contract
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10.
    
    Definition implicit_account
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := step_cost 10.
    
    Definition set_delegate : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 10) (write_bytes_cost (Z.of_int 32)).
    
    Definition balance : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition now : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition check_signature_secp256k1 (bytes : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 10342 (op_div string 5)).
    
    Definition check_signature_ed25519 (bytes : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 36864 (op_div string 5)).
    
    Definition check_signature_p256 (bytes : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 36864 (op_div string 5)).
    
    Definition check_signature
      (pkey : Tezos_protocol_environment_alpha__Environment.Signature.public_key)
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match pkey with
      | Tezos_protocol_environment_alpha__Environment.Signature.Ed25519 _ =>
        check_signature_ed25519 (MBytes.length string)
      | Tezos_protocol_environment_alpha__Environment.Signature.Secp256k1 _ =>
        check_signature_secp256k1 (MBytes.length string)
      | Tezos_protocol_environment_alpha__Environment.Signature.P256 _ =>
        check_signature_p256 (MBytes.length string)
      end.
    
    Definition hash_key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 30.
    
    Definition hash_blake2b
      (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 102 (op_div (MBytes.length b) 5)).
    
    Definition hash_sha256
      (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost (op_plus 409 (MBytes.length b)).
    
    Definition hash_sha512
      (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      let bytes := MBytes.length b in
      atomic_step_cost (op_plus 409 (op_plus (lsr string 1) (lsr string 4))).
    
    Definition steps_to_quota
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := atomic_step_cost 10.
    
    Definition source : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition self : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition amount : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost 10.
    
    Definition chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      step_cost 1.
    
    Definition stack_n_op (n : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      atomic_step_cost
        (op_plus 20 (op_plus (op_plus (lsr n 1) (lsr n 2)) (lsr n 4))).
    
    Definition apply : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (alloc_cost 8) (step_cost 1).
    
    Fixpoint compare {a s : Type}
      (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
      (x : a) (y : a) : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      match ty with
      | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ => compare_bool x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ =>
        compare_string x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ =>
        compare_bytes x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ => compare_tez x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ => compare_zint x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ => compare_zint x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ =>
        compare_key_hash x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ =>
        compare_timestamp x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ =>
        compare_address x y
      | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
        in
        op_plusat (compare tl xl yl) (compare tr xr yr)
      end.
  End Interpreter.
  
  Module Typechecking.
    Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      step_cost 1.
    
    Definition bool : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
    
    Definition unit : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := free.
    
    Definition string : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      string.
    
    Definition bytes : Z -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      string.
    
    Definition z
      : Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.zint.
    
    Definition int_of_string (str : string)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_atat alloc_cost (Pervasives.op_div (String.length str) 5).
    
    Definition tez : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 1) (alloc_cost 1).
    
    Definition string_timestamp
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 3) (alloc_cost 3).
    
    Definition key : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 3) (alloc_cost 3).
    
    Definition key_hash : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 1) (alloc_cost 1).
    
    Definition signature : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 1) (alloc_cost 1).
    
    Definition chain_id : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 1) (alloc_cost 1).
    
    Definition contract : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      step_cost 5.
    
    Definition get_script : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 20) (alloc_cost 5).
    
    Definition contract_exists
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (step_cost 15) (alloc_cost 5).
    
    Definition pair : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 2.
    
    Definition union : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 1.
    
    Definition lambda : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (alloc_cost 5) (step_cost 3).
    
    Definition some : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 1.
    
    Definition none : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 0.
    
    Definition list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (alloc_cost 2) (step_cost 1).
    
    Definition set_element (size : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_starat (log2 size) (op_plusat (alloc_cost 3) (step_cost 2)).
    
    Definition map_element (size : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_starat (log2 size) (op_plusat (alloc_cost 4) (step_cost 2)).
    
    Definition primitive_type
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := alloc_cost 1.
    
    Definition one_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 2.
    
    Definition two_arg_type : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 3.
    
    Definition operation (b : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := string b.
    
    Definition type_ (nb_args : Z)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost (op_plus nb_args 1).
    
    Definition instr {a b : Type}
      (i : Tezos_raw_protocol_alpha.Script_typed_ir.instr b a)
      : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      op_plusat (alloc_cost 1)
        match i with
        | Tezos_raw_protocol_alpha.Script_typed_ir.Drop => alloc_cost 0
        | Tezos_raw_protocol_alpha.Script_typed_ir.Dup => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Swap => alloc_cost 0
        | Tezos_raw_protocol_alpha.Script_typed_ir.Const _ => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Car => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Cdr => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none _ => alloc_cost 3
        | Tezos_raw_protocol_alpha.Script_typed_ir.If_none _ _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Left => alloc_cost 3
        | Tezos_raw_protocol_alpha.Script_typed_ir.Right => alloc_cost 3
        | Tezos_raw_protocol_alpha.Script_typed_ir.If_left _ _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Nil => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.If_cons _ _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.List_map _ => alloc_cost 5
        | Tezos_raw_protocol_alpha.Script_typed_ir.List_iter _ => alloc_cost 4
        | Tezos_raw_protocol_alpha.Script_typed_ir.List_size => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set _ => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter _ => alloc_cost 4
        | Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Set_update => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Set_size => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map _ _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Map_map _ => alloc_cost 5
        | Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter _ => alloc_cost 4
        | Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Map_get => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Map_update => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Map_size => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map _ _ =>
          alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.String_size => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Or => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.And => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Xor => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Not => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.And_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Not_int => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Seq _ _ => alloc_cost 8
        | Tezos_raw_protocol_alpha.Script_typed_ir.If _ _ => alloc_cost 8
        | Tezos_raw_protocol_alpha.Script_typed_ir.Loop _ => alloc_cost 4
        | Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left _ => alloc_cost 5
        | Tezos_raw_protocol_alpha.Script_typed_ir.Dip _ => alloc_cost 4
        | Tezos_raw_protocol_alpha.Script_typed_ir.Exec => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Apply _ => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Failwith _ => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Nop => alloc_cost 0
        | Tezos_raw_protocol_alpha.Script_typed_ir.Compare _ => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Eq => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Neq => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Lt => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Gt => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Le => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Ge => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Address => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Contract _ _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Create_account =>
          alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract _ _ _ _ =>
          alloc_cost 8
        | Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2 _ _ _ _ =>
          alloc_cost 7
        | Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Now => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Balance => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Pack _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Unpack _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Sha256 => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Sha512 => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota =>
          alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Source => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Sender => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Self _ _ => alloc_cost 2
        | Tezos_raw_protocol_alpha.Script_typed_ir.Amount => alloc_cost 1
        | Tezos_raw_protocol_alpha.Script_typed_ir.Dig n _ =>
          op_starat n (alloc_cost 1)
        | Tezos_raw_protocol_alpha.Script_typed_ir.Dug n _ =>
          op_starat n (alloc_cost 1)
        | Tezos_raw_protocol_alpha.Script_typed_ir.Dipn n _ _ =>
          op_starat n (alloc_cost 1)
        | Tezos_raw_protocol_alpha.Script_typed_ir.Dropn n _ =>
          op_starat n (alloc_cost 1)
        | Tezos_raw_protocol_alpha.Script_typed_ir.ChainId => alloc_cost 1
        end.
  End Typechecking.
  
  Module Unparse.
    Definition prim_cost
      (l : Z) (annot : Tezos_raw_protocol_alpha.Alpha_context.Script.annot)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.prim_node_cost_nonrec_of_length l annot.
    
    Definition seq_cost
      : Z -> Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.seq_node_cost_nonrec_of_length.
    
    Definition string_cost (length : Z)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.string_node_cost_of_length length.
    
    Definition cycle : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      step_cost 1.
    
    Definition bool : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 0 [].
    
    Definition unit : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 0 [].
    
    Definition string (s : string)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.string_node_cost s.
    
    Definition bytes
      (s : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.bytes_node_cost s.
    
    Definition z (i : Tezos_protocol_environment_alpha__Environment.Z.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.int_node_cost i.
    
    Definition int {A : Type}
      (i : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num A)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.int_node_cost (Script_int.to_zint i).
    
    Definition tez : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.int_node_cost_of_numbits 60.
    
    Definition timestamp
      (x : Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      op_pipegt (op_pipegt (Script_timestamp.to_zint x) Script_int.of_zint) Z.
    
    Definition operation
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.bytes_node_cost string.
    
    Definition chain_id
      (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
      : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      Script.bytes_node_cost string.
    
    Definition key : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 54.
    
    Definition key_hash : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 36.
    
    Definition signature : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 128.
    
    Definition contract : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      string_cost 36.
    
    Definition pair : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 2 [].
    
    Definition union : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 1 [].
    
    Definition some : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 1 [].
    
    Definition none : Tezos_raw_protocol_alpha__Alpha_context.Gas.cost :=
      prim_cost 0 [].
    
    Definition list_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 2.
    
    Definition set_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 2.
    
    Definition map_element : Tezos_raw_protocol_alpha.Alpha_context.Gas.cost :=
      alloc_cost 2.
    
    Definition one_arg_type
      : Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
        Tezos_raw_protocol_alpha__Alpha_context.Gas.cost := prim_cost 1.
    
    Definition two_arg_type
      : Tezos_raw_protocol_alpha.Alpha_context.Script.annot ->
        Tezos_raw_protocol_alpha__Alpha_context.Gas.cost := prim_cost 2.
    
    Definition set_to_list {A : Type}
      : (Tezos_raw_protocol_alpha.Script_typed_ir.set A) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.set_to_list.
    
    Definition map_to_list {A B : Type}
      : (Tezos_raw_protocol_alpha.Script_typed_ir.map A B) ->
        Tezos_raw_protocol_alpha.Alpha_context.Gas.cost := Legacy.map_to_list.
  End Unparse.
End Cost_of.

src/proto_alpha/lib_protocol/michelson_v1_primitives.ml 11 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Micheline

type error += Unknown_primitive_name of string

type error += Invalid_case of string

type error +=
  | Invalid_primitive_name of
      string Micheline.canonical * Micheline.canonical_location

type prim =
  | K_parameter
  | K_storage
  | K_code
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id

let valid_case name =
  let is_lower = function '_' | 'a' .. 'z' -> true | _ -> false in
  let is_upper = function '_' | 'A' .. 'Z' -> true | _ -> false in
  let rec for_all a b f =
    Compare.Int.(a > b) || (f a && for_all (a + 1) b f)
  in
  let len = String.length name in
  Compare.Int.(len <> 0)
  && Compare.Char.(name.[0] <> '_')
  && ( (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_upper name.[i]))
     || (is_upper name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
     || (is_lower name.[0] && for_all 1 (len - 1) (fun i -> is_lower name.[i]))
     )

let string_of_prim = function
  | K_parameter ->
      "parameter"
  | K_storage ->
      "storage"
  | K_code ->
      "code"
  | D_False ->
      "False"
  | D_Elt ->
      "Elt"
  | D_Left ->
      "Left"
  | D_None ->
      "None"
  | D_Pair ->
      "Pair"
  | D_Right ->
      "Right"
  | D_Some ->
      "Some"
  | D_True ->
      "True"
  | D_Unit ->
      "Unit"
  | I_PACK ->
      "PACK"
  | I_UNPACK ->
      "UNPACK"
  | I_BLAKE2B ->
      "BLAKE2B"
  | I_SHA256 ->
      "SHA256"
  | I_SHA512 ->
      "SHA512"
  | I_ABS ->
      "ABS"
  | I_ADD ->
      "ADD"
  | I_AMOUNT ->
      "AMOUNT"
  | I_AND ->
      "AND"
  | I_BALANCE ->
      "BALANCE"
  | I_CAR ->
      "CAR"
  | I_CDR ->
      "CDR"
  | I_CHAIN_ID ->
      "CHAIN_ID"
  | I_CHECK_SIGNATURE ->
      "CHECK_SIGNATURE"
  | I_COMPARE ->
      "COMPARE"
  | I_CONCAT ->
      "CONCAT"
  | I_CONS ->
      "CONS"
  | I_CREATE_ACCOUNT ->
      "CREATE_ACCOUNT"
  | I_CREATE_CONTRACT ->
      "CREATE_CONTRACT"
  | I_IMPLICIT_ACCOUNT ->
      "IMPLICIT_ACCOUNT"
  | I_DIP ->
      "DIP"
  | I_DROP ->
      "DROP"
  | I_DUP ->
      "DUP"
  | I_EDIV ->
      "EDIV"
  | I_EMPTY_BIG_MAP ->
      "EMPTY_BIG_MAP"
  | I_EMPTY_MAP ->
      "EMPTY_MAP"
  | I_EMPTY_SET ->
      "EMPTY_SET"
  | I_EQ ->
      "EQ"
  | I_EXEC ->
      "EXEC"
  | I_APPLY ->
      "APPLY"
  | I_FAILWITH ->
      "FAILWITH"
  | I_GE ->
      "GE"
  | I_GET ->
      "GET"
  | I_GT ->
      "GT"
  | I_HASH_KEY ->
      "HASH_KEY"
  | I_IF ->
      "IF"
  | I_IF_CONS ->
      "IF_CONS"
  | I_IF_LEFT ->
      "IF_LEFT"
  | I_IF_NONE ->
      "IF_NONE"
  | I_INT ->
      "INT"
  | I_LAMBDA ->
      "LAMBDA"
  | I_LE ->
      "LE"
  | I_LEFT ->
      "LEFT"
  | I_LOOP ->
      "LOOP"
  | I_LSL ->
      "LSL"
  | I_LSR ->
      "LSR"
  | I_LT ->
      "LT"
  | I_MAP ->
      "MAP"
  | I_MEM ->
      "MEM"
  | I_MUL ->
      "MUL"
  | I_NEG ->
      "NEG"
  | I_NEQ ->
      "NEQ"
  | I_NIL ->
      "NIL"
  | I_NONE ->
      "NONE"
  | I_NOT ->
      "NOT"
  | I_NOW ->
      "NOW"
  | I_OR ->
      "OR"
  | I_PAIR ->
      "PAIR"
  | I_PUSH ->
      "PUSH"
  | I_RIGHT ->
      "RIGHT"
  | I_SIZE ->
      "SIZE"
  | I_SOME ->
      "SOME"
  | I_SOURCE ->
      "SOURCE"
  | I_SENDER ->
      "SENDER"
  | I_SELF ->
      "SELF"
  | I_SLICE ->
      "SLICE"
  | I_STEPS_TO_QUOTA ->
      "STEPS_TO_QUOTA"
  | I_SUB ->
      "SUB"
  | I_SWAP ->
      "SWAP"
  | I_TRANSFER_TOKENS ->
      "TRANSFER_TOKENS"
  | I_SET_DELEGATE ->
      "SET_DELEGATE"
  | I_UNIT ->
      "UNIT"
  | I_UPDATE ->
      "UPDATE"
  | I_XOR ->
      "XOR"
  | I_ITER ->
      "ITER"
  | I_LOOP_LEFT ->
      "LOOP_LEFT"
  | I_ADDRESS ->
      "ADDRESS"
  | I_CONTRACT ->
      "CONTRACT"
  | I_ISNAT ->
      "ISNAT"
  | I_CAST ->
      "CAST"
  | I_RENAME ->
      "RENAME"
  | I_DIG ->
      "DIG"
  | I_DUG ->
      "DUG"
  | T_bool ->
      "bool"
  | T_contract ->
      "contract"
  | T_int ->
      "int"
  | T_key ->
      "key"
  | T_key_hash ->
      "key_hash"
  | T_lambda ->
      "lambda"
  | T_list ->
      "list"
  | T_map ->
      "map"
  | T_big_map ->
      "big_map"
  | T_nat ->
      "nat"
  | T_option ->
      "option"
  | T_or ->
      "or"
  | T_pair ->
      "pair"
  | T_set ->
      "set"
  | T_signature ->
      "signature"
  | T_string ->
      "string"
  | T_bytes ->
      "bytes"
  | T_mutez ->
      "mutez"
  | T_timestamp ->
      "timestamp"
  | T_unit ->
      "unit"
  | T_operation ->
      "operation"
  | T_address ->
      "address"
  | T_chain_id ->
      "chain_id"

let prim_of_string = function
  | "parameter" ->
      ok K_parameter
  | "storage" ->
      ok K_storage
  | "code" ->
      ok K_code
  | "False" ->
      ok D_False
  | "Elt" ->
      ok D_Elt
  | "Left" ->
      ok D_Left
  | "None" ->
      ok D_None
  | "Pair" ->
      ok D_Pair
  | "Right" ->
      ok D_Right
  | "Some" ->
      ok D_Some
  | "True" ->
      ok D_True
  | "Unit" ->
      ok D_Unit
  | "PACK" ->
      ok I_PACK
  | "UNPACK" ->
      ok I_UNPACK
  | "BLAKE2B" ->
      ok I_BLAKE2B
  | "SHA256" ->
      ok I_SHA256
  | "SHA512" ->
      ok I_SHA512
  | "ABS" ->
      ok I_ABS
  | "ADD" ->
      ok I_ADD
  | "AMOUNT" ->
      ok I_AMOUNT
  | "AND" ->
      ok I_AND
  | "BALANCE" ->
      ok I_BALANCE
  | "CAR" ->
      ok I_CAR
  | "CDR" ->
      ok I_CDR
  | "CHAIN_ID" ->
      ok I_CHAIN_ID
  | "CHECK_SIGNATURE" ->
      ok I_CHECK_SIGNATURE
  | "COMPARE" ->
      ok I_COMPARE
  | "CONCAT" ->
      ok I_CONCAT
  | "CONS" ->
      ok I_CONS
  | "CREATE_ACCOUNT" ->
      ok I_CREATE_ACCOUNT
  | "CREATE_CONTRACT" ->
      ok I_CREATE_CONTRACT
  | "IMPLICIT_ACCOUNT" ->
      ok I_IMPLICIT_ACCOUNT
  | "DIP" ->
      ok I_DIP
  | "DROP" ->
      ok I_DROP
  | "DUP" ->
      ok I_DUP
  | "EDIV" ->
      ok I_EDIV
  | "EMPTY_BIG_MAP" ->
      ok I_EMPTY_BIG_MAP
  | "EMPTY_MAP" ->
      ok I_EMPTY_MAP
  | "EMPTY_SET" ->
      ok I_EMPTY_SET
  | "EQ" ->
      ok I_EQ
  | "EXEC" ->
      ok I_EXEC
  | "APPLY" ->
      ok I_APPLY
  | "FAILWITH" ->
      ok I_FAILWITH
  | "GE" ->
      ok I_GE
  | "GET" ->
      ok I_GET
  | "GT" ->
      ok I_GT
  | "HASH_KEY" ->
      ok I_HASH_KEY
  | "IF" ->
      ok I_IF
  | "IF_CONS" ->
      ok I_IF_CONS
  | "IF_LEFT" ->
      ok I_IF_LEFT
  | "IF_NONE" ->
      ok I_IF_NONE
  | "INT" ->
      ok I_INT
  | "LAMBDA" ->
      ok I_LAMBDA
  | "LE" ->
      ok I_LE
  | "LEFT" ->
      ok I_LEFT
  | "LOOP" ->
      ok I_LOOP
  | "LSL" ->
      ok I_LSL
  | "LSR" ->
      ok I_LSR
  | "LT" ->
      ok I_LT
  | "MAP" ->
      ok I_MAP
  | "MEM" ->
      ok I_MEM
  | "MUL" ->
      ok I_MUL
  | "NEG" ->
      ok I_NEG
  | "NEQ" ->
      ok I_NEQ
  | "NIL" ->
      ok I_NIL
  | "NONE" ->
      ok I_NONE
  | "NOT" ->
      ok I_NOT
  | "NOW" ->
      ok I_NOW
  | "OR" ->
      ok I_OR
  | "PAIR" ->
      ok I_PAIR
  | "PUSH" ->
      ok I_PUSH
  | "RIGHT" ->
      ok I_RIGHT
  | "SIZE" ->
      ok I_SIZE
  | "SOME" ->
      ok I_SOME
  | "SOURCE" ->
      ok I_SOURCE
  | "SENDER" ->
      ok I_SENDER
  | "SELF" ->
      ok I_SELF
  | "SLICE" ->
      ok I_SLICE
  | "STEPS_TO_QUOTA" ->
      ok I_STEPS_TO_QUOTA
  | "SUB" ->
      ok I_SUB
  | "SWAP" ->
      ok I_SWAP
  | "TRANSFER_TOKENS" ->
      ok I_TRANSFER_TOKENS
  | "SET_DELEGATE" ->
      ok I_SET_DELEGATE
  | "UNIT" ->
      ok I_UNIT
  | "UPDATE" ->
      ok I_UPDATE
  | "XOR" ->
      ok I_XOR
  | "ITER" ->
      ok I_ITER
  | "LOOP_LEFT" ->
      ok I_LOOP_LEFT
  | "ADDRESS" ->
      ok I_ADDRESS
  | "CONTRACT" ->
      ok I_CONTRACT
  | "ISNAT" ->
      ok I_ISNAT
  | "CAST" ->
      ok I_CAST
  | "RENAME" ->
      ok I_RENAME
  | "DIG" ->
      ok I_DIG
  | "DUG" ->
      ok I_DUG
  | "bool" ->
      ok T_bool
  | "contract" ->
      ok T_contract
  | "int" ->
      ok T_int
  | "key" ->
      ok T_key
  | "key_hash" ->
      ok T_key_hash
  | "lambda" ->
      ok T_lambda
  | "list" ->
      ok T_list
  | "map" ->
      ok T_map
  | "big_map" ->
      ok T_big_map
  | "nat" ->
      ok T_nat
  | "option" ->
      ok T_option
  | "or" ->
      ok T_or
  | "pair" ->
      ok T_pair
  | "set" ->
      ok T_set
  | "signature" ->
      ok T_signature
  | "string" ->
      ok T_string
  | "bytes" ->
      ok T_bytes
  | "mutez" ->
      ok T_mutez
  | "timestamp" ->
      ok T_timestamp
  | "unit" ->
      ok T_unit
  | "operation" ->
      ok T_operation
  | "address" ->
      ok T_address
  | "chain_id" ->
      ok T_chain_id
  | n ->
      if valid_case n then error (Unknown_primitive_name n)
      else error (Invalid_case n)

let prims_of_strings expr =
  let rec convert = function
    | (Int _ | String _ | Bytes _) as expr ->
        ok expr
    | Prim (loc, prim, args, annot) ->
        Error_monad.record_trace
          (Invalid_primitive_name (expr, loc))
          (prim_of_string prim)
        >>? fun prim ->
        List.fold_left
          (fun acc arg ->
            acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
          (ok [])
          args
        >>? fun args -> ok (Prim (0, prim, List.rev args, annot))
    | Seq (_, args) ->
        List.fold_left
          (fun acc arg ->
            acc >>? fun args -> convert arg >>? fun arg -> ok (arg :: args))
          (ok [])
          args
        >>? fun args -> ok (Seq (0, List.rev args))
  in
  convert (root expr) >>? fun expr -> ok (strip_locations expr)

let strings_of_prims expr =
  let rec convert = function
    | (Int _ | String _ | Bytes _) as expr ->
        expr
    | Prim (_, prim, args, annot) ->
        let prim = string_of_prim prim in
        let args = List.map convert args in
        Prim (0, prim, args, annot)
    | Seq (_, args) ->
        let args = List.map convert args in
        Seq (0, args)
  in
  strip_locations (convert (root expr))

let prim_encoding =
  let open Data_encoding in
  def "michelson.v1.primitives"
  @@ string_enum
       [ (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("parameter", K_parameter);
         ("storage", K_storage);
         ("code", K_code);
         ("False", D_False);
         ("Elt", D_Elt);
         ("Left", D_Left);
         ("None", D_None);
         ("Pair", D_Pair);
         ("Right", D_Right);
         ("Some", D_Some);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("True", D_True);
         ("Unit", D_Unit);
         ("PACK", I_PACK);
         ("UNPACK", I_UNPACK);
         ("BLAKE2B", I_BLAKE2B);
         ("SHA256", I_SHA256);
         ("SHA512", I_SHA512);
         ("ABS", I_ABS);
         ("ADD", I_ADD);
         ("AMOUNT", I_AMOUNT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("AND", I_AND);
         ("BALANCE", I_BALANCE);
         ("CAR", I_CAR);
         ("CDR", I_CDR);
         ("CHECK_SIGNATURE", I_CHECK_SIGNATURE);
         ("COMPARE", I_COMPARE);
         ("CONCAT", I_CONCAT);
         ("CONS", I_CONS);
         ("CREATE_ACCOUNT", I_CREATE_ACCOUNT);
         ("CREATE_CONTRACT", I_CREATE_CONTRACT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("IMPLICIT_ACCOUNT", I_IMPLICIT_ACCOUNT);
         ("DIP", I_DIP);
         ("DROP", I_DROP);
         ("DUP", I_DUP);
         ("EDIV", I_EDIV);
         ("EMPTY_MAP", I_EMPTY_MAP);
         ("EMPTY_SET", I_EMPTY_SET);
         ("EQ", I_EQ);
         ("EXEC", I_EXEC);
         ("FAILWITH", I_FAILWITH);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("GE", I_GE);
         ("GET", I_GET);
         ("GT", I_GT);
         ("HASH_KEY", I_HASH_KEY);
         ("IF", I_IF);
         ("IF_CONS", I_IF_CONS);
         ("IF_LEFT", I_IF_LEFT);
         ("IF_NONE", I_IF_NONE);
         ("INT", I_INT);
         ("LAMBDA", I_LAMBDA);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("LE", I_LE);
         ("LEFT", I_LEFT);
         ("LOOP", I_LOOP);
         ("LSL", I_LSL);
         ("LSR", I_LSR);
         ("LT", I_LT);
         ("MAP", I_MAP);
         ("MEM", I_MEM);
         ("MUL", I_MUL);
         ("NEG", I_NEG);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("NEQ", I_NEQ);
         ("NIL", I_NIL);
         ("NONE", I_NONE);
         ("NOT", I_NOT);
         ("NOW", I_NOW);
         ("OR", I_OR);
         ("PAIR", I_PAIR);
         ("PUSH", I_PUSH);
         ("RIGHT", I_RIGHT);
         ("SIZE", I_SIZE);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("SOME", I_SOME);
         ("SOURCE", I_SOURCE);
         ("SENDER", I_SENDER);
         ("SELF", I_SELF);
         ("STEPS_TO_QUOTA", I_STEPS_TO_QUOTA);
         ("SUB", I_SUB);
         ("SWAP", I_SWAP);
         ("TRANSFER_TOKENS", I_TRANSFER_TOKENS);
         ("SET_DELEGATE", I_SET_DELEGATE);
         ("UNIT", I_UNIT);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("UPDATE", I_UPDATE);
         ("XOR", I_XOR);
         ("ITER", I_ITER);
         ("LOOP_LEFT", I_LOOP_LEFT);
         ("ADDRESS", I_ADDRESS);
         ("CONTRACT", I_CONTRACT);
         ("ISNAT", I_ISNAT);
         ("CAST", I_CAST);
         ("RENAME", I_RENAME);
         ("bool", T_bool);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("contract", T_contract);
         ("int", T_int);
         ("key", T_key);
         ("key_hash", T_key_hash);
         ("lambda", T_lambda);
         ("list", T_list);
         ("map", T_map);
         ("big_map", T_big_map);
         ("nat", T_nat);
         ("option", T_option);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("or", T_or);
         ("pair", T_pair);
         ("set", T_set);
         ("signature", T_signature);
         ("string", T_string);
         ("bytes", T_bytes);
         ("mutez", T_mutez);
         ("timestamp", T_timestamp);
         ("unit", T_unit);
         ("operation", T_operation);
         (* /!\ NEW INSTRUCTIONS MUST BE ADDED AT THE END OF THE STRING_ENUM, FOR BACKWARD COMPATIBILITY OF THE ENCODING. *)
         ("address", T_address);
         (* Alpha_002 addition *)
         ("SLICE", I_SLICE);
         (* Alpha_005 addition *)
         ("DIG", I_DIG);
         ("DUG", I_DUG);
         ("EMPTY_BIG_MAP", I_EMPTY_BIG_MAP);
         ("APPLY", I_APPLY);
         ("chain_id", T_chain_id);
         ("CHAIN_ID", I_CHAIN_ID)
         (* New instructions must be added here, for backward compatibility of the encoding. *)
        ]

let () =
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unknown_primitive_name"
    ~title:"Unknown primitive name"
    ~description:"In a script or data expression, a primitive was unknown."
    ~pp:(fun ppf n -> Format.fprintf ppf "Unknown primitive %s." n)
    Data_encoding.(obj1 (req "wrong_primitive_name" string))
    (function Unknown_primitive_name got -> Some got | _ -> None)
    (fun got -> Unknown_primitive_name got) ;
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_name_case"
    ~title:"Invalid primitive name case"
    ~description:
      "In a script or data expression, a primitive name is neither uppercase, \
       lowercase or capitalized."
    ~pp:(fun ppf n -> Format.fprintf ppf "Primitive %s has invalid case." n)
    Data_encoding.(obj1 (req "wrong_primitive_name" string))
    (function Invalid_case name -> Some name | _ -> None)
    (fun name -> Invalid_case name) ;
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_name"
    ~title:"Invalid primitive name"
    ~description:
      "In a script or data expression, a primitive name is unknown or has a \
       wrong case."
    ~pp:(fun ppf _ -> Format.fprintf ppf "Invalid primitive.")
    Data_encoding.(
      obj2
        (req
           "expression"
           (Micheline.canonical_encoding ~variant:"generic" string))
        (req "location" Micheline.canonical_location_encoding))
    (function
      | Invalid_primitive_name (expr, loc) -> Some (expr, loc) | _ -> None)
    (fun (expr, loc) -> Invalid_primitive_name (expr, loc))
src/proto_alpha/lib_protocol/michelson_v1_primitives.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Micheline.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

Inductive prim : Type :=
| K_parameter : prim
| K_storage : prim
| K_code : prim
| D_False : prim
| D_Elt : prim
| D_Left : prim
| D_None : prim
| D_Pair : prim
| D_Right : prim
| D_Some : prim
| D_True : prim
| D_Unit : prim
| I_PACK : prim
| I_UNPACK : prim
| I_BLAKE2B : prim
| I_SHA256 : prim
| I_SHA512 : prim
| I_ABS : prim
| I_ADD : prim
| I_AMOUNT : prim
| I_AND : prim
| I_BALANCE : prim
| I_CAR : prim
| I_CDR : prim
| I_CHAIN_ID : prim
| I_CHECK_SIGNATURE : prim
| I_COMPARE : prim
| I_CONCAT : prim
| I_CONS : prim
| I_CREATE_ACCOUNT : prim
| I_CREATE_CONTRACT : prim
| I_IMPLICIT_ACCOUNT : prim
| I_DIP : prim
| I_DROP : prim
| I_DUP : prim
| I_EDIV : prim
| I_EMPTY_BIG_MAP : prim
| I_EMPTY_MAP : prim
| I_EMPTY_SET : prim
| I_EQ : prim
| I_EXEC : prim
| I_APPLY : prim
| I_FAILWITH : prim
| I_GE : prim
| I_GET : prim
| I_GT : prim
| I_HASH_KEY : prim
| I_IF : prim
| I_IF_CONS : prim
| I_IF_LEFT : prim
| I_IF_NONE : prim
| I_INT : prim
| I_LAMBDA : prim
| I_LE : prim
| I_LEFT : prim
| I_LOOP : prim
| I_LSL : prim
| I_LSR : prim
| I_LT : prim
| I_MAP : prim
| I_MEM : prim
| I_MUL : prim
| I_NEG : prim
| I_NEQ : prim
| I_NIL : prim
| I_NONE : prim
| I_NOT : prim
| I_NOW : prim
| I_OR : prim
| I_PAIR : prim
| I_PUSH : prim
| I_RIGHT : prim
| I_SIZE : prim
| I_SOME : prim
| I_SOURCE : prim
| I_SENDER : prim
| I_SELF : prim
| I_SLICE : prim
| I_STEPS_TO_QUOTA : prim
| I_SUB : prim
| I_SWAP : prim
| I_TRANSFER_TOKENS : prim
| I_SET_DELEGATE : prim
| I_UNIT : prim
| I_UPDATE : prim
| I_XOR : prim
| I_ITER : prim
| I_LOOP_LEFT : prim
| I_ADDRESS : prim
| I_CONTRACT : prim
| I_ISNAT : prim
| I_CAST : prim
| I_RENAME : prim
| I_DIG : prim
| I_DUG : prim
| T_bool : prim
| T_contract : prim
| T_int : prim
| T_key : prim
| T_key_hash : prim
| T_lambda : prim
| T_list : prim
| T_map : prim
| T_big_map : prim
| T_nat : prim
| T_option : prim
| T_or : prim
| T_pair : prim
| T_set : prim
| T_signature : prim
| T_string : prim
| T_bytes : prim
| T_mutez : prim
| T_timestamp : prim
| T_unit : prim
| T_operation : prim
| T_address : prim
| T_chain_id : prim.

Definition valid_case (name : string) : bool :=
  let is_lower (function_parameter : ascii) : bool :=
    match function_parameter with
    |
      "_" % char |
        "a" % char |
          "b" % char |
            "c" % char |
              "d" % char |
                "e" % char |
                  "f" % char |
                    "g" % char |
                      "h" % char |
                        "i" % char |
                          "j" % char |
                            "k" % char |
                              "l" % char |
                                "m" % char |
                                  "n" % char |
                                    "o" % char |
                                      "p" % char |
                                        "q" % char |
                                          "r" % char |
                                            "s" % char |
                                              "t" % char |
                                                "u" % char |
                                                  "v" % char |
                                                    "w" % char |
                                                      "x" % char |
                                                        "y" % char | "z" % char
      => true
    | _ => false
    end in
  let is_upper (function_parameter : ascii) : bool :=
    match function_parameter with
    |
      "_" % char |
        "A" % char |
          "B" % char |
            "C" % char |
              "D" % char |
                "E" % char |
                  "F" % char |
                    "G" % char |
                      "H" % char |
                        "I" % char |
                          "J" % char |
                            "K" % char |
                              "L" % char |
                                "M" % char |
                                  "N" % char |
                                    "O" % char |
                                      "P" % char |
                                        "Q" % char |
                                          "R" % char |
                                            "S" % char |
                                              "T" % char |
                                                "U" % char |
                                                  "V" % char |
                                                    "W" % char |
                                                      "X" % char |
                                                        "Y" % char | "Z" % char
      => true
    | _ => false
    end in
  let fix for_all
    (a :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (b :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (f :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
      -> bool) : bool :=
    op_pipepipe
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        a b) (op_andand (f a) (for_all (op_plus a 1) b f)) in
  let len := String.length name in
  op_andand
    (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
      len 0)
    (op_andand
      (Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
        (String.get name 0) "_" % char)
      (op_pipepipe
        (op_andand (is_upper (String.get name 0))
          (for_all 1 (op_minus len 1) (fun i => is_upper (String.get name i))))
        (op_pipepipe
          (op_andand (is_upper (String.get name 0))
            (for_all 1 (op_minus len 1) (fun i => is_lower (String.get name i))))
          (op_andand (is_lower (String.get name 0))
            (for_all 1 (op_minus len 1) (fun i => is_lower (String.get name i))))))).

Definition string_of_prim (function_parameter : prim) : string :=
  match function_parameter with
  | K_parameter => "parameter" % string
  | K_storage => "storage" % string
  | K_code => "code" % string
  | D_False => "False" % string
  | D_Elt => "Elt" % string
  | D_Left => "Left" % string
  | D_None => "None" % string
  | D_Pair => "Pair" % string
  | D_Right => "Right" % string
  | D_Some => "Some" % string
  | D_True => "True" % string
  | D_Unit => "Unit" % string
  | I_PACK => "PACK" % string
  | I_UNPACK => "UNPACK" % string
  | I_BLAKE2B => "BLAKE2B" % string
  | I_SHA256 => "SHA256" % string
  | I_SHA512 => "SHA512" % string
  | I_ABS => "ABS" % string
  | I_ADD => "ADD" % string
  | I_AMOUNT => "AMOUNT" % string
  | I_AND => "AND" % string
  | I_BALANCE => "BALANCE" % string
  | I_CAR => "CAR" % string
  | I_CDR => "CDR" % string
  | I_CHAIN_ID => "CHAIN_ID" % string
  | I_CHECK_SIGNATURE => "CHECK_SIGNATURE" % string
  | I_COMPARE => "COMPARE" % string
  | I_CONCAT => "CONCAT" % string
  | I_CONS => "CONS" % string
  | I_CREATE_ACCOUNT => "CREATE_ACCOUNT" % string
  | I_CREATE_CONTRACT => "CREATE_CONTRACT" % string
  | I_IMPLICIT_ACCOUNT => "IMPLICIT_ACCOUNT" % string
  | I_DIP => "DIP" % string
  | I_DROP => "DROP" % string
  | I_DUP => "DUP" % string
  | I_EDIV => "EDIV" % string
  | I_EMPTY_BIG_MAP => "EMPTY_BIG_MAP" % string
  | I_EMPTY_MAP => "EMPTY_MAP" % string
  | I_EMPTY_SET => "EMPTY_SET" % string
  | I_EQ => "EQ" % string
  | I_EXEC => "EXEC" % string
  | I_APPLY => "APPLY" % string
  | I_FAILWITH => "FAILWITH" % string
  | I_GE => "GE" % string
  | I_GET => "GET" % string
  | I_GT => "GT" % string
  | I_HASH_KEY => "HASH_KEY" % string
  | I_IF => "IF" % string
  | I_IF_CONS => "IF_CONS" % string
  | I_IF_LEFT => "IF_LEFT" % string
  | I_IF_NONE => "IF_NONE" % string
  | I_INT => "INT" % string
  | I_LAMBDA => "LAMBDA" % string
  | I_LE => "LE" % string
  | I_LEFT => "LEFT" % string
  | I_LOOP => "LOOP" % string
  | I_LSL => "LSL" % string
  | I_LSR => "LSR" % string
  | I_LT => "LT" % string
  | I_MAP => "MAP" % string
  | I_MEM => "MEM" % string
  | I_MUL => "MUL" % string
  | I_NEG => "NEG" % string
  | I_NEQ => "NEQ" % string
  | I_NIL => "NIL" % string
  | I_NONE => "NONE" % string
  | I_NOT => "NOT" % string
  | I_NOW => "NOW" % string
  | I_OR => "OR" % string
  | I_PAIR => "PAIR" % string
  | I_PUSH => "PUSH" % string
  | I_RIGHT => "RIGHT" % string
  | I_SIZE => "SIZE" % string
  | I_SOME => "SOME" % string
  | I_SOURCE => "SOURCE" % string
  | I_SENDER => "SENDER" % string
  | I_SELF => "SELF" % string
  | I_SLICE => "SLICE" % string
  | I_STEPS_TO_QUOTA => "STEPS_TO_QUOTA" % string
  | I_SUB => "SUB" % string
  | I_SWAP => "SWAP" % string
  | I_TRANSFER_TOKENS => "TRANSFER_TOKENS" % string
  | I_SET_DELEGATE => "SET_DELEGATE" % string
  | I_UNIT => "UNIT" % string
  | I_UPDATE => "UPDATE" % string
  | I_XOR => "XOR" % string
  | I_ITER => "ITER" % string
  | I_LOOP_LEFT => "LOOP_LEFT" % string
  | I_ADDRESS => "ADDRESS" % string
  | I_CONTRACT => "CONTRACT" % string
  | I_ISNAT => "ISNAT" % string
  | I_CAST => "CAST" % string
  | I_RENAME => "RENAME" % string
  | I_DIG => "DIG" % string
  | I_DUG => "DUG" % string
  | T_bool => "bool" % string
  | T_contract => "contract" % string
  | T_int => "int" % string
  | T_key => "key" % string
  | T_key_hash => "key_hash" % string
  | T_lambda => "lambda" % string
  | T_list => "list" % string
  | T_map => "map" % string
  | T_big_map => "big_map" % string
  | T_nat => "nat" % string
  | T_option => "option" % string
  | T_or => "or" % string
  | T_pair => "pair" % string
  | T_set => "set" % string
  | T_signature => "signature" % string
  | T_string => "string" % string
  | T_bytes => "bytes" % string
  | T_mutez => "mutez" % string
  | T_timestamp => "timestamp" % string
  | T_unit => "unit" % string
  | T_operation => "operation" % string
  | T_address => "address" % string
  | T_chain_id => "chain_id" % string
  end.

Definition prim_of_string (function_parameter : string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult prim :=
  match function_parameter with
  | "parameter" % string => ok K_parameter
  | "storage" % string => ok K_storage
  | "code" % string => ok K_code
  | "False" % string => ok D_False
  | "Elt" % string => ok D_Elt
  | "Left" % string => ok D_Left
  | "None" % string => ok D_None
  | "Pair" % string => ok D_Pair
  | "Right" % string => ok D_Right
  | "Some" % string => ok D_Some
  | "True" % string => ok D_True
  | "Unit" % string => ok D_Unit
  | "PACK" % string => ok I_PACK
  | "UNPACK" % string => ok I_UNPACK
  | "BLAKE2B" % string => ok I_BLAKE2B
  | "SHA256" % string => ok I_SHA256
  | "SHA512" % string => ok I_SHA512
  | "ABS" % string => ok I_ABS
  | "ADD" % string => ok I_ADD
  | "AMOUNT" % string => ok I_AMOUNT
  | "AND" % string => ok I_AND
  | "BALANCE" % string => ok I_BALANCE
  | "CAR" % string => ok I_CAR
  | "CDR" % string => ok I_CDR
  | "CHAIN_ID" % string => ok I_CHAIN_ID
  | "CHECK_SIGNATURE" % string => ok I_CHECK_SIGNATURE
  | "COMPARE" % string => ok I_COMPARE
  | "CONCAT" % string => ok I_CONCAT
  | "CONS" % string => ok I_CONS
  | "CREATE_ACCOUNT" % string => ok I_CREATE_ACCOUNT
  | "CREATE_CONTRACT" % string => ok I_CREATE_CONTRACT
  | "IMPLICIT_ACCOUNT" % string => ok I_IMPLICIT_ACCOUNT
  | "DIP" % string => ok I_DIP
  | "DROP" % string => ok I_DROP
  | "DUP" % string => ok I_DUP
  | "EDIV" % string => ok I_EDIV
  | "EMPTY_BIG_MAP" % string => ok I_EMPTY_BIG_MAP
  | "EMPTY_MAP" % string => ok I_EMPTY_MAP
  | "EMPTY_SET" % string => ok I_EMPTY_SET
  | "EQ" % string => ok I_EQ
  | "EXEC" % string => ok I_EXEC
  | "APPLY" % string => ok I_APPLY
  | "FAILWITH" % string => ok I_FAILWITH
  | "GE" % string => ok I_GE
  | "GET" % string => ok I_GET
  | "GT" % string => ok I_GT
  | "HASH_KEY" % string => ok I_HASH_KEY
  | "IF" % string => ok I_IF
  | "IF_CONS" % string => ok I_IF_CONS
  | "IF_LEFT" % string => ok I_IF_LEFT
  | "IF_NONE" % string => ok I_IF_NONE
  | "INT" % string => ok I_INT
  | "LAMBDA" % string => ok I_LAMBDA
  | "LE" % string => ok I_LE
  | "LEFT" % string => ok I_LEFT
  | "LOOP" % string => ok I_LOOP
  | "LSL" % string => ok I_LSL
  | "LSR" % string => ok I_LSR
  | "LT" % string => ok I_LT
  | "MAP" % string => ok I_MAP
  | "MEM" % string => ok I_MEM
  | "MUL" % string => ok I_MUL
  | "NEG" % string => ok I_NEG
  | "NEQ" % string => ok I_NEQ
  | "NIL" % string => ok I_NIL
  | "NONE" % string => ok I_NONE
  | "NOT" % string => ok I_NOT
  | "NOW" % string => ok I_NOW
  | "OR" % string => ok I_OR
  | "PAIR" % string => ok I_PAIR
  | "PUSH" % string => ok I_PUSH
  | "RIGHT" % string => ok I_RIGHT
  | "SIZE" % string => ok I_SIZE
  | "SOME" % string => ok I_SOME
  | "SOURCE" % string => ok I_SOURCE
  | "SENDER" % string => ok I_SENDER
  | "SELF" % string => ok I_SELF
  | "SLICE" % string => ok I_SLICE
  | "STEPS_TO_QUOTA" % string => ok I_STEPS_TO_QUOTA
  | "SUB" % string => ok I_SUB
  | "SWAP" % string => ok I_SWAP
  | "TRANSFER_TOKENS" % string => ok I_TRANSFER_TOKENS
  | "SET_DELEGATE" % string => ok I_SET_DELEGATE
  | "UNIT" % string => ok I_UNIT
  | "UPDATE" % string => ok I_UPDATE
  | "XOR" % string => ok I_XOR
  | "ITER" % string => ok I_ITER
  | "LOOP_LEFT" % string => ok I_LOOP_LEFT
  | "ADDRESS" % string => ok I_ADDRESS
  | "CONTRACT" % string => ok I_CONTRACT
  | "ISNAT" % string => ok I_ISNAT
  | "CAST" % string => ok I_CAST
  | "RENAME" % string => ok I_RENAME
  | "DIG" % string => ok I_DIG
  | "DUG" % string => ok I_DUG
  | "bool" % string => ok T_bool
  | "contract" % string => ok T_contract
  | "int" % string => ok T_int
  | "key" % string => ok T_key
  | "key_hash" % string => ok T_key_hash
  | "lambda" % string => ok T_lambda
  | "list" % string => ok T_list
  | "map" % string => ok T_map
  | "big_map" % string => ok T_big_map
  | "nat" % string => ok T_nat
  | "option" % string => ok T_option
  | "or" % string => ok T_or
  | "pair" % string => ok T_pair
  | "set" % string => ok T_set
  | "signature" % string => ok T_signature
  | "string" % string => ok T_string
  | "bytes" % string => ok T_bytes
  | "mutez" % string => ok T_mutez
  | "timestamp" % string => ok T_timestamp
  | "unit" % string => ok T_unit
  | "operation" % string => ok T_operation
  | "address" % string => ok T_address
  | "chain_id" % string => ok T_chain_id
  | n =>
    if valid_case n then
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unknown_primitive_name
          n)
    else
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_case
          n)
  end.

Definition prims_of_strings
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim) :=
  let fix convert
    (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location
      string)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Micheline.node
        Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location
        prim) :=
    match function_parameter with
    |
      (Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
        Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
        Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as
        expr => ok expr
    |
      Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
        annot =>
      op_gtgtquestion
        (Error_monad.record_trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive_name
            expr loc) (prim_of_string prim))
        (fun prim =>
          op_gtgtquestion
            (List.fold_left
              (fun acc =>
                fun arg =>
                  op_gtgtquestion acc
                    (fun args =>
                      op_gtgtquestion (convert arg)
                        (fun arg => ok (cons arg args)))) (ok []) args)
            (fun args =>
              ok
                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                  prim (List.rev args) annot)))
    | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ args =>
      op_gtgtquestion
        (List.fold_left
          (fun acc =>
            fun arg =>
              op_gtgtquestion acc
                (fun args =>
                  op_gtgtquestion (convert arg) (fun arg => ok (cons arg args))))
          (ok []) args)
        (fun args =>
          ok
            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0
              (List.rev args)))
    end in
  op_gtgtquestion (convert (root expr)) (fun expr => ok (strip_locations expr)).

Definition strings_of_prims
  (expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical prim)
  : Tezos_protocol_environment_alpha__Environment.Micheline.canonical string :=
  let fix convert
    (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node Z prim)
    : Tezos_protocol_environment_alpha__Environment.Micheline.node Z string :=
    match function_parameter with
    |
      (Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
        Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
        Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as
        expr => expr
    |
      Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ prim args
        annot =>
      let prim := string_of_prim prim in
      let args := List.map convert args in
      Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0 prim args
        annot
    | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ args =>
      let args := List.map convert args in
      Tezos_protocol_environment_alpha__Environment.Micheline.Seq 0 args
    end in
  strip_locations (convert (root expr)).

Definition prim_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding prim :=
  op_atat
    (let arg := def "michelson.v1.primitives" % string in
    fun eta => arg None None eta)
    (string_enum
      (cons ("parameter" % string, K_parameter)
        (cons ("storage" % string, K_storage)
          (cons ("code" % string, K_code)
            (cons ("False" % string, D_False)
              (cons ("Elt" % string, D_Elt)
                (cons ("Left" % string, D_Left)
                  (cons ("None" % string, D_None)
                    (cons ("Pair" % string, D_Pair)
                      (cons ("Right" % string, D_Right)
                        (cons ("Some" % string, D_Some)
                          (cons ("True" % string, D_True)
                            (cons ("Unit" % string, D_Unit)
                              (cons ("PACK" % string, I_PACK)
                                (cons ("UNPACK" % string, I_UNPACK)
                                  (cons ("BLAKE2B" % string, I_BLAKE2B)
                                    (cons ("SHA256" % string, I_SHA256)
                                      (cons ("SHA512" % string, I_SHA512)
                                        (cons ("ABS" % string, I_ABS)
                                          (cons ("ADD" % string, I_ADD)
                                            (cons ("AMOUNT" % string, I_AMOUNT)
                                              (cons ("AND" % string, I_AND)
                                                (cons
                                                  ("BALANCE" % string, I_BALANCE)
                                                  (cons ("CAR" % string, I_CAR)
                                                    (cons
                                                      ("CDR" % string, I_CDR)
                                                      (cons
                                                        ("CHECK_SIGNATURE" %
                                                          string,
                                                          I_CHECK_SIGNATURE)
                                                        (cons
                                                          ("COMPARE" % string,
                                                            I_COMPARE)
                                                          (cons
                                                            ("CONCAT" % string,
                                                              I_CONCAT)
                                                            (cons
                                                              ("CONS" % string,
                                                                I_CONS)
                                                              (cons
                                                                ("CREATE_ACCOUNT"
                                                                  % string,
                                                                  I_CREATE_ACCOUNT)
                                                                (cons
                                                                  ("CREATE_CONTRACT"
                                                                    % string,
                                                                    I_CREATE_CONTRACT)
                                                                  (cons
                                                                    ("IMPLICIT_ACCOUNT"
                                                                      % string,
                                                                      I_IMPLICIT_ACCOUNT)
                                                                    (cons
                                                                      ("DIP" %
                                                                        string,
                                                                        I_DIP)
                                                                      (cons
                                                                        ("DROP"
                                                                          %
                                                                          string,
                                                                          I_DROP)
                                                                        (cons
                                                                          ("DUP"
                                                                            %
                                                                            string,
                                                                            I_DUP)
                                                                          (cons
                                                                            ("EDIV"
                                                                              %
                                                                              string,
                                                                              I_EDIV)
                                                                            (cons
                                                                              ("EMPTY_MAP"
                                                                                %
                                                                                string,
                                                                                I_EMPTY_MAP)
                                                                              (cons
                                                                                ("EMPTY_SET"
                                                                                  %
                                                                                  string,
                                                                                  I_EMPTY_SET)
                                                                                (cons
                                                                                  ("EQ"
                                                                                    %
                                                                                    string,
                                                                                    I_EQ)
                                                                                  (cons
                                                                                    ("EXEC"
                                                                                      %
                                                                                      string,
                                                                                      I_EXEC)
                                                                                    (cons
                                                                                      ("FAILWITH"
                                                                                        %
                                                                                        string,
                                                                                        I_FAILWITH)
                                                                                      (cons
                                                                                        ("GE"
                                                                                          %
                                                                                          string,
                                                                                          I_GE)
                                                                                        (cons
                                                                                          ("GET"
                                                                                            %
                                                                                            string,
                                                                                            I_GET)
                                                                                          (cons
                                                                                            ("GT"
                                                                                              %
                                                                                              string,
                                                                                              I_GT)
                                                                                            (cons
                                                                                              ("HASH_KEY"
                                                                                                %
                                                                                                string,
                                                                                                I_HASH_KEY)
                                                                                              (cons
                                                                                                ("IF"
                                                                                                  %
                                                                                                  string,
                                                                                                  I_IF)
                                                                                                (cons
                                                                                                  ("IF_CONS"
                                                                                                    %
                                                                                                    string,
                                                                                                    I_IF_CONS)
                                                                                                  (cons
                                                                                                    ("IF_LEFT"
                                                                                                      %
                                                                                                      string,
                                                                                                      I_IF_LEFT)
                                                                                                    (cons
                                                                                                      ("IF_NONE"
                                                                                                        %
                                                                                                        string,
                                                                                                        I_IF_NONE)
                                                                                                      (cons
                                                                                                        ("INT"
                                                                                                          %
                                                                                                          string,
                                                                                                          I_INT)
                                                                                                        (cons
                                                                                                          ("LAMBDA"
                                                                                                            %
                                                                                                            string,
                                                                                                            I_LAMBDA)
                                                                                                          (cons
                                                                                                            ("LE"
                                                                                                              %
                                                                                                              string,
                                                                                                              I_LE)
                                                                                                            (cons
                                                                                                              ("LEFT"
                                                                                                                %
                                                                                                                string,
                                                                                                                I_LEFT)
                                                                                                              (cons
                                                                                                                ("LOOP"
                                                                                                                  %
                                                                                                                  string,
                                                                                                                  I_LOOP)
                                                                                                                (cons
                                                                                                                  ("LSL"
                                                                                                                    %
                                                                                                                    string,
                                                                                                                    I_LSL)
                                                                                                                  (cons
                                                                                                                    ("LSR"
                                                                                                                      %
                                                                                                                      string,
                                                                                                                      I_LSR)
                                                                                                                    (cons
                                                                                                                      ("LT"
                                                                                                                        %
                                                                                                                        string,
                                                                                                                        I_LT)
                                                                                                                      (cons
                                                                                                                        ("MAP"
                                                                                                                          %
                                                                                                                          string,
                                                                                                                          I_MAP)
                                                                                                                        (cons
                                                                                                                          ("MEM"
                                                                                                                            %
                                                                                                                            string,
                                                                                                                            I_MEM)
                                                                                                                          (cons
                                                                                                                            ("MUL"
                                                                                                                              %
                                                                                                                              string,
                                                                                                                              I_MUL)
                                                                                                                            (cons
                                                                                                                              ("NEG"
                                                                                                                                %
                                                                                                                                string,
                                                                                                                                I_NEG)
                                                                                                                              (cons
                                                                                                                                ("NEQ"
                                                                                                                                  %
                                                                                                                                  string,
                                                                                                                                  I_NEQ)
                                                                                                                                (cons
                                                                                                                                  ("NIL"
                                                                                                                                    %
                                                                                                                                    string,
                                                                                                                                    I_NIL)
                                                                                                                                  (cons
                                                                                                                                    ("NONE"
                                                                                                                                      %
                                                                                                                                      string,
                                                                                                                                      I_NONE)
                                                                                                                                    (cons
                                                                                                                                      ("NOT"
                                                                                                                                        %
                                                                                                                                        string,
                                                                                                                                        I_NOT)
                                                                                                                                      (cons
                                                                                                                                        ("NOW"
                                                                                                                                          %
                                                                                                                                          string,
                                                                                                                                          I_NOW)
                                                                                                                                        (cons
                                                                                                                                          ("OR"
                                                                                                                                            %
                                                                                                                                            string,
                                                                                                                                            I_OR)
                                                                                                                                          (cons
                                                                                                                                            ("PAIR"
                                                                                                                                              %
                                                                                                                                              string,
                                                                                                                                              I_PAIR)
                                                                                                                                            (cons
                                                                                                                                              ("PUSH"
                                                                                                                                                %
                                                                                                                                                string,
                                                                                                                                                I_PUSH)
                                                                                                                                              (cons
                                                                                                                                                ("RIGHT"
                                                                                                                                                  %
                                                                                                                                                  string,
                                                                                                                                                  I_RIGHT)
                                                                                                                                                (cons
                                                                                                                                                  ("SIZE"
                                                                                                                                                    %
                                                                                                                                                    string,
                                                                                                                                                    I_SIZE)
                                                                                                                                                  (cons
                                                                                                                                                    ("SOME"
                                                                                                                                                      %
                                                                                                                                                      string,
                                                                                                                                                      I_SOME)
                                                                                                                                                    (cons
                                                                                                                                                      ("SOURCE"
                                                                                                                                                        %
                                                                                                                                                        string,
                                                                                                                                                        I_SOURCE)
                                                                                                                                                      (cons
                                                                                                                                                        ("SENDER"
                                                                                                                                                          %
                                                                                                                                                          string,
                                                                                                                                                          I_SENDER)
                                                                                                                                                        (cons
                                                                                                                                                          ("SELF"
                                                                                                                                                            %
                                                                                                                                                            string,
                                                                                                                                                            I_SELF)
                                                                                                                                                          (cons
                                                                                                                                                            ("STEPS_TO_QUOTA"
                                                                                                                                                              %
                                                                                                                                                              string,
                                                                                                                                                              I_STEPS_TO_QUOTA)
                                                                                                                                                            (cons
                                                                                                                                                              ("SUB"
                                                                                                                                                                %
                                                                                                                                                                string,
                                                                                                                                                                I_SUB)
                                                                                                                                                              (cons
                                                                                                                                                                ("SWAP"
                                                                                                                                                                  %
                                                                                                                                                                  string,
                                                                                                                                                                  I_SWAP)
                                                                                                                                                                (cons
                                                                                                                                                                  ("TRANSFER_TOKENS"
                                                                                                                                                                    %
                                                                                                                                                                    string,
                                                                                                                                                                    I_TRANSFER_TOKENS)
                                                                                                                                                                  (cons
                                                                                                                                                                    ("SET_DELEGATE"
                                                                                                                                                                      %
                                                                                                                                                                      string,
                                                                                                                                                                      I_SET_DELEGATE)
                                                                                                                                                                    (cons
                                                                                                                                                                      ("UNIT"
                                                                                                                                                                        %
                                                                                                                                                                        string,
                                                                                                                                                                        I_UNIT)
                                                                                                                                                                      (cons
                                                                                                                                                                        ("UPDATE"
                                                                                                                                                                          %
                                                                                                                                                                          string,
                                                                                                                                                                          I_UPDATE)
                                                                                                                                                                        (cons
                                                                                                                                                                          ("XOR"
                                                                                                                                                                            %
                                                                                                                                                                            string,
                                                                                                                                                                            I_XOR)
                                                                                                                                                                          (cons
                                                                                                                                                                            ("ITER"
                                                                                                                                                                              %
                                                                                                                                                                              string,
                                                                                                                                                                              I_ITER)
                                                                                                                                                                            (cons
                                                                                                                                                                              ("LOOP_LEFT"
                                                                                                                                                                                %
                                                                                                                                                                                string,
                                                                                                                                                                                I_LOOP_LEFT)
                                                                                                                                                                              (cons
                                                                                                                                                                                ("ADDRESS"
                                                                                                                                                                                  %
                                                                                                                                                                                  string,
                                                                                                                                                                                  I_ADDRESS)
                                                                                                                                                                                (cons
                                                                                                                                                                                  ("CONTRACT"
                                                                                                                                                                                    %
                                                                                                                                                                                    string,
                                                                                                                                                                                    I_CONTRACT)
                                                                                                                                                                                  (cons
                                                                                                                                                                                    ("ISNAT"
                                                                                                                                                                                      %
                                                                                                                                                                                      string,
                                                                                                                                                                                      I_ISNAT)
                                                                                                                                                                                    (cons
                                                                                                                                                                                      ("CAST"
                                                                                                                                                                                        %
                                                                                                                                                                                        string,
                                                                                                                                                                                        I_CAST)
                                                                                                                                                                                      (cons
                                                                                                                                                                                        ("RENAME"
                                                                                                                                                                                          %
                                                                                                                                                                                          string,
                                                                                                                                                                                          I_RENAME)
                                                                                                                                                                                        (cons
                                                                                                                                                                                          ("bool"
                                                                                                                                                                                            %
                                                                                                                                                                                            string,
                                                                                                                                                                                            T_bool)
                                                                                                                                                                                          (cons
                                                                                                                                                                                            ("contract"
                                                                                                                                                                                              %
                                                                                                                                                                                              string,
                                                                                                                                                                                              T_contract)
                                                                                                                                                                                            (cons
                                                                                                                                                                                              ("int"
                                                                                                                                                                                                %
                                                                                                                                                                                                string,
                                                                                                                                                                                                T_int)
                                                                                                                                                                                              (cons
                                                                                                                                                                                                ("key"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string,
                                                                                                                                                                                                  T_key)
                                                                                                                                                                                                (cons
                                                                                                                                                                                                  ("key_hash"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string,
                                                                                                                                                                                                    T_key_hash)
                                                                                                                                                                                                  (cons
                                                                                                                                                                                                    ("lambda"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      string,
                                                                                                                                                                                                      T_lambda)
                                                                                                                                                                                                    (cons
                                                                                                                                                                                                      ("list"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        string,
                                                                                                                                                                                                        T_list)
                                                                                                                                                                                                      (cons
                                                                                                                                                                                                        ("map"
                                                                                                                                                                                                          %
                                                                                                                                                                                                          string,
                                                                                                                                                                                                          T_map)
                                                                                                                                                                                                        (cons
                                                                                                                                                                                                          ("big_map"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            string,
                                                                                                                                                                                                            T_big_map)
                                                                                                                                                                                                          (cons
                                                                                                                                                                                                            ("nat"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              string,
                                                                                                                                                                                                              T_nat)
                                                                                                                                                                                                            (cons
                                                                                                                                                                                                              ("option"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                string,
                                                                                                                                                                                                                T_option)
                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                ("or"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  string,
                                                                                                                                                                                                                  T_or)
                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                  ("pair"
                                                                                                                                                                                                                    %
                                                                                                                                                                                                                    string,
                                                                                                                                                                                                                    T_pair)
                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                    ("set"
                                                                                                                                                                                                                      %
                                                                                                                                                                                                                      string,
                                                                                                                                                                                                                      T_set)
                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                      ("signature"
                                                                                                                                                                                                                        %
                                                                                                                                                                                                                        string,
                                                                                                                                                                                                                        T_signature)
                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                        ("string"
                                                                                                                                                                                                                          %
                                                                                                                                                                                                                          string,
                                                                                                                                                                                                                          T_string)
                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                          ("bytes"
                                                                                                                                                                                                                            %
                                                                                                                                                                                                                            string,
                                                                                                                                                                                                                            T_bytes)
                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                            ("mutez"
                                                                                                                                                                                                                              %
                                                                                                                                                                                                                              string,
                                                                                                                                                                                                                              T_mutez)
                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                              ("timestamp"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string,
                                                                                                                                                                                                                                T_timestamp)
                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                ("unit"
                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                  string,
                                                                                                                                                                                                                                  T_unit)
                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                  ("operation"
                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                    string,
                                                                                                                                                                                                                                    T_operation)
                                                                                                                                                                                                                                  (cons
                                                                                                                                                                                                                                    ("address"
                                                                                                                                                                                                                                      %
                                                                                                                                                                                                                                      string,
                                                                                                                                                                                                                                      T_address)
                                                                                                                                                                                                                                    (cons
                                                                                                                                                                                                                                      ("SLICE"
                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                        string,
                                                                                                                                                                                                                                        I_SLICE)
                                                                                                                                                                                                                                      (cons
                                                                                                                                                                                                                                        ("DIG"
                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                          string,
                                                                                                                                                                                                                                          I_DIG)
                                                                                                                                                                                                                                        (cons
                                                                                                                                                                                                                                          ("DUG"
                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                            string,
                                                                                                                                                                                                                                            I_DUG)
                                                                                                                                                                                                                                          (cons
                                                                                                                                                                                                                                            ("EMPTY_BIG_MAP"
                                                                                                                                                                                                                                              %
                                                                                                                                                                                                                                              string,
                                                                                                                                                                                                                                              I_EMPTY_BIG_MAP)
                                                                                                                                                                                                                                            (cons
                                                                                                                                                                                                                                              ("APPLY"
                                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                                string,
                                                                                                                                                                                                                                                I_APPLY)
                                                                                                                                                                                                                                              (cons
                                                                                                                                                                                                                                                ("chain_id"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string,
                                                                                                                                                                                                                                                  T_chain_id)
                                                                                                                                                                                                                                                (cons
                                                                                                                                                                                                                                                  ("CHAIN_ID"
                                                                                                                                                                                                                                                    %
                                                                                                                                                                                                                                                    string,
                                                                                                                                                                                                                                                    I_CHAIN_ID)
                                                                                                                                                                                                                                                  []))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).



src/proto_alpha/lib_protocol/misc.ml 32 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type 'a lazyt = unit -> 'a

type 'a lazy_list_t = LCons of 'a * 'a lazy_list_t tzresult Lwt.t lazyt

type 'a lazy_list = 'a lazy_list_t tzresult Lwt.t

let rec ( --> ) i j =
  (* [i; i+1; ...; j] *)
  if Compare.Int.(i > j) then [] else i :: (succ i --> j)

let rec ( ---> ) i j =
  (* [i; i+1; ...; j] *)
  if Compare.Int32.(i > j) then [] else i :: (Int32.succ i ---> j)

let split delim ?(limit = max_int) path =
  let l = String.length path in
  let rec do_slashes acc limit i =
    if Compare.Int.(i >= l) then List.rev acc
    else if Compare.Char.(path.[i] = delim) then do_slashes acc limit (i + 1)
    else do_split acc limit i
  and do_split acc limit i =
    if Compare.Int.(limit <= 0) then
      if Compare.Int.(i = l) then List.rev acc
      else List.rev (String.sub path i (l - i) :: acc)
    else do_component acc (pred limit) i i
  and do_component acc limit i j =
    if Compare.Int.(j >= l) then
      if Compare.Int.(i = j) then List.rev acc
      else List.rev (String.sub path i (j - i) :: acc)
    else if Compare.Char.(path.[j] = delim) then
      do_slashes (String.sub path i (j - i) :: acc) limit j
    else do_component acc limit i (j + 1)
  in
  if Compare.Int.(limit > 0) then do_slashes [] limit 0 else [path]

let pp_print_paragraph ppf description =
  Format.fprintf
    ppf
    "@[%a@]"
    Format.(pp_print_list ~pp_sep:pp_print_space pp_print_string)
    (split ' ' description)

let take n l =
  let rec loop acc n = function
    | xs when Compare.Int.(n <= 0) ->
        Some (List.rev acc, xs)
    | [] ->
        None
    | x :: xs ->
        loop (x :: acc) (n - 1) xs
  in
  loop [] n l

let remove_prefix ~prefix s =
  let x = String.length prefix in
  let n = String.length s in
  if Compare.Int.(n >= x) && Compare.String.(String.sub s 0 x = prefix) then
    Some (String.sub s x (n - x))
  else None

let rec remove_elem_from_list nb = function
  | [] ->
      []
  | l when Compare.Int.(nb <= 0) ->
      l
  | _ :: tl ->
      remove_elem_from_list (nb - 1) tl
src/proto_alpha/lib_protocol/misc.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition lazyt (a : Type) := unit -> a.

Inductive lazy_list_t (a : Type) : Type :=
| LCons : a ->
  (lazyt
    (Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (lazy_list_t a)))) -> lazy_list_t a.

Arguments LCons {_}.

Definition lazy_list (a : Type) :=
  Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (lazy_list_t a)).

Fixpoint op_minusminusgt
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (j :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : list
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      i j then
    []
  else
    cons i (op_minusminusgt (succ i) j).

Fixpoint op_minusminusminusgt
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (j :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : list
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      i j then
    []
  else
    cons i (op_minusminusminusgt (Int32.succ i) j).

Definition split
  (delim :
    Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (op_staroptstar :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : string -> list string :=
  let limit :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => max_int
    end in
  fun path =>
    let l := String.length path in
    let fix do_slashes
      (acc : list string) (limit :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (i :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list string :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
          i l then
        List.rev acc
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.get path i) delim then
          do_slashes acc limit (op_plus i 1)
        else
          do_split acc limit i
    with do_split
      (acc : list string) (limit :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (i :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list string :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
          limit 0 then
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            i l then
          List.rev acc
        else
          List.rev (cons (String.sub path i (op_minus l i)) acc)
      else
        do_component acc (pred limit) i i
    with do_component
      (acc : list string) (limit :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (i :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      (j :
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : list string :=
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
          j l then
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            i j then
          List.rev acc
        else
          List.rev (cons (String.sub path i (op_minus j i)) acc)
      else
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (String.get path j) delim then
          do_slashes (cons (String.sub path i (op_minus j i)) acc) limit j
        else
          do_component acc limit i (op_plus j 1) in
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        limit 0 then
      do_slashes [] limit 0
    else
      cons path [].

Definition pp_print_paragraph
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (description : string) : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format
            "" % string))
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
      "@[%a@]" % string) (pp_print_list (Some pp_print_space) pp_print_string)
    (split " " % char None description).

Definition take {A : Type}
  (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (l : list A) : option ((list A) * (list A)) :=
  let fix loop {B : Type}
    (acc : list B) (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    (function_parameter : list B) : option ((list B) * (list B)) :=
    match function_parameter with
    | xs => Some ((List.rev acc), xs)
    | [] => None
    | cons x xs => loop (cons x acc) (op_minus n 1) xs
    end in
  loop [] n l.

Definition remove_prefix
  (prefix :
    Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (s : string) : option string :=
  let x := String.length prefix in
  let n := String.length s in
  if
    op_andand
      (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
        n x)
      (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        (String.sub s 0 x) prefix) then
    Some (String.sub s x (op_minus n x))
  else
    None.

Fixpoint remove_elem_from_list {A : Type}
  (nb :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (function_parameter : list A) : list A :=
  match function_parameter with
  | [] => []
  | l => l
  | cons _ tl => remove_elem_from_list (op_minus nb 1) tl
  end.

src/proto_alpha/lib_protocol/nonce_hash.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* 32 *)
let nonce_hash = "\069\220\169" (* nce(53) *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "cycle_nonce"

            let title = "A nonce hash"

            let b58check_prefix = nonce_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "nce" 53
src/proto_alpha/lib_protocol/nonce_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition nonce_hash : string := "Eܩ" % string.

(* ❌ Structure item `include` not handled. *)
include



src/proto_alpha/lib_protocol/nonce_storage.ml 13 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Seed_repr.nonce

type nonce = t

let encoding = Seed_repr.nonce_encoding

type error +=
  | Too_late_revelation
  | Too_early_revelation
  | Previously_revealed_nonce
  | Unexpected_nonce

let () =
  register_error_kind
    `Branch
    ~id:"nonce.too_late_revelation"
    ~title:"Too late nonce revelation"
    ~description:"Nonce revelation happens too late"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "This nonce cannot be revealed anymore.")
    Data_encoding.unit
    (function Too_late_revelation -> Some () | _ -> None)
    (fun () -> Too_late_revelation) ;
  register_error_kind
    `Temporary
    ~id:"nonce.too_early_revelation"
    ~title:"Too early nonce revelation"
    ~description:"Nonce revelation happens before cycle end"
    ~pp:(fun ppf () ->
      Format.fprintf ppf "This nonce should not yet be revealed")
    Data_encoding.unit
    (function Too_early_revelation -> Some () | _ -> None)
    (fun () -> Too_early_revelation) ;
  register_error_kind
    `Branch
    ~id:"nonce.previously_revealed"
    ~title:"Previously revealed nonce"
    ~description:"Duplicated revelation for a nonce."
    ~pp:(fun ppf () -> Format.fprintf ppf "This nonce was previously revealed")
    Data_encoding.unit
    (function Previously_revealed_nonce -> Some () | _ -> None)
    (fun () -> Previously_revealed_nonce) ;
  register_error_kind
    `Branch
    ~id:"nonce.unexpected"
    ~title:"Unexpected nonce"
    ~description:
      "The provided nonce is inconsistent with the committed nonce hash."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "This nonce revelation is invalid (inconsistent with the committed \
         hash)")
    Data_encoding.unit
    (function Unexpected_nonce -> Some () | _ -> None)
    (fun () -> Unexpected_nonce)

(* checks that the level of a revelation is not too early or too late wrt to the
   current context and that a nonce has not been already revealed for that level *)
let get_unrevealed ctxt level =
  let cur_level = Level_storage.current ctxt in
  match Cycle_repr.pred cur_level.cycle with
  | None ->
      fail Too_early_revelation (* no revelations during cycle 0 *)
  | Some revealed_cycle -> (
      if Cycle_repr.(revealed_cycle < level.Level_repr.cycle) then
        fail Too_early_revelation
      else if Cycle_repr.(level.Level_repr.cycle < revealed_cycle) then
        fail Too_late_revelation
      else
        Storage.Seed.Nonce.get ctxt level
        >>=? function
        | Revealed _ ->
            fail Previously_revealed_nonce
        | Unrevealed status ->
            return status )

let record_hash ctxt unrevealed =
  let level = Level_storage.current ctxt in
  Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed)

let reveal ctxt level nonce =
  get_unrevealed ctxt level
  >>=? fun unrevealed ->
  fail_unless
    (Seed_repr.check_hash nonce unrevealed.nonce_hash)
    Unexpected_nonce
  >>=? fun () ->
  Storage.Seed.Nonce.set ctxt level (Revealed nonce)
  >>=? fun ctxt -> return ctxt

type unrevealed = Storage.Seed.unrevealed_nonce = {
  nonce_hash : Nonce_hash.t;
  delegate : Signature.Public_key_hash.t;
  rewards : Tez_repr.t;
  fees : Tez_repr.t;
}

type status = Storage.Seed.nonce_status =
  | Unrevealed of unrevealed
  | Revealed of Seed_repr.nonce

let get = Storage.Seed.Nonce.get

let of_bytes = Seed_repr.make_nonce

let hash = Seed_repr.hash

let check_hash = Seed_repr.check_hash
src/proto_alpha/lib_protocol/nonce_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_raw_protocol_alpha.Seed_repr.nonce.

Definition nonce := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_raw_protocol_alpha.Seed_repr.nonce := Seed_repr.nonce_encoding.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition get_unrevealed
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce) :=
  let cur_level := Level_storage.current ctxt in
  match Cycle_repr.pred (cycle cur_level) with
  | None =>
    fail
      Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_revelation
  | Some revealed_cycle =>
    if op_lt revealed_cycle (Level_repr.cycle level) then
      fail
        Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_revelation
    else
      if op_lt (Level_repr.cycle level) revealed_cycle then
        fail
          Tezos_protocol_environment_alpha__Environment.Error_monad.Too_late_revelation
      else
        op_gtgteqquestion (Storage.Seed.Nonce.get ctxt level)
          (fun function_parameter =>
            match function_parameter with
            | Tezos_raw_protocol_alpha__Storage.Seed.Revealed _ =>
              fail
                Tezos_protocol_environment_alpha__Environment.Error_monad.Previously_revealed_nonce
            | Tezos_raw_protocol_alpha__Storage.Seed.Unrevealed status =>
              _return status
            end)
  end.

Definition record_hash
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (unrevealed : Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let level := Level_storage.current ctxt in
  Storage.Seed.Nonce.init ctxt level
    (Tezos_raw_protocol_alpha__Storage.Seed.Unrevealed unrevealed).

Definition reveal
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t)
  (nonce : Tezos_raw_protocol_alpha.Seed_repr.nonce)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (get_unrevealed ctxt level)
    (fun unrevealed =>
      op_gtgteqquestion
        (fail_unless (Seed_repr.check_hash nonce (nonce_hash unrevealed))
          Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_nonce)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (Storage.Seed.Nonce.set ctxt level
              (Tezos_raw_protocol_alpha__Storage.Seed.Revealed nonce))
            (fun ctxt => _return ctxt))).

Record unrevealed := {
  nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
  delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
  fees : Tezos_raw_protocol_alpha.Tez_repr.t }.

Inductive status : Type :=
| Unrevealed : unrevealed -> status
| Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> status.

Definition get
  : Tezos_raw_protocol_alpha.Storage.Seed.Nonce.context ->
    Tezos_raw_protocol_alpha.Level_repr.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha__Storage.Seed.nonce_status) :=
  Storage.Seed.Nonce.get.

Definition of_bytes
  : Tezos_protocol_environment_alpha__Environment.MBytes.t ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Seed_repr.nonce := Seed_repr.make_nonce.

Definition hash
  : Tezos_raw_protocol_alpha.Seed_repr.nonce ->
    Tezos_raw_protocol_alpha.Nonce_hash.t := Seed_repr.hash.

Definition check_hash
  : Tezos_raw_protocol_alpha.Seed_repr.nonce ->
    Tezos_raw_protocol_alpha.Nonce_hash.t -> bool := Seed_repr.check_hash.

src/proto_alpha/lib_protocol/operation_repr.ml 36 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Low level Repr. of Operations *)

module Kind = struct
  type seed_nonce_revelation = Seed_nonce_revelation_kind

  type double_endorsement_evidence = Double_endorsement_evidence_kind

  type double_baking_evidence = Double_baking_evidence_kind

  type activate_account = Activate_account_kind

  type endorsement = Endorsement_kind

  type proposals = Proposals_kind

  type ballot = Ballot_kind

  type reveal = Reveal_kind

  type transaction = Transaction_kind

  type origination = Origination_kind

  type delegation = Delegation_kind

  type 'a manager =
    | Reveal_manager_kind : reveal manager
    | Transaction_manager_kind : transaction manager
    | Origination_manager_kind : origination manager
    | Delegation_manager_kind : delegation manager
end

type raw = Operation.t = {shell : Operation.shell_header; proto : MBytes.t}

let raw_encoding = Operation.encoding

type 'kind operation = {
  shell : Operation.shell_header;
  protocol_data : 'kind protocol_data;
}

and 'kind protocol_data = {
  contents : 'kind contents_list;
  signature : Signature.t option;
}

and _ contents_list =
  | Single : 'kind contents -> 'kind contents_list
  | Cons :
      'kind Kind.manager contents * 'rest Kind.manager contents_list
      -> ('kind * 'rest) Kind.manager contents_list

and _ contents =
  | Endorsement : {level : Raw_level_repr.t} -> Kind.endorsement contents
  | Seed_nonce_revelation : {
      level : Raw_level_repr.t;
      nonce : Seed_repr.nonce;
    }
      -> Kind.seed_nonce_revelation contents
  | Double_endorsement_evidence : {
      op1 : Kind.endorsement operation;
      op2 : Kind.endorsement operation;
    }
      -> Kind.double_endorsement_evidence contents
  | Double_baking_evidence : {
      bh1 : Block_header_repr.t;
      bh2 : Block_header_repr.t;
    }
      -> Kind.double_baking_evidence contents
  | Activate_account : {
      id : Ed25519.Public_key_hash.t;
      activation_code : Blinded_public_key_hash.activation_code;
    }
      -> Kind.activate_account contents
  | Proposals : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposals : Protocol_hash.t list;
    }
      -> Kind.proposals contents
  | Ballot : {
      source : Signature.Public_key_hash.t;
      period : Voting_period_repr.t;
      proposal : Protocol_hash.t;
      ballot : Vote_repr.ballot;
    }
      -> Kind.ballot contents
  | Manager_operation : {
      source : Signature.public_key_hash;
      fee : Tez_repr.tez;
      counter : counter;
      operation : 'kind manager_operation;
      gas_limit : Z.t;
      storage_limit : Z.t;
    }
      -> 'kind Kind.manager contents

and _ manager_operation =
  | Reveal : Signature.Public_key.t -> Kind.reveal manager_operation
  | Transaction : {
      amount : Tez_repr.tez;
      parameters : Script_repr.lazy_expr;
      entrypoint : string;
      destination : Contract_repr.contract;
    }
      -> Kind.transaction manager_operation
  | Origination : {
      delegate : Signature.Public_key_hash.t option;
      script : Script_repr.t;
      credit : Tez_repr.tez;
      preorigination : Contract_repr.t option;
    }
      -> Kind.origination manager_operation
  | Delegation :
      Signature.Public_key_hash.t option
      -> Kind.delegation manager_operation

and counter = Z.t

let manager_kind : type kind. kind manager_operation -> kind Kind.manager =
  function
  | Reveal _ ->
      Kind.Reveal_manager_kind
  | Transaction _ ->
      Kind.Transaction_manager_kind
  | Origination _ ->
      Kind.Origination_manager_kind
  | Delegation _ ->
      Kind.Delegation_manager_kind

type 'kind internal_operation = {
  source : Contract_repr.contract;
  operation : 'kind manager_operation;
  nonce : int;
}

type packed_manager_operation =
  | Manager : 'kind manager_operation -> packed_manager_operation

type packed_contents = Contents : 'kind contents -> packed_contents

type packed_contents_list =
  | Contents_list : 'kind contents_list -> packed_contents_list

type packed_protocol_data =
  | Operation_data : 'kind protocol_data -> packed_protocol_data

type packed_operation = {
  shell : Operation.shell_header;
  protocol_data : packed_protocol_data;
}

let pack ({shell; protocol_data} : _ operation) : packed_operation =
  {shell; protocol_data = Operation_data protocol_data}

type packed_internal_operation =
  | Internal_operation : 'kind internal_operation -> packed_internal_operation

let rec to_list = function
  | Contents_list (Single o) ->
      [Contents o]
  | Contents_list (Cons (o, os)) ->
      Contents o :: to_list (Contents_list os)

let rec of_list = function
  | [] ->
      assert false
  | [Contents o] ->
      Contents_list (Single o)
  | Contents o :: os -> (
      let (Contents_list os) = of_list os in
      match (o, os) with
      | (Manager_operation _, Single (Manager_operation _)) ->
          Contents_list (Cons (o, os))
      | (Manager_operation _, Cons _) ->
          Contents_list (Cons (o, os))
      | _ ->
          Pervasives.failwith
            "Operation list of length > 1 should only contains manager \
             operations." )

module Encoding = struct
  open Data_encoding

  let case tag name args proj inj =
    let open Data_encoding in
    case
      tag
      ~title:(String.capitalize_ascii name)
      (merge_objs (obj1 (req "kind" (constant name))) args)
      (fun x -> match proj x with None -> None | Some x -> Some ((), x))
      (fun ((), x) -> inj x)

  module Manager_operations = struct
    type 'kind case =
      | MCase : {
          tag : int;
          name : string;
          encoding : 'a Data_encoding.t;
          select : packed_manager_operation -> 'kind manager_operation option;
          proj : 'kind manager_operation -> 'a;
          inj : 'a -> 'kind manager_operation;
        }
          -> 'kind case

    let reveal_case =
      MCase
        {
          tag = 0;
          name = "reveal";
          encoding = obj1 (req "public_key" Signature.Public_key.encoding);
          select = (function Manager (Reveal _ as op) -> Some op | _ -> None);
          proj = (function Reveal pkh -> pkh);
          inj = (fun pkh -> Reveal pkh);
        }

    let entrypoint_encoding =
      def
        ~title:"entrypoint"
        ~description:"Named entrypoint to a Michelson smart contract"
        "entrypoint"
      @@
      let builtin_case tag name =
        Data_encoding.case
          (Tag tag)
          ~title:name
          (constant name)
          (fun n -> if Compare.String.(n = name) then Some () else None)
          (fun () -> name)
      in
      union
        [ builtin_case 0 "default";
          builtin_case 1 "root";
          builtin_case 2 "do";
          builtin_case 3 "set_delegate";
          builtin_case 4 "remove_delegate";
          Data_encoding.case
            (Tag 255)
            ~title:"named"
            (Bounded.string 31)
            (fun s -> Some s)
            (fun s -> s) ]

    let transaction_case =
      MCase
        {
          tag = 1;
          name = "transaction";
          encoding =
            obj3
              (req "amount" Tez_repr.encoding)
              (req "destination" Contract_repr.encoding)
              (opt
                 "parameters"
                 (obj2
                    (req "entrypoint" entrypoint_encoding)
                    (req "value" Script_repr.lazy_expr_encoding)));
          select =
            (function Manager (Transaction _ as op) -> Some op | _ -> None);
          proj =
            (function
            | Transaction {amount; destination; parameters; entrypoint} ->
                let parameters =
                  if
                    Script_repr.is_unit_parameter parameters
                    && Compare.String.(entrypoint = "default")
                  then None
                  else Some (entrypoint, parameters)
                in
                (amount, destination, parameters));
          inj =
            (fun (amount, destination, parameters) ->
              let (entrypoint, parameters) =
                match parameters with
                | None ->
                    ("default", Script_repr.unit_parameter)
                | Some (entrypoint, value) ->
                    (entrypoint, value)
              in
              Transaction {amount; destination; parameters; entrypoint});
        }

    let origination_case =
      MCase
        {
          tag = 2;
          name = "origination";
          encoding =
            obj3
              (req "balance" Tez_repr.encoding)
              (opt "delegate" Signature.Public_key_hash.encoding)
              (req "script" Script_repr.encoding);
          select =
            (function Manager (Origination _ as op) -> Some op | _ -> None);
          proj =
            (function
            | Origination
                { credit;
                  delegate;
                  script;
                  preorigination =
                    _
                    (* the hash is only used internally
                               when originating from smart
                               contracts, don't serialize it *)
                } ->
                (credit, delegate, script));
          inj =
            (fun (credit, delegate, script) ->
              Origination {credit; delegate; script; preorigination = None});
        }

    let delegation_case =
      MCase
        {
          tag = 3;
          name = "delegation";
          encoding = obj1 (opt "delegate" Signature.Public_key_hash.encoding);
          select =
            (function Manager (Delegation _ as op) -> Some op | _ -> None);
          proj = (function Delegation key -> key);
          inj = (fun key -> Delegation key);
        }

    let encoding =
      let make (MCase {tag; name; encoding; select; proj; inj}) =
        case
          (Tag tag)
          name
          encoding
          (fun o ->
            match select o with None -> None | Some o -> Some (proj o))
          (fun x -> Manager (inj x))
      in
      union
        ~tag_size:`Uint8
        [ make reveal_case;
          make transaction_case;
          make origination_case;
          make delegation_case ]
  end

  type 'b case =
    | Case : {
        tag : int;
        name : string;
        encoding : 'a Data_encoding.t;
        select : packed_contents -> 'b contents option;
        proj : 'b contents -> 'a;
        inj : 'a -> 'b contents;
      }
        -> 'b case

  let endorsement_encoding = obj1 (req "level" Raw_level_repr.encoding)

  let endorsement_case =
    Case
      {
        tag = 0;
        name = "endorsement";
        encoding = endorsement_encoding;
        select =
          (function Contents (Endorsement _ as op) -> Some op | _ -> None);
        proj = (fun (Endorsement {level}) -> level);
        inj = (fun level -> Endorsement {level});
      }

  let endorsement_encoding =
    let make (Case {tag; name; encoding; select = _; proj; inj}) =
      case (Tag tag) name encoding (fun o -> Some (proj o)) (fun x -> inj x)
    in
    let to_list : Kind.endorsement contents_list -> _ = function
      | Single o ->
          o
    in
    let of_list : Kind.endorsement contents -> _ = function o -> Single o in
    def "inlined.endorsement"
    @@ conv
         (fun ({shell; protocol_data = {contents; signature}} : _ operation) ->
           (shell, (contents, signature)))
         (fun (shell, (contents, signature)) ->
           ({shell; protocol_data = {contents; signature}} : _ operation))
         (merge_objs
            Operation.shell_header_encoding
            (obj2
               (req
                  "operations"
                  ( conv to_list of_list
                  @@ def "inlined.endorsement.contents"
                  @@ union [make endorsement_case] ))
               (varopt "signature" Signature.encoding)))

  let seed_nonce_revelation_case =
    Case
      {
        tag = 1;
        name = "seed_nonce_revelation";
        encoding =
          obj2
            (req "level" Raw_level_repr.encoding)
            (req "nonce" Seed_repr.nonce_encoding);
        select =
          (function
          | Contents (Seed_nonce_revelation _ as op) -> Some op | _ -> None);
        proj = (fun (Seed_nonce_revelation {level; nonce}) -> (level, nonce));
        inj = (fun (level, nonce) -> Seed_nonce_revelation {level; nonce});
      }

  let double_endorsement_evidence_case : Kind.double_endorsement_evidence case
      =
    Case
      {
        tag = 2;
        name = "double_endorsement_evidence";
        encoding =
          obj2
            (req "op1" (dynamic_size endorsement_encoding))
            (req "op2" (dynamic_size endorsement_encoding));
        select =
          (function
          | Contents (Double_endorsement_evidence _ as op) ->
              Some op
          | _ ->
              None);
        proj = (fun (Double_endorsement_evidence {op1; op2}) -> (op1, op2));
        inj = (fun (op1, op2) -> Double_endorsement_evidence {op1; op2});
      }

  let double_baking_evidence_case =
    Case
      {
        tag = 3;
        name = "double_baking_evidence";
        encoding =
          obj2
            (req "bh1" (dynamic_size Block_header_repr.encoding))
            (req "bh2" (dynamic_size Block_header_repr.encoding));
        select =
          (function
          | Contents (Double_baking_evidence _ as op) -> Some op | _ -> None);
        proj = (fun (Double_baking_evidence {bh1; bh2}) -> (bh1, bh2));
        inj = (fun (bh1, bh2) -> Double_baking_evidence {bh1; bh2});
      }

  let activate_account_case =
    Case
      {
        tag = 4;
        name = "activate_account";
        encoding =
          obj2
            (req "pkh" Ed25519.Public_key_hash.encoding)
            (req "secret" Blinded_public_key_hash.activation_code_encoding);
        select =
          (function
          | Contents (Activate_account _ as op) -> Some op | _ -> None);
        proj =
          (fun (Activate_account {id; activation_code}) ->
            (id, activation_code));
        inj =
          (fun (id, activation_code) -> Activate_account {id; activation_code});
      }

  let proposals_case =
    Case
      {
        tag = 5;
        name = "proposals";
        encoding =
          obj3
            (req "source" Signature.Public_key_hash.encoding)
            (req "period" Voting_period_repr.encoding)
            (req "proposals" (list Protocol_hash.encoding));
        select =
          (function Contents (Proposals _ as op) -> Some op | _ -> None);
        proj =
          (fun (Proposals {source; period; proposals}) ->
            (source, period, proposals));
        inj =
          (fun (source, period, proposals) ->
            Proposals {source; period; proposals});
      }

  let ballot_case =
    Case
      {
        tag = 6;
        name = "ballot";
        encoding =
          obj4
            (req "source" Signature.Public_key_hash.encoding)
            (req "period" Voting_period_repr.encoding)
            (req "proposal" Protocol_hash.encoding)
            (req "ballot" Vote_repr.ballot_encoding);
        select = (function Contents (Ballot _ as op) -> Some op | _ -> None);
        proj =
          (function
          | Ballot {source; period; proposal; ballot} ->
              (source, period, proposal, ballot));
        inj =
          (fun (source, period, proposal, ballot) ->
            Ballot {source; period; proposal; ballot});
      }

  let manager_encoding =
    obj5
      (req "source" Signature.Public_key_hash.encoding)
      (req "fee" Tez_repr.encoding)
      (req "counter" (check_size 10 n))
      (req "gas_limit" (check_size 10 n))
      (req "storage_limit" (check_size 10 n))

  let extract (type kind)
      (Manager_operation
         {source; fee; counter; gas_limit; storage_limit; operation = _} :
        kind Kind.manager contents) =
    (source, fee, counter, gas_limit, storage_limit)

  let rebuild (source, fee, counter, gas_limit, storage_limit) operation =
    Manager_operation
      {source; fee; counter; gas_limit; storage_limit; operation}

  let make_manager_case tag (type kind)
      (Manager_operations.MCase mcase : kind Manager_operations.case) =
    Case
      {
        tag;
        name = mcase.name;
        encoding = merge_objs manager_encoding mcase.encoding;
        select =
          (function
          | Contents (Manager_operation ({operation; _} as op)) -> (
            match mcase.select (Manager operation) with
            | None ->
                None
            | Some operation ->
                Some (Manager_operation {op with operation}) )
          | _ ->
              None);
        proj =
          (function
          | Manager_operation {operation; _} as op ->
              (extract op, mcase.proj operation));
        inj = (fun (op, contents) -> rebuild op (mcase.inj contents));
      }

  let reveal_case = make_manager_case 107 Manager_operations.reveal_case

  let transaction_case =
    make_manager_case 108 Manager_operations.transaction_case

  let origination_case =
    make_manager_case 109 Manager_operations.origination_case

  let delegation_case =
    make_manager_case 110 Manager_operations.delegation_case

  let contents_encoding =
    let make (Case {tag; name; encoding; select; proj; inj}) =
      case
        (Tag tag)
        name
        encoding
        (fun o -> match select o with None -> None | Some o -> Some (proj o))
        (fun x -> Contents (inj x))
    in
    def "operation.alpha.contents"
    @@ union
         [ make endorsement_case;
           make seed_nonce_revelation_case;
           make double_endorsement_evidence_case;
           make double_baking_evidence_case;
           make activate_account_case;
           make proposals_case;
           make ballot_case;
           make reveal_case;
           make transaction_case;
           make origination_case;
           make delegation_case ]

  let contents_list_encoding =
    conv to_list of_list (Variable.list contents_encoding)

  let optional_signature_encoding =
    conv
      (function Some s -> s | None -> Signature.zero)
      (fun s -> if Signature.equal s Signature.zero then None else Some s)
      Signature.encoding

  let protocol_data_encoding =
    def "operation.alpha.contents_and_signature"
    @@ conv
         (fun (Operation_data {contents; signature}) ->
           (Contents_list contents, signature))
         (fun (Contents_list contents, signature) ->
           Operation_data {contents; signature})
         (obj2
            (req "contents" contents_list_encoding)
            (req "signature" optional_signature_encoding))

  let operation_encoding =
    conv
      (fun {shell; protocol_data} -> (shell, protocol_data))
      (fun (shell, protocol_data) -> {shell; protocol_data})
      (merge_objs Operation.shell_header_encoding protocol_data_encoding)

  let unsigned_operation_encoding =
    def "operation.alpha.unsigned_operation"
    @@ merge_objs
         Operation.shell_header_encoding
         (obj1 (req "contents" contents_list_encoding))

  let internal_operation_encoding =
    def "operation.alpha.internal_operation"
    @@ conv
         (fun (Internal_operation {source; operation; nonce}) ->
           ((source, nonce), Manager operation))
         (fun ((source, nonce), Manager operation) ->
           Internal_operation {source; operation; nonce})
         (merge_objs
            (obj2 (req "source" Contract_repr.encoding) (req "nonce" uint16))
            Manager_operations.encoding)
end

let encoding = Encoding.operation_encoding

let contents_encoding = Encoding.contents_encoding

let contents_list_encoding = Encoding.contents_list_encoding

let protocol_data_encoding = Encoding.protocol_data_encoding

let unsigned_operation_encoding = Encoding.unsigned_operation_encoding

let internal_operation_encoding = Encoding.internal_operation_encoding

let raw ({shell; protocol_data} : _ operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding
      (Operation_data protocol_data)
  in
  {Operation.shell; proto}

let acceptable_passes (op : packed_operation) =
  let (Operation_data protocol_data) = op.protocol_data in
  match protocol_data.contents with
  | Single (Endorsement _) ->
      [0]
  | Single (Proposals _) ->
      [1]
  | Single (Ballot _) ->
      [1]
  | Single (Seed_nonce_revelation _) ->
      [2]
  | Single (Double_endorsement_evidence _) ->
      [2]
  | Single (Double_baking_evidence _) ->
      [2]
  | Single (Activate_account _) ->
      [2]
  | Single (Manager_operation _) ->
      [3]
  | Cons _ ->
      [3]

type error += Invalid_signature (* `Permanent *)

type error += Missing_signature (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"operation.invalid_signature"
    ~title:"Invalid operation signature"
    ~description:
      "The operation signature is ill-formed or has been made with the wrong \
       public key"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation signature is invalid")
    Data_encoding.unit
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature) ;
  register_error_kind
    `Permanent
    ~id:"operation.missing_signature"
    ~title:"Missing operation signature"
    ~description:
      "The operation is of a kind that must be signed, but the signature is \
       missing"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation requires a signature")
    Data_encoding.unit
    (function Missing_signature -> Some () | _ -> None)
    (fun () -> Missing_signature)

let check_signature_sync (type kind) key chain_id
    ({shell; protocol_data} : kind operation) =
  let check ~watermark contents signature =
    let unsigned_operation =
      Data_encoding.Binary.to_bytes_exn
        unsigned_operation_encoding
        (shell, contents)
    in
    if Signature.check ~watermark key signature unsigned_operation then Ok ()
    else error Invalid_signature
  in
  match (protocol_data.contents, protocol_data.signature) with
  | (Single _, None) ->
      error Missing_signature
  | (Cons _, None) ->
      error Missing_signature
  | ((Single (Endorsement _) as contents), Some signature) ->
      check
        ~watermark:(Endorsement chain_id)
        (Contents_list contents)
        signature
  | ((Single _ as contents), Some signature) ->
      check ~watermark:Generic_operation (Contents_list contents) signature
  | ((Cons _ as contents), Some signature) ->
      check ~watermark:Generic_operation (Contents_list contents) signature

let check_signature pk chain_id op =
  Lwt.return (check_signature_sync pk chain_id op)

let hash_raw = Operation.hash

let hash (o : _ operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn
      protocol_data_encoding
      (Operation_data o.protocol_data)
  in
  Operation.hash {shell = o.shell; proto}

let hash_packed (o : packed_operation) =
  let proto =
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding o.protocol_data
  in
  Operation.hash {shell = o.shell; proto}

type ('a, 'b) eq = Eq : ('a, 'a) eq

let equal_manager_operation_kind :
    type a b. a manager_operation -> b manager_operation -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Reveal _, Reveal _) ->
      Some Eq
  | (Reveal _, _) ->
      None
  | (Transaction _, Transaction _) ->
      Some Eq
  | (Transaction _, _) ->
      None
  | (Origination _, Origination _) ->
      Some Eq
  | (Origination _, _) ->
      None
  | (Delegation _, Delegation _) ->
      Some Eq
  | (Delegation _, _) ->
      None

let equal_contents_kind :
    type a b. a contents -> b contents -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Endorsement _, Endorsement _) ->
      Some Eq
  | (Endorsement _, _) ->
      None
  | (Seed_nonce_revelation _, Seed_nonce_revelation _) ->
      Some Eq
  | (Seed_nonce_revelation _, _) ->
      None
  | (Double_endorsement_evidence _, Double_endorsement_evidence _) ->
      Some Eq
  | (Double_endorsement_evidence _, _) ->
      None
  | (Double_baking_evidence _, Double_baking_evidence _) ->
      Some Eq
  | (Double_baking_evidence _, _) ->
      None
  | (Activate_account _, Activate_account _) ->
      Some Eq
  | (Activate_account _, _) ->
      None
  | (Proposals _, Proposals _) ->
      Some Eq
  | (Proposals _, _) ->
      None
  | (Ballot _, Ballot _) ->
      Some Eq
  | (Ballot _, _) ->
      None
  | (Manager_operation op1, Manager_operation op2) -> (
    match equal_manager_operation_kind op1.operation op2.operation with
    | None ->
        None
    | Some Eq ->
        Some Eq )
  | (Manager_operation _, _) ->
      None

let rec equal_contents_kind_list :
    type a b. a contents_list -> b contents_list -> (a, b) eq option =
 fun op1 op2 ->
  match (op1, op2) with
  | (Single op1, Single op2) ->
      equal_contents_kind op1 op2
  | (Single _, Cons _) ->
      None
  | (Cons _, Single _) ->
      None
  | (Cons (op1, ops1), Cons (op2, ops2)) -> (
    match equal_contents_kind op1 op2 with
    | None ->
        None
    | Some Eq -> (
      match equal_contents_kind_list ops1 ops2 with
      | None ->
          None
      | Some Eq ->
          Some Eq ) )

let equal : type a b. a operation -> b operation -> (a, b) eq option =
 fun op1 op2 ->
  if not (Operation_hash.equal (hash op1) (hash op2)) then None
  else
    equal_contents_kind_list
      op1.protocol_data.contents
      op2.protocol_data.contents
src/proto_alpha/lib_protocol/operation_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Kind.
  Inductive seed_nonce_revelation : Type :=
  | Seed_nonce_revelation_kind : seed_nonce_revelation.
  
  Inductive double_endorsement_evidence : Type :=
  | Double_endorsement_evidence_kind : double_endorsement_evidence.
  
  Inductive double_baking_evidence : Type :=
  | Double_baking_evidence_kind : double_baking_evidence.
  
  Inductive activate_account : Type :=
  | Activate_account_kind : activate_account.
  
  Inductive endorsement : Type :=
  | Endorsement_kind : endorsement.
  
  Inductive proposals : Type :=
  | Proposals_kind : proposals.
  
  Inductive ballot : Type :=
  | Ballot_kind : ballot.
  
  Inductive reveal : Type :=
  | Reveal_kind : reveal.
  
  Inductive transaction : Type :=
  | Transaction_kind : transaction.
  
  Inductive origination : Type :=
  | Origination_kind : origination.
  
  Inductive delegation : Type :=
  | Delegation_kind : delegation.
  
  Inductive manager : forall (a : Type), Type :=
  | Reveal_manager_kind : manager reveal
  | Transaction_manager_kind : manager transaction
  | Origination_manager_kind : manager origination
  | Delegation_manager_kind : manager delegation.
End Kind.

Record raw := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  proto : Tezos_protocol_environment_alpha__Environment.MBytes.t }.

Definition raw_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.t
    Tezos_protocol_environment_alpha__Environment.Operation.t :=
  Operation.encoding.

Reserved Notation "'counter".

Inductive contents_list : forall (_ : Type), Type :=
| Single : forall {kind : Type}, (contents kind) -> contents_list kind
| Cons : forall {kind rest : Type}, (contents (Kind.manager kind)) ->
  (contents_list (Kind.manager rest)) ->
  contents_list (Kind.manager (kind * rest))

with contents : forall (_ : Type), Type :=
| Endorsement : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  contents Kind.endorsement
| Seed_nonce_revelation : Tezos_raw_protocol_alpha.Raw_level_repr.t ->
  Tezos_raw_protocol_alpha.Seed_repr.nonce ->
  contents Kind.seed_nonce_revelation
| Double_endorsement_evidence : (operation Kind.endorsement) ->
  (operation Kind.endorsement) -> contents Kind.double_endorsement_evidence
| Double_baking_evidence : Tezos_raw_protocol_alpha.Block_header_repr.t ->
  Tezos_raw_protocol_alpha.Block_header_repr.t ->
  contents Kind.double_baking_evidence
| Activate_account :
  Tezos_protocol_environment_alpha__Environment.Ed25519.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code ->
  contents Kind.activate_account
| Proposals :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.t ->
  (list
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  -> contents Kind.proposals
| Ballot :
  Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t ->
  Tezos_raw_protocol_alpha.Voting_period_repr.t ->
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  -> Tezos_raw_protocol_alpha.Vote_repr.ballot -> contents Kind.ballot
| Manager_operation : forall {kind : Type},
  Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash ->
  Tezos_raw_protocol_alpha.Tez_repr.tez -> 'counter -> (manager_operation kind)
  -> Tezos_protocol_environment_alpha__Environment.Z.t ->
  Tezos_protocol_environment_alpha__Environment.Z.t ->
  contents (Kind.manager kind)

with manager_operation : forall (_ : Type), Type :=
| Reveal : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t
  -> manager_operation Kind.reveal
| Transaction : Tezos_raw_protocol_alpha.Tez_repr.tez ->
  Tezos_raw_protocol_alpha.Script_repr.lazy_expr -> string ->
  Tezos_raw_protocol_alpha.Contract_repr.contract ->
  manager_operation Kind.transaction
| Origination :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> Tezos_raw_protocol_alpha.Script_repr.t ->
  Tezos_raw_protocol_alpha.Tez_repr.tez ->
  (option Tezos_raw_protocol_alpha.Contract_repr.t) ->
  manager_operation Kind.origination
| Delegation :
  (option
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  -> manager_operation Kind.delegation

where "'counter" := ( Tezos_protocol_environment_alpha__Environment.Z.t).

Definition counter := 'counter.

Definition manager_kind {kind : Type}
  (function_parameter : manager_operation kind) : Kind.manager kind :=
  match function_parameter with
  | Reveal _ => Kind.Reveal_manager_kind
  | Transaction _ => Kind.Transaction_manager_kind
  | Origination _ => Kind.Origination_manager_kind
  | Delegation _ => Kind.Delegation_manager_kind
  end.

Record internal_operation {kind : Type} := {
  source : Tezos_raw_protocol_alpha.Contract_repr.contract;
  operation : manager_operation kind;
  nonce : Z }.
Arguments internal_operation : clear implicits.

Inductive packed_manager_operation : Type :=
| Manager : forall {kind : Type}, (manager_operation kind) ->
  packed_manager_operation.

Inductive packed_contents : Type :=
| Contents : forall {kind : Type}, (contents kind) -> packed_contents.

Inductive packed_contents_list : Type :=
| Contents_list : forall {kind : Type}, (contents_list kind) ->
  packed_contents_list.

Inductive packed_protocol_data : Type :=
| Operation_data : forall {kind : Type}, (protocol_data kind) ->
  packed_protocol_data.

Record packed_operation := {
  shell : Tezos_protocol_environment_alpha__Environment.Operation.shell_header;
  protocol_data : packed_protocol_data }.

Definition pack {A : Type} (function_parameter : operation A)
  : packed_operation :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  {| shell := shell; protocol_data := Operation_data protocol_data |}.

Inductive packed_internal_operation : Type :=
| Internal_operation : forall {kind : Type}, (internal_operation kind) ->
  packed_internal_operation.

Fixpoint to_list (function_parameter : packed_contents_list)
  : list packed_contents :=
  match function_parameter with
  | Contents_list (Single o) => cons (Contents o) []
  | Contents_list (Cons o os) => cons (Contents o) (to_list (Contents_list os))
  end.

Fixpoint of_list (function_parameter : list packed_contents)
  : packed_contents_list :=
  match function_parameter with
  | [] =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | cons (Contents o) [] => Contents_list (Single o)
  | cons (Contents o) os =>
    let 'Contents_list os := of_list os in
    match (o, os) with
    | (Manager_operation _, Single (Manager_operation _)) =>
      Contents_list (Cons o os)
    | (Manager_operation _, Cons _ _) => Contents_list (Cons o os)
    | _ =>
      Pervasives.failwith
        "Operation list of length > 1 should only contains manager operations."
          % string
    end
  end.

Module Encoding.
  Import Data_encoding.
  
  Definition case {A B : Type}
    (tag : Tezos_protocol_environment_alpha__Environment.Data_encoding.case_tag)
    (name : string)
    (args :
      Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding A)
    (proj : B -> option A) (inj : A -> B)
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.case B :=
    case (String.capitalize_ascii name) None tag
      (merge_objs (obj1 (req None None "kind" % string (constant name))) args)
      (fun x =>
        match proj x with
        | None => None
        | Some x => Some (tt, x)
        end)
      (fun function_parameter =>
        let '(tt, x) := function_parameter in
        inj x).
  
  Module Manager_operations.
    Inductive case (kind : Type) : Type :=
    | MCase : forall {a : Type}, Z -> string ->
      (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
      (packed_manager_operation -> option (manager_operation kind)) ->
      ((manager_operation kind) -> a) -> (a -> manager_operation kind) ->
      case kind.
    
    Arguments MCase {_}.
    
    Definition reveal_case : case Kind.reveal :=
      MCase
        {| tag := 0; name := "reveal" % string;
          encoding :=
            obj1
              (req None None "public_key" % string Signature.Public_key.encoding);
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Reveal _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              let 'Reveal pkh := function_parameter in
              pkh; inj := fun pkh => Reveal pkh |}.
    
    Definition entrypoint_encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
      op_atat
        (def "entrypoint" % string (Some "entrypoint" % string)
          (Some "Named entrypoint to a Michelson smart contract" % string))
        (let builtin_case
          (tag : Z) (name :
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
          : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
          Data_encoding.case name None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
            (constant name)
            (fun n =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  n name then
                Some tt
              else
                None)
            (fun function_parameter =>
              let 'tt := function_parameter in
              name) in
        union None
          (cons (builtin_case 0 "default" % string)
            (cons (builtin_case 1 "root" % string)
              (cons (builtin_case 2 "do" % string)
                (cons (builtin_case 3 "set_delegate" % string)
                  (cons (builtin_case 4 "remove_delegate" % string)
                    (cons
                      (Data_encoding.case "named" % string None
                        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
                          255) (Bounded.string 31) (fun s => Some s)
                        (fun s => s)) []))))))).
    
    Definition transaction_case : case Kind.transaction :=
      MCase
        {| tag := 1; name := "transaction" % string;
          encoding :=
            obj3 (req None None "amount" % string Tez_repr.encoding)
              (req None None "destination" % string Contract_repr.encoding)
              (opt None None "parameters" % string
                (obj2 (req None None "entrypoint" % string entrypoint_encoding)
                  (req None None "value" % string Script_repr.lazy_expr_encoding)));
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Transaction _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              let
                'Transaction {|
                  amount := amount;
                    parameters := parameters;
                    entrypoint := entrypoint;
                    destination := destination
                    |} := function_parameter in
              let parameters :=
                if
                  op_andand (Script_repr.is_unit_parameter parameters)
                    (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                      entrypoint "default" % string) then
                  None
                else
                  Some (entrypoint, parameters) in
              (amount, destination, parameters);
          inj :=
            fun function_parameter =>
              let '(amount, destination, parameters) := function_parameter in
              let '(entrypoint, parameters) :=
                match parameters with
                | None => ("default" % string, Script_repr.unit_parameter)
                | Some (entrypoint, value) => (entrypoint, value)
                end in
              Transaction
                {| amount := amount; parameters := parameters;
                  entrypoint := entrypoint; destination := destination |} |}.
    
    Definition origination_case : case Kind.origination :=
      MCase
        {| tag := 2; name := "origination" % string;
          encoding :=
            obj3 (req None None "balance" % string Tez_repr.encoding)
              (opt None None "delegate" % string
                Signature.Public_key_hash.encoding)
              (req None None "script" % string Script_repr.encoding);
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Origination _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              let
                'Origination {|
                  delegate := delegate;
                    script := script;
                    credit := credit;
                    preorigination := _
                    |} := function_parameter in
              (credit, delegate, script);
          inj :=
            fun function_parameter =>
              let '(credit, delegate, script) := function_parameter in
              Origination
                {| delegate := delegate; script := script; credit := credit;
                  preorigination := None |} |}.
    
    Definition delegation_case : case Kind.delegation :=
      MCase
        {| tag := 3; name := "delegation" % string;
          encoding :=
            obj1
              (opt None None "delegate" % string
                Signature.Public_key_hash.encoding);
          select :=
            fun function_parameter =>
              match function_parameter with
              | Manager ((Delegation _) as op) => Some op
              | _ => None
              end;
          proj :=
            fun function_parameter =>
              let 'Delegation key := function_parameter in
              key; inj := fun key => Delegation key |}.
    
    Definition encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        packed_manager_operation :=
      let make {A : Type} (function_parameter : case A)
        : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
          packed_manager_operation :=
        let
          'MCase {|
            tag := tag;
              name := name;
              encoding := encoding;
              select := select;
              proj := proj;
              inj := inj
              |} := function_parameter in
        case
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
          name encoding
          (fun o =>
            match select o with
            | None => None
            | Some o => Some (proj o)
            end) (fun x => Manager (inj x)) in
      union
        (Some
          (* ❌ Variants not supported *)
          variant)
        (cons (make reveal_case)
          (cons (make transaction_case)
            (cons (make origination_case) (cons (make delegation_case) [])))).
  End Manager_operations.
  
  Inductive case (b : Type) : Type :=
  | Case : forall {a : Type}, Z -> string ->
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
    (packed_contents -> option (contents b)) -> ((contents b) -> a) ->
    (a -> contents b) -> case b.
  
  Arguments Case {_}.
  
  Definition endorsement_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      Tezos_raw_protocol_alpha.Raw_level_repr.raw_level :=
    obj1 (req None None "level" % string Raw_level_repr.encoding).
  
  Definition endorsement_case : case Kind.endorsement :=
    Case
      {| tag := 0; name := "endorsement" % string;
        encoding := endorsement_encoding;
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Endorsement _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Endorsement {| level := level |} := function_parameter in
            level; inj := fun level => Endorsement {| level := level |} |}.
  
  Definition endorsement_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (operation Kind.endorsement) :=
    let make {A : Type} (function_parameter : case A)
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        (contents A) :=
      let
        'Case {|
          tag := tag;
            name := name;
            encoding := encoding;
            select := _;
            proj := proj;
            inj := inj
            |} := function_parameter in
      case (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
        name encoding (fun o => Some (proj o)) (fun x => inj x) in
    let to_list (function_parameter : contents_list Kind.endorsement)
      : contents Kind.endorsement :=
      let 'Single o := function_parameter in
      o in
    let of_list (o : contents Kind.endorsement)
      : contents_list Kind.endorsement :=
      Single o in
    op_atat
      (let arg := def "inlined.endorsement" % string in
      fun eta => arg None None eta)
      (conv
        (fun function_parameter =>
          let '{|
            shell := shell;
              protocol_data := {|
                contents := contents;
                  signature := signature
                  |}
              |} := function_parameter in
          (shell, (contents, signature)))
        (fun function_parameter =>
          let '(shell, (contents, signature)) := function_parameter in
          {| shell := shell;
            protocol_data := {| contents := contents; signature := signature |}
            |}) None
        (merge_objs Operation.shell_header_encoding
          (obj2
            (req None None "operations" % string
              (op_atat
                (let arg := conv to_list of_list in
                fun eta => arg None eta)
                (op_atat
                  (let arg := def "inlined.endorsement.contents" % string in
                  fun eta => arg None None eta)
                  (union None (cons (make endorsement_case) [])))))
            (varopt None None "signature" % string Signature.encoding)))).
  
  Definition seed_nonce_revelation_case : case Kind.seed_nonce_revelation :=
    Case
      {| tag := 1; name := "seed_nonce_revelation" % string;
        encoding :=
          obj2 (req None None "level" % string Raw_level_repr.encoding)
            (req None None "nonce" % string Seed_repr.nonce_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Seed_nonce_revelation _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Seed_nonce_revelation {| level := level; nonce := nonce |} :=
              function_parameter in
            (level, nonce);
        inj :=
          fun function_parameter =>
            let '(level, nonce) := function_parameter in
            Seed_nonce_revelation {| level := level; nonce := nonce |} |}.
  
  Definition double_endorsement_evidence_case
    : case Kind.double_endorsement_evidence :=
    Case
      {| tag := 2; name := "double_endorsement_evidence" % string;
        encoding :=
          obj2
            (req None None "op1" % string
              (dynamic_size None endorsement_encoding))
            (req None None "op2" % string
              (dynamic_size None endorsement_encoding));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Double_endorsement_evidence _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Double_endorsement_evidence {| op1 := op1; op2 := op2 |} :=
              function_parameter in
            (op1, op2);
        inj :=
          fun function_parameter =>
            let '(op1, op2) := function_parameter in
            Double_endorsement_evidence {| op1 := op1; op2 := op2 |} |}.
  
  Definition double_baking_evidence_case : case Kind.double_baking_evidence :=
    Case
      {| tag := 3; name := "double_baking_evidence" % string;
        encoding :=
          obj2
            (req None None "bh1" % string
              (dynamic_size None Block_header_repr.encoding))
            (req None None "bh2" % string
              (dynamic_size None Block_header_repr.encoding));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Double_baking_evidence _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let 'Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |} :=
              function_parameter in
            (bh1, bh2);
        inj :=
          fun function_parameter =>
            let '(bh1, bh2) := function_parameter in
            Double_baking_evidence {| bh1 := bh1; bh2 := bh2 |} |}.
  
  Definition activate_account_case : case Kind.activate_account :=
    Case
      {| tag := 4; name := "activate_account" % string;
        encoding :=
          obj2 (req None None "pkh" % string Ed25519.Public_key_hash.encoding)
            (req None None "secret" % string
              Blinded_public_key_hash.activation_code_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Activate_account _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let
              'Activate_account {|
                id := id; activation_code := activation_code |} :=
              function_parameter in
            (id, activation_code);
        inj :=
          fun function_parameter =>
            let '(id, activation_code) := function_parameter in
            Activate_account {| id := id; activation_code := activation_code |}
        |}.
  
  Definition proposals_case : case Kind.proposals :=
    Case
      {| tag := 5; name := "proposals" % string;
        encoding :=
          obj3
            (req None None "source" % string Signature.Public_key_hash.encoding)
            (req None None "period" % string Voting_period_repr.encoding)
            (req None None "proposals" % string
              (list None
                Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)));
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Proposals _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let
              'Proposals {|
                source := source;
                  period := period;
                  proposals := proposals
                  |} := function_parameter in
            (source, period, proposals);
        inj :=
          fun function_parameter =>
            let '(source, period, proposals) := function_parameter in
            Proposals
              {| source := source; period := period; proposals := proposals |}
        |}.
  
  Definition ballot_case : case Kind.ballot :=
    Case
      {| tag := 6; name := "ballot" % string;
        encoding :=
          obj4
            (req None None "source" % string Signature.Public_key_hash.encoding)
            (req None None "period" % string Voting_period_repr.encoding)
            (req None None "proposal" % string
              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
            (req None None "ballot" % string Vote_repr.ballot_encoding);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents ((Ballot _) as op) => Some op
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let
              'Ballot {|
                source := source;
                  period := period;
                  proposal := proposal;
                  ballot := ballot
                  |} := function_parameter in
            (source, period, proposal, ballot);
        inj :=
          fun function_parameter =>
            let '(source, period, proposal, ballot) := function_parameter in
            Ballot
              {| source := source; period := period; proposal := proposal;
                ballot := ballot |} |}.
  
  Definition manager_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Tezos_raw_protocol_alpha.Tez_repr.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t) :=
    obj5 (req None None "source" % string Signature.Public_key_hash.encoding)
      (req None None "fee" % string Tez_repr.encoding)
      (req None None "counter" % string (check_size 10 n))
      (req None None "gas_limit" % string (check_size 10 n))
      (req None None "storage_limit" % string (check_size 10 n)).
  
  Definition extract {A : Type} (function_parameter : contents (Kind.manager A))
    : Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash *
      Tezos_raw_protocol_alpha.Tez_repr.tez * counter *
      Tezos_protocol_environment_alpha__Environment.Z.t *
      Tezos_protocol_environment_alpha__Environment.Z.t :=
    let
      'Manager_operation {|
        source := source;
          fee := fee;
          counter := counter;
          operation := _;
          gas_limit := gas_limit;
          storage_limit := storage_limit
          |} := function_parameter in
    (source, fee, counter, gas_limit, storage_limit).
  
  Definition rebuild {A : Type}
    (function_parameter :
      Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash *
        Tezos_raw_protocol_alpha.Tez_repr.tez * counter *
        Tezos_protocol_environment_alpha__Environment.Z.t *
        Tezos_protocol_environment_alpha__Environment.Z.t)
    : (manager_operation A) -> contents (Kind.manager A) :=
    let '(source, fee, counter, gas_limit, storage_limit) := function_parameter
      in
    fun operation =>
      Manager_operation
        {| source := source; fee := fee; counter := counter;
          operation := operation; gas_limit := gas_limit;
          storage_limit := storage_limit |}.
  
  Definition make_manager_case {A : Type}
    (tag : Z) (function_parameter : Manager_operations.case A)
    : case (Kind.manager A) :=
    let 'Manager_operations.MCase mcase := function_parameter in
    Case
      {| tag := tag; name := name mcase;
        encoding := merge_objs manager_encoding (encoding mcase);
        select :=
          fun function_parameter =>
            match function_parameter with
            | Contents (Manager_operation ({| operation := operation |} as op))
              =>
              match (select mcase) (Manager operation) with
              | None => None
              | Some operation =>
                Some
                  (Manager_operation
                    (* ❌ Record substitution not handled *)
                    record_substitution)
              end
            | _ => None
            end;
        proj :=
          fun function_parameter =>
            let '(Manager_operation {| operation := operation |}) as op :=
              function_parameter in
            ((extract op), ((proj mcase) operation));
        inj :=
          fun function_parameter =>
            let '(op, contents) := function_parameter in
            rebuild op ((inj mcase) contents) |}.
  
  Definition reveal_case : case (Kind.manager Kind.reveal) :=
    make_manager_case 107 Manager_operations.reveal_case.
  
  Definition transaction_case : case (Kind.manager Kind.transaction) :=
    make_manager_case 108 Manager_operations.transaction_case.
  
  Definition origination_case : case (Kind.manager Kind.origination) :=
    make_manager_case 109 Manager_operations.origination_case.
  
  Definition delegation_case : case (Kind.manager Kind.delegation) :=
    make_manager_case 110 Manager_operations.delegation_case.
  
  Definition contents_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_contents :=
    let make {A : Type} (function_parameter : case A)
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.case
        packed_contents :=
      let
        'Case {|
          tag := tag;
            name := name;
            encoding := encoding;
            select := select;
            proj := proj;
            inj := inj
            |} := function_parameter in
      case (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag tag)
        name encoding
        (fun o =>
          match select o with
          | None => None
          | Some o => Some (proj o)
          end) (fun x => Contents (inj x)) in
    op_atat
      (let arg := def "operation.alpha.contents" % string in
      fun eta => arg None None eta)
      (union None
        (cons (make endorsement_case)
          (cons (make seed_nonce_revelation_case)
            (cons (make double_endorsement_evidence_case)
              (cons (make double_baking_evidence_case)
                (cons (make activate_account_case)
                  (cons (make proposals_case)
                    (cons (make ballot_case)
                      (cons (make reveal_case)
                        (cons (make transaction_case)
                          (cons (make origination_case)
                            (cons (make delegation_case) [])))))))))))).
  
  Definition contents_list_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_contents_list :=
    conv to_list of_list None (Variable.list None contents_encoding).
  
  Definition optional_signature_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (option Tezos_protocol_environment_alpha__Environment.Signature.t) :=
    conv
      (fun function_parameter =>
        match function_parameter with
        | Some s => s
        | None => Signature.zero
        end)
      (fun s =>
        if Signature.equal s Signature.zero then
          None
        else
          Some s) None Signature.encoding.
  
  Definition protocol_data_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_protocol_data :=
    op_atat
      (let arg := def "operation.alpha.contents_and_signature" % string in
      fun eta => arg None None eta)
      (conv
        (fun function_parameter =>
          let
            'Operation_data {| contents := contents; signature := signature |} :=
            function_parameter in
          ((Contents_list contents), signature))
        (fun function_parameter =>
          let '(Contents_list contents, signature) := function_parameter in
          Operation_data {| contents := contents; signature := signature |})
        None
        (obj2 (req None None "contents" % string contents_list_encoding)
          (req None None "signature" % string optional_signature_encoding))).
  
  Definition operation_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_operation :=
    conv
      (fun function_parameter =>
        let '{| shell := shell; protocol_data := protocol_data |} :=
          function_parameter in
        (shell, protocol_data))
      (fun function_parameter =>
        let '(shell, protocol_data) := function_parameter in
        {| shell := shell; protocol_data := protocol_data |}) None
      (merge_objs Operation.shell_header_encoding protocol_data_encoding).
  
  Definition unsigned_operation_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
        packed_contents_list) :=
    op_atat
      (let arg := def "operation.alpha.unsigned_operation" % string in
      fun eta => arg None None eta)
      (merge_objs Operation.shell_header_encoding
        (obj1 (req None None "contents" % string contents_list_encoding))).
  
  Definition internal_operation_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      packed_internal_operation :=
    op_atat
      (let arg := def "operation.alpha.internal_operation" % string in
      fun eta => arg None None eta)
      (conv
        (fun function_parameter =>
          let
            'Internal_operation {|
              source := source; operation := operation; nonce := nonce |} :=
            function_parameter in
          ((source, nonce), (Manager operation)))
        (fun function_parameter =>
          let '((source, nonce), Manager operation) := function_parameter in
          Internal_operation
            {| source := source; operation := operation; nonce := nonce |}) None
        (merge_objs
          (obj2 (req None None "source" % string Contract_repr.encoding)
            (req None None "nonce" % string uint16)) Manager_operations.encoding)).
End Encoding.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_operation := Encoding.operation_encoding.

Definition contents_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents := Encoding.contents_encoding.

Definition contents_list_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_contents_list := Encoding.contents_list_encoding.

Definition protocol_data_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_protocol_data := Encoding.protocol_data_encoding.

Definition unsigned_operation_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Operation.shell_header *
      packed_contents_list) := Encoding.unsigned_operation_encoding.

Definition internal_operation_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    packed_internal_operation := Encoding.internal_operation_encoding.

Definition raw {A : Type} (function_parameter : operation A)
  : Tezos_protocol_environment_alpha__Environment.Operation.t :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  let proto :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding
      (Operation_data protocol_data) in
  {| Operation.shell := shell; Operation.proto := proto |}.

Definition acceptable_passes (op : packed_operation) : list Z :=
  let 'Operation_data protocol_data := protocol_data op in
  match contents protocol_data with
  | Single (Endorsement _) => cons 0 []
  | Single (Proposals _) => cons 1 []
  | Single (Ballot _) => cons 1 []
  | Single (Seed_nonce_revelation _) => cons 2 []
  | Single (Double_endorsement_evidence _) => cons 2 []
  | Single (Double_baking_evidence _) => cons 2 []
  | Single (Activate_account _) => cons 2 []
  | Single (Manager_operation _) => cons 3 []
  | Cons _ _ => cons 3 []
  end.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition check_signature_sync {A : Type}
  (key : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (function_parameter : operation A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  let '{| shell := shell; protocol_data := protocol_data |} :=
    function_parameter in
  let check
    (watermark :
    Tezos_protocol_environment_alpha__Environment.Signature.watermark) (contents
    : packed_contents_list) (signature :
    Tezos_protocol_environment_alpha__Environment.Signature.t)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result unit
      (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
    let unsigned_operation :=
      Data_encoding.Binary.to_bytes_exn unsigned_operation_encoding
        (shell, contents) in
    if Signature.check (Some watermark) key signature unsigned_operation then
      Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt
    else
      error
        Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_signature
    in
  match ((contents protocol_data), (signature protocol_data)) with
  | (Single _, None) =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_signature
  | (Cons _ _, None) =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_signature
  | ((Single (Endorsement _)) as contents, Some signature) =>
    check
      (Tezos_protocol_environment_alpha__Environment.Signature.Endorsement
        chain_id) (Contents_list contents) signature
  | ((Single _) as contents, Some signature) =>
    check
      Tezos_protocol_environment_alpha__Environment.Signature.Generic_operation
      (Contents_list contents) signature
  | ((Cons _ _) as contents, Some signature) =>
    check
      Tezos_protocol_environment_alpha__Environment.Signature.Generic_operation
      (Contents_list contents) signature
  end.

Definition check_signature {A : Type}
  (pk : Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t)
  (chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (op : operation A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Lwt._return (check_signature_sync pk chain_id op).

Definition hash_raw
  : Tezos_protocol_environment_alpha__Environment.Operation.t ->
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  Operation.hash.

Definition hash {A : Type} (o : operation A)
  : Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  let proto :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding
      (Operation_data (protocol_data o)) in
  Operation.hash {| shell := shell o; proto := proto |}.

Definition hash_packed (o : packed_operation)
  : Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t) :=
  let proto :=
    Data_encoding.Binary.to_bytes_exn protocol_data_encoding (protocol_data o)
    in
  Operation.hash {| shell := shell o; proto := proto |}.

Inductive eq (a : Type) : forall (b : Type), Type :=
| Eq : eq a a.

Arguments Eq {_}.

Definition equal_manager_operation_kind {a b : Type}
  (op1 : manager_operation a) (op2 : manager_operation b) : option (eq a b) :=
  match (op1, op2) with
  | (Reveal _, Reveal _) => Some Eq
  | (Reveal _, _) => None
  | (Transaction _, Transaction _) => Some Eq
  | (Transaction _, _) => None
  | (Origination _, Origination _) => Some Eq
  | (Origination _, _) => None
  | (Delegation _, Delegation _) => Some Eq
  | (Delegation _, _) => None
  end.

Definition equal_contents_kind {a b : Type}
  (op1 : contents a) (op2 : contents b) : option (eq a b) :=
  match (op1, op2) with
  | (Endorsement _, Endorsement _) => Some Eq
  | (Endorsement _, _) => None
  | (Seed_nonce_revelation _, Seed_nonce_revelation _) => Some Eq
  | (Seed_nonce_revelation _, _) => None
  | (Double_endorsement_evidence _, Double_endorsement_evidence _) => Some Eq
  | (Double_endorsement_evidence _, _) => None
  | (Double_baking_evidence _, Double_baking_evidence _) => Some Eq
  | (Double_baking_evidence _, _) => None
  | (Activate_account _, Activate_account _) => Some Eq
  | (Activate_account _, _) => None
  | (Proposals _, Proposals _) => Some Eq
  | (Proposals _, _) => None
  | (Ballot _, Ballot _) => Some Eq
  | (Ballot _, _) => None
  | (Manager_operation op1, Manager_operation op2) =>
    match equal_manager_operation_kind (operation op1) (operation op2) with
    | None => None
    | Some Eq => Some Eq
    end
  | (Manager_operation _, _) => None
  end.

Fixpoint equal_contents_kind_list {a b : Type}
  (op1 : contents_list a) (op2 : contents_list b) : option (eq a b) :=
  match (op1, op2) with
  | (Single op1, Single op2) => equal_contents_kind op1 op2
  | (Single _, Cons _ _) => None
  | (Cons _ _, Single _) => None
  | (Cons op1 ops1, Cons op2 ops2) =>
    match equal_contents_kind op1 op2 with
    | None => None
    | Some Eq =>
      match equal_contents_kind_list ops1 ops2 with
      | None => None
      | Some Eq => Some Eq
      end
    end
  end.

Definition equal {a b : Type} (op1 : operation a) (op2 : operation b)
  : option (eq a b) :=
  if
    not
      (Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
        (hash op1) (hash op2)) then
    None
  else
    equal_contents_kind_list (contents (protocol_data op1))
      (contents (protocol_data op2)).

src/proto_alpha/lib_protocol/parameters_repr.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type bootstrap_account = {
  public_key_hash : Signature.Public_key_hash.t;
  public_key : Signature.Public_key.t option;
  amount : Tez_repr.t;
}

type bootstrap_contract = {
  delegate : Signature.Public_key_hash.t;
  amount : Tez_repr.t;
  script : Script_repr.t;
}

type t = {
  bootstrap_accounts : bootstrap_account list;
  bootstrap_contracts : bootstrap_contract list;
  commitments : Commitment_repr.t list;
  constants : Constants_repr.parametric;
  security_deposit_ramp_up_cycles : int option;
  no_reward_cycles : int option;
}

let bootstrap_account_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Public_key_known"
        (tup2 Signature.Public_key.encoding Tez_repr.encoding)
        (function
          | {public_key_hash; public_key = Some public_key; amount} ->
              assert (
                Signature.Public_key_hash.equal
                  (Signature.Public_key.hash public_key)
                  public_key_hash ) ;
              Some (public_key, amount)
          | {public_key = None} ->
              None)
        (fun (public_key, amount) ->
          {
            public_key = Some public_key;
            public_key_hash = Signature.Public_key.hash public_key;
            amount;
          });
      case
        (Tag 1)
        ~title:"Public_key_unknown"
        (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
        (function
          | {public_key_hash; public_key = None; amount} ->
              Some (public_key_hash, amount)
          | {public_key = Some _} ->
              None)
        (fun (public_key_hash, amount) ->
          {public_key = None; public_key_hash; amount}) ]

let bootstrap_contract_encoding =
  let open Data_encoding in
  conv
    (fun {delegate; amount; script} -> (delegate, amount, script))
    (fun (delegate, amount, script) -> {delegate; amount; script})
    (obj3
       (req "delegate" Signature.Public_key_hash.encoding)
       (req "amount" Tez_repr.encoding)
       (req "script" Script_repr.encoding))

let encoding =
  let open Data_encoding in
  conv
    (fun { bootstrap_accounts;
           bootstrap_contracts;
           commitments;
           constants;
           security_deposit_ramp_up_cycles;
           no_reward_cycles } ->
      ( ( bootstrap_accounts,
          bootstrap_contracts,
          commitments,
          security_deposit_ramp_up_cycles,
          no_reward_cycles ),
        constants ))
    (fun ( ( bootstrap_accounts,
             bootstrap_contracts,
             commitments,
             security_deposit_ramp_up_cycles,
             no_reward_cycles ),
           constants ) ->
      {
        bootstrap_accounts;
        bootstrap_contracts;
        commitments;
        constants;
        security_deposit_ramp_up_cycles;
        no_reward_cycles;
      })
    (merge_objs
       (obj5
          (req "bootstrap_accounts" (list bootstrap_account_encoding))
          (dft "bootstrap_contracts" (list bootstrap_contract_encoding) [])
          (dft "commitments" (list Commitment_repr.encoding) [])
          (opt "security_deposit_ramp_up_cycles" int31)
          (opt "no_reward_cycles" int31))
       Constants_repr.parametric_encoding)
src/proto_alpha/lib_protocol/parameters_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Record bootstrap_account := {
  public_key_hash :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  public_key :
    option Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t }.

Record bootstrap_contract := {
  delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
  amount : Tezos_raw_protocol_alpha.Tez_repr.t;
  script : Tezos_raw_protocol_alpha.Script_repr.t }.

Record t := {
  bootstrap_accounts : list bootstrap_account;
  bootstrap_contracts : list bootstrap_contract;
  commitments : list Tezos_raw_protocol_alpha.Commitment_repr.t;
  constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
  security_deposit_ramp_up_cycles : option Z;
  no_reward_cycles : option Z }.

Definition bootstrap_account_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    bootstrap_account :=
  union None
    (cons
      (case "Public_key_known" % string None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
        (tup2 Signature.Public_key.encoding Tez_repr.encoding)
        (fun function_parameter =>
          match function_parameter with
          | {|
            public_key_hash := public_key_hash;
              public_key := Some public_key;
              amount := amount
              |} =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              (* ❌ Assert instruction is not handled. *)
              assert
                (Signature.Public_key_hash.equal
                  (Signature.Public_key.hash public_key) public_key_hash) in
            Some (public_key, amount)
          | {| public_key := None |} => None
          end)
        (fun function_parameter =>
          let '(public_key, amount) := function_parameter in
          {| public_key_hash := Signature.Public_key.hash public_key;
            public_key := Some public_key; amount := amount |}))
      (cons
        (case "Public_key_unknown" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
          (tup2 Signature.Public_key_hash.encoding Tez_repr.encoding)
          (fun function_parameter =>
            match function_parameter with
            | {|
              public_key_hash := public_key_hash;
                public_key := None;
                amount := amount
                |} => Some (public_key_hash, amount)
            | {| public_key := Some _ |} => None
            end)
          (fun function_parameter =>
            let '(public_key_hash, amount) := function_parameter in
            {| public_key_hash := public_key_hash; public_key := None;
              amount := amount |})) [])).

Definition bootstrap_contract_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    bootstrap_contract :=
  conv
    (fun function_parameter =>
      let '{| delegate := delegate; amount := amount; script := script |} :=
        function_parameter in
      (delegate, amount, script))
    (fun function_parameter =>
      let '(delegate, amount, script) := function_parameter in
      {| delegate := delegate; amount := amount; script := script |}) None
    (obj3 (req None None "delegate" % string Signature.Public_key_hash.encoding)
      (req None None "amount" % string Tez_repr.encoding)
      (req None None "script" % string Script_repr.encoding)).

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  conv
    (fun function_parameter =>
      let '{|
        bootstrap_accounts := bootstrap_accounts;
          bootstrap_contracts := bootstrap_contracts;
          commitments := commitments;
          constants := constants;
          security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
          no_reward_cycles := no_reward_cycles
          |} := function_parameter in
      ((bootstrap_accounts, bootstrap_contracts, commitments,
        security_deposit_ramp_up_cycles, no_reward_cycles), constants))
    (fun function_parameter =>
      let
        '((bootstrap_accounts, bootstrap_contracts, commitments,
          security_deposit_ramp_up_cycles, no_reward_cycles), constants) :=
        function_parameter in
      {| bootstrap_accounts := bootstrap_accounts;
        bootstrap_contracts := bootstrap_contracts; commitments := commitments;
        constants := constants;
        security_deposit_ramp_up_cycles := security_deposit_ramp_up_cycles;
        no_reward_cycles := no_reward_cycles |}) None
    (merge_objs
      (obj5
        (req None None "bootstrap_accounts" % string
          (list None bootstrap_account_encoding))
        (dft None None "bootstrap_contracts" % string
          (list None bootstrap_contract_encoding) [])
        (dft None None "commitments" % string
          (list None Commitment_repr.encoding) [])
        (opt None None "security_deposit_ramp_up_cycles" % string int31)
        (opt None None "no_reward_cycles" % string int31))
      Constants_repr.parametric_encoding).

src/proto_alpha/lib_protocol/period_repr.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Int64.t

type period = t

include (Compare.Int64 : Compare.S with type t := t)

let encoding = Data_encoding.int64

let rpc_arg = RPC_arg.int64

let pp ppf v = Format.fprintf ppf "%Ld" v

type error += (* `Permanent *)
                Malformed_period | Invalid_arg

let () =
  let open Data_encoding in
  (* Malformed period *)
  register_error_kind
    `Permanent
    ~id:"malformed_period"
    ~title:"Malformed period"
    ~description:"Period is negative."
    ~pp:(fun ppf () -> Format.fprintf ppf "Malformed period")
    empty
    (function Malformed_period -> Some () | _ -> None)
    (fun () -> Malformed_period) ;
  (* Invalid arg *)
  register_error_kind
    `Permanent
    ~id:"invalid_arg"
    ~title:"Invalid arg"
    ~description:"Negative multiple of periods are not allowed."
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid arg")
    empty
    (function Invalid_arg -> Some () | _ -> None)
    (fun () -> Invalid_arg)

let of_seconds t =
  if Compare.Int64.(t >= 0L) then ok t else error Malformed_period

let to_seconds t = t

let of_seconds_exn t =
  match of_seconds t with
  | Ok t ->
      t
  | _ ->
      invalid_arg "Period.of_seconds_exn"

let mult i p =
  (* TODO check overflow *)
  if Compare.Int32.(i < 0l) then error Invalid_arg
  else ok (Int64.mul (Int64.of_int32 i) p)

let zero = of_seconds_exn 0L

let one_second = of_seconds_exn 1L

let one_minute = of_seconds_exn 60L

let one_hour = of_seconds_exn 3600L
src/proto_alpha/lib_protocol/period_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_protocol_environment_alpha__Environment.Int64.t.

Definition period := t.

(* ❌ Structure item `include` not handled. *)
include

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int64 :=
  Data_encoding.int64.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int64 :=
  RPC_arg.int64.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (v : int64) : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int64
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
      "%Ld" % string) v.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition of_seconds
  (t :
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      t
      (* ❌ Constant of type int64 is converted to int *)
      0 then
    ok t
  else
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Malformed_period.

Definition to_seconds {A : Type} (t : A) : A := t.

Definition of_seconds_exn
  (t :
    Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  match of_seconds t with
  | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok t => t
  | _ => invalid_arg "Period.of_seconds_exn" % string
  end.

Definition mult
  (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (p : int64)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int64 :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      i
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    error Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arg
  else
    ok (Int64.mul (Int64.of_int32 i) p).

Definition zero
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    0.

Definition one_second
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    1.

Definition one_minute
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    60.

Definition one_hour
  : Tezos_protocol_environment_alpha__Environment.Compare.Int64.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  of_seconds_exn
    (* ❌ Constant of type int64 is converted to int *)
    3600.

src/proto_alpha/lib_protocol/qty_repr.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type QTY = sig
  val id : string
end

module type S = sig
  type qty

  type error +=
    | Addition_overflow of qty * qty (* `Temporary *)
    | Subtraction_underflow of qty * qty (* `Temporary *)
    | Multiplication_overflow of qty * int64 (* `Temporary *)
    | Negative_multiplicator of qty * int64 (* `Temporary *)
    | Invalid_divisor of qty * int64

  (* `Temporary *)

  val id : string

  val zero : qty

  val one_mutez : qty

  val one_cent : qty

  val fifty_cents : qty

  val one : qty

  val ( -? ) : qty -> qty -> qty tzresult

  val ( +? ) : qty -> qty -> qty tzresult

  val ( *? ) : qty -> int64 -> qty tzresult

  val ( /? ) : qty -> int64 -> qty tzresult

  val to_mutez : qty -> int64

  (** [of_mutez n] (micro tez) is None if n is negative *)
  val of_mutez : int64 -> qty option

  (** [of_mutez_exn n] fails if n is negative.
      It should only be used at toplevel for constants. *)
  val of_mutez_exn : int64 -> qty

  (** It should only be used at toplevel for constants. *)
  val add_exn : qty -> qty -> qty

  (** It should only be used at toplevel for constants. *)
  val mul_exn : qty -> int -> qty

  val encoding : qty Data_encoding.t

  val to_int64 : qty -> int64

  include Compare.S with type t := qty

  val pp : Format.formatter -> qty -> unit

  val of_string : string -> qty option

  val to_string : qty -> string
end

module Make (T : QTY) : S = struct
  type qty = int64 (* invariant: positive *)

  type error +=
    | Addition_overflow of qty * qty (* `Temporary *)
    | Subtraction_underflow of qty * qty (* `Temporary *)
    | Multiplication_overflow of qty * int64 (* `Temporary *)
    | Negative_multiplicator of qty * int64 (* `Temporary *)
    | Invalid_divisor of qty * int64

  (* `Temporary *)

  include Compare.Int64

  let zero = 0L

  (* all other constant are defined from the value of one micro tez *)
  let one_mutez = 1L

  let one_cent = Int64.mul one_mutez 10_000L

  let fifty_cents = Int64.mul one_cent 50L

  (* 1 tez = 100 cents = 1_000_000 mutez *)
  let one = Int64.mul one_cent 100L

  let id = T.id

  let of_string s =
    let triplets = function
      | hd :: tl ->
          let len = String.length hd in
          Compare.Int.(
            len <= 3 && len > 0
            && List.for_all (fun s -> String.length s = 3) tl)
      | [] ->
          false
    in
    let integers s = triplets (String.split_on_char ',' s) in
    let decimals s =
      let l = String.split_on_char ',' s in
      if Compare.Int.(List.length l > 2) then false else triplets (List.rev l)
    in
    let parse left right =
      let remove_commas s = String.concat "" (String.split_on_char ',' s) in
      let pad_to_six s =
        let len = String.length s in
        String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')
      in
      try
        Some
          (Int64.of_string
             (remove_commas left ^ pad_to_six (remove_commas right)))
      with _ -> None
    in
    match String.split_on_char '.' s with
    | [left; right] ->
        if String.contains s ',' then
          if integers left && decimals right then parse left right else None
        else if
          Compare.Int.(String.length right > 0)
          && Compare.Int.(String.length right <= 6)
        then parse left right
        else None
    | [left] ->
        if (not (String.contains s ',')) || integers left then parse left ""
        else None
    | _ ->
        None

  let pp ppf amount =
    let mult_int = 1_000_000L in
    let rec left ppf amount =
      let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in
      if d > 0L then Format.fprintf ppf "%a%03Ld" left d r
      else Format.fprintf ppf "%Ld" r
    in
    let right ppf amount =
      let triplet ppf v =
        if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v
        else if Compare.Int.(v mod 100 > 0) then
          Format.fprintf ppf "%02d" (v / 10)
        else Format.fprintf ppf "%d" (v / 100)
      in
      let (hi, lo) = (amount / 1000, amount mod 1000) in
      if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi
      else Format.fprintf ppf "%03d%a" hi triplet lo
    in
    let (ints, decs) =
      (Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))
    in
    Format.fprintf ppf "%a" left ints ;
    if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs

  let to_string t = Format.asprintf "%a" pp t

  let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None

  let ( -? ) t1 t2 =
    match t1 - t2 with
    | None ->
        error (Subtraction_underflow (t1, t2))
    | Some v ->
        ok v

  let ( +? ) t1 t2 =
    let t = Int64.add t1 t2 in
    if t < t1 then error (Addition_overflow (t1, t2)) else ok t

  let ( *? ) t m =
    let open Compare.Int64 in
    let open Int64 in
    let rec step cur pow acc =
      if cur = 0L then ok acc
      else
        pow +? pow
        >>? fun npow ->
        if logand cur 1L = 1L then
          acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc
        else step (shift_right_logical cur 1) npow acc
    in
    if m < 0L then error (Negative_multiplicator (t, m))
    else
      match step m t 0L with
      | Ok res ->
          Ok res
      | Error ([Addition_overflow _] as errs) ->
          Error (Multiplication_overflow (t, m) :: errs)
      | Error errs ->
          Error errs

  let ( /? ) t d =
    if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d)

  let add_exn t1 t2 =
    let t = Int64.add t1 t2 in
    if t <= 0L then invalid_arg "add_exn" else t

  let mul_exn t m =
    match t *? Int64.(of_int m) with
    | Ok v ->
        v
    | Error _ ->
        invalid_arg "mul_exn"

  let of_mutez t = if t < 0L then None else Some t

  let of_mutez_exn x =
    match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v

  let to_int64 t = t

  let to_mutez t = t

  let encoding =
    let open Data_encoding in
    check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)

  let () =
    let open Data_encoding in
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".addition_overflow")
      ~title:("Overflowing " ^ T.id ^ " addition")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Overflowing addition of %a %s and %a %s"
          pp
          opa
          T.id
          pp
          opb
          T.id)
      ~description:("An addition of two " ^ T.id ^ " amounts overflowed")
      (obj1 (req "amounts" (tup2 encoding encoding)))
      (function Addition_overflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Addition_overflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".subtraction_underflow")
      ~title:("Underflowing " ^ T.id ^ " subtraction")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Underflowing subtraction of %a %s and %a %s"
          pp
          opa
          T.id
          pp
          opb
          T.id)
      ~description:("An subtraction of two " ^ T.id ^ " amounts underflowed")
      (obj1 (req "amounts" (tup2 encoding encoding)))
      (function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Subtraction_underflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".multiplication_overflow")
      ~title:("Overflowing " ^ T.id ^ " multiplication")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Overflowing multiplication of %a %s and %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("A multiplication of a " ^ T.id ^ " amount by an integer overflowed")
      (obj2 (req "amount" encoding) (req "multiplicator" int64))
      (function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Multiplication_overflow (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".negative_multiplicator")
      ~title:("Negative " ^ T.id ^ " multiplicator")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Multiplication of %a %s by negative integer %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("Multiplication of a " ^ T.id ^ " amount by a negative integer")
      (obj2 (req "amount" encoding) (req "multiplicator" int64))
      (function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Negative_multiplicator (a, b)) ;
    register_error_kind
      `Temporary
      ~id:(T.id ^ ".invalid_divisor")
      ~title:("Invalid " ^ T.id ^ " divisor")
      ~pp:(fun ppf (opa, opb) ->
        Format.fprintf
          ppf
          "Division of %a %s by non positive integer %Ld"
          pp
          opa
          T.id
          opb)
      ~description:
        ("Multiplication of a " ^ T.id ^ " amount by a non positive integer")
      (obj2 (req "amount" encoding) (req "divisor" int64))
      (function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)
      (fun (a, b) -> Invalid_divisor (a, b))
end
src/proto_alpha/lib_protocol/qty_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module QTY.
  Record signature := {
    id : string;
  }.
End QTY.

Module S.
  Record signature {qty : Type} := {
    qty := qty;
    extensible_type;
    id : string;
    zero : qty;
    one_mutez : qty;
    one_cent : qty;
    fifty_cents : qty;
    one : qty;
    op_minusquestion : qty ->
      qty ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    op_plusquestion : qty ->
      qty ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    op_starquestion : qty ->
      int64 ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    op_divquestion : qty ->
      int64 ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult qty;
    to_mutez : qty -> int64;
    of_mutez : int64 -> option qty;
    of_mutez_exn : int64 -> qty;
    add_exn : qty -> qty -> qty;
    mul_exn : qty -> Z -> qty;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t qty;
    to_int64 : qty -> int64;
    include;
    pp : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
      qty -> unit;
    of_string : string -> option qty;
    to_string : qty -> string;
  }.
  Arguments signature : clear implicits.
End S.

(* ❌ Functors are not handled. *)
functor

src/proto_alpha/lib_protocol/raw_context.ml 85 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Int_set = Set.Make (Compare.Int)

type t = {
  context : Context.t;
  constants : Constants_repr.parametric;
  first_level : Raw_level_repr.t;
  level : Level_repr.t;
  predecessor_timestamp : Time.t;
  timestamp : Time.t;
  fitness : Int64.t;
  deposits : Tez_repr.t Signature.Public_key_hash.Map.t;
  included_endorsements : int;
  allowed_endorsements :
    (Signature.Public_key.t * int list * bool) Signature.Public_key_hash.Map.t;
  fees : Tez_repr.t;
  rewards : Tez_repr.t;
  block_gas : Z.t;
  operation_gas : Gas_limit_repr.t;
  internal_gas : Gas_limit_repr.internal_gas;
  storage_space_to_pay : Z.t option;
  allocated_contracts : int option;
  origination_nonce : Contract_repr.origination_nonce option;
  temporary_big_map : Z.t;
  internal_nonce : int;
  internal_nonces_used : Int_set.t;
}

type context = t

type root_context = t

let current_level ctxt = ctxt.level

let predecessor_timestamp ctxt = ctxt.predecessor_timestamp

let current_timestamp ctxt = ctxt.timestamp

let current_fitness ctxt = ctxt.fitness

let first_level ctxt = ctxt.first_level

let constants ctxt = ctxt.constants

let recover ctxt = ctxt.context

let record_endorsement ctxt k =
  match Signature.Public_key_hash.Map.find_opt k ctxt.allowed_endorsements with
  | None ->
      assert false
  | Some (_, _, true) ->
      assert false (* right already used *)
  | Some (d, s, false) ->
      {
        ctxt with
        included_endorsements = ctxt.included_endorsements + List.length s;
        allowed_endorsements =
          Signature.Public_key_hash.Map.add
            k
            (d, s, true)
            ctxt.allowed_endorsements;
      }

let init_endorsements ctxt allowed_endorsements =
  if Signature.Public_key_hash.Map.is_empty allowed_endorsements then
    assert false (* can't initialize to empty *)
  else if Signature.Public_key_hash.Map.is_empty ctxt.allowed_endorsements then
    {ctxt with allowed_endorsements}
  else assert false

(* can't initialize twice *)

let allowed_endorsements ctxt = ctxt.allowed_endorsements

let included_endorsements ctxt = ctxt.included_endorsements

type error += Too_many_internal_operations (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"too_many_internal_operations"
    ~title:"Too many internal operations"
    ~description:
      "A transaction exceeded the hard limit of internal operations it can emit"
    empty
    (function Too_many_internal_operations -> Some () | _ -> None)
    (fun () -> Too_many_internal_operations)

let fresh_internal_nonce ctxt =
  if Compare.Int.(ctxt.internal_nonce >= 65_535) then
    error Too_many_internal_operations
  else
    ok
      ( {ctxt with internal_nonce = ctxt.internal_nonce + 1},
        ctxt.internal_nonce )

let reset_internal_nonce ctxt =
  {ctxt with internal_nonces_used = Int_set.empty; internal_nonce = 0}

let record_internal_nonce ctxt k =
  {ctxt with internal_nonces_used = Int_set.add k ctxt.internal_nonces_used}

let internal_nonce_already_recorded ctxt k =
  Int_set.mem k ctxt.internal_nonces_used

let set_current_fitness ctxt fitness = {ctxt with fitness}

let add_fees ctxt fees =
  Lwt.return Tez_repr.(ctxt.fees +? fees)
  >>=? fun fees -> return {ctxt with fees}

let add_rewards ctxt rewards =
  Lwt.return Tez_repr.(ctxt.rewards +? rewards)
  >>=? fun rewards -> return {ctxt with rewards}

let add_deposit ctxt delegate deposit =
  let previous =
    match Signature.Public_key_hash.Map.find_opt delegate ctxt.deposits with
    | Some tz ->
        tz
    | None ->
        Tez_repr.zero
  in
  Lwt.return Tez_repr.(previous +? deposit)
  >>=? fun deposit ->
  let deposits =
    Signature.Public_key_hash.Map.add delegate deposit ctxt.deposits
  in
  return {ctxt with deposits}

let get_deposits ctxt = ctxt.deposits

let get_rewards ctxt = ctxt.rewards

let get_fees ctxt = ctxt.fees

type error += Undefined_operation_nonce (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"undefined_operation_nonce"
    ~title:"Ill timed access to the origination nonce"
    ~description:
      "An origination was attemped out of the scope of a manager operation"
    empty
    (function Undefined_operation_nonce -> Some () | _ -> None)
    (fun () -> Undefined_operation_nonce)

let init_origination_nonce ctxt operation_hash =
  let origination_nonce =
    Some (Contract_repr.initial_origination_nonce operation_hash)
  in
  {ctxt with origination_nonce}

let origination_nonce ctxt =
  match ctxt.origination_nonce with
  | None ->
      error Undefined_operation_nonce
  | Some origination_nonce ->
      ok origination_nonce

let increment_origination_nonce ctxt =
  match ctxt.origination_nonce with
  | None ->
      error Undefined_operation_nonce
  | Some cur_origination_nonce ->
      let origination_nonce =
        Some (Contract_repr.incr_origination_nonce cur_origination_nonce)
      in
      ok ({ctxt with origination_nonce}, cur_origination_nonce)

let unset_origination_nonce ctxt = {ctxt with origination_nonce = None}

type error += Gas_limit_too_high (* `Permanent *)

let () =
  let open Data_encoding in
  register_error_kind
    `Permanent
    ~id:"gas_limit_too_high"
    ~title:"Gas limit out of protocol hard bounds"
    ~description:"A transaction tried to exceed the hard limit on gas"
    empty
    (function Gas_limit_too_high -> Some () | _ -> None)
    (fun () -> Gas_limit_too_high)

let check_gas_limit ctxt remaining =
  if
    Compare.Z.(remaining > ctxt.constants.hard_gas_limit_per_operation)
    || Compare.Z.(remaining < Z.zero)
  then error Gas_limit_too_high
  else ok ()

let set_gas_limit ctxt remaining =
  {
    ctxt with
    operation_gas = Limited {remaining};
    internal_gas = Gas_limit_repr.internal_gas_zero;
  }

let set_gas_unlimited ctxt = {ctxt with operation_gas = Unaccounted}

let consume_gas ctxt cost =
  Gas_limit_repr.consume
    ctxt.block_gas
    ctxt.operation_gas
    ctxt.internal_gas
    cost
  >>? fun (block_gas, operation_gas, internal_gas) ->
  ok {ctxt with block_gas; operation_gas; internal_gas}

let check_enough_gas ctxt cost =
  Gas_limit_repr.check_enough
    ctxt.block_gas
    ctxt.operation_gas
    ctxt.internal_gas
    cost

let gas_level ctxt = ctxt.operation_gas

let block_gas_level ctxt = ctxt.block_gas

let gas_consumed ~since ~until =
  match (gas_level since, gas_level until) with
  | (Limited {remaining = before}, Limited {remaining = after}) ->
      Z.sub before after
  | (_, _) ->
      Z.zero

let init_storage_space_to_pay ctxt =
  match ctxt.storage_space_to_pay with
  | Some _ ->
      assert false
  | None ->
      {
        ctxt with
        storage_space_to_pay = Some Z.zero;
        allocated_contracts = Some 0;
      }

let update_storage_space_to_pay ctxt n =
  match ctxt.storage_space_to_pay with
  | None ->
      assert false
  | Some storage_space_to_pay ->
      {ctxt with storage_space_to_pay = Some (Z.add n storage_space_to_pay)}

let update_allocated_contracts_count ctxt =
  match ctxt.allocated_contracts with
  | None ->
      assert false
  | Some allocated_contracts ->
      {ctxt with allocated_contracts = Some (succ allocated_contracts)}

let clear_storage_space_to_pay ctxt =
  match (ctxt.storage_space_to_pay, ctxt.allocated_contracts) with
  | (None, _) | (_, None) ->
      assert false
  | (Some storage_space_to_pay, Some allocated_contracts) ->
      ( {ctxt with storage_space_to_pay = None; allocated_contracts = None},
        storage_space_to_pay,
        allocated_contracts )

type storage_error =
  | Incompatible_protocol_version of string
  | Missing_key of string list * [`Get | `Set | `Del | `Copy]
  | Existing_key of string list
  | Corrupted_data of string list

let storage_error_encoding =
  let open Data_encoding in
  union
    [ case
        (Tag 0)
        ~title:"Incompatible_protocol_version"
        (obj1 (req "incompatible_protocol_version" string))
        (function Incompatible_protocol_version arg -> Some arg | _ -> None)
        (fun arg -> Incompatible_protocol_version arg);
      case
        (Tag 1)
        ~title:"Missing_key"
        (obj2
           (req "missing_key" (list string))
           (req
              "function"
              (string_enum
                 [("get", `Get); ("set", `Set); ("del", `Del); ("copy", `Copy)])))
        (function Missing_key (key, f) -> Some (key, f) | _ -> None)
        (fun (key, f) -> Missing_key (key, f));
      case
        (Tag 2)
        ~title:"Existing_key"
        (obj1 (req "existing_key" (list string)))
        (function Existing_key key -> Some key | _ -> None)
        (fun key -> Existing_key key);
      case
        (Tag 3)
        ~title:"Corrupted_data"
        (obj1 (req "corrupted_data" (list string)))
        (function Corrupted_data key -> Some key | _ -> None)
        (fun key -> Corrupted_data key) ]

let pp_storage_error ppf = function
  | Incompatible_protocol_version version ->
      Format.fprintf
        ppf
        "Found a context with an unexpected version '%s'."
        version
  | Missing_key (key, `Get) ->
      Format.fprintf ppf "Missing key '%s'." (String.concat "/" key)
  | Missing_key (key, `Set) ->
      Format.fprintf
        ppf
        "Cannot set undefined key '%s'."
        (String.concat "/" key)
  | Missing_key (key, `Del) ->
      Format.fprintf
        ppf
        "Cannot delete undefined key '%s'."
        (String.concat "/" key)
  | Missing_key (key, `Copy) ->
      Format.fprintf
        ppf
        "Cannot copy undefined key '%s'."
        (String.concat "/" key)
  | Existing_key key ->
      Format.fprintf
        ppf
        "Cannot initialize defined key '%s'."
        (String.concat "/" key)
  | Corrupted_data key ->
      Format.fprintf
        ppf
        "Failed to parse the data at '%s'."
        (String.concat "/" key)

type error += Storage_error of storage_error

let () =
  register_error_kind
    `Permanent
    ~id:"context.storage_error"
    ~title:"Storage error (fatal internal error)"
    ~description:
      "An error that should never happen unless something has been deleted or \
       corrupted in the database."
    ~pp:(fun ppf err ->
      Format.fprintf ppf "@[<v 2>Storage error:@ %a@]" pp_storage_error err)
    storage_error_encoding
    (function Storage_error err -> Some err | _ -> None)
    (fun err -> Storage_error err)

let storage_error err = fail (Storage_error err)

(* Initialization *********************************************************)

(* This key should always be populated for every version of the
   protocol.  It's absence meaning that the context is empty. *)
let version_key = ["version"]

let version_value = "alpha_current"

let version = "v1"

let first_level_key = [version; "first_level"]

let constants_key = [version; "constants"]

let protocol_param_key = ["protocol_parameters"]

let get_first_level ctxt =
  Context.get ctxt first_level_key
  >>= function
  | None ->
      storage_error (Missing_key (first_level_key, `Get))
  | Some bytes -> (
    match Data_encoding.Binary.of_bytes Raw_level_repr.encoding bytes with
    | None ->
        storage_error (Corrupted_data first_level_key)
    | Some level ->
        return level )

let set_first_level ctxt level =
  let bytes =
    Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level
  in
  Context.set ctxt first_level_key bytes >>= fun ctxt -> return ctxt

type error += Failed_to_parse_parameter of MBytes.t

type error += Failed_to_decode_parameter of Data_encoding.json * string

let () =
  register_error_kind
    `Temporary
    ~id:"context.failed_to_parse_parameter"
    ~title:"Failed to parse parameter"
    ~description:"The protocol parameters are not valid JSON."
    ~pp:(fun ppf bytes ->
      Format.fprintf
        ppf
        "@[<v 2>Cannot parse the protocol parameter:@ %s@]"
        (MBytes.to_string bytes))
    Data_encoding.(obj1 (req "contents" bytes))
    (function Failed_to_parse_parameter data -> Some data | _ -> None)
    (fun data -> Failed_to_parse_parameter data) ;
  register_error_kind
    `Temporary
    ~id:"context.failed_to_decode_parameter"
    ~title:"Failed to decode parameter"
    ~description:"Unexpected JSON object."
    ~pp:(fun ppf (json, msg) ->
      Format.fprintf
        ppf
        "@[<v 2>Cannot decode the protocol parameter:@ %s@ %a@]"
        msg
        Data_encoding.Json.pp
        json)
    Data_encoding.(obj2 (req "contents" json) (req "error" string))
    (function
      | Failed_to_decode_parameter (json, msg) -> Some (json, msg) | _ -> None)
    (fun (json, msg) -> Failed_to_decode_parameter (json, msg))

let get_proto_param ctxt =
  Context.get ctxt protocol_param_key
  >>= function
  | None ->
      failwith "Missing protocol parameters."
  | Some bytes -> (
    match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
    | None ->
        fail (Failed_to_parse_parameter bytes)
    | Some json -> (
        Context.del ctxt protocol_param_key
        >>= fun ctxt ->
        match Data_encoding.Json.destruct Parameters_repr.encoding json with
        | exception (Data_encoding.Json.Cannot_destruct _ as exn) ->
            Format.kasprintf
              failwith
              "Invalid protocol_parameters: %a %a"
              (fun ppf -> Data_encoding.Json.print_error ppf)
              exn
              Data_encoding.Json.pp
              json
        | param ->
            return (param, ctxt) ) )

let set_constants ctxt constants =
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Constants_repr.parametric_encoding
      constants
  in
  Context.set ctxt constants_key bytes

let get_constants ctxt =
  Context.get ctxt constants_key
  >>= function
  | None ->
      failwith "Internal error: cannot read constants in context."
  | Some bytes -> (
    match
      Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding bytes
    with
    | None ->
        failwith "Internal error: cannot parse constants in context."
    | Some constants ->
        return constants )

let patch_constants ctxt f =
  let constants = f ctxt.constants in
  set_constants ctxt.context constants
  >>= fun context -> Lwt.return {ctxt with context; constants}

let check_inited ctxt =
  Context.get ctxt version_key
  >>= function
  | None ->
      failwith "Internal error: un-initialized context."
  | Some bytes ->
      let s = MBytes.to_string bytes in
      if Compare.String.(s = version_value) then return_unit
      else storage_error (Incompatible_protocol_version s)

let prepare ~level ~predecessor_timestamp ~timestamp ~fitness ctxt =
  Lwt.return (Raw_level_repr.of_int32 level)
  >>=? fun level ->
  Lwt.return (Fitness_repr.to_int64 fitness)
  >>=? fun fitness ->
  check_inited ctxt
  >>=? fun () ->
  get_constants ctxt
  >>=? fun constants ->
  get_first_level ctxt
  >>=? fun first_level ->
  let level =
    Level_repr.from_raw
      ~first_level
      ~blocks_per_cycle:constants.Constants_repr.blocks_per_cycle
      ~blocks_per_voting_period:
        constants.Constants_repr.blocks_per_voting_period
      ~blocks_per_commitment:constants.Constants_repr.blocks_per_commitment
      level
  in
  return
    {
      context = ctxt;
      constants;
      level;
      predecessor_timestamp;
      timestamp;
      fitness;
      first_level;
      allowed_endorsements = Signature.Public_key_hash.Map.empty;
      included_endorsements = 0;
      fees = Tez_repr.zero;
      rewards = Tez_repr.zero;
      deposits = Signature.Public_key_hash.Map.empty;
      operation_gas = Unaccounted;
      internal_gas = Gas_limit_repr.internal_gas_zero;
      storage_space_to_pay = None;
      allocated_contracts = None;
      block_gas = constants.Constants_repr.hard_gas_limit_per_block;
      origination_nonce = None;
      temporary_big_map = Z.sub Z.zero Z.one;
      internal_nonce = 0;
      internal_nonces_used = Int_set.empty;
    }

type previous_protocol = Genesis of Parameters_repr.t | Alpha_previous

let check_and_update_protocol_version ctxt =
  Context.get ctxt version_key
  >>= (function
        | None ->
            failwith
              "Internal error: un-initialized context in check_first_block."
        | Some bytes ->
            let s = MBytes.to_string bytes in
            if Compare.String.(s = version_value) then
              failwith "Internal error: previously initialized context."
            else if Compare.String.(s = "genesis") then
              get_proto_param ctxt
              >>=? fun (param, ctxt) -> return (Genesis param, ctxt)
            else if Compare.String.(s = "alpha_previous") then
              return (Alpha_previous, ctxt)
            else storage_error (Incompatible_protocol_version s))
  >>=? fun (previous_proto, ctxt) ->
  Context.set ctxt version_key (MBytes.of_string version_value)
  >>= fun ctxt -> return (previous_proto, ctxt)

let prepare_first_block ~level ~timestamp ~fitness ctxt =
  check_and_update_protocol_version ctxt
  >>=? fun (previous_proto, ctxt) ->
  ( match previous_proto with
  | Genesis param ->
      Lwt.return (Raw_level_repr.of_int32 level)
      >>=? fun first_level ->
      set_first_level ctxt first_level
      >>=? fun ctxt ->
      set_constants ctxt param.constants >>= fun ctxt -> return ctxt
  | Alpha_previous ->
      return ctxt )
  >>=? fun ctxt ->
  prepare ctxt ~level ~predecessor_timestamp:timestamp ~timestamp ~fitness
  >>=? fun ctxt -> return (previous_proto, ctxt)

let activate ({context = c; _} as s) h =
  Updater.activate c h >>= fun c -> Lwt.return {s with context = c}

let fork_test_chain ({context = c; _} as s) protocol expiration =
  Updater.fork_test_chain c ~protocol ~expiration
  >>= fun c -> Lwt.return {s with context = c}

(* Generic context ********************************************************)

type key = string list

type value = MBytes.t

module type T = sig
  type t

  type context = t

  val mem : context -> key -> bool Lwt.t

  val dir_mem : context -> key -> bool Lwt.t

  val get : context -> key -> value tzresult Lwt.t

  val get_option : context -> key -> value option Lwt.t

  val init : context -> key -> value -> context tzresult Lwt.t

  val set : context -> key -> value -> context tzresult Lwt.t

  val init_set : context -> key -> value -> context Lwt.t

  val set_option : context -> key -> value option -> context Lwt.t

  val delete : context -> key -> context tzresult Lwt.t

  val remove : context -> key -> context Lwt.t

  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  val fold :
    context ->
    key ->
    init:'a ->
    f:([`Key of key | `Dir of key] -> 'a -> 'a Lwt.t) ->
    'a Lwt.t

  val keys : context -> key -> key list Lwt.t

  val fold_keys :
    context -> key -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val project : context -> root_context

  val absolute_key : context -> key -> key

  val consume_gas : context -> Gas_limit_repr.cost -> context tzresult

  val check_enough_gas : context -> Gas_limit_repr.cost -> unit tzresult

  val description : context Storage_description.t
end

let mem ctxt k = Context.mem ctxt.context k

let dir_mem ctxt k = Context.dir_mem ctxt.context k

let get ctxt k =
  Context.get ctxt.context k
  >>= function
  | None -> storage_error (Missing_key (k, `Get)) | Some v -> return v

let get_option ctxt k = Context.get ctxt.context k

(* Verify that the k is present before modifying *)
let set ctxt k v =
  Context.mem ctxt.context k
  >>= function
  | false ->
      storage_error (Missing_key (k, `Set))
  | true ->
      Context.set ctxt.context k v
      >>= fun context -> return {ctxt with context}

(* Verify that the k is not present before inserting *)
let init ctxt k v =
  Context.mem ctxt.context k
  >>= function
  | true ->
      storage_error (Existing_key k)
  | false ->
      Context.set ctxt.context k v
      >>= fun context -> return {ctxt with context}

(* Does not verify that the key is present or not *)
let init_set ctxt k v =
  Context.set ctxt.context k v
  >>= fun context -> Lwt.return {ctxt with context}

(* Verify that the key is present before deleting *)
let delete ctxt k =
  Context.mem ctxt.context k
  >>= function
  | false ->
      storage_error (Missing_key (k, `Del))
  | true ->
      Context.del ctxt.context k >>= fun context -> return {ctxt with context}

(* Do not verify before deleting *)
let remove ctxt k =
  Context.del ctxt.context k >>= fun context -> Lwt.return {ctxt with context}

let set_option ctxt k = function
  | None ->
      remove ctxt k
  | Some v ->
      init_set ctxt k v

let remove_rec ctxt k =
  Context.remove_rec ctxt.context k
  >>= fun context -> Lwt.return {ctxt with context}

let copy ctxt ~from ~to_ =
  Context.copy ctxt.context ~from ~to_
  >>= function
  | None ->
      storage_error (Missing_key (from, `Copy))
  | Some context ->
      return {ctxt with context}

let fold ctxt k ~init ~f = Context.fold ctxt.context k ~init ~f

let keys ctxt k = Context.keys ctxt.context k

let fold_keys ctxt k ~init ~f = Context.fold_keys ctxt.context k ~init ~f

let project x = x

let absolute_key _ k = k

let description = Storage_description.create ()

let fresh_temporary_big_map ctxt =
  ( {ctxt with temporary_big_map = Z.sub ctxt.temporary_big_map Z.one},
    ctxt.temporary_big_map )

let reset_temporary_big_map ctxt =
  {ctxt with temporary_big_map = Z.sub Z.zero Z.one}

let temporary_big_maps ctxt f acc =
  let rec iter acc id =
    if Z.equal id ctxt.temporary_big_map then Lwt.return acc
    else f acc id >>= fun acc -> iter acc (Z.sub id Z.one)
  in
  iter acc (Z.sub Z.zero Z.one)
src/proto_alpha/lib_protocol/raw_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

Record t := {
  context : Tezos_protocol_environment_alpha__Environment.Context.t;
  constants : Tezos_raw_protocol_alpha.Constants_repr.parametric;
  first_level : Tezos_raw_protocol_alpha.Raw_level_repr.t;
  level : Tezos_raw_protocol_alpha.Level_repr.t;
  predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t;
  timestamp : Tezos_protocol_environment_alpha__Environment.Time.t;
  fitness : Tezos_protocol_environment_alpha__Environment.Int64.t;
  deposits :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      Tezos_raw_protocol_alpha.Tez_repr.t;
  included_endorsements : Z;
  allowed_endorsements :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool);
  fees : Tezos_raw_protocol_alpha.Tez_repr.t;
  rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
  block_gas : Tezos_protocol_environment_alpha__Environment.Z.t;
  operation_gas : Tezos_raw_protocol_alpha.Gas_limit_repr.t;
  internal_gas : Tezos_raw_protocol_alpha.Gas_limit_repr.internal_gas;
  storage_space_to_pay :
    option Tezos_protocol_environment_alpha__Environment.Z.t;
  allocated_contracts : option Z;
  origination_nonce :
    option Tezos_raw_protocol_alpha.Contract_repr.origination_nonce;
  temporary_big_map : Tezos_protocol_environment_alpha__Environment.Z.t;
  internal_nonce : Z;
  internal_nonces_used :
    Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.t) }.

Definition context := t.

Definition root_context := t.

Definition current_level (ctxt : t) : Tezos_raw_protocol_alpha.Level_repr.t :=
  level ctxt.

Definition predecessor_timestamp (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Time.t :=
  predecessor_timestamp ctxt.

Definition current_timestamp (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Time.t := timestamp ctxt.

Definition current_fitness (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Int64.t := fitness ctxt.

Definition first_level (ctxt : t) : Tezos_raw_protocol_alpha.Raw_level_repr.t :=
  first_level ctxt.

Definition constants (ctxt : t)
  : Tezos_raw_protocol_alpha.Constants_repr.parametric := constants ctxt.

Definition recover (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Context.t := context ctxt.

Definition record_endorsement
  (ctxt : t)
  (k :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key)
  : t :=
  match Signature.Public_key_hash.Map.find_opt k (allowed_endorsements ctxt)
    with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some (_, _, true) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some (d, s, false) =>
    (* ❌ Record substitution not handled *)
    record_substitution
  end.

Definition init_endorsements
  (ctxt : t)
  (allowed_endorsements :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
        (list Z) * bool)) : t :=
  if Signature.Public_key_hash.Map.is_empty allowed_endorsements then
    (* ❌ Assert instruction is not handled. *)
    assert false
  else
    if Signature.Public_key_hash.Map.is_empty (allowed_endorsements ctxt) then
      (* ❌ Record substitution not handled *)
      record_substitution
    else
      (* ❌ Assert instruction is not handled. *)
      assert false.

Definition allowed_endorsements (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    (Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t *
      (list Z) * bool) := allowed_endorsements ctxt.

Definition included_endorsements (ctxt : t) : Z := included_endorsements ctxt.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition fresh_internal_nonce (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (t * Z) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      (internal_nonce ctxt) 65535 then
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Too_many_internal_operations
  else
    ok
      ((* ❌ Record substitution not handled *)
      record_substitution, (internal_nonce ctxt)).

Definition reset_internal_nonce (ctxt : t) : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition record_internal_nonce
  (ctxt : t)
  (k : Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.elt)) : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition internal_nonce_already_recorded
  (ctxt : t)
  (k : Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.elt))
  : bool :=
  Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.mem) k
    (internal_nonces_used ctxt).

Definition set_current_fitness
  (ctxt : t) (fitness : Tezos_protocol_environment_alpha__Environment.Int64.t)
  : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition add_fees (ctxt : t) (fees : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteqquestion (Lwt._return (op_plusquestion (fees ctxt) fees))
    (fun fees =>
      _return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition add_rewards
  (ctxt : t) (rewards : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteqquestion (Lwt._return (op_plusquestion (rewards ctxt) rewards))
    (fun rewards =>
      _return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition add_deposit
  (ctxt : t)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.key)
  (deposit : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  let previous :=
    match Signature.Public_key_hash.Map.find_opt delegate (deposits ctxt) with
    | Some tz => tz
    | None => Tez_repr.zero
    end in
  op_gtgteqquestion (Lwt._return (op_plusquestion previous deposit))
    (fun deposit =>
      let deposits :=
        Signature.Public_key_hash.Map.add delegate deposit (deposits ctxt) in
      _return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition get_deposits (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.Map.t
    Tezos_raw_protocol_alpha.Tez_repr.t := deposits ctxt.

Definition get_rewards (ctxt : t) : Tezos_raw_protocol_alpha.Tez_repr.t :=
  rewards ctxt.

Definition get_fees (ctxt : t) : Tezos_raw_protocol_alpha.Tez_repr.t :=
  fees ctxt.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition init_origination_nonce
  (ctxt : t)
  (operation_hash :
    Tezos_protocol_environment_alpha__Environment.Operation_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : t :=
  let origination_nonce :=
    Some (Contract_repr.initial_origination_nonce operation_hash) in
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition origination_nonce (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Contract_repr.origination_nonce :=
  match origination_nonce ctxt with
  | None =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_operation_nonce
  | Some origination_nonce => ok origination_nonce
  end.

Definition increment_origination_nonce (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (t * Tezos_raw_protocol_alpha.Contract_repr.origination_nonce) :=
  match origination_nonce ctxt with
  | None =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_operation_nonce
  | Some cur_origination_nonce =>
    let origination_nonce :=
      Some (Contract_repr.incr_origination_nonce cur_origination_nonce) in
    ok
      ((* ❌ Record substitution not handled *)
      record_substitution, cur_origination_nonce)
  end.

Definition unset_origination_nonce (ctxt : t) : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition check_gas_limit
  (ctxt : t)
  (remaining :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  if
    op_pipepipe
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        remaining (hard_gas_limit_per_operation (constants ctxt)))
      (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
        remaining Z.zero) then
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Gas_limit_too_high
  else
    ok tt.

Definition set_gas_limit
  (ctxt : t) (remaining : Tezos_protocol_environment_alpha__Environment.Z.t)
  : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition set_gas_unlimited (ctxt : t) : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition consume_gas
  (ctxt : t) (cost : Tezos_raw_protocol_alpha.Gas_limit_repr.cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
  op_gtgtquestion
    (Gas_limit_repr.consume (block_gas ctxt) (operation_gas ctxt)
      (internal_gas ctxt) cost)
    (fun function_parameter =>
      let '(block_gas, operation_gas, internal_gas) := function_parameter in
      ok
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition check_enough_gas
  (ctxt : t) (cost : Tezos_raw_protocol_alpha.Gas_limit_repr.cost)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  Gas_limit_repr.check_enough (block_gas ctxt) (operation_gas ctxt)
    (internal_gas ctxt) cost.

Definition gas_level (ctxt : t) : Tezos_raw_protocol_alpha.Gas_limit_repr.t :=
  operation_gas ctxt.

Definition block_gas_level (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := block_gas ctxt.

Definition gas_consumed (since : t) (until : t)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  match ((gas_level since), (gas_level until)) with
  |
    (Tezos_raw_protocol_alpha.Gas_limit_repr.Limited {| remaining := before |},
      Tezos_raw_protocol_alpha.Gas_limit_repr.Limited {| remaining := after |})
    => Z.sub before after
  | (_, _) => Z.zero
  end.

Definition init_storage_space_to_pay (ctxt : t) : t :=
  match storage_space_to_pay ctxt with
  | Some _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | None =>
    (* ❌ Record substitution not handled *)
    record_substitution
  end.

Definition update_storage_space_to_pay
  (ctxt : t) (n : Tezos_protocol_environment_alpha__Environment.Z.t) : t :=
  match storage_space_to_pay ctxt with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some storage_space_to_pay =>
    (* ❌ Record substitution not handled *)
    record_substitution
  end.

Definition update_allocated_contracts_count (ctxt : t) : t :=
  match allocated_contracts ctxt with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some allocated_contracts =>
    (* ❌ Record substitution not handled *)
    record_substitution
  end.

Definition clear_storage_space_to_pay (ctxt : t)
  : t * Tezos_protocol_environment_alpha__Environment.Z.t * Z :=
  match ((storage_space_to_pay ctxt), (allocated_contracts ctxt)) with
  | (None, _) | (_, None) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | (Some storage_space_to_pay, Some allocated_contracts) =>
    ((* ❌ Record substitution not handled *)
    record_substitution, storage_space_to_pay, allocated_contracts)
  end.

Inductive storage_error : Type :=
| Incompatible_protocol_version : string -> storage_error
| Missing_key : (list string) -> variant -> storage_error
| Existing_key : (list string) -> storage_error
| Corrupted_data : (list string) -> storage_error.

Definition storage_error_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    storage_error :=
  union None
    (cons
      (case "Incompatible_protocol_version" % string None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
        (obj1 (req None None "incompatible_protocol_version" % string string))
        (fun function_parameter =>
          match function_parameter with
          | Incompatible_protocol_version arg => Some arg
          | _ => None
          end) (fun arg => Incompatible_protocol_version arg))
      (cons
        (case "Missing_key" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
          (obj2 (req None None "missing_key" % string (list None string))
            (req None None "function" % string
              (string_enum
                (cons
                  ("get" % string,
                    (* ❌ Variants not supported *)
                    variant)
                  (cons
                    ("set" % string,
                      (* ❌ Variants not supported *)
                      variant)
                    (cons
                      ("del" % string,
                        (* ❌ Variants not supported *)
                        variant)
                      (cons
                        ("copy" % string,
                          (* ❌ Variants not supported *)
                          variant) [])))))))
          (fun function_parameter =>
            match function_parameter with
            | Missing_key key f => Some (key, f)
            | _ => None
            end)
          (fun function_parameter =>
            let '(key, f) := function_parameter in
            Missing_key key f))
        (cons
          (case "Existing_key" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
            (obj1 (req None None "existing_key" % string (list None string)))
            (fun function_parameter =>
              match function_parameter with
              | Existing_key key => Some key
              | _ => None
              end) (fun key => Existing_key key))
          (cons
            (case "Corrupted_data" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 3)
              (obj1 (req None None "corrupted_data" % string (list None string)))
              (fun function_parameter =>
                match function_parameter with
                | Corrupted_data key => Some key
                | _ => None
                end) (fun key => Corrupted_data key)) [])))).

Definition pp_storage_error
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : storage_error) : unit :=
  match function_parameter with
  | Incompatible_protocol_version version =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Found a context with an unexpected version '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Found a context with an unexpected version '%s'." % string) version
  | Missing_key key Get =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Missing key '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Missing key '%s'." % string) (String.concat "/" % string key)
  | Missing_key key Set =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Cannot set undefined key '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Cannot set undefined key '%s'." % string)
      (String.concat "/" % string key)
  | Missing_key key Del =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Cannot delete undefined key '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Cannot delete undefined key '%s'." % string)
      (String.concat "/" % string key)
  | Missing_key key Copy =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Cannot copy undefined key '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Cannot copy undefined key '%s'." % string)
      (String.concat "/" % string key)
  | Existing_key key =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Cannot initialize defined key '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Cannot initialize defined key '%s'." % string)
      (String.concat "/" % string key)
  | Corrupted_data key =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Failed to parse the data at '" % string
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "'." % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "Failed to parse the data at '%s'." % string)
      (String.concat "/" % string key)
  end.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition storage_error {A : Type} (err : storage_error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  fail
    (Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_error err).

Definition version_key : list string := cons "version" % string [].

Definition version_value : string := "alpha_current" % string.

Definition version : string := "v1" % string.

Definition first_level_key : list string :=
  cons version (cons "first_level" % string []).

Definition constants_key : list string :=
  cons version (cons "constants" % string []).

Definition protocol_param_key : list string :=
  cons "protocol_parameters" % string [].

Definition get_first_level
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_level_repr.raw_level) :=
  op_gtgteq (Context.get ctxt first_level_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        storage_error
          (Missing_key first_level_key
            (* ❌ Variants not supported *)
            variant)
      | Some bytes =>
        match Data_encoding.Binary.of_bytes Raw_level_repr.encoding string with
        | None => storage_error (Corrupted_data first_level_key)
        | Some level => _return level
        end
      end).

Definition set_first_level
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (level : Tezos_raw_protocol_alpha.Raw_level_repr.raw_level)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Context.t) :=
  let bytes := Data_encoding.Binary.to_bytes_exn Raw_level_repr.encoding level
    in
  op_gtgteq (Context.set ctxt first_level_key string) (fun ctxt => _return ctxt).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition get_proto_param
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Parameters_repr.t *
        Tezos_protocol_environment_alpha__Environment.Context.t)) :=
  op_gtgteq (Context.get ctxt protocol_param_key)
    (fun function_parameter =>
      match function_parameter with
      | None => failwith "Missing protocol parameters." % string
      | Some bytes =>
        match Data_encoding.Binary.of_bytes Data_encoding.json string with
        | None =>
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Failed_to_parse_parameter
              string)
        | Some json =>
          op_gtgteq (Context.del ctxt protocol_param_key)
            (fun ctxt =>
              let 'param :=
                Data_encoding.Json.destruct Parameters_repr.encoding json in
              _return (param, ctxt))
        end
      end).

Definition set_constants
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  (constants : Tezos_raw_protocol_alpha.Constants_repr.parametric)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    Tezos_protocol_environment_alpha__Environment.Context.t :=
  let bytes :=
    Data_encoding.Binary.to_bytes_exn Constants_repr.parametric_encoding
      constants in
  Context.set ctxt constants_key string.

Definition get_constants
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Constants_repr.parametric) :=
  op_gtgteq (Context.get ctxt constants_key)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        failwith "Internal error: cannot read constants in context." % string
      | Some bytes =>
        match
          Data_encoding.Binary.of_bytes Constants_repr.parametric_encoding
            string with
        | None =>
          failwith "Internal error: cannot parse constants in context." % string
        | Some constants => _return constants
        end
      end).

Definition patch_constants
  (ctxt : t)
  (f :
    Tezos_raw_protocol_alpha.Constants_repr.parametric ->
      Tezos_raw_protocol_alpha.Constants_repr.parametric)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  let constants := f (constants ctxt) in
  op_gtgteq (set_constants (context ctxt) constants)
    (fun context =>
      Lwt._return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition check_inited
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  op_gtgteq (Context.get ctxt version_key)
    (fun function_parameter =>
      match function_parameter with
      | None => failwith "Internal error: un-initialized context." % string
      | Some bytes =>
        let s := MBytes.to_string string in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            s version_value then
          return_unit
        else
          storage_error (Incompatible_protocol_version s)
      end).

Definition prepare
  (level : int32)
  (predecessor_timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness : list Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteqquestion (Lwt._return (Raw_level_repr.of_int32 level))
    (fun level =>
      op_gtgteqquestion (Lwt._return (Fitness_repr.to_int64 fitness))
        (fun fitness =>
          op_gtgteqquestion (check_inited ctxt)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (get_constants ctxt)
                (fun constants =>
                  op_gtgteqquestion (get_first_level ctxt)
                    (fun first_level =>
                      let level :=
                        Level_repr.from_raw first_level
                          (Constants_repr.blocks_per_cycle constants)
                          (Constants_repr.blocks_per_voting_period constants)
                          (Constants_repr.blocks_per_commitment constants) level
                        in
                      _return
                        {| context := ctxt; constants := constants;
                          first_level := first_level; level := level;
                          predecessor_timestamp := predecessor_timestamp;
                          timestamp := timestamp; fitness := fitness;
                          deposits := Signature.Public_key_hash.Map.empty;
                          included_endorsements := 0;
                          allowed_endorsements :=
                            Signature.Public_key_hash.Map.empty;
                          fees := Tez_repr.zero; rewards := Tez_repr.zero;
                          block_gas :=
                            Constants_repr.hard_gas_limit_per_block constants;
                          operation_gas :=
                            Tezos_raw_protocol_alpha.Gas_limit_repr.Unaccounted;
                          internal_gas := Gas_limit_repr.internal_gas_zero;
                          storage_space_to_pay := None;
                          allocated_contracts := None;
                          origination_nonce := None;
                          temporary_big_map := Z.sub Z.zero Z.one;
                          internal_nonce := 0;
                          internal_nonces_used :=
                            Int_set.(Tezos_protocol_environment_alpha__Environment.SET.S.empty)
                          |}))))).

Inductive previous_protocol : Type :=
| Genesis : Tezos_raw_protocol_alpha.Parameters_repr.t -> previous_protocol
| Alpha_previous : previous_protocol.

Definition check_and_update_protocol_version
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (previous_protocol *
        Tezos_protocol_environment_alpha__Environment.Context.t)) :=
  op_gtgteqquestion
    (op_gtgteq (Context.get ctxt version_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          failwith
            "Internal error: un-initialized context in check_first_block." %
              string
        | Some bytes =>
          let s := MBytes.to_string string in
          if
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              s version_value then
            failwith "Internal error: previously initialized context." % string
          else
            if
              Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                s "genesis" % string then
              op_gtgteqquestion (get_proto_param ctxt)
                (fun function_parameter =>
                  let '(param, ctxt) := function_parameter in
                  _return ((Genesis param), ctxt))
            else
              if
                Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  s "alpha_previous" % string then
                _return (Alpha_previous, ctxt)
              else
                storage_error (Incompatible_protocol_version s)
        end))
    (fun function_parameter =>
      let '(previous_proto, ctxt) := function_parameter in
      op_gtgteq (Context.set ctxt version_key (MBytes.of_string version_value))
        (fun ctxt => _return (previous_proto, ctxt))).

Definition prepare_first_block
  (level : int32)
  (timestamp : Tezos_protocol_environment_alpha__Environment.Time.t)
  (fitness : list Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (ctxt : Tezos_protocol_environment_alpha__Environment.Context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (previous_protocol * t)) :=
  op_gtgteqquestion (check_and_update_protocol_version ctxt)
    (fun function_parameter =>
      let '(previous_proto, ctxt) := function_parameter in
      op_gtgteqquestion
        match previous_proto with
        | Genesis param =>
          op_gtgteqquestion (Lwt._return (Raw_level_repr.of_int32 level))
            (fun first_level =>
              op_gtgteqquestion (set_first_level ctxt first_level)
                (fun ctxt =>
                  op_gtgteq (set_constants ctxt (constants param))
                    (fun ctxt => _return ctxt)))
        | Alpha_previous => _return ctxt
        end
        (fun ctxt =>
          op_gtgteqquestion (prepare level timestamp timestamp fitness ctxt)
            (fun ctxt => _return (previous_proto, ctxt)))).

Definition activate (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    -> Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  let '{| context := c |} as s := function_parameter in
  fun h =>
    op_gtgteq (Updater.activate c h)
      (fun c =>
        Lwt._return
          (* ❌ Record substitution not handled *)
          record_substitution).

Definition fork_test_chain (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_alpha__Environment.Time.t ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  let '{| context := c |} as s := function_parameter in
  fun protocol =>
    fun expiration =>
      op_gtgteq (Updater.fork_test_chain c protocol expiration)
        (fun c =>
          Lwt._return
            (* ❌ Record substitution not handled *)
            record_substitution).

Definition key := list string.

Definition value := Tezos_protocol_environment_alpha__Environment.MBytes.t.

Module T.
  Record signature {t : Type} := {
    t := t;
    context := t;
    mem : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    dir_mem : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    get : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            value);
    get_option : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t (option value);
    init : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    init_set : context ->
      key ->
        value -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    set_option : context ->
      key ->
        (option value) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    delete : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            context);
    remove : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    remove_rec : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    copy : context ->
      key ->
        key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    fold : forall {a variant : Type}, context ->
      key ->
        a ->
          (variant -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a)
            -> Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    keys : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    fold_keys : forall {a : Type}, context ->
      key ->
        a ->
          (key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    project : context -> root_context;
    absolute_key : context -> key -> key;
    consume_gas : context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          context;
    check_enough_gas : context ->
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit;
    description : Tezos_raw_protocol_alpha.Storage_description.t context;
  }.
  Arguments signature : clear implicits.
End T.

Definition mem
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Context.mem (context ctxt) k.

Definition dir_mem
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Context.dir_mem (context ctxt) k.

Definition get
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Context.value) :=
  op_gtgteq (Context.get (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        storage_error
          (Missing_key k
            (* ❌ Variants not supported *)
            variant)
      | Some v => _return v
      end).

Definition get_option
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (option Tezos_protocol_environment_alpha__Environment.Context.value) :=
  Context.get (context ctxt) k.

Definition set
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (v : Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteq (Context.mem (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | false =>
        storage_error
          (Missing_key k
            (* ❌ Variants not supported *)
            variant)
      | true =>
        op_gtgteq (Context.set (context ctxt) k v)
          (fun context =>
            _return
              (* ❌ Record substitution not handled *)
              record_substitution)
      end).

Definition init
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (v : Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteq (Context.mem (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | true => storage_error (Existing_key k)
      | false =>
        op_gtgteq (Context.set (context ctxt) k v)
          (fun context =>
            _return
              (* ❌ Record substitution not handled *)
              record_substitution)
      end).

Definition init_set
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (v : Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  op_gtgteq (Context.set (context ctxt) k v)
    (fun context =>
      Lwt._return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition delete
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteq (Context.mem (context ctxt) k)
    (fun function_parameter =>
      match function_parameter with
      | false =>
        storage_error
          (Missing_key k
            (* ❌ Variants not supported *)
            variant)
      | true =>
        op_gtgteq (Context.del (context ctxt) k)
          (fun context =>
            _return
              (* ❌ Record substitution not handled *)
              record_substitution)
      end).

Definition remove
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  op_gtgteq (Context.del (context ctxt) k)
    (fun context =>
      Lwt._return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition set_option
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (function_parameter :
    option Tezos_protocol_environment_alpha__Environment.Context.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  match function_parameter with
  | None => remove ctxt k
  | Some v => init_set ctxt k v
  end.

Definition remove_rec
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t t :=
  op_gtgteq (Context.remove_rec (context ctxt) k)
    (fun context =>
      Lwt._return
        (* ❌ Record substitution not handled *)
        record_substitution).

Definition copy
  (ctxt : t) (from : Tezos_protocol_environment_alpha__Environment.Context.key)
  (to_ : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t) :=
  op_gtgteq (Context.copy (context ctxt) from to_)
    (fun function_parameter =>
      match function_parameter with
      | None =>
        storage_error
          (Missing_key from
            (* ❌ Variants not supported *)
            variant)
      | Some context =>
        _return
          (* ❌ Record substitution not handled *)
          record_substitution
      end).

Definition fold {A : Type}
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (init : A)
  (f : variant -> A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  Context.fold (context ctxt) k init f.

Definition keys
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (list Tezos_protocol_environment_alpha__Environment.Context.key) :=
  Context.keys (context ctxt) k.

Definition fold_keys {A : Type}
  (ctxt : t) (k : Tezos_protocol_environment_alpha__Environment.Context.key)
  (init : A)
  (f :
    Tezos_protocol_environment_alpha__Environment.Context.key ->
      A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  Context.fold_keys (context ctxt) k init f.

Definition project {A : Type} (x : A) : A := x.

Definition absolute_key {A B : Type} (function_parameter : A) : B -> B :=
  let '_ := function_parameter in
  fun k => k.

Definition description {A : Type}
  : Tezos_raw_protocol_alpha.Storage_description.t A :=
  Storage_description.create tt.

Definition fresh_temporary_big_map (ctxt : t)
  : t * Tezos_protocol_environment_alpha__Environment.Z.t :=
  ((* ❌ Record substitution not handled *)
  record_substitution, (temporary_big_map ctxt)).

Definition reset_temporary_big_map (ctxt : t) : t :=
  (* ❌ Record substitution not handled *)
  record_substitution.

Definition temporary_big_maps {A : Type}
  (ctxt : t)
  (f :
    A ->
      Tezos_protocol_environment_alpha__Environment.Z.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t A) (acc : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
  let fix iter
    (acc : A) (id : Tezos_protocol_environment_alpha__Environment.Z.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
    if Z.equal id (temporary_big_map ctxt) then
      Lwt._return acc
    else
      op_gtgteq (f acc id) (fun acc => iter acc (Z.sub id Z.one)) in
  iter acc (Z.sub Z.zero Z.one).

src/proto_alpha/lib_protocol/raw_level_repr.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type raw_level = t

include (Compare.Int32 : Compare.S with type t := t)

let encoding = Data_encoding.int32

let pp ppf level = Format.fprintf ppf "%ld" level

let rpc_arg =
  let construct raw_level = Int32.to_string raw_level in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse level"
    | raw_level ->
        Ok raw_level
  in
  RPC_arg.make
    ~descr:"A level integer"
    ~name:"block_level"
    ~construct
    ~destruct
    ()

let root = 0l

let succ = Int32.succ

let pred l = if l = 0l then None else Some (Int32.pred l)

let diff = Int32.sub

let to_int32 l = l

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l else invalid_arg "Level_repr.of_int32"

type error += Unexpected_level of Int32.t (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"unexpected_level"
    ~title:"Unexpected level"
    ~description:"Level must be non-negative."
    ~pp:(fun ppf l ->
      Format.fprintf
        ppf
        "The level is %s but should be non-negative."
        (Int32.to_string l))
    Data_encoding.(obj1 (req "level" int32))
    (function Unexpected_level l -> Some l | _ -> None)
    (fun l -> Unexpected_level l)

let of_int32 l = try Ok (of_int32_exn l) with _ -> error (Unexpected_level l)

module Index = struct
  type t = raw_level

  let path_length = 1

  let to_path level l = Int32.to_string level :: l

  let of_path = function
    | [s] -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/raw_level_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition raw_level := t.

(* ❌ Structure item `include` not handled. *)
include

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Data_encoding.int32.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (level : int32) : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
      "%ld" % string) level.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  let construct (raw_level : int32) : string :=
    Int32.to_string raw_level in
  let destruct (str : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
      string :=
    let 'raw_level := Int32.of_string str in
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok raw_level in
  RPC_arg.make (Some "A level integer" % string) "block_level" % string destruct
    construct tt.

Definition root : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ : int32 -> int32 := Int32.succ.

Definition pred (l : t) : option int32 :=
  if
    op_eq l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    None
  else
    Some (Int32.pred l).

Definition diff : int32 -> int32 -> int32 := Int32.sub.

Definition to_int32 {A : Type} (l : A) : A := l.

Definition of_int32_exn
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    l
  else
    invalid_arg "Level_repr.of_int32" % string.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition of_int32
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Pervasives.result
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
    (list Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
  (* ❌ Try-with are not handled *)
  try
    (Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
      (of_int32_exn l)).

Module Index.
  Definition t := raw_level.
  
  Definition path_length : Z := 1.
  
  Definition to_path (level : int32) (l : list string) : list string :=
    cons (Int32.to_string level) l.
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons s [] =>
      (* ❌ Try-with are not handled *)
      try (Some (Int32.of_string s))
    | _ => None
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

src/proto_alpha/lib_protocol/roll_repr.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Compare.Int32

type roll = t

let encoding = Data_encoding.int32

let first = 0l

let succ i = Int32.succ i

let random sequence ~bound = Seed_repr.take_int32 sequence bound

let rpc_arg = RPC_arg.like RPC_arg.int32 "roll"

let to_int32 v = v

module Index = struct
  type t = roll

  let path_length = 3

  let to_path roll l =
    (Int32.to_string @@ Int32.logand roll (Int32.of_int 0xff))
    :: ( Int32.to_string
       @@ Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 0xff)
       )
    :: Int32.to_string roll :: l

  let of_path = function
    | _ :: _ :: s :: _ -> (
      try Some (Int32.of_string s) with _ -> None )
    | _ ->
        None

  let rpc_arg = rpc_arg

  let encoding = encoding

  let compare = compare
end
src/proto_alpha/lib_protocol/roll_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition roll := t.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Data_encoding.int32.

Definition first : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ (i : int32) : int32 := Int32.succ i.

Definition random
  (sequence : Tezos_raw_protocol_alpha.Seed_repr.sequence) (bound : int32)
  : int32 * Tezos_raw_protocol_alpha.Seed_repr.sequence :=
  Seed_repr.take_int32 sequence bound.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  RPC_arg.like RPC_arg.int32 None "roll" % string.

Definition to_int32 {A : Type} (v : A) : A := v.

Module Index.
  Definition t := roll.
  
  Definition path_length : Z := 3.
  
  Definition to_path (roll : int32) (l : list string) : list string :=
    cons (op_atat Int32.to_string (Int32.logand roll (Int32.of_int 255)))
      (cons
        (op_atat Int32.to_string
          (Int32.logand (Int32.shift_right_logical roll 8) (Int32.of_int 255)))
        (cons (Int32.to_string roll) l)).
  
  Definition of_path (function_parameter : list string) : option int32 :=
    match function_parameter with
    | cons _ (cons _ (cons s _)) =>
      (* ❌ Try-with are not handled *)
      try (Some (Int32.of_string s))
    | _ => None
    end.
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 := rpc_arg.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    encoding.
  
  Definition compare : t -> t -> Z := compare.
End Index.

src/proto_alpha/lib_protocol/roll_storage.ml 282 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

type error +=
  | Consume_roll_change (* `Permanent *)
  | No_roll_for_delegate (* `Permanent *)
  | No_roll_snapshot_for_cycle of Cycle_repr.t (* `Permanent *)
  | Unregistered_delegate of Signature.Public_key_hash.t

(* `Permanent *)

let () =
  let open Data_encoding in
  (* Consume roll change *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.consume_roll_change"
    ~title:"Consume roll change"
    ~description:"Change is not enough to consume a roll."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Not enough change to consume a roll.")
    empty
    (function Consume_roll_change -> Some () | _ -> None)
    (fun () -> Consume_roll_change) ;
  (* No roll for delegate *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.no_roll_for_delegate"
    ~title:"No roll for delegate"
    ~description:"Delegate has no roll."
    ~pp:(fun ppf () -> Format.fprintf ppf "Delegate has no roll.")
    empty
    (function No_roll_for_delegate -> Some () | _ -> None)
    (fun () -> No_roll_for_delegate) ;
  (* No roll snapshot for cycle *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.no_roll_snapshot_for_cycle"
    ~title:"No roll snapshot for cycle"
    ~description:
      "A snapshot of the rolls distribution does not exist for this cycle."
    ~pp:(fun ppf c ->
      Format.fprintf
        ppf
        "A snapshot of the rolls distribution does not exist for cycle %a"
        Cycle_repr.pp
        c)
    (obj1 (req "cycle" Cycle_repr.encoding))
    (function No_roll_snapshot_for_cycle c -> Some c | _ -> None)
    (fun c -> No_roll_snapshot_for_cycle c) ;
  (* Unregistered delegate *)
  register_error_kind
    `Permanent
    ~id:"contract.manager.unregistered_delegate"
    ~title:"Unregistered delegate"
    ~description:"A contract cannot be delegated to an unregistered delegate"
    ~pp:(fun ppf k ->
      Format.fprintf
        ppf
        "The provided public key (with hash %a) is  not registered as valid \
         delegate key."
        Signature.Public_key_hash.pp
        k)
    (obj1 (req "hash" Signature.Public_key_hash.encoding))
    (function Unregistered_delegate k -> Some k | _ -> None)
    (fun k -> Unregistered_delegate k)

let get_contract_delegate c contract =
  Storage.Contract.Delegate.get_option c contract

let delegate_pubkey ctxt delegate =
  Storage.Contract.Manager.get_option
    ctxt
    (Contract_repr.implicit_contract delegate)
  >>=? function
  | None | Some (Manager_repr.Hash _) ->
      fail (Unregistered_delegate delegate)
  | Some (Manager_repr.Public_key pk) ->
      return pk

let clear_cycle c cycle =
  Storage.Roll.Snapshot_for_cycle.get c cycle
  >>=? fun index ->
  Storage.Roll.Snapshot_for_cycle.delete c cycle
  >>=? fun c ->
  Storage.Roll.Last_for_snapshot.delete (c, cycle) index
  >>=? fun c ->
  Storage.Roll.Owner.delete_snapshot c (cycle, index) >>= fun c -> return c

let fold ctxt ~f init =
  Storage.Roll.Next.get ctxt
  >>=? fun last ->
  let rec loop ctxt roll acc =
    acc
    >>=? fun acc ->
    if Roll_repr.(roll = last) then return acc
    else
      Storage.Roll.Owner.get_option ctxt roll
      >>=? function
      | None ->
          loop ctxt (Roll_repr.succ roll) (return acc)
      | Some delegate ->
          loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
  in
  loop ctxt Roll_repr.first (return init)

let snapshot_rolls_for_cycle ctxt cycle =
  Storage.Roll.Snapshot_for_cycle.get ctxt cycle
  >>=? fun index ->
  Storage.Roll.Snapshot_for_cycle.set ctxt cycle (index + 1)
  >>=? fun ctxt ->
  Storage.Roll.Owner.snapshot ctxt (cycle, index)
  >>=? fun ctxt ->
  Storage.Roll.Next.get ctxt
  >>=? fun last ->
  Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index last
  >>=? fun ctxt -> return ctxt

let freeze_rolls_for_cycle ctxt cycle =
  Storage.Roll.Snapshot_for_cycle.get ctxt cycle
  >>=? fun max_index ->
  Storage.Seed.For_cycle.get ctxt cycle
  >>=? fun seed ->
  let rd = Seed_repr.initialize_new seed [MBytes.of_string "roll_snapshot"] in
  let seq = Seed_repr.sequence rd 0l in
  let selected_index =
    Seed_repr.take_int32 seq (Int32.of_int max_index) |> fst |> Int32.to_int
  in
  Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index
  >>=? fun ctxt ->
  fold_left_s
    (fun ctxt index ->
      if Compare.Int.(index = selected_index) then return ctxt
      else
        Storage.Roll.Owner.delete_snapshot ctxt (cycle, index)
        >>= fun ctxt ->
        Storage.Roll.Last_for_snapshot.delete (ctxt, cycle) index
        >>=? fun ctxt -> return ctxt)
    ctxt
    Misc.(0 --> (max_index - 1))
  >>=? fun ctxt -> return ctxt

(* Roll selection *)

module Random = struct
  let int32_to_bytes i =
    let b = MBytes.create 4 in
    MBytes.set_int32 b 0 i ; b

  let level_random seed use level =
    let position = level.Level_repr.cycle_position in
    Seed_repr.initialize_new
      seed
      [MBytes.of_string ("level " ^ use ^ ":"); int32_to_bytes position]

  let owner c kind level offset =
    let cycle = level.Level_repr.cycle in
    Seed_storage.for_cycle c cycle
    >>=? fun random_seed ->
    let rd = level_random random_seed kind level in
    let sequence = Seed_repr.sequence rd (Int32.of_int offset) in
    Storage.Roll.Snapshot_for_cycle.get c cycle
    >>=? fun index ->
    Storage.Roll.Last_for_snapshot.get (c, cycle) index
    >>=? fun bound ->
    let rec loop sequence =
      let (roll, sequence) = Roll_repr.random sequence ~bound in
      Storage.Roll.Owner.Snapshot.get_option c ((cycle, index), roll)
      >>=? function None -> loop sequence | Some delegate -> return delegate
    in
    Storage.Roll.Owner.snapshot_exists c (cycle, index)
    >>= fun snapshot_exists ->
    fail_unless snapshot_exists (No_roll_snapshot_for_cycle cycle)
    >>=? fun () -> loop sequence
end

let baking_rights_owner c level ~priority =
  Random.owner c "baking" level priority

let endorsement_rights_owner c level ~slot =
  Random.owner c "endorsement" level slot

let traverse_rolls ctxt head =
  let rec loop acc roll =
    Storage.Roll.Successor.get_option ctxt roll
    >>=? function
    | None -> return (List.rev acc) | Some next -> loop (next :: acc) next
  in
  loop [head] head

let get_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>=? function
  | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll

let count_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>=? function
  | None ->
      return 0
  | Some head_roll ->
      let rec loop acc roll =
        Storage.Roll.Successor.get_option ctxt roll
        >>=? function None -> return acc | Some next -> loop (succ acc) next
      in
      loop 1 head_roll

let get_change c delegate =
  Storage.Roll.Delegate_change.get_option c delegate
  >>=? function None -> return Tez_repr.zero | Some change -> return change

module Delegate = struct
  let fresh_roll c =
    Storage.Roll.Next.get c
    >>=? fun roll ->
    Storage.Roll.Next.set c (Roll_repr.succ roll) >>=? fun c -> return (roll, c)

  let get_limbo_roll c =
    Storage.Roll.Limbo.get_option c
    >>=? function
    | None ->
        fresh_roll c
        >>=? fun (roll, c) ->
        Storage.Roll.Limbo.init c roll >>=? fun c -> return (roll, c)
    | Some roll ->
        return (roll, c)

  let consume_roll_change c delegate =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    trace Consume_roll_change (Lwt.return Tez_repr.(change -? tokens_per_roll))
    >>=? fun new_change ->
    Storage.Roll.Delegate_change.set c delegate new_change

  let recover_roll_change c delegate =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    Lwt.return Tez_repr.(change +? tokens_per_roll)
    >>=? fun new_change ->
    Storage.Roll.Delegate_change.set c delegate new_change

  let pop_roll_from_delegate c delegate =
    recover_roll_change c delegate
    >>=? fun c ->
    (* beginning:
       delegate : roll -> successor_roll -> ...
       limbo : limbo_head -> ...
    *)
    Storage.Roll.Limbo.get_option c
    >>=? fun limbo_head ->
    Storage.Roll.Delegate_roll_list.get_option c delegate
    >>=? function
    | None ->
        fail No_roll_for_delegate
    | Some roll ->
        Storage.Roll.Owner.delete c roll
        >>=? fun c ->
        Storage.Roll.Successor.get_option c roll
        >>=? fun successor_roll ->
        Storage.Roll.Delegate_roll_list.set_option c delegate successor_roll
        >>= fun c ->
        (* delegate : successor_roll -> ...
           roll ------^
           limbo : limbo_head -> ... *)
        Storage.Roll.Successor.set_option c roll limbo_head
        >>= fun c ->
        (* delegate : successor_roll -> ...
           roll ------v
           limbo : limbo_head -> ... *)
        Storage.Roll.Limbo.init_set c roll
        >>= fun c ->
        (* delegate : successor_roll -> ...
           limbo : roll -> limbo_head -> ... *)
        return (roll, c)

  let create_roll_in_delegate c delegate delegate_pk =
    consume_roll_change c delegate
    >>=? fun c ->
    (* beginning:
       delegate : delegate_head -> ...
       limbo : roll -> limbo_successor -> ...
    *)
    Storage.Roll.Delegate_roll_list.get_option c delegate
    >>=? fun delegate_head ->
    get_limbo_roll c
    >>=? fun (roll, c) ->
    Storage.Roll.Owner.init c roll delegate_pk
    >>=? fun c ->
    Storage.Roll.Successor.get_option c roll
    >>=? fun limbo_successor ->
    Storage.Roll.Limbo.set_option c limbo_successor
    >>= fun c ->
    (* delegate : delegate_head -> ...
       roll ------v
       limbo : limbo_successor -> ... *)
    Storage.Roll.Successor.set_option c roll delegate_head
    >>= fun c ->
    (* delegate : delegate_head -> ...
       roll ------^
       limbo : limbo_successor -> ... *)
    Storage.Roll.Delegate_roll_list.init_set c delegate roll
    >>= fun c ->
    (* delegate : roll -> delegate_head -> ...
       limbo : limbo_successor -> ... *)
    return c

  let ensure_inited c delegate =
    Storage.Roll.Delegate_change.mem c delegate
    >>= function
    | true ->
        return c
    | false ->
        Storage.Roll.Delegate_change.init c delegate Tez_repr.zero

  let is_inactive c delegate =
    Storage.Contract.Inactive_delegate.mem
      c
      (Contract_repr.implicit_contract delegate)
    >>= fun inactive ->
    if inactive then return inactive
    else
      Storage.Contract.Delegate_desactivation.get_option
        c
        (Contract_repr.implicit_contract delegate)
      >>=? function
      | Some last_active_cycle ->
          let {Level_repr.cycle = current_cycle} =
            Raw_context.current_level c
          in
          return Cycle_repr.(last_active_cycle < current_cycle)
      | None ->
          (* This case is only when called from `set_active`, when creating
             a contract. *)
          return_false

  let add_amount c delegate amount =
    ensure_inited c delegate
    >>=? fun c ->
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    Lwt.return Tez_repr.(amount +? change)
    >>=? fun change ->
    Storage.Roll.Delegate_change.set c delegate change
    >>=? fun c ->
    delegate_pubkey c delegate
    >>=? fun delegate_pk ->
    let rec loop c change =
      if Tez_repr.(change < tokens_per_roll) then return c
      else
        Lwt.return Tez_repr.(change -? tokens_per_roll)
        >>=? fun change ->
        create_roll_in_delegate c delegate delegate_pk
        >>=? fun c -> loop c change
    in
    is_inactive c delegate
    >>=? fun inactive ->
    if inactive then return c
    else
      loop c change
      >>=? fun c ->
      Storage.Roll.Delegate_roll_list.get_option c delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          return c
      | Some _ ->
          Storage.Active_delegates_with_rolls.add c delegate
          >>= fun c -> return c

  let remove_amount c delegate amount =
    let tokens_per_roll = Constants_storage.tokens_per_roll c in
    let rec loop c change =
      if Tez_repr.(amount <= change) then return (c, change)
      else
        pop_roll_from_delegate c delegate
        >>=? fun (_, c) ->
        Lwt.return Tez_repr.(change +? tokens_per_roll)
        >>=? fun change -> loop c change
    in
    Storage.Roll.Delegate_change.get c delegate
    >>=? fun change ->
    is_inactive c delegate
    >>=? fun inactive ->
    ( if inactive then return (c, change)
    else
      loop c change
      >>=? fun (c, change) ->
      Storage.Roll.Delegate_roll_list.get_option c delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          Storage.Active_delegates_with_rolls.del c delegate
          >>= fun c -> return (c, change)
      | Some _ ->
          return (c, change) )
    >>=? fun (c, change) ->
    Lwt.return Tez_repr.(change -? amount)
    >>=? fun change -> Storage.Roll.Delegate_change.set c delegate change

  let set_inactive ctxt delegate =
    ensure_inited ctxt delegate
    >>=? fun ctxt ->
    let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
    Storage.Roll.Delegate_change.get ctxt delegate
    >>=? fun change ->
    Storage.Contract.Inactive_delegate.add
      ctxt
      (Contract_repr.implicit_contract delegate)
    >>= fun ctxt ->
    Storage.Active_delegates_with_rolls.del ctxt delegate
    >>= fun ctxt ->
    let rec loop ctxt change =
      Storage.Roll.Delegate_roll_list.get_option ctxt delegate
      >>=? function
      | None ->
          return (ctxt, change)
      | Some _roll ->
          pop_roll_from_delegate ctxt delegate
          >>=? fun (_, ctxt) ->
          Lwt.return Tez_repr.(change +? tokens_per_roll)
          >>=? fun change -> loop ctxt change
    in
    loop ctxt change
    >>=? fun (ctxt, change) ->
    Storage.Roll.Delegate_change.set ctxt delegate change
    >>=? fun ctxt -> return ctxt

  let set_active ctxt delegate =
    is_inactive ctxt delegate
    >>=? fun inactive ->
    let current_cycle = (Raw_context.current_level ctxt).cycle in
    let preserved_cycles = Constants_storage.preserved_cycles ctxt in
    (* When the delegate is new or inactive, she will become active in
       `1+preserved_cycles`, and we allow `preserved_cycles` for the
       delegate to start baking. When the delegate is active, we only
       give her at least `preserved_cycles` after the current cycle
       before to be deactivated.  *)
    Storage.Contract.Delegate_desactivation.get_option
      ctxt
      (Contract_repr.implicit_contract delegate)
    >>=? fun current_expiration ->
    let expiration =
      match current_expiration with
      | None ->
          Cycle_repr.add current_cycle (1 + (2 * preserved_cycles))
      | Some current_expiration ->
          let delay =
            if inactive then 1 + (2 * preserved_cycles)
            else 1 + preserved_cycles
          in
          let updated = Cycle_repr.add current_cycle delay in
          Cycle_repr.max current_expiration updated
    in
    Storage.Contract.Delegate_desactivation.init_set
      ctxt
      (Contract_repr.implicit_contract delegate)
      expiration
    >>= fun ctxt ->
    if not inactive then return ctxt
    else
      ensure_inited ctxt delegate
      >>=? fun ctxt ->
      let tokens_per_roll = Constants_storage.tokens_per_roll ctxt in
      Storage.Roll.Delegate_change.get ctxt delegate
      >>=? fun change ->
      Storage.Contract.Inactive_delegate.del
        ctxt
        (Contract_repr.implicit_contract delegate)
      >>= fun ctxt ->
      delegate_pubkey ctxt delegate
      >>=? fun delegate_pk ->
      let rec loop ctxt change =
        if Tez_repr.(change < tokens_per_roll) then return ctxt
        else
          Lwt.return Tez_repr.(change -? tokens_per_roll)
          >>=? fun change ->
          create_roll_in_delegate ctxt delegate delegate_pk
          >>=? fun ctxt -> loop ctxt change
      in
      loop ctxt change
      >>=? fun ctxt ->
      Storage.Roll.Delegate_roll_list.get_option ctxt delegate
      >>=? fun rolls ->
      match rolls with
      | None ->
          return ctxt
      | Some _ ->
          Storage.Active_delegates_with_rolls.add ctxt delegate
          >>= fun ctxt -> return ctxt
end

module Contract = struct
  let add_amount c contract amount =
    get_contract_delegate c contract
    >>=? function
    | None -> return c | Some delegate -> Delegate.add_amount c delegate amount

  let remove_amount c contract amount =
    get_contract_delegate c contract
    >>=? function
    | None ->
        return c
    | Some delegate ->
        Delegate.remove_amount c delegate amount
end

let init ctxt = Storage.Roll.Next.init ctxt Roll_repr.first

let init_first_cycles ctxt =
  let preserved = Constants_storage.preserved_cycles ctxt in
  (* Precompute rolls for cycle (0 --> preserved_cycles) *)
  List.fold_left
    (fun ctxt c ->
      ctxt
      >>=? fun ctxt ->
      let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
      Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
      >>=? fun ctxt ->
      snapshot_rolls_for_cycle ctxt cycle
      >>=? fun ctxt -> freeze_rolls_for_cycle ctxt cycle)
    (return ctxt)
    (0 --> preserved)
  >>=? fun ctxt ->
  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 1)) in
  (* Precomputed a snapshot for cycle (preserved_cycles + 1) *)
  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
  >>=? fun ctxt ->
  snapshot_rolls_for_cycle ctxt cycle
  >>=? fun ctxt ->
  (* Prepare storage for storing snapshots for cycle (preserved_cycles+2) *)
  let cycle = Cycle_repr.of_int32_exn (Int32.of_int (preserved + 2)) in
  Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0
  >>=? fun ctxt -> return ctxt

let snapshot_rolls ctxt =
  let current_level = Raw_context.current_level ctxt in
  let preserved = Constants_storage.preserved_cycles ctxt in
  let cycle = Cycle_repr.add current_level.cycle (preserved + 2) in
  snapshot_rolls_for_cycle ctxt cycle

let cycle_end ctxt last_cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.sub last_cycle preserved with
  | None ->
      return ctxt
  | Some cleared_cycle ->
      clear_cycle ctxt cleared_cycle )
  >>=? fun ctxt ->
  let frozen_roll_cycle = Cycle_repr.add last_cycle (preserved + 1) in
  freeze_rolls_for_cycle ctxt frozen_roll_cycle
  >>=? fun ctxt ->
  Storage.Roll.Snapshot_for_cycle.init
    ctxt
    (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle))
    0
  >>=? fun ctxt -> return ctxt

let update_tokens_per_roll ctxt new_tokens_per_roll =
  let constants = Raw_context.constants ctxt in
  let old_tokens_per_roll = constants.tokens_per_roll in
  Raw_context.patch_constants ctxt (fun constants ->
      {constants with Constants_repr.tokens_per_roll = new_tokens_per_roll})
  >>= fun ctxt ->
  let decrease = Tez_repr.(new_tokens_per_roll < old_tokens_per_roll) in
  ( if decrease then
    Lwt.return Tez_repr.(old_tokens_per_roll -? new_tokens_per_roll)
  else Lwt.return Tez_repr.(new_tokens_per_roll -? old_tokens_per_roll) )
  >>=? fun abs_diff ->
  Storage.Delegates.fold ctxt (Ok ctxt) (fun pkh ctxt ->
      Lwt.return ctxt
      >>=? fun ctxt ->
      count_rolls ctxt pkh
      >>=? fun rolls ->
      Lwt.return Tez_repr.(abs_diff *? Int64.of_int rolls)
      >>=? fun amount ->
      if decrease then Delegate.add_amount ctxt pkh amount
      else Delegate.remove_amount ctxt pkh amount)
src/proto_alpha/lib_protocol/roll_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Misc.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition get_contract_delegate
  (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
  (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Storage.Contract.Delegate.value)) :=
  Storage.Contract.Delegate.get_option c contract.

Definition delegate_pubkey
  (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Manager.context)
  (delegate :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key.t) :=
  op_gtgteqquestion
    (Storage.Contract.Manager.get_option ctxt
      (Contract_repr.implicit_contract delegate))
    (fun function_parameter =>
      match function_parameter with
      | None | Some (Tezos_raw_protocol_alpha.Manager_repr.Hash _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
            delegate)
      | Some (Tezos_raw_protocol_alpha.Manager_repr.Public_key pk) => _return pk
      end).

Definition clear_cycle
  (c : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get c cycle)
    (fun index =>
      op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.delete c cycle)
        (fun c =>
          op_gtgteqquestion
            (Storage.Roll.Last_for_snapshot.delete (c, cycle) index)
            (fun c =>
              op_gtgteq (Storage.Roll.Owner.delete_snapshot c (cycle, index))
                (fun c => _return c)))).

Definition fold {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
  (f :
    Tezos_raw_protocol_alpha.Roll_repr.roll ->
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.value ->
        A ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              A)) (init : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  op_gtgteqquestion (Storage.Roll.Next.get ctxt)
    (fun last =>
      let fix loop
        (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Owner.context) (roll :
        Tezos_raw_protocol_alpha.Roll_repr.roll) (acc :
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A))
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
        op_gtgteqquestion acc
          (fun acc =>
            if op_eq roll last then
              _return acc
            else
              op_gtgteqquestion (Storage.Roll.Owner.get_option ctxt roll)
                (fun function_parameter =>
                  match function_parameter with
                  | None => loop ctxt (Roll_repr.succ roll) (_return acc)
                  | Some delegate =>
                    loop ctxt (Roll_repr.succ roll) (f roll delegate acc)
                  end)) in
      loop ctxt Roll_repr.first (_return init)).

Definition snapshot_rolls_for_cycle
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
    (fun index =>
      op_gtgteqquestion
        (Storage.Roll.Snapshot_for_cycle.set ctxt cycle (op_plus index 1))
        (fun ctxt =>
          op_gtgteqquestion (Storage.Roll.Owner.snapshot ctxt (cycle, index))
            (fun ctxt =>
              op_gtgteqquestion (Storage.Roll.Next.get ctxt)
                (fun last =>
                  op_gtgteqquestion
                    (Storage.Roll.Last_for_snapshot.init (ctxt, cycle) index
                      last) (fun ctxt => _return ctxt))))).

Definition freeze_rolls_for_cycle
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.context)
  (cycle : Tezos_raw_protocol_alpha.Storage.Roll.Snapshot_for_cycle.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.context) :=
  op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get ctxt cycle)
    (fun max_index =>
      op_gtgteqquestion (Storage.Seed.For_cycle.get ctxt cycle)
        (fun seed =>
          let rd :=
            Seed_repr.initialize_new seed
              (cons (MBytes.of_string "roll_snapshot" % string) []) in
          let seq :=
            Seed_repr.sequence rd
              (* ❌ Constant of type int32 is converted to int *)
              0 in
          let selected_index :=
            op_pipegt
              (op_pipegt (Seed_repr.take_int32 seq (Int32.of_int max_index)) fst)
              Int32.to_int in
          op_gtgteqquestion
            (Storage.Roll.Snapshot_for_cycle.set ctxt cycle selected_index)
            (fun ctxt =>
              op_gtgteqquestion
                (fold_left_s
                  (fun ctxt =>
                    fun index =>
                      if
                        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                          index selected_index then
                        _return ctxt
                      else
                        op_gtgteq
                          (Storage.Roll.Owner.delete_snapshot ctxt
                            (cycle, index))
                          (fun ctxt =>
                            op_gtgteqquestion
                              (Storage.Roll.Last_for_snapshot.delete
                                (ctxt, cycle) index) (fun ctxt => _return ctxt)))
                  ctxt (op_minusminusgt 0 (op_minus max_index 1)))
                (fun ctxt => _return ctxt)))).

Module Random.
  Definition int32_to_bytes (i : int32)
    : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
    let b := MBytes.create 4 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := MBytes.set_int32 b 0 i in
    b.
  
  Definition level_random
    (seed : Tezos_raw_protocol_alpha.Seed_repr.seed) (use : string)
    (level : Tezos_raw_protocol_alpha.Level_repr.t)
    : Tezos_raw_protocol_alpha.Seed_repr.t :=
    let position := Level_repr.cycle_position level in
    Seed_repr.initialize_new seed
      (cons
        (MBytes.of_string
          (op_caret "level " % string (op_caret use ":" % string)))
        (cons (int32_to_bytes position) [])).
  
  Definition owner
    (c : Tezos_raw_protocol_alpha.Raw_context.t) (kind : string)
    (level : Tezos_raw_protocol_alpha.Level_repr.t) (offset : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
    let cycle := Level_repr.cycle level in
    op_gtgteqquestion (Seed_storage.for_cycle c cycle)
      (fun random_seed =>
        let rd := level_random random_seed kind level in
        let sequence := Seed_repr.sequence rd (Int32.of_int offset) in
        op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.get c cycle)
          (fun index =>
            op_gtgteqquestion
              (Storage.Roll.Last_for_snapshot.get (c, cycle) index)
              (fun bound =>
                let fix loop
                  (sequence : Tezos_raw_protocol_alpha.Seed_repr.sequence)
                  : Tezos_protocol_environment_alpha__Environment.Lwt.t
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                      Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
                  let '(roll, sequence) := Roll_repr.random sequence bound in
                  op_gtgteqquestion
                    (Storage.Roll.Owner.Snapshot.get_option c
                      ((cycle, index), roll))
                    (fun function_parameter =>
                      match function_parameter with
                      | None => loop sequence
                      | Some delegate => _return delegate
                      end) in
                op_gtgteq (Storage.Roll.Owner.snapshot_exists c (cycle, index))
                  (fun snapshot_exists =>
                    op_gtgteqquestion
                      (fail_unless snapshot_exists
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.No_roll_snapshot_for_cycle
                          cycle))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        loop sequence))))).
End Random.

Definition baking_rights_owner
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t) (priority : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
  Random.owner c "baking" % string level priority.

Definition endorsement_rights_owner
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (level : Tezos_raw_protocol_alpha.Level_repr.t) (slot : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Roll.Owner.Snapshot.value) :=
  Random.owner c "endorsement" % string level slot.

Definition traverse_rolls
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Successor.context)
  (head : Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
  let fix loop
    (acc : list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value) (roll :
    Tezos_raw_protocol_alpha.Storage.Roll.Successor.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
    op_gtgteqquestion (Storage.Roll.Successor.get_option ctxt roll)
      (fun function_parameter =>
        match function_parameter with
        | None => _return (List.rev acc)
        | Some next => loop (cons next acc) next
        end) in
  loop (cons head []) head.

Definition get_rolls
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
  (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_raw_protocol_alpha.Storage.Roll.Successor.value)) :=
  op_gtgteqquestion (Storage.Roll.Delegate_roll_list.get_option ctxt delegate)
    (fun function_parameter =>
      match function_parameter with
      | None => return_nil
      | Some head_roll => traverse_rolls ctxt head_roll
      end).

Definition count_rolls
  (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
  (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  op_gtgteqquestion (Storage.Roll.Delegate_roll_list.get_option ctxt delegate)
    (fun function_parameter =>
      match function_parameter with
      | None => _return 0
      | Some head_roll =>
        let fix loop
          (acc : Z) (roll : Tezos_raw_protocol_alpha.Storage.Roll.Successor.key)
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Z) :=
          op_gtgteqquestion (Storage.Roll.Successor.get_option ctxt roll)
            (fun function_parameter =>
              match function_parameter with
              | None => _return acc
              | Some next => loop (succ acc) next
              end) in
        loop 1 head_roll
      end).

Definition get_change
  (c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
  (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Tez_repr.t) :=
  op_gtgteqquestion (Storage.Roll.Delegate_change.get_option c delegate)
    (fun function_parameter =>
      match function_parameter with
      | None => _return Tez_repr.zero
      | Some change => _return change
      end).

Module Delegate.
  Definition fresh_roll (c : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Storage.Roll.Next.value *
          Tezos_raw_protocol_alpha.Raw_context.t)) :=
    op_gtgteqquestion (Storage.Roll.Next.get c)
      (fun roll =>
        op_gtgteqquestion (Storage.Roll.Next.set c (Roll_repr.succ roll))
          (fun c => _return (roll, c))).
  
  Definition get_limbo_roll
    (c : Tezos_raw_protocol_alpha.Storage.Roll.Limbo.context)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Storage.Roll.Next.value *
          Tezos_raw_protocol_alpha.Raw_context.t)) :=
    op_gtgteqquestion (Storage.Roll.Limbo.get_option c)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_gtgteqquestion (fresh_roll c)
            (fun function_parameter =>
              let '(roll, c) := function_parameter in
              op_gtgteqquestion (Storage.Roll.Limbo.init c roll)
                (fun c => _return (roll, c)))
        | Some roll => _return (roll, c)
        end).
  
  Definition consume_roll_change
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let tokens_per_roll := Constants_storage.tokens_per_roll c in
    op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        op_gtgteqquestion
          (trace
            Tezos_protocol_environment_alpha__Environment.Error_monad.Consume_roll_change
            (Lwt._return (op_minusquestion change tokens_per_roll)))
          (fun new_change =>
            Storage.Roll.Delegate_change.set c delegate new_change)).
  
  Definition recover_roll_change
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let tokens_per_roll := Constants_storage.tokens_per_roll c in
    op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        op_gtgteqquestion (Lwt._return (op_plusquestion change tokens_per_roll))
          (fun new_change =>
            Storage.Roll.Delegate_change.set c delegate new_change)).
  
  Definition pop_roll_from_delegate
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.value *
          Tezos_raw_protocol_alpha.Raw_context.t)) :=
    op_gtgteqquestion (recover_roll_change c delegate)
      (fun c =>
        op_gtgteqquestion (Storage.Roll.Limbo.get_option c)
          (fun limbo_head =>
            op_gtgteqquestion
              (Storage.Roll.Delegate_roll_list.get_option c delegate)
              (fun function_parameter =>
                match function_parameter with
                | None =>
                  fail
                    Tezos_protocol_environment_alpha__Environment.Error_monad.No_roll_for_delegate
                | Some roll =>
                  op_gtgteqquestion (Storage.Roll.Owner.delete c roll)
                    (fun c =>
                      op_gtgteqquestion
                        (Storage.Roll.Successor.get_option c roll)
                        (fun successor_roll =>
                          op_gtgteq
                            (Storage.Roll.Delegate_roll_list.set_option c
                              delegate successor_roll)
                            (fun c =>
                              op_gtgteq
                                (Storage.Roll.Successor.set_option c roll
                                  limbo_head)
                                (fun c =>
                                  op_gtgteq (Storage.Roll.Limbo.init_set c roll)
                                    (fun c => _return (roll, c))))))
                end))).
  
  Definition create_roll_in_delegate
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    (delegate_pk : Tezos_raw_protocol_alpha.Storage.Roll.Owner.value)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    op_gtgteqquestion (consume_roll_change c delegate)
      (fun c =>
        op_gtgteqquestion
          (Storage.Roll.Delegate_roll_list.get_option c delegate)
          (fun delegate_head =>
            op_gtgteqquestion (get_limbo_roll c)
              (fun function_parameter =>
                let '(roll, c) := function_parameter in
                op_gtgteqquestion (Storage.Roll.Owner.init c roll delegate_pk)
                  (fun c =>
                    op_gtgteqquestion (Storage.Roll.Successor.get_option c roll)
                      (fun limbo_successor =>
                        op_gtgteq
                          (Storage.Roll.Limbo.set_option c limbo_successor)
                          (fun c =>
                            op_gtgteq
                              (Storage.Roll.Successor.set_option c roll
                                delegate_head)
                              (fun c =>
                                op_gtgteq
                                  (Storage.Roll.Delegate_roll_list.init_set c
                                    delegate roll) (fun c => _return c)))))))).
  
  Definition ensure_inited
    (c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context) :=
    op_gtgteq (Storage.Roll.Delegate_change.mem c delegate)
      (fun function_parameter =>
        match function_parameter with
        | true => _return c
        | false => Storage.Roll.Delegate_change.init c delegate Tez_repr.zero
        end).
  
  Definition is_inactive
    (c : Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.context)
    (delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult bool) :=
    op_gtgteq
      (Storage.Contract.Inactive_delegate.mem c
        (Contract_repr.implicit_contract delegate))
      (fun inactive =>
        if inactive then
          _return inactive
        else
          op_gtgteqquestion
            (Storage.Contract.Delegate_desactivation.get_option c
              (Contract_repr.implicit_contract delegate))
            (fun function_parameter =>
              match function_parameter with
              | Some last_active_cycle =>
                let '{| Level_repr.cycle := current_cycle |} :=
                  Raw_context.current_level c in
                _return (op_lt last_active_cycle current_cycle)
              | None => return_false
              end)).
  
  Definition add_amount
    (c : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    op_gtgteqquestion (ensure_inited c delegate)
      (fun c =>
        let tokens_per_roll := Constants_storage.tokens_per_roll c in
        op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
          (fun change =>
            op_gtgteqquestion (Lwt._return (op_plusquestion amount change))
              (fun change =>
                op_gtgteqquestion
                  (Storage.Roll.Delegate_change.set c delegate change)
                  (fun c =>
                    op_gtgteqquestion (delegate_pubkey c delegate)
                      (fun delegate_pk =>
                        let fix loop
                          (c : Tezos_raw_protocol_alpha.Raw_context.context)
                          (change : Tezos_raw_protocol_alpha.Tez_repr.t)
                          : Tezos_protocol_environment_alpha__Environment.Lwt.t
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                              Tezos_raw_protocol_alpha.Raw_context.context) :=
                          if op_lt change tokens_per_roll then
                            _return c
                          else
                            op_gtgteqquestion
                              (Lwt._return
                                (op_minusquestion change tokens_per_roll))
                              (fun change =>
                                op_gtgteqquestion
                                  (create_roll_in_delegate c delegate
                                    delegate_pk) (fun c => loop c change)) in
                        op_gtgteqquestion (is_inactive c delegate)
                          (fun inactive =>
                            if inactive then
                              _return c
                            else
                              op_gtgteqquestion (loop c change)
                                (fun c =>
                                  op_gtgteqquestion
                                    (Storage.Roll.Delegate_roll_list.get_option
                                      c delegate)
                                    (fun rolls =>
                                      match rolls with
                                      | None => _return c
                                      | Some _ =>
                                        op_gtgteq
                                          (Storage.Active_delegates_with_rolls.add
                                            c delegate) (fun c => _return c)
                                      end)))))))).
  
  Definition remove_amount
    (c : Tezos_raw_protocol_alpha.Raw_context.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    let tokens_per_roll := Constants_storage.tokens_per_roll c in
    let fix loop
      (c : Tezos_raw_protocol_alpha.Raw_context.context) (change :
      Tezos_raw_protocol_alpha.Tez_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.context *
            Tezos_raw_protocol_alpha.Tez_repr.t)) :=
      if op_lteq amount change then
        _return (c, change)
      else
        op_gtgteqquestion (pop_roll_from_delegate c delegate)
          (fun function_parameter =>
            let '(_, c) := function_parameter in
            op_gtgteqquestion
              (Lwt._return (op_plusquestion change tokens_per_roll))
              (fun change => loop c change)) in
    op_gtgteqquestion (Storage.Roll.Delegate_change.get c delegate)
      (fun change =>
        op_gtgteqquestion (is_inactive c delegate)
          (fun inactive =>
            op_gtgteqquestion
              (if inactive then
                _return (c, change)
              else
                op_gtgteqquestion (loop c change)
                  (fun function_parameter =>
                    let '(c, change) := function_parameter in
                    op_gtgteqquestion
                      (Storage.Roll.Delegate_roll_list.get_option c delegate)
                      (fun rolls =>
                        match rolls with
                        | None =>
                          op_gtgteq
                            (Storage.Active_delegates_with_rolls.del c delegate)
                            (fun c => _return (c, change))
                        | Some _ => _return (c, change)
                        end)))
              (fun function_parameter =>
                let '(c, change) := function_parameter in
                op_gtgteqquestion (Lwt._return (op_minusquestion change amount))
                  (fun change =>
                    Storage.Roll.Delegate_change.set c delegate change)))).
  
  Definition set_inactive
    (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.context)
    (delegate : Tezos_raw_protocol_alpha.Storage.Roll.Delegate_change.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    op_gtgteqquestion (ensure_inited ctxt delegate)
      (fun ctxt =>
        let tokens_per_roll := Constants_storage.tokens_per_roll ctxt in
        op_gtgteqquestion (Storage.Roll.Delegate_change.get ctxt delegate)
          (fun change =>
            op_gtgteq
              (Storage.Contract.Inactive_delegate.add ctxt
                (Contract_repr.implicit_contract delegate))
              (fun ctxt =>
                op_gtgteq
                  (Storage.Active_delegates_with_rolls.del ctxt delegate)
                  (fun ctxt =>
                    let fix loop
                      (ctxt :
                      Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context)
                      (change : Tezos_raw_protocol_alpha.Tez_repr.t)
                      : Tezos_protocol_environment_alpha__Environment.Lwt.t
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                          (Tezos_raw_protocol_alpha.Storage.Roll.Delegate_roll_list.context
                            * Tezos_raw_protocol_alpha.Tez_repr.t)) :=
                      op_gtgteqquestion
                        (Storage.Roll.Delegate_roll_list.get_option ctxt
                          delegate)
                        (fun function_parameter =>
                          match function_parameter with
                          | None => _return (ctxt, change)
                          | Some _roll =>
                            op_gtgteqquestion
                              (pop_roll_from_delegate ctxt delegate)
                              (fun function_parameter =>
                                let '(_, ctxt) := function_parameter in
                                op_gtgteqquestion
                                  (Lwt._return
                                    (op_plusquestion change tokens_per_roll))
                                  (fun change => loop ctxt change))
                          end) in
                    op_gtgteqquestion (loop ctxt change)
                      (fun function_parameter =>
                        let '(ctxt, change) := function_parameter in
                        op_gtgteqquestion
                          (Storage.Roll.Delegate_change.set ctxt delegate change)
                          (fun ctxt => _return ctxt)))))).
  
  Definition set_active
    (ctxt : Tezos_raw_protocol_alpha.Storage.Contract.Inactive_delegate.context)
    (delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
    op_gtgteqquestion (is_inactive ctxt delegate)
      (fun inactive =>
        let current_cycle := cycle (Raw_context.current_level ctxt) in
        let preserved_cycles := Constants_storage.preserved_cycles ctxt in
        op_gtgteqquestion
          (Storage.Contract.Delegate_desactivation.get_option ctxt
            (Contract_repr.implicit_contract delegate))
          (fun current_expiration =>
            let expiration :=
              match current_expiration with
              | None =>
                Cycle_repr.add current_cycle
                  (op_plus 1 (op_star 2 preserved_cycles))
              | Some current_expiration =>
                let delay :=
                  if inactive then
                    op_plus 1 (op_star 2 preserved_cycles)
                  else
                    op_plus 1 preserved_cycles in
                let updated := Cycle_repr.add current_cycle delay in
                Cycle_repr.max current_expiration updated
              end in
            op_gtgteq
              (Storage.Contract.Delegate_desactivation.init_set ctxt
                (Contract_repr.implicit_contract delegate) expiration)
              (fun ctxt =>
                if not inactive then
                  _return ctxt
                else
                  op_gtgteqquestion (ensure_inited ctxt delegate)
                    (fun ctxt =>
                      let tokens_per_roll :=
                        Constants_storage.tokens_per_roll ctxt in
                      op_gtgteqquestion
                        (Storage.Roll.Delegate_change.get ctxt delegate)
                        (fun change =>
                          op_gtgteq
                            (Storage.Contract.Inactive_delegate.del ctxt
                              (Contract_repr.implicit_contract delegate))
                            (fun ctxt =>
                              op_gtgteqquestion (delegate_pubkey ctxt delegate)
                                (fun delegate_pk =>
                                  let fix loop
                                    (ctxt :
                                    Tezos_raw_protocol_alpha.Raw_context.context)
                                    (change :
                                    Tezos_raw_protocol_alpha.Tez_repr.t)
                                    : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                        Tezos_raw_protocol_alpha.Raw_context.context) :=
                                    if op_lt change tokens_per_roll then
                                      _return ctxt
                                    else
                                      op_gtgteqquestion
                                        (Lwt._return
                                          (op_minusquestion change
                                            tokens_per_roll))
                                        (fun change =>
                                          op_gtgteqquestion
                                            (create_roll_in_delegate ctxt
                                              delegate delegate_pk)
                                            (fun ctxt => loop ctxt change)) in
                                  op_gtgteqquestion (loop ctxt change)
                                    (fun ctxt =>
                                      op_gtgteqquestion
                                        (Storage.Roll.Delegate_roll_list.get_option
                                          ctxt delegate)
                                        (fun rolls =>
                                          match rolls with
                                          | None => _return ctxt
                                          | Some _ =>
                                            op_gtgteq
                                              (Storage.Active_delegates_with_rolls.add
                                                ctxt delegate)
                                              (fun ctxt => _return ctxt)
                                          end))))))))).
End Delegate.

Module Contract.
  Definition add_amount
    (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
    (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context) :=
    op_gtgteqquestion (get_contract_delegate c contract)
      (fun function_parameter =>
        match function_parameter with
        | None => _return c
        | Some delegate => Delegate.add_amount c delegate amount
        end).
  
  Definition remove_amount
    (c : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context)
    (contract : Tezos_raw_protocol_alpha.Storage.Contract.Delegate.key)
    (amount : Tezos_raw_protocol_alpha.Tez_repr.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Contract.Delegate.context) :=
    op_gtgteqquestion (get_contract_delegate c contract)
      (fun function_parameter =>
        match function_parameter with
        | None => _return c
        | Some delegate => Delegate.remove_amount c delegate amount
        end).
End Contract.

Definition init (ctxt : Tezos_raw_protocol_alpha.Storage.Roll.Next.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Roll.Next.init ctxt Roll_repr.first.

Definition init_first_cycles
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  op_gtgteqquestion
    (List.fold_left
      (fun ctxt =>
        fun c =>
          op_gtgteqquestion ctxt
            (fun ctxt =>
              let cycle := Cycle_repr.of_int32_exn (Int32.of_int c) in
              op_gtgteqquestion
                (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
                (fun ctxt =>
                  op_gtgteqquestion (snapshot_rolls_for_cycle ctxt cycle)
                    (fun ctxt => freeze_rolls_for_cycle ctxt cycle))))
      (_return ctxt) (op_minusminusgt 0 preserved))
    (fun ctxt =>
      let cycle := Cycle_repr.of_int32_exn (Int32.of_int (op_plus preserved 1))
        in
      op_gtgteqquestion (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
        (fun ctxt =>
          op_gtgteqquestion (snapshot_rolls_for_cycle ctxt cycle)
            (fun ctxt =>
              let cycle :=
                Cycle_repr.of_int32_exn (Int32.of_int (op_plus preserved 2)) in
              op_gtgteqquestion
                (Storage.Roll.Snapshot_for_cycle.init ctxt cycle 0)
                (fun ctxt => _return ctxt)))).

Definition snapshot_rolls (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let current_level := Raw_context.current_level ctxt in
  let preserved := Constants_storage.preserved_cycles ctxt in
  let cycle := Cycle_repr.add (cycle current_level) (op_plus preserved 2) in
  snapshot_rolls_for_cycle ctxt cycle.

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  op_gtgteqquestion
    match Cycle_repr.sub last_cycle preserved with
    | None => _return ctxt
    | Some cleared_cycle => clear_cycle ctxt cleared_cycle
    end
    (fun ctxt =>
      let frozen_roll_cycle := Cycle_repr.add last_cycle (op_plus preserved 1)
        in
      op_gtgteqquestion (freeze_rolls_for_cycle ctxt frozen_roll_cycle)
        (fun ctxt =>
          op_gtgteqquestion
            (Storage.Roll.Snapshot_for_cycle.init ctxt
              (Cycle_repr.succ (Cycle_repr.succ frozen_roll_cycle)) 0)
            (fun ctxt => _return ctxt))).

Definition update_tokens_per_roll
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (new_tokens_per_roll : Tezos_raw_protocol_alpha.Tez_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.context) :=
  let constants := Raw_context.constants ctxt in
  let old_tokens_per_roll := tokens_per_roll constants in
  op_gtgteq
    (Raw_context.patch_constants ctxt
      (fun constants =>
        (* ❌ Record substitution not handled *)
        record_substitution))
    (fun ctxt =>
      let decrease := op_lt new_tokens_per_roll old_tokens_per_roll in
      op_gtgteqquestion
        (if decrease then
          Lwt._return (op_minusquestion old_tokens_per_roll new_tokens_per_roll)
        else
          Lwt._return (op_minusquestion new_tokens_per_roll old_tokens_per_roll))
        (fun abs_diff =>
          Storage.Delegates.fold ctxt
            (Tezos_protocol_environment_alpha__Environment.Pervasives.Ok ctxt)
            (fun pkh =>
              fun ctxt =>
                op_gtgteqquestion (Lwt._return ctxt)
                  (fun ctxt =>
                    op_gtgteqquestion (count_rolls ctxt pkh)
                      (fun rolls =>
                        op_gtgteqquestion
                          (Lwt._return
                            (op_starquestion abs_diff (Int64.of_int rolls)))
                          (fun amount =>
                            if decrease then
                              Delegate.add_amount ctxt pkh amount
                            else
                              Delegate.remove_amount ctxt pkh amount)))))).

src/proto_alpha/lib_protocol/script_expr_hash.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let script_expr_hash = "\013\044\064\027" (* expr(54) *)

include Blake2B.Make
          (Base58)
          (struct
            let name = "script_expr"

            let title = "A script expression ID"

            let b58check_prefix = script_expr_hash

            let size = None
          end)

let () = Base58.check_encoded_prefix b58check_encoding "expr" 54
src/proto_alpha/lib_protocol/script_expr_hash.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition script_expr_hash : string := "
,@" % string.

(* ❌ Structure item `include` not handled. *)
include



src/proto_alpha/lib_protocol/script_int_repr.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type n = Natural_tag

type z = Integer_tag

type 't num = Z.t

let compare x y = Z.compare x y

let zero = Z.zero

let zero_n = Z.zero

let to_string x = Z.to_string x

let of_string s = try Some (Z.of_string s) with _ -> None

let to_int64 x = try Some (Z.to_int64 x) with _ -> None

let of_int64 n = Z.of_int64 n

let to_int x = try Some (Z.to_int x) with _ -> None

let of_int n = Z.of_int n

let of_zint x = x

let to_zint x = x

let add x y = Z.add x y

let sub x y = Z.sub x y

let mul x y = Z.mul x y

let ediv x y =
  try
    let (q, r) = Z.ediv_rem x y in
    Some (q, r)
  with _ -> None

let add_n = add

let mul_n = mul

let ediv_n = ediv

let abs x = Z.abs x

let is_nat x = if Compare.Z.(x < Z.zero) then None else Some x

let neg x = Z.neg x

let int x = x

let shift_left x y =
  if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
  else
    let y = Z.to_int y in
    Some (Z.shift_left x y)

let shift_right x y =
  if Compare.Int.(Z.compare y (Z.of_int 256) > 0) then None
  else
    let y = Z.to_int y in
    Some (Z.shift_right x y)

let shift_left_n = shift_left

let shift_right_n = shift_right

let logor x y = Z.logor x y

let logxor x y = Z.logxor x y

let logand x y = Z.logand x y

let lognot x = Z.lognot x
src/proto_alpha/lib_protocol/script_int_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive n : Type :=
| Natural_tag : n.

Inductive z : Type :=
| Integer_tag : z.

Definition num (t : Type) := Tezos_protocol_environment_alpha__Environment.Z.t.

Definition compare
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t) : Z := Z.compare x y.

Definition zero : Tezos_protocol_environment_alpha__Environment.Z.t := Z.zero.

Definition zero_n : Tezos_protocol_environment_alpha__Environment.Z.t := Z.zero.

Definition to_string (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : string := Z.to_string x.

Definition of_string (s : string)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.of_string s)).

Definition to_int64 (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option int64 :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.to_int64 x)).

Definition of_int64 (n : int64)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int64 n.

Definition to_int (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option Z :=
  (* ❌ Try-with are not handled *)
  try (Some (Z.to_int x)).

Definition of_int (n : Z) : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.of_int n.

Definition of_zint {A : Type} (x : A) : A := x.

Definition to_zint {A : Type} (x : A) : A := x.

Definition add
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.add x y.

Definition sub
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.sub x y.

Definition mul
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.mul x y.

Definition ediv
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option
    (Tezos_protocol_environment_alpha__Environment.Z.t *
      Tezos_protocol_environment_alpha__Environment.Z.t) :=
  (* ❌ Try-with are not handled *)
  try
    (let '(q, r) := Z.ediv_rem x y in
    Some (q, r)).

Definition add_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t := add.

Definition mul_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      Tezos_protocol_environment_alpha__Environment.Z.t := mul.

Definition ediv_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      option
        (Tezos_protocol_environment_alpha__Environment.Z.t *
          Tezos_protocol_environment_alpha__Environment.Z.t) := ediv.

Definition abs (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.abs x.

Definition is_nat
  (x :
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : option
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
      x Z.zero then
    None
  else
    Some x.

Definition neg (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.neg x.

Definition int {A : Type} (x : A) : A := x.

Definition shift_left
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      (Z.compare y (Z.of_int 256)) 0 then
    None
  else
    let y := Z.to_int y in
    Some (Z.shift_left x y).

Definition shift_right
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      (Z.compare y (Z.of_int 256)) 0 then
    None
  else
    let y := Z.to_int y in
    Some (Z.shift_right x y).

Definition shift_left_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      option Tezos_protocol_environment_alpha__Environment.Z.t := shift_left.

Definition shift_right_n
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t ->
      option Tezos_protocol_environment_alpha__Environment.Z.t := shift_right.

Definition logor
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.logor x y.

Definition logxor
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.logxor x y.

Definition logand
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.logand x y.

Definition lognot (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_protocol_environment_alpha__Environment.Z.t := Z.lognot x.

src/proto_alpha/lib_protocol/script_interpreter.ml 272 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script
open Script_typed_ir
open Script_ir_translator

(* ---- Run-time errors -----------------------------------------------------*)

type execution_trace =
  (Script.location * Gas.t * (Script.expr * string option) list) list

type error +=
  | Reject of Script.location * Script.expr * execution_trace option

type error += Overflow of Script.location * execution_trace option

type error += Runtime_contract_error : Contract.t * Script.expr -> error

type error += Bad_contract_parameter of Contract.t (* `Permanent *)

type error += Cannot_serialize_log

type error += Cannot_serialize_failure

type error += Cannot_serialize_storage

let () =
  let open Data_encoding in
  let trace_encoding =
    list
    @@ obj3
         (req "location" Script.location_encoding)
         (req "gas" Gas.encoding)
         (req
            "stack"
            (list (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))
  in
  (* Reject *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.script_rejected"
    ~title:"Script failed"
    ~description:"A FAILWITH instruction was reached"
    (obj3
       (req "location" Script.location_encoding)
       (req "with" Script.expr_encoding)
       (opt "trace" trace_encoding))
    (function Reject (loc, v, trace) -> Some (loc, v, trace) | _ -> None)
    (fun (loc, v, trace) -> Reject (loc, v, trace)) ;
  (* Overflow *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.script_overflow"
    ~title:"Script failed (overflow error)"
    ~description:
      "A FAIL instruction was reached due to the detection of an overflow"
    (obj2
       (req "location" Script.location_encoding)
       (opt "trace" trace_encoding))
    (function Overflow (loc, trace) -> Some (loc, trace) | _ -> None)
    (fun (loc, trace) -> Overflow (loc, trace)) ;
  (* Runtime contract error *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.runtime_error"
    ~title:"Script runtime error"
    ~description:"Toplevel error for all runtime script errors"
    (obj2
       (req "contract_handle" Contract.encoding)
       (req "contract_code" Script.expr_encoding))
    (function
      | Runtime_contract_error (contract, expr) ->
          Some (contract, expr)
      | _ ->
          None)
    (fun (contract, expr) -> Runtime_contract_error (contract, expr)) ;
  (* Bad contract parameter *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_contract_parameter"
    ~title:"Contract supplied an invalid parameter"
    ~description:
      "Either no parameter was supplied to a contract with a non-unit \
       parameter type, a non-unit parameter was passed to an account, or a \
       parameter was supplied of the wrong type"
    Data_encoding.(obj1 (req "contract" Contract.encoding))
    (function Bad_contract_parameter c -> Some c | _ -> None)
    (fun c -> Bad_contract_parameter c) ;
  (* Cannot serialize log *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_log"
    ~title:"Not enough gas to serialize execution trace"
    ~description:
      "Execution trace with stacks was to big to be serialized with the \
       provided gas"
    Data_encoding.empty
    (function Cannot_serialize_log -> Some () | _ -> None)
    (fun () -> Cannot_serialize_log) ;
  (* Cannot serialize failure *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_failure"
    ~title:"Not enough gas to serialize argument of FAILWITH"
    ~description:
      "Argument of FAILWITH was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_failure -> Some () | _ -> None)
    (fun () -> Cannot_serialize_failure) ;
  (* Cannot serialize storage *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_storage"
    ~title:"Not enough gas to serialize execution storage"
    ~description:
      "The returned storage was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_storage -> Some () | _ -> None)
    (fun () -> Cannot_serialize_storage)

(* ---- interpreter ---------------------------------------------------------*)

type 'tys stack =
  | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
  | Empty : end_of_stack stack

let unparse_stack ctxt (stack, stack_ty) =
  (* We drop the gas limit as this function is only used for debugging/errors. *)
  let ctxt = Gas.set_unlimited ctxt in
  let rec unparse_stack :
      type a.
      a stack * a stack_ty -> (Script.expr * string option) list tzresult Lwt.t
      = function
    | (Empty, Empty_t) ->
        return_nil
    | (Item (v, rest), Item_t (ty, rest_ty, annot)) ->
        unparse_data ctxt Readable ty v
        >>=? fun (data, _ctxt) ->
        unparse_stack (rest, rest_ty)
        >>=? fun rest ->
        let annot =
          match Script_ir_annot.unparse_var_annot annot with
          | [] ->
              None
          | [a] ->
              Some a
          | _ ->
              assert false
        in
        let data = Micheline.strip_locations data in
        return ((data, annot) :: rest)
  in
  unparse_stack (stack, stack_ty)

module Interp_costs = Michelson_v1_gas.Cost_of.Interpreter

let rec interp_stack_prefix_preserving_operation :
    type fbef bef faft aft result.
    (fbef stack -> (faft stack * result) tzresult Lwt.t) ->
    (fbef, faft, bef, aft) stack_prefix_preservation_witness ->
    bef stack ->
    (aft stack * result) tzresult Lwt.t =
 fun f n stk ->
  match (n, stk) with
  | ( Prefix
        (Prefix
          (Prefix
            (Prefix
              (Prefix
                (Prefix
                  (Prefix
                    (Prefix
                      (Prefix
                        (Prefix
                          (Prefix
                            (Prefix (Prefix (Prefix (Prefix (Prefix n))))))))))))))),
      Item
        ( v0,
          Item
            ( v1,
              Item
                ( v2,
                  Item
                    ( v3,
                      Item
                        ( v4,
                          Item
                            ( v5,
                              Item
                                ( v6,
                                  Item
                                    ( v7,
                                      Item
                                        ( v8,
                                          Item
                                            ( v9,
                                              Item
                                                ( va,
                                                  Item
                                                    ( vb,
                                                      Item
                                                        ( vc,
                                                          Item
                                                            ( vd,
                                                              Item
                                                                ( ve,
                                                                  Item
                                                                    (vf, rest)
                                                                ) ) ) ) ) ) )
                                    ) ) ) ) ) ) ) ) ) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) ->
      return
        ( Item
            ( v0,
              Item
                ( v1,
                  Item
                    ( v2,
                      Item
                        ( v3,
                          Item
                            ( v4,
                              Item
                                ( v5,
                                  Item
                                    ( v6,
                                      Item
                                        ( v7,
                                          Item
                                            ( v8,
                                              Item
                                                ( v9,
                                                  Item
                                                    ( va,
                                                      Item
                                                        ( vb,
                                                          Item
                                                            ( vc,
                                                              Item
                                                                ( vd,
                                                                  Item
                                                                    ( ve,
                                                                      Item
                                                                        ( vf,
                                                                          rest'
                                                                        ) ) )
                                                            ) ) ) ) ) ) ) ) )
                        ) ) ) ),
          result )
  | ( Prefix (Prefix (Prefix (Prefix n))),
      Item (v0, Item (v1, Item (v2, Item (v3, rest)))) ) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) ->
      return (Item (v0, Item (v1, Item (v2, Item (v3, rest')))), result)
  | (Prefix n, Item (v, rest)) ->
      interp_stack_prefix_preserving_operation f n rest
      >>=? fun (rest', result) -> return (Item (v, rest'), result)
  | (Rest, v) ->
      f v

type step_constants = {
  source : Contract.t;
  payer : Contract.t;
  self : Contract.t;
  amount : Tez.t;
  chain_id : Chain_id.t;
}

let rec step :
    type b a.
    ?log:execution_trace ref ->
    context ->
    step_constants ->
    (b, a) descr ->
    b stack ->
    (a stack * context) tzresult Lwt.t =
 fun ?log ctxt step_constants ({instr; loc; _} as descr) stack ->
  Lwt.return (Gas.consume ctxt Interp_costs.cycle)
  >>=? fun ctxt ->
  let logged_return :
      type a b.
      (b, a) descr -> a stack * context -> (a stack * context) tzresult Lwt.t =
   fun descr (ret, ctxt) ->
    match log with
    | None ->
        return (ret, ctxt)
    | Some log ->
        trace Cannot_serialize_log (unparse_stack ctxt (ret, descr.aft))
        >>=? fun stack ->
        log := (descr.loc, Gas.level ctxt, stack) :: !log ;
        return (ret, ctxt)
  in
  let get_log (log : execution_trace ref option) =
    Option.map ~f:(fun l -> List.rev !l) log
  in
  let consume_gas_terop :
      type ret arg1 arg2 arg3 rest.
      (_ * (_ * (_ * rest)), ret * rest) descr ->
      (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3 ->
      (arg1 -> arg2 -> arg3 -> Gas.cost) ->
      rest stack ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, x1, x2, x3) cost_func rest ->
    Lwt.return (Gas.consume ctxt (cost_func x1 x2 x3))
    >>=? fun ctxt -> logged_return descr (Item (op x1 x2 x3, rest), ctxt)
  in
  let consume_gas_binop :
      type ret arg1 arg2 rest.
      (_ * (_ * rest), ret * rest) descr ->
      (arg1 -> arg2 -> ret) * arg1 * arg2 ->
      (arg1 -> arg2 -> Gas.cost) ->
      rest stack ->
      context ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, x1, x2) cost_func rest ctxt ->
    Lwt.return (Gas.consume ctxt (cost_func x1 x2))
    >>=? fun ctxt -> logged_return descr (Item (op x1 x2, rest), ctxt)
  in
  let consume_gas_unop :
      type ret arg rest.
      (_ * rest, ret * rest) descr ->
      (arg -> ret) * arg ->
      (arg -> Gas.cost) ->
      rest stack ->
      context ->
      ((ret * rest) stack * context) tzresult Lwt.t =
   fun descr (op, arg) cost_func rest ctxt ->
    Lwt.return (Gas.consume ctxt (cost_func arg))
    >>=? fun ctxt -> logged_return descr (Item (op arg, rest), ctxt)
  in
  let logged_return : a stack * context -> (a stack * context) tzresult Lwt.t =
    logged_return descr
  in
  match (instr, stack) with
  (* stack ops *)
  | (Drop, Item (_, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (rest, ctxt)
  | (Dup, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (Item (v, Item (v, rest)), ctxt)
  | (Swap, Item (vi, Item (vo, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt -> logged_return (Item (vo, Item (vi, rest)), ctxt)
  | (Const v, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
  (* options *)
  | (Cons_some, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (Some v, rest), ctxt)
  | (Cons_none _, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
      >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (If_none (bt, _), Item (None, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt rest
  | (If_none (_, bf), Item (Some v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
  (* pairs *)
  | (Cons_pair, Item (a, Item (b, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair)
      >>=? fun ctxt -> logged_return (Item ((a, b), rest), ctxt)
  (* Peephole optimization for UNPAIR *)
  | ( Seq
        ( {instr = Dup; _},
          { instr =
              Seq
                ( {instr = Car; _},
                  { instr = Seq ({instr = Dip {instr = Cdr}}, {instr = Nop; _});
                    _ } );
            _ } ),
      Item ((a, b), rest) ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (a, Item (b, rest)), ctxt)
  | (Car, Item ((a, _), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (a, rest), ctxt)
  | (Cdr, Item ((_, b), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.pair_access)
      >>=? fun ctxt -> logged_return (Item (b, rest), ctxt)
  (* unions *)
  | (Left, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (L v, rest), ctxt)
  | (Right, Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.wrap)
      >>=? fun ctxt -> logged_return (Item (R v, rest), ctxt)
  | (If_left (bt, _), Item (L v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt (Item (v, rest))
  | (If_left (_, bf), Item (R v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf (Item (v, rest))
  (* lists *)
  | (Cons_list, Item (hd, Item (tl, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.cons)
      >>=? fun ctxt -> logged_return (Item (hd :: tl, rest), ctxt)
  | (Nil, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.variant_no_data)
      >>=? fun ctxt -> logged_return (Item ([], rest), ctxt)
  | (If_cons (_, bf), Item ([], rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf rest
  | (If_cons (bt, _), Item (hd :: tl, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt ->
      step ?log ctxt step_constants bt (Item (hd, Item (tl, rest)))
  | (List_map body, Item (l, rest)) ->
      let rec loop rest ctxt l acc =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (Item (List.rev acc, rest), ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, rest))
            >>=? fun (Item (hd, rest), ctxt) -> loop rest ctxt tl (hd :: acc)
      in
      loop rest ctxt l [] >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (List_size, Item (list, rest)) ->
      Lwt.return
        (List.fold_left
           (fun acc _ ->
             acc
             >>? fun (size, ctxt) ->
             Gas.consume ctxt Interp_costs.loop_size
             >>? fun ctxt -> ok (size + 1 (* FIXME: overflow *), ctxt))
           (ok (0, ctxt))
           list)
      >>=? fun (len, ctxt) ->
      logged_return (Item (Script_int.(abs (of_int len)), rest), ctxt)
  | (List_iter body, Item (l, init)) ->
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  (* sets *)
  | (Empty_set t, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_set)
      >>=? fun ctxt -> logged_return (Item (empty_set t, rest), ctxt)
  | (Set_iter body, Item (set, init)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.set_to_list set))
      >>=? fun ctxt ->
      let l = List.rev (set_fold (fun e acc -> e :: acc) set []) in
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (Set_mem, Item (v, Item (set, rest))) ->
      consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest ctxt
  | (Set_update, Item (v, Item (presence, Item (set, rest)))) ->
      consume_gas_terop
        descr
        (set_update, v, presence, set)
        Interp_costs.set_update
        rest
  | (Set_size, Item (set, rest)) ->
      consume_gas_unop
        descr
        (set_size, set)
        (fun _ -> Interp_costs.set_size)
        rest
        ctxt
  (* maps *)
  | (Empty_map (t, _), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
      >>=? fun ctxt -> logged_return (Item (empty_map t, rest), ctxt)
  | (Map_map body, Item (map, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
      >>=? fun ctxt ->
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop rest ctxt l acc =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_map)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (acc, ctxt)
        | ((k, _) as hd) :: tl ->
            step ?log ctxt step_constants body (Item (hd, rest))
            >>=? fun (Item (hd, rest), ctxt) ->
            loop rest ctxt tl (map_update k (Some hd) acc)
      in
      loop rest ctxt l (empty_map (map_key_ty map))
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Map_iter body, Item (map, init)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_to_list map))
      >>=? fun ctxt ->
      let l = List.rev (map_fold (fun k v acc -> (k, v) :: acc) map []) in
      let rec loop ctxt l stack =
        Lwt.return (Gas.consume ctxt Interp_costs.loop_iter)
        >>=? fun ctxt ->
        match l with
        | [] ->
            return (stack, ctxt)
        | hd :: tl ->
            step ?log ctxt step_constants body (Item (hd, stack))
            >>=? fun (stack, ctxt) -> loop ctxt tl stack
      in
      loop ctxt l init >>=? fun (res, ctxt) -> logged_return (res, ctxt)
  | (Map_mem, Item (v, Item (map, rest))) ->
      consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest ctxt
  | (Map_get, Item (v, Item (map, rest))) ->
      consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest ctxt
  | (Map_update, Item (k, Item (v, Item (map, rest)))) ->
      consume_gas_terop
        descr
        (map_update, k, v, map)
        Interp_costs.map_update
        rest
  | (Map_size, Item (map, rest)) ->
      consume_gas_unop
        descr
        (map_size, map)
        (fun _ -> Interp_costs.map_size)
        rest
        ctxt
  (* Big map operations *)
  | (Empty_big_map (tk, tv), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.empty_map)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_ir_translator.empty_big_map tk tv, rest), ctxt)
  | (Big_map_mem, Item (key, Item (map, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_mem key map.diff))
      >>=? fun ctxt ->
      Script_ir_translator.big_map_mem ctxt key map
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Big_map_get, Item (key, Item (map, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.map_get key map.diff))
      >>=? fun ctxt ->
      Script_ir_translator.big_map_get ctxt key map
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Big_map_update, Item (key, Item (maybe_value, Item (map, rest)))) ->
      consume_gas_terop
        descr
        (Script_ir_translator.big_map_update, key, maybe_value, map)
        (fun k v m -> Interp_costs.map_update k (Some v) m.diff)
        rest
  (* timestamp operations *)
  | (Add_seconds_to_timestamp, Item (n, Item (t, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.add_delta, t, n)
        Interp_costs.add_timestamp
        rest
        ctxt
  | (Add_timestamp_to_seconds, Item (t, Item (n, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.add_delta, t, n)
        Interp_costs.add_timestamp
        rest
        ctxt
  | (Sub_timestamp_seconds, Item (t, Item (s, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.sub_delta, t, s)
        Interp_costs.sub_timestamp
        rest
        ctxt
  | (Diff_timestamps, Item (t1, Item (t2, rest))) ->
      consume_gas_binop
        descr
        (Script_timestamp.diff, t1, t2)
        Interp_costs.diff_timestamps
        rest
        ctxt
  (* string operations *)
  | (Concat_string_pair, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_string [x; y]))
      >>=? fun ctxt ->
      let s = String.concat "" [x; y] in
      logged_return (Item (s, rest), ctxt)
  | (Concat_string, Item (ss, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_string ss))
      >>=? fun ctxt ->
      let s = String.concat "" ss in
      logged_return (Item (s, rest), ctxt)
  | (Slice_string, Item (offset, Item (length, Item (s, rest)))) ->
      let s_length = Z.of_int (String.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
        Lwt.return
          (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
        >>=? fun ctxt ->
        logged_return
          ( Item (Some (String.sub s (Z.to_int offset) (Z.to_int length)), rest),
            ctxt )
      else
        Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
        >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (String_size, Item (s, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_int.(abs (of_int (String.length s))), rest), ctxt)
  (* bytes operations *)
  | (Concat_bytes_pair, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes [x; y]))
      >>=? fun ctxt ->
      let s = MBytes.concat "" [x; y] in
      logged_return (Item (s, rest), ctxt)
  | (Concat_bytes, Item (ss, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.concat_bytes ss))
      >>=? fun ctxt ->
      let s = MBytes.concat "" ss in
      logged_return (Item (s, rest), ctxt)
  | (Slice_bytes, Item (offset, Item (length, Item (s, rest)))) ->
      let s_length = Z.of_int (MBytes.length s) in
      let offset = Script_int.to_zint offset in
      let length = Script_int.to_zint length in
      if Compare.Z.(offset < s_length && Z.add offset length <= s_length) then
        Lwt.return
          (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length)))
        >>=? fun ctxt ->
        logged_return
          ( Item (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)), rest),
            ctxt )
      else
        Lwt.return (Gas.consume ctxt (Interp_costs.slice_string 0))
        >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
  | (Bytes_size, Item (s, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt ->
      logged_return
        (Item (Script_int.(abs (of_int (MBytes.length s))), rest), ctxt)
  (* currency operations *)
  | (Add_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return Tez.(x +? y)
      >>=? fun res -> logged_return (Item (res, rest), ctxt)
  | (Sub_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return Tez.(x -? y)
      >>=? fun res -> logged_return (Item (res, rest), ctxt)
  | (Mul_teznat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
      >>=? fun ctxt ->
      match Script_int.to_int64 y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some y ->
          Lwt.return Tez.(x *? y)
          >>=? fun res -> logged_return (Item (res, rest), ctxt) )
  | (Mul_nattez, Item (y, Item (x, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.int64_op)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.z_to_int64)
      >>=? fun ctxt ->
      match Script_int.to_int64 y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some y ->
          Lwt.return Tez.(x *? y)
          >>=? fun res -> logged_return (Item (res, rest), ctxt) )
  (* boolean operations *)
  | (Or, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (( || ), x, y) Interp_costs.bool_binop rest ctxt
  | (And, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (( && ), x, y) Interp_costs.bool_binop rest ctxt
  | (Xor, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Compare.Bool.( <> ), x, y)
        Interp_costs.bool_binop
        rest
        ctxt
  | (Not, Item (x, rest)) ->
      consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
  (* integer operations *)
  | (Is_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest ctxt
  | (Abs_int, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
  | (Int_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
  | (Neg_int, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
  | (Neg_nat, Item (x, rest)) ->
      consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
  | (Add_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest ctxt
  | (Add_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.add_n, x, y)
        Interp_costs.add
        rest
        ctxt
  | (Sub_int, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest ctxt
  | (Mul_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest ctxt
  | (Mul_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.mul_n, x, y)
        Interp_costs.mul
        rest
        ctxt
  | (Ediv_teznat, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      let x = Script_int.of_int64 (Tez.to_mutez x) in
      consume_gas_binop
        descr
        ( (fun x y ->
            match Script_int.ediv x y with
            | None ->
                None
            | Some (q, r) -> (
              match (Script_int.to_int64 q, Script_int.to_int64 r) with
              | (Some q, Some r) -> (
                match (Tez.of_mutez q, Tez.of_mutez r) with
                | (Some q, Some r) ->
                    Some (q, r)
                (* Cannot overflow *)
                | _ ->
                    assert false )
              (* Cannot overflow *)
              | _ ->
                  assert false )),
          x,
          y )
        Interp_costs.div
        rest
        ctxt
  | (Ediv_tez, Item (x, Item (y, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      Lwt.return (Gas.consume ctxt Interp_costs.int64_to_z)
      >>=? fun ctxt ->
      let x = Script_int.abs (Script_int.of_int64 (Tez.to_mutez x)) in
      let y = Script_int.abs (Script_int.of_int64 (Tez.to_mutez y)) in
      consume_gas_binop
        descr
        ( (fun x y ->
            match Script_int.ediv_n x y with
            | None ->
                None
            | Some (q, r) -> (
              match Script_int.to_int64 r with
              | None ->
                  assert false (* Cannot overflow *)
              | Some r -> (
                match Tez.of_mutez r with
                | None ->
                    assert false (* Cannot overflow *)
                | Some r ->
                    Some (q, r) ) )),
          x,
          y )
        Interp_costs.div
        rest
        ctxt
  | (Ediv_intint, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_intnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_natint, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Ediv_natnat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.ediv_n, x, y)
        Interp_costs.div
        rest
        ctxt
  | (Lsl_nat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt (Interp_costs.shift_left x y))
      >>=? fun ctxt ->
      match Script_int.shift_left_n x y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some x ->
          logged_return (Item (x, rest), ctxt) )
  | (Lsr_nat, Item (x, Item (y, rest))) -> (
      Lwt.return (Gas.consume ctxt (Interp_costs.shift_right x y))
      >>=? fun ctxt ->
      match Script_int.shift_right_n x y with
      | None ->
          fail (Overflow (loc, get_log log))
      | Some r ->
          logged_return (Item (r, rest), ctxt) )
  | (Or_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logor, x, y)
        Interp_costs.logor
        rest
        ctxt
  | (And_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logand, x, y)
        Interp_costs.logand
        rest
        ctxt
  | (And_int_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logand, x, y)
        Interp_costs.logand
        rest
        ctxt
  | (Xor_nat, Item (x, Item (y, rest))) ->
      consume_gas_binop
        descr
        (Script_int.logxor, x, y)
        Interp_costs.logxor
        rest
        ctxt
  | (Not_int, Item (x, rest)) ->
      consume_gas_unop
        descr
        (Script_int.lognot, x)
        Interp_costs.lognot
        rest
        ctxt
  | (Not_nat, Item (x, rest)) ->
      consume_gas_unop
        descr
        (Script_int.lognot, x)
        Interp_costs.lognot
        rest
        ctxt
  (* control *)
  | (Seq (hd, tl), stack) ->
      step ?log ctxt step_constants hd stack
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants tl trans
  | (If (bt, _), Item (true, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bt rest
  | (If (_, bf), Item (false, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.branch)
      >>=? fun ctxt -> step ?log ctxt step_constants bf rest
  | (Loop body, Item (true, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt ->
      step ?log ctxt step_constants body rest
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
  | (Loop _, Item (false, rest)) ->
      logged_return (rest, ctxt)
  | (Loop_left body, Item (L v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt ->
      step ?log ctxt step_constants body (Item (v, rest))
      >>=? fun (trans, ctxt) -> step ?log ctxt step_constants descr trans
  | (Loop_left _, Item (R v, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.loop_cycle)
      >>=? fun ctxt -> logged_return (Item (v, rest), ctxt)
  | (Dip b, Item (ign, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.stack_op)
      >>=? fun ctxt ->
      step ?log ctxt step_constants b rest
      >>=? fun (res, ctxt) -> logged_return (Item (ign, res), ctxt)
  | (Exec, Item (arg, Item (lam, rest))) ->
      Lwt.return (Gas.consume ctxt Interp_costs.exec)
      >>=? fun ctxt ->
      interp ?log ctxt step_constants lam arg
      >>=? fun (res, ctxt) -> logged_return (Item (res, rest), ctxt)
  | (Apply capture_ty, Item (capture, Item (lam, rest))) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.apply)
      >>=? fun ctxt ->
      let (Lam (descr, expr)) = lam in
      let (Item_t (full_arg_ty, _, _)) = descr.bef in
      unparse_data ctxt Optimized capture_ty capture
      >>=? fun (const_expr, ctxt) ->
      unparse_ty ctxt capture_ty
      >>=? fun (ty_expr, ctxt) ->
      match full_arg_ty with
      | Pair_t ((capture_ty, _, _), (arg_ty, _, _), _, _) ->
          let arg_stack_ty = Item_t (arg_ty, Empty_t, None) in
          let const_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = Item_t (capture_ty, arg_stack_ty, None);
                instr = Const capture;
              }
              : (_, _) descr )
          in
          let pair_descr =
            ( {
                loc = descr.loc;
                bef = Item_t (capture_ty, arg_stack_ty, None);
                aft = Item_t (full_arg_ty, Empty_t, None);
                instr = Cons_pair;
              }
              : (_, _) descr )
          in
          let seq_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = Item_t (full_arg_ty, Empty_t, None);
                instr = Seq (const_descr, pair_descr);
              }
              : (_, _) descr )
          in
          let full_descr =
            ( {
                loc = descr.loc;
                bef = arg_stack_ty;
                aft = descr.aft;
                instr = Seq (seq_descr, descr);
              }
              : (_, _) descr )
          in
          let full_expr =
            Micheline.Seq
              ( 0,
                [ Prim (0, I_PUSH, [ty_expr; const_expr], []);
                  Prim (0, I_PAIR, [], []);
                  expr ] )
          in
          let lam' = Lam (full_descr, full_expr) in
          logged_return (Item (lam', rest), ctxt)
      | _ ->
          assert false )
  | (Lambda lam, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.push)
      >>=? fun ctxt -> logged_return (Item (lam, rest), ctxt)
  | (Failwith tv, Item (v, _)) ->
      trace Cannot_serialize_failure (unparse_data ctxt Optimized tv v)
      >>=? fun (v, _ctxt) ->
      let v = Micheline.strip_locations v in
      fail (Reject (loc, v, get_log log))
  | (Nop, stack) ->
      logged_return (stack, ctxt)
  (* comparison *)
  | (Compare ty, Item (a, Item (b, rest))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.compare ty a b))
      >>=? fun ctxt ->
      logged_return
        ( Item
            ( Script_int.of_int
              @@ Script_ir_translator.compare_comparable ty a b,
              rest ),
          ctxt )
  (* comparators *)
  | (Eq, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres = 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Neq, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres <> 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Lt, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres < 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Le, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres <= 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Gt, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres > 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  | (Ge, Item (cmpres, rest)) ->
      let cmpres = Script_int.compare cmpres Script_int.zero in
      let cmpres = Compare.Int.(cmpres >= 0) in
      Lwt.return (Gas.consume ctxt Interp_costs.compare_res)
      >>=? fun ctxt -> logged_return (Item (cmpres, rest), ctxt)
  (* packing *)
  | (Pack t, Item (value, rest)) ->
      Script_ir_translator.pack_data ctxt t value
      >>=? fun (bytes, ctxt) -> logged_return (Item (bytes, rest), ctxt)
  | (Unpack t, Item (bytes, rest)) ->
      Lwt.return (Gas.check_enough ctxt (Script.serialized_cost bytes))
      >>=? fun () ->
      if
        Compare.Int.(MBytes.length bytes >= 1)
        && Compare.Int.(MBytes.get_uint8 bytes 0 = 0x05)
      then
        let bytes = MBytes.sub bytes 1 (MBytes.length bytes - 1) in
        match Data_encoding.Binary.of_bytes Script.expr_encoding bytes with
        | None ->
            Lwt.return (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
            >>=? fun ctxt -> logged_return (Item (None, rest), ctxt)
        | Some expr -> (
            Lwt.return (Gas.consume ctxt (Script.deserialized_cost expr))
            >>=? fun ctxt ->
            parse_data ctxt ~legacy:false t (Micheline.root expr)
            >>= function
            | Ok (value, ctxt) ->
                logged_return (Item (Some value, rest), ctxt)
            | Error _ignored ->
                Lwt.return
                  (Gas.consume ctxt (Interp_costs.unpack_failed bytes))
                >>=? fun ctxt -> logged_return (Item (None, rest), ctxt) )
      else logged_return (Item (None, rest), ctxt)
  (* protocol *)
  | (Address, Item ((_, address), rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.address)
      >>=? fun ctxt -> logged_return (Item (address, rest), ctxt)
  | (Contract (t, entrypoint), Item (contract, rest)) -> (
      Lwt.return (Gas.consume ctxt Interp_costs.contract)
      >>=? fun ctxt ->
      match (contract, entrypoint) with
      | ((contract, "default"), entrypoint)
      | ((contract, entrypoint), "default") ->
          Script_ir_translator.parse_contract_for_script
            ~legacy:false
            ctxt
            loc
            t
            contract
            ~entrypoint
          >>=? fun (ctxt, maybe_contract) ->
          logged_return (Item (maybe_contract, rest), ctxt)
      | _ ->
          logged_return (Item (None, rest), ctxt) )
  | ( Transfer_tokens,
      Item (p, Item (amount, Item ((tp, (destination, entrypoint)), rest))) )
    ->
      Lwt.return (Gas.consume ctxt Interp_costs.transfer)
      >>=? fun ctxt ->
      collect_big_maps ctxt tp p
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        tp
        p
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (p, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized tp p
      >>=? fun (p, ctxt) ->
      let operation =
        Transaction
          {
            amount;
            destination;
            entrypoint;
            parameters = Script.lazy_expr (Micheline.strip_locations p);
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              rest ),
          ctxt )
  | ( Create_account,
      Item (manager, Item (delegate, Item (_delegatable, Item (credit, rest))))
    ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_account)
      >>=? fun ctxt ->
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      (* store in optimized binary representation - as unparsed with [Optimized]. *)
      let manager_bytes =
        Data_encoding.Binary.to_bytes_exn
          Signature.Public_key_hash.encoding
          manager
      in
      let storage =
        Script_repr.lazy_expr @@ Micheline.strip_locations
        @@ Micheline.Bytes (0, manager_bytes)
      in
      let script = {code = Legacy_support.manager_script_code; storage} in
      let operation =
        Origination {credit; delegate; preorigination = Some contract; script}
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                None ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | (Implicit_account, Item (key, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.implicit_account)
      >>=? fun ctxt ->
      let contract = Contract.implicit_contract key in
      logged_return (Item ((Unit_t None, (contract, "default")), rest), ctxt)
  | ( Create_contract (storage_type, param_type, Lam (_, code), root_name),
      Item
        ( manager,
          Item
            ( delegate,
              Item
                ( spendable,
                  Item (delegatable, Item (credit, Item (init, rest))) ) ) ) )
    ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
      >>=? fun ctxt ->
      unparse_ty ctxt param_type
      >>=? fun (unparsed_param_type, ctxt) ->
      let unparsed_param_type =
        Script_ir_translator.add_field_annot
          (Option.map ~f:(fun n -> `Field_annot n) root_name)
          None
          unparsed_param_type
      in
      unparse_ty ctxt storage_type
      >>=? fun (unparsed_storage_type, ctxt) ->
      let code =
        Script.lazy_expr
        @@ Micheline.strip_locations
             (Seq
                ( 0,
                  [ Prim (0, K_parameter, [unparsed_param_type], []);
                    Prim (0, K_storage, [unparsed_storage_type], []);
                    Prim (0, K_code, [code], []) ] ))
      in
      collect_big_maps ctxt storage_type init
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        storage_type
        init
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (init, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized storage_type init
      >>=? fun (storage, ctxt) ->
      let storage = Script.lazy_expr @@ Micheline.strip_locations storage in
      ( if spendable then
        Legacy_support.add_do
          ~manager_pkh:manager
          ~script_code:code
          ~script_storage:storage
      else if delegatable then
        Legacy_support.add_set_delegate
          ~manager_pkh:manager
          ~script_code:code
          ~script_storage:storage
      else if Legacy_support.has_default_entrypoint code then
        Legacy_support.add_root_entrypoint code
        >>=? fun code -> return (code, storage)
      else return (code, storage) )
      >>=? fun (code, storage) ->
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      let operation =
        Origination
          {
            credit;
            delegate;
            preorigination = Some contract;
            script = {code; storage};
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | ( Create_contract_2 (storage_type, param_type, Lam (_, code), root_name),
      (* Removed the instruction's arguments manager, spendable and delegatable *)
    Item (delegate, Item (credit, Item (init, rest))) ) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_contract)
      >>=? fun ctxt ->
      unparse_ty ctxt param_type
      >>=? fun (unparsed_param_type, ctxt) ->
      let unparsed_param_type =
        Script_ir_translator.add_field_annot
          (Option.map ~f:(fun n -> `Field_annot n) root_name)
          None
          unparsed_param_type
      in
      unparse_ty ctxt storage_type
      >>=? fun (unparsed_storage_type, ctxt) ->
      let code =
        Micheline.strip_locations
          (Seq
             ( 0,
               [ Prim (0, K_parameter, [unparsed_param_type], []);
                 Prim (0, K_storage, [unparsed_storage_type], []);
                 Prim (0, K_code, [code], []) ] ))
      in
      collect_big_maps ctxt storage_type init
      >>=? fun (to_duplicate, ctxt) ->
      let to_update = no_big_map_id in
      extract_big_map_diff
        ctxt
        Optimized
        storage_type
        init
        ~to_duplicate
        ~to_update
        ~temporary:true
      >>=? fun (init, big_map_diff, ctxt) ->
      unparse_data ctxt Optimized storage_type init
      >>=? fun (storage, ctxt) ->
      let storage = Micheline.strip_locations storage in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, contract) ->
      let operation =
        Origination
          {
            credit;
            delegate;
            preorigination = Some contract;
            script =
              {
                code = Script.lazy_expr code;
                storage = Script.lazy_expr storage;
              };
          }
      in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                big_map_diff ),
              Item ((contract, "default"), rest) ),
          ctxt )
  | (Set_delegate, Item (delegate, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.create_account)
      >>=? fun ctxt ->
      let operation = Delegation delegate in
      Lwt.return (fresh_internal_nonce ctxt)
      >>=? fun (ctxt, nonce) ->
      logged_return
        ( Item
            ( ( Internal_operation
                  {source = step_constants.self; operation; nonce},
                None ),
              rest ),
          ctxt )
  | (Balance, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.balance)
      >>=? fun ctxt ->
      Contract.get_balance ctxt step_constants.self
      >>=? fun balance -> logged_return (Item (balance, rest), ctxt)
  | (Now, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.now)
      >>=? fun ctxt ->
      let now = Script_timestamp.now ctxt in
      logged_return (Item (now, rest), ctxt)
  | (Check_signature, Item (key, Item (signature, Item (message, rest)))) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.check_signature key message))
      >>=? fun ctxt ->
      let res = Signature.check key signature message in
      logged_return (Item (res, rest), ctxt)
  | (Hash_key, Item (key, rest)) ->
      Lwt.return (Gas.consume ctxt Interp_costs.hash_key)
      >>=? fun ctxt ->
      logged_return (Item (Signature.Public_key.hash key, rest), ctxt)
  | (Blake2b, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_blake2b bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.blake2b bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Sha256, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha256 bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.sha256 bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Sha512, Item (bytes, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.hash_sha512 bytes))
      >>=? fun ctxt ->
      let hash = Raw_hashes.sha512 bytes in
      logged_return (Item (hash, rest), ctxt)
  | (Steps_to_quota, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.steps_to_quota)
      >>=? fun ctxt ->
      let steps =
        match Gas.level ctxt with
        | Limited {remaining} ->
            remaining
        | Unaccounted ->
            Z.of_string "99999999"
      in
      logged_return (Item (Script_int.(abs (of_zint steps)), rest), ctxt)
  | (Source, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.source)
      >>=? fun ctxt ->
      logged_return (Item ((step_constants.payer, "default"), rest), ctxt)
  | (Sender, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.source)
      >>=? fun ctxt ->
      logged_return (Item ((step_constants.source, "default"), rest), ctxt)
  | (Self (t, entrypoint), rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.self)
      >>=? fun ctxt ->
      logged_return (Item ((t, (step_constants.self, entrypoint)), rest), ctxt)
  | (Amount, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.amount)
      >>=? fun ctxt -> logged_return (Item (step_constants.amount, rest), ctxt)
  | (Dig (n, n'), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun (Item (v, rest)) -> return (rest, v))
        n'
        stack
      >>=? fun (aft, x) -> logged_return (Item (x, aft), ctxt)
  | (Dug (n, n'), Item (v, rest)) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk -> return (Item (v, stk), ()))
        n'
        rest
      >>=? fun (aft, ()) -> logged_return (aft, ctxt)
  | (Dipn (n, n', b), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk ->
          step ?log ctxt step_constants b stk
          >>=? fun (res, ctxt') -> return (res, ctxt'))
        n'
        stack
      >>=? fun (aft, ctxt') -> logged_return (aft, ctxt')
  | (Dropn (n, n'), stack) ->
      Lwt.return (Gas.consume ctxt (Interp_costs.stack_n_op n))
      >>=? fun ctxt ->
      interp_stack_prefix_preserving_operation
        (fun stk -> return (stk, stk))
        n'
        stack
      >>=? fun (_, rest) -> logged_return (rest, ctxt)
  | (ChainId, rest) ->
      Lwt.return (Gas.consume ctxt Interp_costs.chain_id)
      >>=? fun ctxt ->
      logged_return (Item (step_constants.chain_id, rest), ctxt)

and interp :
    type p r.
    ?log:execution_trace ref ->
    context ->
    step_constants ->
    (p, r) lambda ->
    p ->
    (r * context) tzresult Lwt.t =
 fun ?log ctxt step_constants (Lam (code, _)) arg ->
  let stack = Item (arg, Empty) in
  ( match log with
  | None ->
      return_unit
  | Some log ->
      trace Cannot_serialize_log (unparse_stack ctxt (stack, code.bef))
      >>=? fun stack ->
      log := (code.loc, Gas.level ctxt, stack) :: !log ;
      return_unit )
  >>=? fun () ->
  step ?log ctxt step_constants code stack
  >>=? fun (Item (ret, Empty), ctxt) -> return (ret, ctxt)

(* ---- contract handling ---------------------------------------------------*)
and execute ?log ctxt mode step_constants ~entrypoint unparsed_script arg :
    ( Script.expr
    * packed_internal_operation list
    * context
    * Contract.big_map_diff option )
    tzresult
    Lwt.t =
  parse_script ctxt unparsed_script ~legacy:true
  >>=? fun (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt) ->
  trace
    (Bad_contract_parameter step_constants.self)
    (Lwt.return (find_entrypoint arg_type ~root_name entrypoint))
  >>=? fun (box, _) ->
  trace
    (Bad_contract_parameter step_constants.self)
    (parse_data ctxt ~legacy:false arg_type (box arg))
  >>=? fun (arg, ctxt) ->
  Script.force_decode ctxt unparsed_script.code
  >>=? fun (script_code, ctxt) ->
  Script_ir_translator.collect_big_maps ctxt arg_type arg
  >>=? fun (to_duplicate, ctxt) ->
  Script_ir_translator.collect_big_maps ctxt storage_type storage
  >>=? fun (to_update, ctxt) ->
  trace
    (Runtime_contract_error (step_constants.self, script_code))
    (interp ?log ctxt step_constants code (arg, storage))
  >>=? fun ((ops, storage), ctxt) ->
  Script_ir_translator.extract_big_map_diff
    ctxt
    mode
    ~temporary:false
    ~to_duplicate
    ~to_update
    storage_type
    storage
  >>=? fun (storage, big_map_diff, ctxt) ->
  trace Cannot_serialize_storage (unparse_data ctxt mode storage_type storage)
  >>=? fun (storage, ctxt) ->
  let (ops, op_diffs) = List.split ops in
  let big_map_diff =
    match
      List.flatten
        (List.map (Option.unopt ~default:[]) (op_diffs @ [big_map_diff]))
    with
    | [] ->
        None
    | diff ->
        Some diff
  in
  return (Micheline.strip_locations storage, ops, ctxt, big_map_diff)

type execution_result = {
  ctxt : context;
  storage : Script.expr;
  big_map_diff : Contract.big_map_diff option;
  operations : packed_internal_operation list;
}

let trace ctxt mode step_constants ~script ~entrypoint ~parameter =
  let log = ref [] in
  execute
    ~log
    ctxt
    mode
    step_constants
    ~entrypoint
    script
    (Micheline.root parameter)
  >>=? fun (storage, operations, ctxt, big_map_diff) ->
  let trace = List.rev !log in
  return ({ctxt; storage; big_map_diff; operations}, trace)

let execute ctxt mode step_constants ~script ~entrypoint ~parameter =
  execute
    ctxt
    mode
    step_constants
    ~entrypoint
    script
    (Micheline.root parameter)
  >>=? fun (storage, operations, ctxt, big_map_diff) ->
  return {ctxt; storage; big_map_diff; operations}
src/proto_alpha/lib_protocol/script_interpreter.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Script.

Import Script_typed_ir.

Import Script_ir_translator.

Definition execution_trace :=
  list
    (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
      Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Inductive stack : forall (tys : Type), Type :=
| Item : forall {rest ty : Type}, ty -> (stack rest) -> stack (ty * rest)
| Empty : stack Tezos_raw_protocol_alpha.Script_typed_ir.end_of_stack.

Definition unparse_stack {A : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (function_parameter :
    (stack A) * (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty A))
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))) :=
  let '(stack, stack_ty) := function_parameter in
  let ctxt := Gas.set_unlimited ctxt in
  let fix unparse_stack {a : Type}
    (function_parameter :
    (stack a) * (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a))
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (option string)))) :=
    match function_parameter with
    | (Empty, Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t) => return_nil
    |
      (Item v rest,
        Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty rest_ty annot) =>
      op_gtgteqquestion
        (unparse_data ctxt
          Tezos_raw_protocol_alpha.Script_ir_translator.Readable ty v)
        (fun function_parameter =>
          let '(data, _ctxt) := function_parameter in
          op_gtgteqquestion (unparse_stack (rest, rest_ty))
            (fun rest =>
              let annot :=
                match Script_ir_annot.unparse_var_annot annot with
                | [] => None
                | cons a [] => Some a
                | _ =>
                  (* ❌ Assert instruction is not handled. *)
                  assert false
                end in
              let data := Micheline.strip_locations data in
              _return (cons (data, annot) rest)))
    end in
  unparse_stack (stack, stack_ty).

(* ❌ This kind of module is not handled. *)
unhandled_module

Fixpoint interp_stack_prefix_preserving_operation
  {aft bef faft fbef result : Type}
  (f :
    (stack fbef) ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((stack faft) * result)))
  (n :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
      fbef faft bef aft) (stk : stack bef)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((stack aft) * result)) :=
  match (n, stk) with
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
      (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
        (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
          (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
            (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
              (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                            (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                              (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                                (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
                                    n))))))))))))))),
      Item v0
        (Item v1
          (Item v2
            (Item v3
              (Item v4
                (Item v5
                  (Item v6
                    (Item v7
                      (Item v8
                        (Item v9
                          (Item va
                            (Item vb
                              (Item vc (Item vd (Item ve (Item vf rest))))))))))))))))
    =>
    op_gtgteqquestion (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        let '(rest', result) := function_parameter in
        _return
          ((Item v0
            (Item v1
              (Item v2
                (Item v3
                  (Item v4
                    (Item v5
                      (Item v6
                        (Item v7
                          (Item v8
                            (Item v9
                              (Item va
                                (Item vb
                                  (Item vc (Item vd (Item ve (Item vf rest')))))))))))))))),
            result))
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
      (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
        (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix
          (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n))),
      Item v0 (Item v1 (Item v2 (Item v3 rest)))) =>
    op_gtgteqquestion (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        let '(rest', result) := function_parameter in
        _return ((Item v0 (Item v1 (Item v2 (Item v3 rest')))), result))
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n, Item v rest) =>
    op_gtgteqquestion (interp_stack_prefix_preserving_operation f n rest)
      (fun function_parameter =>
        let '(rest', result) := function_parameter in
        _return ((Item v rest'), result))
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Rest, v) => f v
  end.

Record step_constants := {
  source : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  payer : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  self : Tezos_raw_protocol_alpha.Alpha_context.Contract.t;
  amount : Tezos_raw_protocol_alpha.Alpha_context.Tez.t;
  chain_id :
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
  }.

Fixpoint step {a b : Type}
  (log :
    option
      (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
        execution_trace))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (step_constants : step_constants)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.descr b a)
  : (stack b) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let '{| loc := loc; instr := instr |} as descr := function_parameter in
  fun stack =>
    op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.cycle))
      (fun ctxt =>
        let logged_return
          (descr : Tezos_raw_protocol_alpha.Script_typed_ir.descr b a)
          (function_parameter :
          (stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              ((stack a) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
          let '(ret, ctxt) := function_parameter in
          match log with
          | None => _return (ret, ctxt)
          | Some log =>
            op_gtgteqquestion
              (trace
                Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_log
                (unparse_stack ctxt (ret, (aft descr))))
              (fun stack =>
                (* ❌ Sequences of instructions are not handled (operator ";") *)
                let _ :=
                  op_coloneq log
                    (cons ((loc descr), (Gas.level ctxt), stack)
                      (op_exclamation log)) in
                _return (ret, ctxt))
          end in
        let get_log
          (log :
          option
            (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
              execution_trace))
          : option
            (list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
                Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
                (list
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                    (option string))))) :=
          Option.map (fun l => List.rev (op_exclamation l)) log in
        let consume_gas_terop {C D E arg1 arg2 arg3 rest ret : Type}
          (descr :
          Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * (D * (E * rest)))
            (ret * rest)) (function_parameter :
          (arg1 -> arg2 -> arg3 -> ret) * arg1 * arg2 * arg3)
          : (arg1 ->
            arg2 -> arg3 -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
            (stack rest) ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  ((stack (ret * rest)) *
                    Tezos_raw_protocol_alpha.Alpha_context.context)) :=
          let '(op, x1, x2, x3) := function_parameter in
          fun cost_func =>
            fun rest =>
              op_gtgteqquestion
                (Lwt._return (Gas.consume ctxt (cost_func x1 x2 x3)))
                (fun ctxt =>
                  logged_return descr ((Item (op x1 x2 x3) rest), ctxt)) in
        let consume_gas_binop {C D arg1 arg2 rest ret : Type}
          (descr :
          Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * (D * rest))
            (ret * rest)) (function_parameter :
          (arg1 -> arg2 -> ret) * arg1 * arg2)
          : (arg1 -> arg2 -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
            (stack rest) ->
              Tezos_raw_protocol_alpha.Alpha_context.context ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((stack (ret * rest)) *
                      Tezos_raw_protocol_alpha.Alpha_context.context)) :=
          let '(op, x1, x2) := function_parameter in
          fun cost_func =>
            fun rest =>
              fun ctxt =>
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt (cost_func x1 x2)))
                  (fun ctxt =>
                    logged_return descr ((Item (op x1 x2) rest), ctxt)) in
        let consume_gas_unop {C arg rest ret : Type}
          (descr :
          Tezos_raw_protocol_alpha.Script_typed_ir.descr (C * rest) (ret * rest))
          (function_parameter : (arg -> ret) * arg)
          : (arg -> Tezos_raw_protocol_alpha.Alpha_context.Gas.cost) ->
            (stack rest) ->
              Tezos_raw_protocol_alpha.Alpha_context.context ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((stack (ret * rest)) *
                      Tezos_raw_protocol_alpha.Alpha_context.context)) :=
          let '(op, arg) := function_parameter in
          fun cost_func =>
            fun rest =>
              fun ctxt =>
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt (cost_func arg)))
                  (fun ctxt => logged_return descr ((Item (op arg) rest), ctxt))
          in
        let logged_return := logged_return descr in
        match (instr, stack) with
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Drop, Item _ rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt => logged_return (rest, ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Dup, Item v rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt => logged_return ((Item v (Item v rest)), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Swap, Item vi (Item vo rest))
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt => logged_return ((Item vo (Item vi rest)), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Const v, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
            (fun ctxt => logged_return ((Item v rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some, Item v rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.wrap))
            (fun ctxt => logged_return ((Item (Some v) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none _, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.variant_no_data))
            (fun ctxt => logged_return ((Item None rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.If_none bt _, Item None rest)
          =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bt rest)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.If_none _ bf,
            Item (Some v) rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf (Item v rest))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair,
            Item a (Item b rest)) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.pair))
            (fun ctxt => logged_return ((Item (a, b) rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Seq {|
            instr := Tezos_raw_protocol_alpha.Script_typed_ir.Dup |} {|
            instr :=
              Tezos_raw_protocol_alpha.Script_typed_ir.Seq {|
                instr := Tezos_raw_protocol_alpha.Script_typed_ir.Car
                  |} {|
                instr :=
                  Tezos_raw_protocol_alpha.Script_typed_ir.Seq
                    {|
                    instr :=
                      Tezos_raw_protocol_alpha.Script_typed_ir.Dip
                        {|
                        instr :=
                          Tezos_raw_protocol_alpha.Script_typed_ir.Cdr
                          |}
                      |}
                    {|
                    instr := Tezos_raw_protocol_alpha.Script_typed_ir.Nop
                      |}
                  |}
              |}, Item (a, b) rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.pair_access))
            (fun ctxt => logged_return ((Item a (Item b rest)), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Car, Item (a, _) rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.pair_access))
            (fun ctxt => logged_return ((Item a rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Cdr, Item (_, b) rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.pair_access))
            (fun ctxt => logged_return ((Item b rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Left, Item v rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.wrap))
            (fun ctxt =>
              logged_return
                ((Item (Tezos_raw_protocol_alpha.Script_typed_ir.L v) rest),
                  ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Right, Item v rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.wrap))
            (fun ctxt =>
              logged_return
                ((Item (Tezos_raw_protocol_alpha.Script_typed_ir.R v) rest),
                  ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.If_left bt _,
            Item (Tezos_raw_protocol_alpha.Script_typed_ir.L v) rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bt (Item v rest))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.If_left _ bf,
            Item (Tezos_raw_protocol_alpha.Script_typed_ir.R v) rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf (Item v rest))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list,
            Item hd (Item tl rest)) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.cons))
            (fun ctxt => logged_return ((Item (cons hd tl) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Nil, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.variant_no_data))
            (fun ctxt => logged_return ((Item [] rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.If_cons _ bf, Item [] rest)
          =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf rest)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.If_cons bt _,
            Item (cons hd tl) rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt =>
              step log ctxt step_constants bt (Item hd (Item tl rest)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.List_map body, Item l rest)
          =>
          let fix loop
            (rest : stack op_dollar49) (ctxt :
            Tezos_raw_protocol_alpha__Alpha_context.context) (l :
            list op_dollar48) (acc : list op_dollar50)
            : Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                ((stack ((list op_dollar50) * op_dollar49)) *
                  Tezos_raw_protocol_alpha__Alpha_context.context)) :=
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Interp_costs.loop_map))
              (fun ctxt =>
                match l with
                | [] => _return ((Item (List.rev acc) rest), ctxt)
                | cons hd tl =>
                  op_gtgteqquestion
                    (step log ctxt step_constants body (Item hd rest))
                    (fun function_parameter =>
                      let '(Item hd rest, ctxt) := function_parameter in
                      loop rest ctxt tl (cons hd acc))
                end) in
          op_gtgteqquestion (loop rest ctxt l [])
            (fun function_parameter =>
              let '(res, ctxt) := function_parameter in
              logged_return (res, ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.List_size, Item list rest)
          =>
          op_gtgteqquestion
            (Lwt._return
              (List.fold_left
                (fun acc =>
                  fun function_parameter =>
                    let '_ := function_parameter in
                    op_gtgtquestion acc
                      (fun function_parameter =>
                        let '(size, ctxt) := function_parameter in
                        op_gtgtquestion
                          (Gas.consume ctxt Interp_costs.loop_size)
                          (fun ctxt => ok ((op_plus size 1), ctxt))))
                (ok (0, ctxt)) list))
            (fun function_parameter =>
              let '(len, ctxt) := function_parameter in
              logged_return ((Item (abs (of_int len)) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.List_iter body, Item l init)
          =>
          let fix loop
            (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
            list op_dollar53) (stack : stack op_dollar54)
            : Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                ((stack op_dollar54) *
                  Tezos_raw_protocol_alpha__Alpha_context.context)) :=
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Interp_costs.loop_iter))
              (fun ctxt =>
                match l with
                | [] => _return (stack, ctxt)
                | cons hd tl =>
                  op_gtgteqquestion
                    (step log ctxt step_constants body (Item hd stack))
                    (fun function_parameter =>
                      let '(stack, ctxt) := function_parameter in
                      loop ctxt tl stack)
                end) in
          op_gtgteqquestion (loop ctxt l init)
            (fun function_parameter =>
              let '(res, ctxt) := function_parameter in
              logged_return (res, ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set t, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.empty_set))
            (fun ctxt => logged_return ((Item (empty_set t) rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter body, Item set init)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.set_to_list set)))
            (fun ctxt =>
              let l :=
                List.rev (set_fold (fun e => fun acc => cons e acc) set []) in
              let fix loop
                (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
                list op_dollar56) (stack : stack op_dollar57)
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((stack op_dollar57) *
                      Tezos_raw_protocol_alpha__Alpha_context.context)) :=
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Interp_costs.loop_iter))
                  (fun ctxt =>
                    match l with
                    | [] => _return (stack, ctxt)
                    | cons hd tl =>
                      op_gtgteqquestion
                        (step log ctxt step_constants body (Item hd stack))
                        (fun function_parameter =>
                          let '(stack, ctxt) := function_parameter in
                          loop ctxt tl stack)
                    end) in
              op_gtgteqquestion (loop ctxt l init)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return (res, ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem,
            Item v (Item set rest)) =>
          consume_gas_binop descr (set_mem, v, set) Interp_costs.set_mem rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Set_update,
            Item v (Item presence (Item set rest))) =>
          consume_gas_terop descr (set_update, v, presence, set)
            Interp_costs.set_update rest
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Set_size, Item set rest) =>
          consume_gas_unop descr (set_size, set)
            (fun function_parameter =>
              let '_ := function_parameter in
              Interp_costs.set_size) rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map t _, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.empty_map))
            (fun ctxt => logged_return ((Item (empty_map t) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_map body, Item map rest)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.map_to_list map)))
            (fun ctxt =>
              let l :=
                List.rev
                  (map_fold (fun k => fun v => fun acc => cons (k, v) acc) map
                    []) in
              let fix loop
                (rest : stack op_dollar68) (ctxt :
                Tezos_raw_protocol_alpha__Alpha_context.context) (l :
                list (op_dollar66 * op_dollar67)) (acc :
                Tezos_raw_protocol_alpha.Script_typed_ir.map op_dollar66
                  op_dollar69)
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.map op_dollar66
                      op_dollar69) *
                      Tezos_raw_protocol_alpha__Alpha_context.context)) :=
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Interp_costs.loop_map))
                  (fun ctxt =>
                    match l with
                    | [] => _return (acc, ctxt)
                    | cons ((k, _) as hd) tl =>
                      op_gtgteqquestion
                        (step log ctxt step_constants body (Item hd rest))
                        (fun function_parameter =>
                          let '(Item hd rest, ctxt) := function_parameter in
                          loop rest ctxt tl (map_update k (Some hd) acc))
                    end) in
              op_gtgteqquestion (loop rest ctxt l (empty_map (map_key_ty map)))
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter body, Item map init)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.map_to_list map)))
            (fun ctxt =>
              let l :=
                List.rev
                  (map_fold (fun k => fun v => fun acc => cons (k, v) acc) map
                    []) in
              let fix loop
                (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (l :
                list (op_dollar70 * op_dollar71)) (stack : stack op_dollar72)
                : Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                    ((stack op_dollar72) *
                      Tezos_raw_protocol_alpha__Alpha_context.context)) :=
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Interp_costs.loop_iter))
                  (fun ctxt =>
                    match l with
                    | [] => _return (stack, ctxt)
                    | cons hd tl =>
                      op_gtgteqquestion
                        (step log ctxt step_constants body (Item hd stack))
                        (fun function_parameter =>
                          let '(stack, ctxt) := function_parameter in
                          loop ctxt tl stack)
                    end) in
              op_gtgteqquestion (loop ctxt l init)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return (res, ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem,
            Item v (Item map rest)) =>
          consume_gas_binop descr (map_mem, v, map) Interp_costs.map_mem rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Map_get,
            Item v (Item map rest)) =>
          consume_gas_binop descr (map_get, v, map) Interp_costs.map_get rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Map_update,
            Item k (Item v (Item map rest))) =>
          consume_gas_terop descr (map_update, k, v, map)
            Interp_costs.map_update rest
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_size, Item map rest) =>
          consume_gas_unop descr (map_size, map)
            (fun function_parameter =>
              let '_ := function_parameter in
              Interp_costs.map_size) rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map tk tv, rest)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.empty_map))
            (fun ctxt =>
              logged_return
                ((Item (Script_ir_translator.empty_big_map tk tv) rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem,
            Item key (Item map rest)) =>
          op_gtgteqquestion
            (Lwt._return
              (Gas.consume ctxt (Interp_costs.map_mem key (diff map))))
            (fun ctxt =>
              op_gtgteqquestion (Script_ir_translator.big_map_mem ctxt key map)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get,
            Item key (Item map rest)) =>
          op_gtgteqquestion
            (Lwt._return
              (Gas.consume ctxt (Interp_costs.map_get key (diff map))))
            (fun ctxt =>
              op_gtgteqquestion (Script_ir_translator.big_map_get ctxt key map)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update,
            Item key (Item maybe_value (Item map rest))) =>
          consume_gas_terop descr
            (Script_ir_translator.big_map_update, key, maybe_value, map)
            (fun k =>
              fun v => fun m => Interp_costs.map_update k (Some v) (diff m))
            rest
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp,
            Item n (Item t rest)) =>
          consume_gas_binop descr (Script_timestamp.add_delta, t, n)
            Interp_costs.add_timestamp rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds,
            Item t (Item n rest)) =>
          consume_gas_binop descr (Script_timestamp.add_delta, t, n)
            Interp_costs.add_timestamp rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds,
            Item t (Item s rest)) =>
          consume_gas_binop descr (Script_timestamp.sub_delta, t, s)
            Interp_costs.sub_timestamp rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps,
            Item t1 (Item t2 rest)) =>
          consume_gas_binop descr (Script_timestamp.diff, t1, t2)
            Interp_costs.diff_timestamps rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return
              (Gas.consume ctxt
                (Interp_costs.concat_string (cons x (cons y [])))))
            (fun ctxt =>
              let s := String.concat "" % string (cons x (cons y [])) in
              logged_return ((Item s rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string, Item ss rest)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.concat_string ss)))
            (fun ctxt =>
              let s := String.concat "" % string ss in
              logged_return ((Item s rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string,
            Item offset (Item length (Item s rest))) =>
          let s_length := Z.of_int (String.length s) in
          let offset := Script_int.to_zint offset in
          let length := Script_int.to_zint length in
          if
            op_andand
              (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                offset s_length)
              (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
                (Z.add offset length) s_length) then
            op_gtgteqquestion
              (Lwt._return
                (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Some (String.sub s (Z.to_int offset) (Z.to_int length)))
                    rest), ctxt))
          else
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt (Interp_costs.slice_string 0)))
              (fun ctxt => logged_return ((Item None rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.String_size, Item s rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
            (fun ctxt =>
              logged_return ((Item (abs (of_int (String.length s))) rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return
              (Gas.consume ctxt (Interp_costs.concat_bytes (cons x (cons y [])))))
            (fun ctxt =>
              let s := MBytes.concat "" % string (cons x (cons y [])) in
              logged_return ((Item s rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes, Item ss rest)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.concat_bytes ss)))
            (fun ctxt =>
              let s := MBytes.concat "" % string ss in
              logged_return ((Item s rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes,
            Item offset (Item length (Item s rest))) =>
          let s_length := Z.of_int (MBytes.length s) in
          let offset := Script_int.to_zint offset in
          let length := Script_int.to_zint length in
          if
            op_andand
              (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                offset s_length)
              (Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
                (Z.add offset length) s_length) then
            op_gtgteqquestion
              (Lwt._return
                (Gas.consume ctxt (Interp_costs.slice_string (Z.to_int length))))
              (fun ctxt =>
                logged_return
                  ((Item
                    (Some (MBytes.sub s (Z.to_int offset) (Z.to_int length)))
                    rest), ctxt))
          else
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt (Interp_costs.slice_string 0)))
              (fun ctxt => logged_return ((Item None rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size, Item s rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
            (fun ctxt =>
              logged_return ((Item (abs (of_int (MBytes.length s))) rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              op_gtgteqquestion (Lwt._return (op_plusquestion x y))
                (fun res => logged_return ((Item res rest), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              op_gtgteqquestion (Lwt._return (op_minusquestion x y))
                (fun res => logged_return ((Item res rest), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              op_gtgteqquestion
                (Lwt._return (Gas.consume ctxt Interp_costs.z_to_int64))
                (fun ctxt =>
                  match Script_int.to_int64 y with
                  | None =>
                    fail
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
                        loc (get_log log))
                  | Some y =>
                    op_gtgteqquestion (Lwt._return (op_starquestion x y))
                      (fun res => logged_return ((Item res rest), ctxt))
                  end))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez,
            Item y (Item x rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.int64_op))
            (fun ctxt =>
              op_gtgteqquestion
                (Lwt._return (Gas.consume ctxt Interp_costs.z_to_int64))
                (fun ctxt =>
                  match Script_int.to_int64 y with
                  | None =>
                    fail
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
                        loc (get_log log))
                  | Some y =>
                    op_gtgteqquestion (Lwt._return (op_starquestion x y))
                      (fun res => logged_return ((Item res rest), ctxt))
                  end))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Or, Item x (Item y rest)) =>
          consume_gas_binop descr (op_pipepipe, x, y) Interp_costs.bool_binop
            rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.And, Item x (Item y rest))
          =>
          consume_gas_binop descr (op_andand, x, y) Interp_costs.bool_binop rest
            ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Xor, Item x (Item y rest))
          =>
          consume_gas_binop descr
            (Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt),
              x, y) Interp_costs.bool_binop rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Not, Item x rest) =>
          consume_gas_unop descr (not, x) Interp_costs.bool_unop rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat, Item x rest) =>
          consume_gas_unop descr (Script_int.is_nat, x) Interp_costs.abs rest
            ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int, Item x rest) =>
          consume_gas_unop descr (Script_int.abs, x) Interp_costs.abs rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat, Item x rest) =>
          consume_gas_unop descr (Script_int.int, x) Interp_costs.int rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int, Item x rest) =>
          consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat, Item x rest) =>
          consume_gas_unop descr (Script_int.neg, x) Interp_costs.neg rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.add, x, y) Interp_costs.add rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.add_n, x, y) Interp_costs.add rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.sub, x, y) Interp_costs.sub rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.mul, x, y) Interp_costs.mul rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.mul_n, x, y) Interp_costs.mul rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.int64_to_z))
            (fun ctxt =>
              let x := Script_int.of_int64 (Tez.to_mutez x) in
              consume_gas_binop descr
                ((fun x =>
                  fun y =>
                    match Script_int.ediv x y with
                    | None => None
                    | Some (q, r) =>
                      match ((Script_int.to_int64 q), (Script_int.to_int64 r))
                        with
                      | (Some q, Some r) =>
                        match ((Tez.of_mutez q), (Tez.of_mutez r)) with
                        | (Some q, Some r) => Some (q, r)
                        | _ =>
                          (* ❌ Assert instruction is not handled. *)
                          assert false
                        end
                      | _ =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end
                    end), x, y) Interp_costs.div rest ctxt)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.int64_to_z))
            (fun ctxt =>
              op_gtgteqquestion
                (Lwt._return (Gas.consume ctxt Interp_costs.int64_to_z))
                (fun ctxt =>
                  let x := Script_int.abs (Script_int.of_int64 (Tez.to_mutez x))
                    in
                  let y := Script_int.abs (Script_int.of_int64 (Tez.to_mutez y))
                    in
                  consume_gas_binop descr
                    ((fun x =>
                      fun y =>
                        match Script_int.ediv_n x y with
                        | None => None
                        | Some (q, r) =>
                          match Script_int.to_int64 r with
                          | None =>
                            (* ❌ Assert instruction is not handled. *)
                            assert false
                          | Some r =>
                            match Tez.of_mutez r with
                            | None =>
                              (* ❌ Assert instruction is not handled. *)
                              assert false
                            | Some r => Some (q, r)
                            end
                          end
                        end), x, y) Interp_costs.div rest ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.ediv, x, y) Interp_costs.div rest
            ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.ediv_n, x, y) Interp_costs.div
            rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.shift_left x y)))
            (fun ctxt =>
              match Script_int.shift_left_n x y with
              | None =>
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
                    loc (get_log log))
              | Some x => logged_return ((Item x rest), ctxt)
              end)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat,
            Item x (Item y rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.shift_right x y)))
            (fun ctxt =>
              match Script_int.shift_right_n x y with
              | None =>
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Overflow
                    loc (get_log log))
              | Some r => logged_return ((Item r rest), ctxt)
              end)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat, Item x (Item y rest))
          =>
          consume_gas_binop descr (Script_int.logor, x, y) Interp_costs.logor
            rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.And_nat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand
            rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.logand, x, y) Interp_costs.logand
            rest ctxt
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat,
            Item x (Item y rest)) =>
          consume_gas_binop descr (Script_int.logxor, x, y) Interp_costs.logxor
            rest ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Not_int, Item x rest) =>
          consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest
            ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat, Item x rest) =>
          consume_gas_unop descr (Script_int.lognot, x) Interp_costs.lognot rest
            ctxt
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Seq hd tl, stack) =>
          op_gtgteqquestion (step log ctxt step_constants hd stack)
            (fun function_parameter =>
              let '(trans, ctxt) := function_parameter in
              step log ctxt step_constants tl trans)
        | (Tezos_raw_protocol_alpha.Script_typed_ir.If bt _, Item true rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bt rest)
        | (Tezos_raw_protocol_alpha.Script_typed_ir.If _ bf, Item false rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.branch))
            (fun ctxt => step log ctxt step_constants bf rest)
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Loop body, Item true rest)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.loop_cycle))
            (fun ctxt =>
              op_gtgteqquestion (step log ctxt step_constants body rest)
                (fun function_parameter =>
                  let '(trans, ctxt) := function_parameter in
                  step log ctxt step_constants descr trans))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Loop _, Item false rest) =>
          logged_return (rest, ctxt)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left body,
            Item (Tezos_raw_protocol_alpha.Script_typed_ir.L v) rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.loop_cycle))
            (fun ctxt =>
              op_gtgteqquestion
                (step log ctxt step_constants body (Item v rest))
                (fun function_parameter =>
                  let '(trans, ctxt) := function_parameter in
                  step log ctxt step_constants descr trans))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left _,
            Item (Tezos_raw_protocol_alpha.Script_typed_ir.R v) rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.loop_cycle))
            (fun ctxt => logged_return ((Item v rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Dip b, Item ign rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.stack_op))
            (fun ctxt =>
              op_gtgteqquestion (step log ctxt step_constants b rest)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item ign res), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Exec,
            Item arg (Item lam rest)) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.exec))
            (fun ctxt =>
              op_gtgteqquestion (interp log ctxt step_constants lam arg)
                (fun function_parameter =>
                  let '(res, ctxt) := function_parameter in
                  logged_return ((Item res rest), ctxt)))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Apply capture_ty,
            Item capture (Item lam rest)) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.apply))
            (fun ctxt =>
              let 'Tezos_raw_protocol_alpha.Script_typed_ir.Lam descr expr :=
                lam in
              let
                'Tezos_raw_protocol_alpha.Script_typed_ir.Item_t full_arg_ty _ _ :=
                bef descr in
              op_gtgteqquestion
                (unparse_data ctxt
                  Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                  capture_ty capture)
                (fun function_parameter =>
                  let '(const_expr, ctxt) := function_parameter in
                  op_gtgteqquestion (unparse_ty ctxt capture_ty)
                    (fun function_parameter =>
                      let '(ty_expr, ctxt) := function_parameter in
                      match full_arg_ty with
                      |
                        Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                          (capture_ty, _, _) (arg_ty, _, _) _ _ =>
                        let arg_stack_ty :=
                          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t arg_ty
                            Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                            None in
                        let const_descr :=
                          {| loc := loc descr; bef := arg_stack_ty;
                            aft :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                capture_ty arg_stack_ty None;
                            instr :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Const
                                capture |} in
                        let pair_descr :=
                          {| loc := loc descr;
                            bef :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                capture_ty arg_stack_ty None;
                            aft :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                full_arg_ty
                                Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                                None;
                            instr :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair
                            |} in
                        let seq_descr :=
                          {| loc := loc descr; bef := arg_stack_ty;
                            aft :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                full_arg_ty
                                Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                                None;
                            instr :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Seq
                                const_descr pair_descr |} in
                        let full_descr :=
                          {| loc := loc descr; bef := arg_stack_ty;
                            aft := aft descr;
                            instr :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Seq
                                seq_descr descr |} in
                        let full_expr :=
                          Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                            0
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0
                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
                                (cons ty_expr (cons const_expr [])) [])
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR
                                  [] []) (cons expr []))) in
                        let lam' :=
                          Tezos_raw_protocol_alpha.Script_typed_ir.Lam
                            full_descr full_expr in
                        logged_return ((Item lam' rest), ctxt)
                      | _ =>
                        (* ❌ Assert instruction is not handled. *)
                        assert false
                      end)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda lam, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.push))
            (fun ctxt => logged_return ((Item lam rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Failwith tv, Item v _) =>
          op_gtgteqquestion
            (trace
              Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_failure
              (unparse_data ctxt
                Tezos_raw_protocol_alpha.Script_ir_translator.Optimized tv v))
            (fun function_parameter =>
              let '(v, _ctxt) := function_parameter in
              let v := Micheline.strip_locations v in
              fail
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Reject
                  loc v (get_log log)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Nop, stack) =>
          logged_return (stack, ctxt)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Compare ty,
            Item a (Item b rest)) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.compare ty a b)))
            (fun ctxt =>
              logged_return
                ((Item
                  (op_atat Script_int.of_int
                    (Script_ir_translator.compare_comparable ty a b)) rest),
                  ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Eq, Item cmpres rest) =>
          let cmpres := Script_int.compare cmpres Script_int.zero in
          let cmpres :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              cmpres 0 in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Neq, Item cmpres rest) =>
          let cmpres := Script_int.compare cmpres Script_int.zero in
          let cmpres :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
              cmpres 0 in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Lt, Item cmpres rest) =>
          let cmpres := Script_int.compare cmpres Script_int.zero in
          let cmpres :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
              cmpres 0 in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Le, Item cmpres rest) =>
          let cmpres := Script_int.compare cmpres Script_int.zero in
          let cmpres :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
              cmpres 0 in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Gt, Item cmpres rest) =>
          let cmpres := Script_int.compare cmpres Script_int.zero in
          let cmpres :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
              cmpres 0 in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Ge, Item cmpres rest) =>
          let cmpres := Script_int.compare cmpres Script_int.zero in
          let cmpres :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
              cmpres 0 in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.compare_res))
            (fun ctxt => logged_return ((Item cmpres rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Pack t, Item value rest) =>
          op_gtgteqquestion (Script_ir_translator.pack_data ctxt t value)
            (fun function_parameter =>
              let '(bytes, ctxt) := function_parameter in
              logged_return ((Item string rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Unpack t, Item bytes rest)
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.check_enough ctxt (Script.serialized_cost string)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              if
                op_andand
                  (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
                    (MBytes.length string) 1)
                  (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                    (MBytes.get_uint8 string 0) 5) then
                let bytes :=
                  MBytes.sub string 1 (op_minus (MBytes.length string) 1) in
                match Data_encoding.Binary.of_bytes Script.expr_encoding string
                  with
                | None =>
                  op_gtgteqquestion
                    (Lwt._return
                      (Gas.consume ctxt (Interp_costs.unpack_failed string)))
                    (fun ctxt => logged_return ((Item None rest), ctxt))
                | Some expr =>
                  op_gtgteqquestion
                    (Lwt._return
                      (Gas.consume ctxt (Script.deserialized_cost expr)))
                    (fun ctxt =>
                      op_gtgteq
                        (parse_data None ctxt false t (Micheline.root expr))
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                              (value, ctxt) =>
                            logged_return ((Item (Some value) rest), ctxt)
                          |
                            Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                              _ignored =>
                            op_gtgteqquestion
                              (Lwt._return
                                (Gas.consume ctxt
                                  (Interp_costs.unpack_failed string)))
                              (fun ctxt =>
                                logged_return ((Item None rest), ctxt))
                          end))
                end
              else
                logged_return ((Item None rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Address,
            Item (_, address) rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.address))
            (fun ctxt => logged_return ((Item address rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Contract t entrypoint,
            Item contract rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.contract))
            (fun ctxt =>
              match (contract, entrypoint) with
              |
                ((contract, "default" % string), entrypoint) |
                  ((contract, entrypoint), "default" % string) =>
                op_gtgteqquestion
                  (Script_ir_translator.parse_contract_for_script false ctxt loc
                    t contract entrypoint)
                  (fun function_parameter =>
                    let '(ctxt, maybe_contract) := function_parameter in
                    logged_return ((Item maybe_contract rest), ctxt))
              | _ => logged_return ((Item None rest), ctxt)
              end)
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens,
            Item p (Item amount (Item (tp, (destination, entrypoint)) rest))) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.transfer))
            (fun ctxt =>
              op_gtgteqquestion (collect_big_maps ctxt tp p)
                (fun function_parameter =>
                  let '(to_duplicate, ctxt) := function_parameter in
                  let to_update := no_big_map_id in
                  op_gtgteqquestion
                    (extract_big_map_diff ctxt
                      Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                      true to_duplicate to_update tp p)
                    (fun function_parameter =>
                      let '(p, big_map_diff, ctxt) := function_parameter in
                      op_gtgteqquestion
                        (unparse_data ctxt
                          Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                          tp p)
                        (fun function_parameter =>
                          let '(p, ctxt) := function_parameter in
                          let operation :=
                            Tezos_raw_protocol_alpha.Alpha_context.Transaction
                              {| amount := amount;
                                parameters :=
                                  Script.lazy_expr (Micheline.strip_locations p);
                                entrypoint := entrypoint;
                                destination := destination |} in
                          op_gtgteqquestion
                            (Lwt._return (fresh_internal_nonce ctxt))
                            (fun function_parameter =>
                              let '(ctxt, nonce) := function_parameter in
                              logged_return
                                ((Item
                                  ((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
                                    {| source := self step_constants;
                                      operation := operation; nonce := nonce |}),
                                    big_map_diff) rest), ctxt))))))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Create_account,
            Item manager (Item delegate (Item _delegatable (Item credit rest))))
          =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.create_account))
            (fun ctxt =>
              op_gtgteqquestion
                (Contract.fresh_contract_from_current_nonce ctxt)
                (fun function_parameter =>
                  let '(ctxt, contract) := function_parameter in
                  let manager_bytes :=
                    Data_encoding.Binary.to_bytes_exn
                      Signature.Public_key_hash.encoding manager in
                  let storage :=
                    op_atat Script_repr.lazy_expr
                      (op_atat Micheline.strip_locations
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                          0 manager_bytes)) in
                  let script :=
                    {| code := Legacy_support.manager_script_code;
                      storage := storage |} in
                  let operation :=
                    Tezos_raw_protocol_alpha.Alpha_context.Origination
                      {| delegate := delegate; script := script;
                        credit := credit; preorigination := Some contract |} in
                  op_gtgteqquestion (Lwt._return (fresh_internal_nonce ctxt))
                    (fun function_parameter =>
                      let '(ctxt, nonce) := function_parameter in
                      logged_return
                        ((Item
                          ((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
                            {| source := self step_constants;
                              operation := operation; nonce := nonce |}), None)
                          (Item (contract, "default" % string) rest)), ctxt))))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account,
            Item key rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.implicit_account))
            (fun ctxt =>
              let contract := Contract.implicit_contract key in
              logged_return
                ((Item
                  ((Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t None),
                    (contract, "default" % string)) rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract storage_type
            param_type (Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ code)
            root_name,
            Item manager
              (Item delegate
                (Item spendable
                  (Item delegatable (Item credit (Item init rest)))))) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.create_contract))
            (fun ctxt =>
              op_gtgteqquestion (unparse_ty ctxt param_type)
                (fun function_parameter =>
                  let '(unparsed_param_type, ctxt) := function_parameter in
                  let unparsed_param_type :=
                    Script_ir_translator.add_field_annot
                      (Option.map
                        (fun n =>
                          (* ❌ Variants not supported *)
                          variant) root_name) None unparsed_param_type in
                  op_gtgteqquestion (unparse_ty ctxt storage_type)
                    (fun function_parameter =>
                      let '(unparsed_storage_type, ctxt) := function_parameter
                        in
                      let code :=
                        op_atat Script.lazy_expr
                          (Micheline.strip_locations
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                              0
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
                                  (cons unparsed_param_type []) [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
                                    (cons unparsed_storage_type []) [])
                                  (cons
                                    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                      0
                                      Tezos_raw_protocol_alpha.Alpha_context.Script.K_code
                                      (cons code []) []) []))))) in
                      op_gtgteqquestion
                        (collect_big_maps ctxt storage_type init)
                        (fun function_parameter =>
                          let '(to_duplicate, ctxt) := function_parameter in
                          let to_update := no_big_map_id in
                          op_gtgteqquestion
                            (extract_big_map_diff ctxt
                              Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                              true to_duplicate to_update storage_type init)
                            (fun function_parameter =>
                              let '(init, big_map_diff, ctxt) :=
                                function_parameter in
                              op_gtgteqquestion
                                (unparse_data ctxt
                                  Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                                  storage_type init)
                                (fun function_parameter =>
                                  let '(storage, ctxt) := function_parameter in
                                  let storage :=
                                    op_atat Script.lazy_expr
                                      (Micheline.strip_locations storage) in
                                  op_gtgteqquestion
                                    (if spendable then
                                      Legacy_support.add_do manager code storage
                                    else
                                      if delegatable then
                                        Legacy_support.add_set_delegate manager
                                          code storage
                                      else
                                        if
                                          Legacy_support.has_default_entrypoint
                                            code then
                                          op_gtgteqquestion
                                            (Legacy_support.add_root_entrypoint
                                              code)
                                            (fun code => _return (code, storage))
                                        else
                                          _return (code, storage))
                                    (fun function_parameter =>
                                      let '(code, storage) := function_parameter
                                        in
                                      op_gtgteqquestion
                                        (Contract.fresh_contract_from_current_nonce
                                          ctxt)
                                        (fun function_parameter =>
                                          let '(ctxt, contract) :=
                                            function_parameter in
                                          let operation :=
                                            Tezos_raw_protocol_alpha.Alpha_context.Origination
                                              {| delegate := delegate;
                                                script :=
                                                  {| code := code;
                                                    storage := storage |};
                                                credit := credit;
                                                preorigination := Some contract
                                                |} in
                                          op_gtgteqquestion
                                            (Lwt._return
                                              (fresh_internal_nonce ctxt))
                                            (fun function_parameter =>
                                              let '(ctxt, nonce) :=
                                                function_parameter in
                                              logged_return
                                                ((Item
                                                  ((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
                                                    {|
                                                      source :=
                                                        self step_constants;
                                                      operation := operation;
                                                      nonce := nonce |}),
                                                    big_map_diff)
                                                  (Item
                                                    (contract,
                                                      "default" % string) rest)),
                                                  ctxt))))))))))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2
            storage_type param_type
            (Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ code) root_name,
            Item delegate (Item credit (Item init rest))) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.create_contract))
            (fun ctxt =>
              op_gtgteqquestion (unparse_ty ctxt param_type)
                (fun function_parameter =>
                  let '(unparsed_param_type, ctxt) := function_parameter in
                  let unparsed_param_type :=
                    Script_ir_translator.add_field_annot
                      (Option.map
                        (fun n =>
                          (* ❌ Variants not supported *)
                          variant) root_name) None unparsed_param_type in
                  op_gtgteqquestion (unparse_ty ctxt storage_type)
                    (fun function_parameter =>
                      let '(unparsed_storage_type, ctxt) := function_parameter
                        in
                      let code :=
                        Micheline.strip_locations
                          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                            0
                            (cons
                              (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                0
                                Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
                                (cons unparsed_param_type []) [])
                              (cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  0
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
                                  (cons unparsed_storage_type []) [])
                                (cons
                                  (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                    0
                                    Tezos_raw_protocol_alpha.Alpha_context.Script.K_code
                                    (cons code []) []) [])))) in
                      op_gtgteqquestion
                        (collect_big_maps ctxt storage_type init)
                        (fun function_parameter =>
                          let '(to_duplicate, ctxt) := function_parameter in
                          let to_update := no_big_map_id in
                          op_gtgteqquestion
                            (extract_big_map_diff ctxt
                              Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                              true to_duplicate to_update storage_type init)
                            (fun function_parameter =>
                              let '(init, big_map_diff, ctxt) :=
                                function_parameter in
                              op_gtgteqquestion
                                (unparse_data ctxt
                                  Tezos_raw_protocol_alpha.Script_ir_translator.Optimized
                                  storage_type init)
                                (fun function_parameter =>
                                  let '(storage, ctxt) := function_parameter in
                                  let storage :=
                                    Micheline.strip_locations storage in
                                  op_gtgteqquestion
                                    (Contract.fresh_contract_from_current_nonce
                                      ctxt)
                                    (fun function_parameter =>
                                      let '(ctxt, contract) :=
                                        function_parameter in
                                      let operation :=
                                        Tezos_raw_protocol_alpha.Alpha_context.Origination
                                          {| delegate := delegate;
                                            script :=
                                              {| code := Script.lazy_expr code;
                                                storage :=
                                                  Script.lazy_expr storage |};
                                            credit := credit;
                                            preorigination := Some contract |}
                                        in
                                      op_gtgteqquestion
                                        (Lwt._return (fresh_internal_nonce ctxt))
                                        (fun function_parameter =>
                                          let '(ctxt, nonce) :=
                                            function_parameter in
                                          logged_return
                                            ((Item
                                              ((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
                                                {|
                                                  source := self step_constants;
                                                  operation := operation;
                                                  nonce := nonce |}),
                                                big_map_diff)
                                              (Item
                                                (contract, "default" % string)
                                                rest)), ctxt)))))))))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate,
            Item delegate rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.create_account))
            (fun ctxt =>
              let operation :=
                Tezos_raw_protocol_alpha.Alpha_context.Delegation delegate in
              op_gtgteqquestion (Lwt._return (fresh_internal_nonce ctxt))
                (fun function_parameter =>
                  let '(ctxt, nonce) := function_parameter in
                  logged_return
                    ((Item
                      ((Tezos_raw_protocol_alpha.Alpha_context.Internal_operation
                        {| source := self step_constants;
                          operation := operation; nonce := nonce |}), None) rest),
                      ctxt)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Balance, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.balance))
            (fun ctxt =>
              op_gtgteqquestion
                (Contract.get_balance ctxt (self step_constants))
                (fun balance => logged_return ((Item balance rest), ctxt)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Now, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.now))
            (fun ctxt =>
              let now := Script_timestamp.now ctxt in
              logged_return ((Item now rest), ctxt))
        |
          (Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature,
            Item key (Item signature (Item message rest))) =>
          op_gtgteqquestion
            (Lwt._return
              (Gas.consume ctxt (Interp_costs.check_signature key message)))
            (fun ctxt =>
              let res := Signature.check None key signature message in
              logged_return ((Item res rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key, Item key rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.hash_key))
            (fun ctxt =>
              logged_return ((Item (Signature.Public_key.hash key) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b, Item bytes rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.hash_blake2b string)))
            (fun ctxt =>
              let hash := Raw_hashes.blake2b string in
              logged_return ((Item hash rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Sha256, Item bytes rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.hash_sha256 string)))
            (fun ctxt =>
              let hash := Raw_hashes.sha256 string in
              logged_return ((Item hash rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Sha512, Item bytes rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.hash_sha512 string)))
            (fun ctxt =>
              let hash := Raw_hashes.sha512 string in
              logged_return ((Item hash rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.steps_to_quota))
            (fun ctxt =>
              let steps :=
                match Gas.level ctxt with
                |
                  Tezos_raw_protocol_alpha.Alpha_context.Gas.Limited {|
                    remaining := remaining |} => remaining
                | Tezos_raw_protocol_alpha.Alpha_context.Gas.Unaccounted =>
                  Z.of_string "99999999" % string
                end in
              logged_return ((Item (abs (of_zint steps)) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Source, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.source))
            (fun ctxt =>
              logged_return
                ((Item ((payer step_constants), "default" % string) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Sender, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.source))
            (fun ctxt =>
              logged_return
                ((Item ((source step_constants), "default" % string) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Self t entrypoint, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.self))
            (fun ctxt =>
              logged_return
                ((Item (t, ((self step_constants), entrypoint)) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Amount, rest) =>
          op_gtgteqquestion (Lwt._return (Gas.consume ctxt Interp_costs.amount))
            (fun ctxt =>
              logged_return ((Item (amount step_constants) rest), ctxt))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Dig n n', stack) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun function_parameter =>
                    let 'Item v rest := function_parameter in
                    _return (rest, v)) n' stack)
                (fun function_parameter =>
                  let '(aft, x) := function_parameter in
                  logged_return ((Item x aft), ctxt)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Dug n n', Item v rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun stk => _return ((Item v stk), tt)) n' rest)
                (fun function_parameter =>
                  let '(aft, tt) := function_parameter in
                  logged_return (aft, ctxt)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Dipn n n' b, stack) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun stk =>
                    op_gtgteqquestion (step log ctxt step_constants b stk)
                      (fun function_parameter =>
                        let '(res, ctxt') := function_parameter in
                        _return (res, ctxt'))) n' stack)
                (fun function_parameter =>
                  let '(aft, ctxt') := function_parameter in
                  logged_return (aft, ctxt')))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.Dropn n n', stack) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Interp_costs.stack_n_op n)))
            (fun ctxt =>
              op_gtgteqquestion
                (interp_stack_prefix_preserving_operation
                  (fun stk => _return (stk, stk)) n' stack)
                (fun function_parameter =>
                  let '(_, rest) := function_parameter in
                  logged_return (rest, ctxt)))
        | (Tezos_raw_protocol_alpha.Script_typed_ir.ChainId, rest) =>
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt Interp_costs.chain_id))
            (fun ctxt =>
              logged_return ((Item (chain_id step_constants) rest), ctxt))
        end)

with interp {p r : Type}
  (log :
    option
      (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
        execution_trace))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (step_constants : step_constants)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.lambda p r)
  : p ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (r * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let 'Tezos_raw_protocol_alpha.Script_typed_ir.Lam code _ := function_parameter
    in
  fun arg =>
    let stack := Item arg Empty in
    op_gtgteqquestion
      match log with
      | None => return_unit
      | Some log =>
        op_gtgteqquestion
          (trace
            Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_log
            (unparse_stack ctxt (stack, (bef code))))
          (fun stack =>
            (* ❌ Sequences of instructions are not handled (operator ";") *)
            let _ :=
              op_coloneq log
                (cons ((loc code), (Gas.level ctxt), stack) (op_exclamation log))
              in
            return_unit)
      end
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion (step log ctxt step_constants code stack)
          (fun function_parameter =>
            let '(Item ret Empty, ctxt) := function_parameter in
            _return (ret, ctxt)))

with execute
  (log :
    option
      (Tezos_protocol_environment_alpha__Environment.Pervasives.ref
        execution_trace))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (step_constants : step_constants) (entrypoint : string)
  (unparsed_script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  (arg : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        (list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation)
        * Tezos_raw_protocol_alpha.Alpha_context.context *
        (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  op_gtgteqquestion (parse_script None ctxt true unparsed_script)
    (fun function_parameter =>
      let
        '(Tezos_raw_protocol_alpha.Script_ir_translator.Ex_script {|
          code := code;
            arg_type := arg_type;
            storage := storage;
            storage_type := storage_type;
            root_name := root_name
            |}, ctxt) := function_parameter in
      op_gtgteqquestion
        (trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
            (self step_constants))
          (Lwt._return (find_entrypoint arg_type root_name entrypoint)))
        (fun function_parameter =>
          let '(box, _) := function_parameter in
          op_gtgteqquestion
            (trace
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_contract_parameter
                (self step_constants))
              (parse_data None ctxt false arg_type (box arg)))
            (fun function_parameter =>
              let '(arg, ctxt) := function_parameter in
              op_gtgteqquestion
                (Script.force_decode ctxt (code unparsed_script))
                (fun function_parameter =>
                  let '(script_code, ctxt) := function_parameter in
                  op_gtgteqquestion
                    (Script_ir_translator.collect_big_maps ctxt arg_type arg)
                    (fun function_parameter =>
                      let '(to_duplicate, ctxt) := function_parameter in
                      op_gtgteqquestion
                        (Script_ir_translator.collect_big_maps ctxt storage_type
                          storage)
                        (fun function_parameter =>
                          let '(to_update, ctxt) := function_parameter in
                          op_gtgteqquestion
                            (trace
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.Runtime_contract_error
                                (self step_constants) script_code)
                              (interp log ctxt step_constants code
                                (arg, storage)))
                            (fun function_parameter =>
                              let '((ops, storage), ctxt) := function_parameter
                                in
                              op_gtgteqquestion
                                (Script_ir_translator.extract_big_map_diff ctxt
                                  mode false to_duplicate to_update storage_type
                                  storage)
                                (fun function_parameter =>
                                  let '(storage, big_map_diff, ctxt) :=
                                    function_parameter in
                                  op_gtgteqquestion
                                    (trace
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_storage
                                      (unparse_data ctxt mode storage_type
                                        storage))
                                    (fun function_parameter =>
                                      let '(storage, ctxt) := function_parameter
                                        in
                                      let '(ops, op_diffs) := List.split ops in
                                      let big_map_diff :=
                                        match
                                          List.flatten
                                            (List.map (Option.unopt [])
                                              (op_at op_diffs
                                                (cons big_map_diff []))) with
                                        | [] => None
                                        | diff => Some diff
                                        end in
                                      _return
                                        ((Micheline.strip_locations storage),
                                          ops, ctxt, big_map_diff)))))))))).

Record execution_result := {
  ctxt : Tezos_raw_protocol_alpha.Alpha_context.context;
  storage : Tezos_raw_protocol_alpha.Alpha_context.Script.expr;
  big_map_diff :
    option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff;
  operations :
    list Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation }.

Definition trace
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (step_constants : step_constants)
  (script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  (entrypoint : string)
  (parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (execution_result *
        (list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_raw_protocol_alpha.Alpha_context.Gas.t *
            (list
              (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
                (option string))))))) :=
  let log := ref [] in
  op_gtgteqquestion
    (execute (Some log) ctxt mode step_constants entrypoint script
      (Micheline.root parameter))
    (fun function_parameter =>
      let '(storage, operations, ctxt, big_map_diff) := function_parameter in
      let trace := List.rev (op_exclamation log) in
      _return
        ({| ctxt := ctxt; storage := storage; big_map_diff := big_map_diff;
          operations := operations |}, trace)).

Definition execute
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : Tezos_raw_protocol_alpha.Script_ir_translator.unparsing_mode)
  (step_constants : step_constants)
  (script : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  (entrypoint : string)
  (parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      execution_result) :=
  op_gtgteqquestion
    (execute None ctxt mode step_constants entrypoint script
      (Micheline.root parameter))
    (fun function_parameter =>
      let '(storage, operations, ctxt, big_map_diff) := function_parameter in
      _return
        {| ctxt := ctxt; storage := storage; big_map_diff := big_map_diff;
          operations := operations |}).

src/proto_alpha/lib_protocol/script_ir_annot.ml 146 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script_tc_errors
open Script_typed_ir

let default_now_annot = Some (`Var_annot "now")

let default_amount_annot = Some (`Var_annot "amount")

let default_balance_annot = Some (`Var_annot "balance")

let default_steps_annot = Some (`Var_annot "steps")

let default_source_annot = Some (`Var_annot "source")

let default_sender_annot = Some (`Var_annot "sender")

let default_self_annot = Some (`Var_annot "self")

let default_arg_annot = Some (`Var_annot "arg")

let default_param_annot = Some (`Var_annot "parameter")

let default_storage_annot = Some (`Var_annot "storage")

let default_car_annot = Some (`Field_annot "car")

let default_cdr_annot = Some (`Field_annot "cdr")

let default_contract_annot = Some (`Field_annot "contract")

let default_addr_annot = Some (`Field_annot "address")

let default_manager_annot = Some (`Field_annot "manager")

let default_pack_annot = Some (`Field_annot "packed")

let default_unpack_annot = Some (`Field_annot "unpacked")

let default_slice_annot = Some (`Field_annot "slice")

let default_elt_annot = Some (`Field_annot "elt")

let default_key_annot = Some (`Field_annot "key")

let default_hd_annot = Some (`Field_annot "hd")

let default_tl_annot = Some (`Field_annot "tl")

let default_some_annot = Some (`Field_annot "some")

let default_left_annot = Some (`Field_annot "left")

let default_right_annot = Some (`Field_annot "right")

let default_binding_annot = Some (`Field_annot "bnd")

let unparse_type_annot : type_annot option -> string list = function
  | None ->
      []
  | Some (`Type_annot a) ->
      [":" ^ a]

let unparse_var_annot : var_annot option -> string list = function
  | None ->
      []
  | Some (`Var_annot a) ->
      ["@" ^ a]

let unparse_field_annot : field_annot option -> string list = function
  | None ->
      []
  | Some (`Field_annot a) ->
      ["%" ^ a]

let field_to_var_annot : field_annot option -> var_annot option = function
  | None ->
      None
  | Some (`Field_annot s) ->
      Some (`Var_annot s)

let type_to_var_annot : type_annot option -> var_annot option = function
  | None ->
      None
  | Some (`Type_annot s) ->
      Some (`Var_annot s)

let var_to_field_annot : var_annot option -> field_annot option = function
  | None ->
      None
  | Some (`Var_annot s) ->
      Some (`Field_annot s)

let default_annot ~default = function None -> default | annot -> annot

let gen_access_annot :
    var_annot option ->
    ?default:field_annot option ->
    field_annot option ->
    var_annot option =
 fun value_annot ?(default = None) field_annot ->
  match (value_annot, field_annot, default) with
  | (None, None, _) | (Some _, None, None) | (None, Some (`Field_annot ""), _)
    ->
      None
  | (None, Some (`Field_annot f), _) ->
      Some (`Var_annot f)
  | ( Some (`Var_annot v),
      (None | Some (`Field_annot "")),
      Some (`Field_annot f) ) ->
      Some (`Var_annot (String.concat "." [v; f]))
  | (Some (`Var_annot v), Some (`Field_annot f), _) ->
      Some (`Var_annot (String.concat "." [v; f]))

let merge_type_annot :
    legacy:bool ->
    type_annot option ->
    type_annot option ->
    type_annot option tzresult =
 fun ~legacy annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      ok None
  | (Some (`Type_annot a1), Some (`Type_annot a2)) ->
      if legacy || String.equal a1 a2 then ok annot1
      else error (Inconsistent_annotations (":" ^ a1, ":" ^ a2))

let merge_field_annot :
    legacy:bool ->
    field_annot option ->
    field_annot option ->
    field_annot option tzresult =
 fun ~legacy annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      ok None
  | (Some (`Field_annot a1), Some (`Field_annot a2)) ->
      if legacy || String.equal a1 a2 then ok annot1
      else error (Inconsistent_annotations ("%" ^ a1, "%" ^ a2))

let merge_var_annot : var_annot option -> var_annot option -> var_annot option
    =
 fun annot1 annot2 ->
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) ->
      None
  | (Some (`Var_annot a1), Some (`Var_annot a2)) ->
      if String.equal a1 a2 then annot1 else None

let error_unexpected_annot loc annot =
  match annot with [] -> ok () | _ :: _ -> error (Unexpected_annotation loc)

let fail_unexpected_annot loc annot =
  Lwt.return (error_unexpected_annot loc annot)

let parse_annots loc ?(allow_special_var = false)
    ?(allow_special_field = false) l =
  (* allow emtpty annotations as wildcards but otherwise only accept
     annotations that start with [a-zA-Z_] *)
  let sub_or_wildcard ~specials wrap s acc =
    let len = String.length s in
    if Compare.Int.(len = 1) then ok @@ (wrap None :: acc)
    else
      match s.[1] with
      | 'a' .. 'z' | 'A' .. 'Z' | '_' ->
          ok @@ (wrap (Some (String.sub s 1 (len - 1))) :: acc)
      | '@' when Compare.Int.(len = 2) && List.mem '@' specials ->
          ok @@ (wrap (Some "@") :: acc)
      | '%' when List.mem '%' specials ->
          if Compare.Int.(len = 2) then ok @@ (wrap (Some "%") :: acc)
          else if Compare.Int.(len = 3) && Compare.Char.(s.[2] = '%') then
            ok @@ (wrap (Some "%%") :: acc)
          else error (Unexpected_annotation loc)
      | _ ->
          error (Unexpected_annotation loc)
  in
  List.fold_left
    (fun acc s ->
      acc
      >>? fun acc ->
      if Compare.Int.(String.length s = 0) then
        error (Unexpected_annotation loc)
      else
        match s.[0] with
        | ':' ->
            sub_or_wildcard ~specials:[] (fun a -> `Type_annot a) s acc
        | '@' ->
            sub_or_wildcard
              ~specials:(if allow_special_var then ['%'] else [])
              (fun a -> `Var_annot a)
              s
              acc
        | '%' ->
            sub_or_wildcard
              ~specials:(if allow_special_field then ['@'] else [])
              (fun a -> `Field_annot a)
              s
              acc
        | _ ->
            error (Unexpected_annotation loc))
    (ok [])
    l
  >|? List.rev

let opt_var_of_var_opt = function
  | `Var_annot None ->
      None
  | `Var_annot (Some a) ->
      Some (`Var_annot a)

let opt_field_of_field_opt = function
  | `Field_annot None ->
      None
  | `Field_annot (Some a) ->
      Some (`Field_annot a)

let opt_type_of_type_opt = function
  | `Type_annot None ->
      None
  | `Type_annot (Some a) ->
      Some (`Type_annot a)

let classify_annot loc l :
    (var_annot option list * type_annot option list * field_annot option list)
    tzresult =
  try
    let (_, rv, _, rt, _, rf) =
      List.fold_left
        (fun (in_v, rv, in_t, rt, in_f, rf) a ->
          match (a, in_v, rv, in_t, rt, in_f, rf) with
          | ((`Var_annot _ as a), true, _, _, _, _, _)
          | ((`Var_annot _ as a), false, [], _, _, _, _) ->
              (true, opt_var_of_var_opt a :: rv, false, rt, false, rf)
          | ((`Type_annot _ as a), _, _, true, _, _, _)
          | ((`Type_annot _ as a), _, _, false, [], _, _) ->
              (false, rv, true, opt_type_of_type_opt a :: rt, false, rf)
          | ((`Field_annot _ as a), _, _, _, _, true, _)
          | ((`Field_annot _ as a), _, _, _, _, false, []) ->
              (false, rv, false, rt, true, opt_field_of_field_opt a :: rf)
          | _ ->
              raise Exit)
        (false, [], false, [], false, [])
        l
    in
    ok (List.rev rv, List.rev rt, List.rev rf)
  with Exit -> error (Ungrouped_annotations loc)

let get_one_annot loc = function
  | [] ->
      ok None
  | [a] ->
      ok a
  | _ ->
      error (Unexpected_annotation loc)

let get_two_annot loc = function
  | [] ->
      ok (None, None)
  | [a] ->
      ok (a, None)
  | [a; b] ->
      ok (a, b)
  | _ ->
      error (Unexpected_annotation loc)

let parse_type_annot : int -> string list -> type_annot option tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  error_unexpected_annot loc fields >>? fun () -> get_one_annot loc types

let parse_type_field_annot :
    int -> string list -> (type_annot option * field_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  get_one_annot loc types
  >>? fun t -> get_one_annot loc fields >|? fun f -> (t, f)

let parse_composed_type_annot :
    int ->
    string list ->
    (type_annot option * field_annot option * field_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  get_one_annot loc types
  >>? fun t -> get_two_annot loc fields >|? fun (f1, f2) -> (t, f1, f2)

let parse_field_annot : int -> string list -> field_annot option tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc vars
  >>? fun () ->
  error_unexpected_annot loc types >>? fun () -> get_one_annot loc fields

let extract_field_annot :
    Script.node -> (Script.node * field_annot option) tzresult = function
  | Prim (loc, prim, args, annot) ->
      let rec extract_first acc = function
        | [] ->
            (None, annot)
        | s :: rest ->
            if Compare.Int.(String.length s > 0) && Compare.Char.(s.[0] = '%')
            then (Some s, List.rev_append acc rest)
            else extract_first (s :: acc) rest
      in
      let (field_annot, annot) = extract_first [] annot in
      let field_annot =
        match field_annot with
        | None ->
            None
        | Some field_annot ->
            Some
              (`Field_annot
                (String.sub field_annot 1 (String.length field_annot - 1)))
      in
      ok (Prim (loc, prim, args, annot), field_annot)
  | expr ->
      ok (expr, None)

let check_correct_field :
    field_annot option -> field_annot option -> unit tzresult =
 fun f1 f2 ->
  match (f1, f2) with
  | (None, _) | (_, None) ->
      ok ()
  | (Some (`Field_annot s1), Some (`Field_annot s2)) ->
      if String.equal s1 s2 then ok ()
      else error (Inconsistent_field_annotations ("%" ^ s1, "%" ^ s2))

let parse_var_annot :
    int ->
    ?default:var_annot option ->
    string list ->
    var_annot option tzresult =
 fun loc ?default annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  error_unexpected_annot loc fields
  >>? fun () ->
  get_one_annot loc vars
  >|? function
  | Some _ as a ->
      a
  | None -> (
    match default with Some a -> a | None -> None )

let split_last_dot = function
  | None ->
      (None, None)
  | Some (`Field_annot s) -> (
    match String.rindex_opt s '.' with
    | None ->
        (None, Some (`Field_annot s))
    | Some i ->
        let s1 = String.sub s 0 i in
        let s2 = String.sub s (i + 1) (String.length s - i - 1) in
        let f =
          if Compare.String.equal s2 "car" || Compare.String.equal s2 "cdr"
          then None
          else Some (`Field_annot s2)
        in
        (Some (`Var_annot s1), f) )

let common_prefix v1 v2 =
  match (v1, v2) with
  | (Some (`Var_annot s1), Some (`Var_annot s2))
    when Compare.String.equal s1 s2 ->
      v1
  | (Some _, None) ->
      v1
  | (None, Some _) ->
      v2
  | (_, _) ->
      None

let parse_constr_annot :
    int ->
    ?if_special_first:field_annot option ->
    ?if_special_second:field_annot option ->
    string list ->
    ( var_annot option
    * type_annot option
    * field_annot option
    * field_annot option )
    tzresult =
 fun loc ?if_special_first ?if_special_second annot ->
  parse_annots ~allow_special_field:true loc annot
  >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  get_one_annot loc vars
  >>? fun v ->
  get_one_annot loc types
  >>? fun t ->
  get_two_annot loc fields
  >>? fun (f1, f2) ->
  ( match (if_special_first, f1) with
  | (Some special_var, Some (`Field_annot "@")) ->
      ok (split_last_dot special_var)
  | (None, Some (`Field_annot "@")) ->
      error (Unexpected_annotation loc)
  | (_, _) ->
      ok (v, f1) )
  >>? fun (v1, f1) ->
  ( match (if_special_second, f2) with
  | (Some special_var, Some (`Field_annot "@")) ->
      ok (split_last_dot special_var)
  | (None, Some (`Field_annot "@")) ->
      error (Unexpected_annotation loc)
  | (_, _) ->
      ok (v, f2) )
  >|? fun (v2, f2) ->
  let v = match v with None -> common_prefix v1 v2 | Some _ -> v in
  (v, t, f1, f2)

let parse_two_var_annot :
    int -> string list -> (var_annot option * var_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  error_unexpected_annot loc fields >>? fun () -> get_two_annot loc vars

let parse_destr_annot :
    int ->
    string list ->
    default_accessor:field_annot option ->
    field_name:field_annot option ->
    pair_annot:var_annot option ->
    value_annot:var_annot option ->
    (var_annot option * field_annot option) tzresult =
 fun loc annot ~default_accessor ~field_name ~pair_annot ~value_annot ->
  parse_annots loc ~allow_special_var:true annot
  >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  get_one_annot loc vars
  >>? fun v ->
  get_one_annot loc fields
  >|? fun f ->
  let default =
    gen_access_annot pair_annot field_name ~default:default_accessor
  in
  let v =
    match v with
    | Some (`Var_annot "%") ->
        field_to_var_annot field_name
    | Some (`Var_annot "%%") ->
        default
    | Some _ ->
        v
    | None ->
        value_annot
  in
  (v, f)

let parse_entrypoint_annot :
    int ->
    ?default:var_annot option ->
    string list ->
    (var_annot option * field_annot option) tzresult =
 fun loc ?default annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc types
  >>? fun () ->
  get_one_annot loc fields
  >>? fun f ->
  get_one_annot loc vars
  >|? function
  | Some _ as a ->
      (a, f)
  | None -> (
    match default with Some a -> (a, f) | None -> (None, f) )

let parse_var_type_annot :
    int -> string list -> (var_annot option * type_annot option) tzresult =
 fun loc annot ->
  parse_annots loc annot >>? classify_annot loc
  >>? fun (vars, types, fields) ->
  error_unexpected_annot loc fields
  >>? fun () ->
  get_one_annot loc vars
  >>? fun v -> get_one_annot loc types >|? fun t -> (v, t)
src/proto_alpha/lib_protocol/script_ir_annot.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Micheline.

Import Script_tc_errors.

Import Script_typed_ir.

Definition default_now_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_amount_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_balance_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_steps_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_source_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_sender_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_self_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_arg_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_param_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_storage_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_car_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_cdr_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_contract_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_addr_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_manager_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_pack_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_unpack_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_slice_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_elt_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_key_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_hd_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_tl_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_some_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_left_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_right_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition default_binding_annot : option variant :=
  Some
    (* ❌ Variants not supported *)
    variant.

Definition unparse_type_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Type_annot a) => cons (op_caret ":" % string a) []
  end.

Definition unparse_var_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) : list string :=
  match function_parameter with
  | None => []
  | Some (Var_annot a) => cons (op_caret "@" % string a) []
  end.

Definition unparse_field_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : list string :=
  match function_parameter with
  | None => []
  | Some (Field_annot a) => cons (op_caret "%" % string a) []
  end.

Definition field_to_var_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  match function_parameter with
  | None => None
  | Some (Field_annot s) =>
    Some
      (* ❌ Variants not supported *)
      variant
  end.

Definition type_to_var_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  match function_parameter with
  | None => None
  | Some (Type_annot s) =>
    Some
      (* ❌ Variants not supported *)
      variant
  end.

Definition var_to_field_annot
  (function_parameter :
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot :=
  match function_parameter with
  | None => None
  | Some (Var_annot s) =>
    Some
      (* ❌ Variants not supported *)
      variant
  end.

Definition default_annot {A : Type}
  (default : option A) (function_parameter : option A) : option A :=
  match function_parameter with
  | None => default
  | annot => annot
  end.

Definition gen_access_annot
  (value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (op_staroptstar :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  : (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) ->
    option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  let default :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => None
    end in
  fun field_annot =>
    match (value_annot, field_annot, default) with
    |
      (None, None, _) | (Some _, None, None) |
        (None, Some (Field_annot "" % string), _) => None
    | (None, Some (Field_annot f), _) =>
      Some
        (* ❌ Variants not supported *)
        variant
    |
      (Some (Var_annot v), None | Some (Field_annot "" % string),
        Some (Field_annot f)) =>
      Some
        (* ❌ Variants not supported *)
        variant
    | (Some (Var_annot v), Some (Field_annot f), _) =>
      Some
        (* ❌ Variants not supported *)
        variant
    end.

Definition merge_type_annot
  (legacy : bool)
  (annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
  (annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => ok None
  | (Some (Type_annot a1), Some (Type_annot a2)) =>
    if op_pipepipe legacy (String.equal a1 a2) then
      ok annot1
    else
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_annotations
          (op_caret ":" % string a1) (op_caret ":" % string a2))
  end.

Definition merge_field_annot
  (legacy : bool)
  (annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => ok None
  | (Some (Field_annot a1), Some (Field_annot a2)) =>
    if op_pipepipe legacy (String.equal a1 a2) then
      ok annot1
    else
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_annotations
          (op_caret "%" % string a1) (op_caret "%" % string a2))
  end.

Definition merge_var_annot
  (annot1 : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (annot2 : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot :=
  match (annot1, annot2) with
  | (None, None) | (Some _, None) | (None, Some _) => None
  | (Some (Var_annot a1), Some (Var_annot a2)) =>
    if String.equal a1 a2 then
      annot1
    else
      None
  end.

Definition error_unexpected_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (annot : list A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  match annot with
  | [] => ok tt
  | cons _ _ =>
    error
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
        loc)
  end.

Definition fail_unexpected_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (annot : list A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  Lwt._return (error_unexpected_annot loc annot).

Definition parse_annots
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (op_staroptstar : option bool)
  : (option bool) ->
    (list string) ->
      Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list variant) :=
  let allow_special_var :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun op_staroptstar =>
    let allow_special_field :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun l =>
      let sub_or_wildcard {A : Type}
        (specials : list ascii) (wrap : (option string) -> A) (s : string) (acc
        : list A)
        : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list A) :=
        let len := String.length s in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            len 1 then
          op_atat ok (cons (wrap None) acc)
        else
          match String.get s 1 with
          |
            "a" % char |
              "b" % char |
                "c" % char |
                  "d" % char |
                    "e" % char |
                      "f" % char |
                        "g" % char |
                          "h" % char |
                            "i" % char |
                              "j" % char |
                                "k" % char |
                                  "l" % char |
                                    "m" % char |
                                      "n" % char |
                                        "o" % char |
                                          "p" % char |
                                            "q" % char |
                                              "r" % char |
                                                "s" % char |
                                                  "t" % char |
                                                    "u" % char |
                                                      "v" % char |
                                                        "w" % char |
                                                          "x" % char |
                                                            "y" % char |
                                                              "z" % char |
              "A" % char |
                "B" % char |
                  "C" % char |
                    "D" % char |
                      "E" % char |
                        "F" % char |
                          "G" % char |
                            "H" % char |
                              "I" % char |
                                "J" % char |
                                  "K" % char |
                                    "L" % char |
                                      "M" % char |
                                        "N" % char |
                                          "O" % char |
                                            "P" % char |
                                              "Q" % char |
                                                "R" % char |
                                                  "S" % char |
                                                    "T" % char |
                                                      "U" % char |
                                                        "V" % char |
                                                          "W" % char |
                                                            "X" % char |
                                                              "Y" % char |
                                                                "Z" % char |
              "_" % char =>
            op_atat ok
              (cons (wrap (Some (String.sub s 1 (op_minus len 1)))) acc)
          | "@" % char => op_atat ok (cons (wrap (Some "@" % string)) acc)
          | "%" % char =>
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                len 2 then
              op_atat ok (cons (wrap (Some "%" % string)) acc)
            else
              if
                op_andand
                  (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                    len 3)
                  (Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                    (String.get s 2) "%" % char) then
                op_atat ok (cons (wrap (Some "%%" % string)) acc)
              else
                error
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                    loc)
          | _ =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                loc)
          end in
      op_gtpipequestion
        (List.fold_left
          (fun acc =>
            fun s =>
              op_gtgtquestion acc
                (fun acc =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                      (String.length s) 0 then
                    error
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                        loc)
                  else
                    match String.get s 0 with
                    | ":" % char =>
                      sub_or_wildcard []
                        (fun a =>
                          (* ❌ Variants not supported *)
                          variant) s acc
                    | "@" % char =>
                      sub_or_wildcard
                        (if allow_special_var then
                          cons "%" % char []
                        else
                          [])
                        (fun a =>
                          (* ❌ Variants not supported *)
                          variant) s acc
                    | "%" % char =>
                      sub_or_wildcard
                        (if allow_special_field then
                          cons "@" % char []
                        else
                          [])
                        (fun a =>
                          (* ❌ Variants not supported *)
                          variant) s acc
                    | _ =>
                      error
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                          loc)
                    end)) (ok []) l) List.rev.

Definition opt_var_of_var_opt (function_parameter : variant) : option variant :=
  match function_parameter with
  | Var_annot None => None
  | Var_annot (Some a) =>
    Some
      (* ❌ Variants not supported *)
      variant
  end.

Definition opt_field_of_field_opt (function_parameter : variant)
  : option variant :=
  match function_parameter with
  | Field_annot None => None
  | Field_annot (Some a) =>
    Some
      (* ❌ Variants not supported *)
      variant
  end.

Definition opt_type_of_type_opt (function_parameter : variant)
  : option variant :=
  match function_parameter with
  | Type_annot None => None
  | Type_annot (Some a) =>
    Some
      (* ❌ Variants not supported *)
      variant
  end.

Definition classify_annot
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (l : list variant)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((list (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) *
      (list (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)) *
      (list (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  (* ❌ Try-with are not handled *)
  try
    (let '(_, rv, _, rt, _, rf) :=
      List.fold_left
        (fun function_parameter =>
          let '(in_v, rv, in_t, rt, in_f, rf) := function_parameter in
          fun a =>
            match (a, in_v, rv, in_t, rt, in_f, rf) with
            |
              ((Var_annot _) as a, true, _, _, _, _, _) |
                ((Var_annot _) as a, false, [], _, _, _, _) =>
              (true, (cons (opt_var_of_var_opt a) rv), false, rt, false, rf)
            |
              ((Type_annot _) as a, _, _, true, _, _, _) |
                ((Type_annot _) as a, _, _, false, [], _, _) =>
              (false, rv, true, (cons (opt_type_of_type_opt a) rt), false, rf)
            |
              ((Field_annot _) as a, _, _, _, _, true, _) |
                ((Field_annot _) as a, _, _, _, _, false, []) =>
              (false, rv, false, rt, true, (cons (opt_field_of_field_opt a) rf))
            | _ => raise Exit
            end) (false, [], false, [], false, []) l in
    ok ((List.rev rv), (List.rev rt), (List.rev rf))).

Definition get_one_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (function_parameter : list (option A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option A) :=
  match function_parameter with
  | [] => ok None
  | cons a [] => ok a
  | _ =>
    error
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
        loc)
  end.

Definition get_two_annot {A : Type}
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (function_parameter : list (option A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option A) * (option A)) :=
  match function_parameter with
  | [] => ok (None, None)
  | cons a [] => ok (a, None)
  | cons a (cons b []) => ok (a, b)
  | _ =>
    error
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
        loc)
  end.

Definition parse_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (error_unexpected_annot loc fields)
            (fun function_parameter =>
              let 'tt := function_parameter in
              get_one_annot loc types))).

Definition parse_type_field_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (get_one_annot loc types)
            (fun t =>
              op_gtpipequestion (get_one_annot loc fields) (fun f => (t, f))))).

Definition parse_composed_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (get_one_annot loc types)
            (fun t =>
              op_gtpipequestion (get_two_annot loc fields)
                (fun function_parameter =>
                  let '(f1, f2) := function_parameter in
                  (t, f1, f2))))).

Definition parse_field_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc vars)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (error_unexpected_annot loc types)
            (fun function_parameter =>
              let 'tt := function_parameter in
              get_one_annot loc fields))).

Definition extract_field_annot
  (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  match function_parameter with
  |
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
      annot =>
    let fix extract_first (acc : list string) (function_parameter : list string)
      : (option string) *
        Tezos_protocol_environment_alpha__Environment.Micheline.annot :=
      match function_parameter with
      | [] => (None, annot)
      | cons s rest =>
        if
          op_andand
            (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
              (String.length s) 0)
            (Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.get s 0) "%" % char) then
          ((Some s), (List.rev_append acc rest))
        else
          extract_first (cons s acc) rest
      end in
    let '(field_annot, annot) := extract_first [] annot in
    let field_annot :=
      match field_annot with
      | None => None
      | Some field_annot =>
        Some
          (* ❌ Variants not supported *)
          variant
      end in
    ok
      ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim
        args annot), field_annot)
  | expr => ok (expr, None)
  end.

Definition check_correct_field
  (f1 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (f2 : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  match (f1, f2) with
  | (None, _) | (_, None) => ok tt
  | (Some (Field_annot s1), Some (Field_annot s2)) =>
    if String.equal s1 s2 then
      ok tt
    else
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_field_annotations
          (op_caret "%" % string s1) (op_caret "%" % string s2))
  end.

Definition parse_var_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (error_unexpected_annot loc fields)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtpipequestion (get_one_annot loc vars)
                (fun function_parameter =>
                  match function_parameter with
                  | (Some _) as a => a
                  | None =>
                    match default with
                    | Some a => a
                    | None => None
                    end
                  end)))).

Definition split_last_dot (function_parameter : option variant)
  : (option variant) * (option variant) :=
  match function_parameter with
  | None => (None, None)
  | Some (Field_annot s) =>
    match String.rindex_opt s "." % char with
    | None =>
      (None,
        (Some
          (* ❌ Variants not supported *)
          variant))
    | Some i =>
      let s1 := String.sub s 0 i in
      let s2 :=
        String.sub s (op_plus i 1) (op_minus (op_minus (String.length s) i) 1)
        in
      let f :=
        if
          op_pipepipe
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
              s2 "car" % string)
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.equal)
              s2 "cdr" % string) then
          None
        else
          Some
            (* ❌ Variants not supported *)
            variant in
      ((Some
        (* ❌ Variants not supported *)
        variant), f)
    end
  end.

Definition common_prefix (v1 : option variant) (v2 : option variant)
  : option variant :=
  match (v1, v2) with
  | (Some (Var_annot s1), Some (Var_annot s2)) => v1
  | (Some _, None) => v1
  | (None, Some _) => v2
  | (_, _) => None
  end.

Definition parse_constr_annot
  (loc : Z)
  (if_special_first :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (if_special_second :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None (Some true) annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (get_one_annot loc vars)
        (fun v =>
          op_gtgtquestion (get_one_annot loc types)
            (fun t =>
              op_gtgtquestion (get_two_annot loc fields)
                (fun function_parameter =>
                  let '(f1, f2) := function_parameter in
                  op_gtgtquestion
                    match (if_special_first, f1) with
                    | (Some special_var, Some (Field_annot "@" % string)) =>
                      ok (split_last_dot special_var)
                    | (None, Some (Field_annot "@" % string)) =>
                      error
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                          loc)
                    | (_, _) => ok (v, f1)
                    end
                    (fun function_parameter =>
                      let '(v1, f1) := function_parameter in
                      op_gtpipequestion
                        match (if_special_second, f2) with
                        | (Some special_var, Some (Field_annot "@" % string)) =>
                          ok (split_last_dot special_var)
                        | (None, Some (Field_annot "@" % string)) =>
                          error
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                              loc)
                        | (_, _) => ok (v, f2)
                        end
                        (fun function_parameter =>
                          let '(v2, f2) := function_parameter in
                          let v :=
                            match v with
                            | None => common_prefix v1 v2
                            | Some _ => v
                            end in
                          (v, t, f1, f2))))))).

Definition parse_two_var_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (error_unexpected_annot loc fields)
            (fun function_parameter =>
              let 'tt := function_parameter in
              get_two_annot loc vars))).

Definition parse_destr_annot
  (loc : Z) (annot : list string)
  (default_accessor :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (field_name : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (pair_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc (Some true) None annot)
      (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (get_one_annot loc vars)
            (fun v =>
              op_gtpipequestion (get_one_annot loc fields)
                (fun f =>
                  let default :=
                    gen_access_annot pair_annot (Some default_accessor)
                      field_name in
                  let v :=
                    match v with
                    | Some (Var_annot "%" % string) =>
                      field_to_var_annot field_name
                    | Some (Var_annot "%%" % string) => default
                    | Some _ => v
                    | None => value_annot
                    end in
                  (v, f))))).

Definition parse_entrypoint_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc types)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (get_one_annot loc fields)
            (fun f =>
              op_gtpipequestion (get_one_annot loc vars)
                (fun function_parameter =>
                  match function_parameter with
                  | (Some _) as a => (a, f)
                  | None =>
                    match default with
                    | Some a => (a, f)
                    | None => (None, f)
                    end
                  end)))).

Definition parse_var_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot)) :=
  op_gtgtquestion
    (op_gtgtquestion (parse_annots loc None None annot) (classify_annot loc))
    (fun function_parameter =>
      let '(vars, types, fields) := function_parameter in
      op_gtgtquestion (error_unexpected_annot loc fields)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtquestion (get_one_annot loc vars)
            (fun v =>
              op_gtpipequestion (get_one_annot loc types) (fun t => (v, t))))).

src/proto_alpha/lib_protocol/script_ir_translator.ml 515 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Micheline
open Script
open Script_typed_ir
open Script_tc_errors
open Script_ir_annot
module Typecheck_costs = Michelson_v1_gas.Cost_of.Typechecking
module Unparse_costs = Michelson_v1_gas.Cost_of.Unparse

type ex_comparable_ty =
  | Ex_comparable_ty : 'a comparable_ty -> ex_comparable_ty

type ex_ty = Ex_ty : 'a ty -> ex_ty

type ex_stack_ty = Ex_stack_ty : 'a stack_ty -> ex_stack_ty

type tc_context =
  | Lambda : tc_context
  | Dip : 'a stack_ty * tc_context -> tc_context
  | Toplevel : {
      storage_type : 'sto ty;
      param_type : 'param ty;
      root_name : string option;
      legacy_create_contract_literal : bool;
    }
      -> tc_context

type unparsing_mode = Optimized | Readable

type type_logger =
  int ->
  (Script.expr * Script.annot) list ->
  (Script.expr * Script.annot) list ->
  unit

let add_dip ty annot prev =
  match prev with
  | Lambda | Toplevel _ ->
      Dip (Item_t (ty, Empty_t, annot), prev)
  | Dip (stack, _) ->
      Dip (Item_t (ty, stack, annot), prev)

(* ---- Type size accounting ------------------------------------------------*)

let rec comparable_type_size : type t a. (t, a) comparable_struct -> int =
 fun ty ->
  (* No wildcard to force the update when comparable_ty chages. *)
  match ty with
  | Int_key _ ->
      1
  | Nat_key _ ->
      1
  | String_key _ ->
      1
  | Bytes_key _ ->
      1
  | Mutez_key _ ->
      1
  | Bool_key _ ->
      1
  | Key_hash_key _ ->
      1
  | Timestamp_key _ ->
      1
  | Address_key _ ->
      1
  | Pair_key (_, (t, _), _) ->
      1 + comparable_type_size t

let rec type_size : type t. t ty -> int =
 fun ty ->
  match ty with
  | Unit_t _ ->
      1
  | Int_t _ ->
      1
  | Nat_t _ ->
      1
  | Signature_t _ ->
      1
  | Bytes_t _ ->
      1
  | String_t _ ->
      1
  | Mutez_t _ ->
      1
  | Key_hash_t _ ->
      1
  | Key_t _ ->
      1
  | Timestamp_t _ ->
      1
  | Address_t _ ->
      1
  | Bool_t _ ->
      1
  | Operation_t _ ->
      1
  | Pair_t ((l, _, _), (r, _, _), _, _) ->
      1 + type_size l + type_size r
  | Union_t ((l, _), (r, _), _, _) ->
      1 + type_size l + type_size r
  | Lambda_t (arg, ret, _) ->
      1 + type_size arg + type_size ret
  | Option_t (t, _, _) ->
      1 + type_size t
  | List_t (t, _, _) ->
      1 + type_size t
  | Set_t (k, _) ->
      1 + comparable_type_size k
  | Map_t (k, v, _, _) ->
      1 + comparable_type_size k + type_size v
  | Big_map_t (k, v, _) ->
      1 + comparable_type_size k + type_size v
  | Contract_t (arg, _) ->
      1 + type_size arg
  | Chain_id_t _ ->
      1

let rec type_size_of_stack_head : type st. st stack_ty -> up_to:int -> int =
 fun stack ~up_to ->
  match stack with
  | Empty_t ->
      0
  | Item_t (head, tail, _annot) ->
      if Compare.Int.(up_to > 0) then
        Compare.Int.max
          (type_size head)
          (type_size_of_stack_head tail ~up_to:(up_to - 1))
      else 0

(* This is the depth of the stack to inspect for sizes overflow. We
   only need to check the produced types that can be larger than the
   arguments. That's why Swap is 0 for instance as no type grows.
   Constant sized types are not checked: it is assumed they are lower
   than the bound (otherwise every program would be rejected). *)
let number_of_generated_growing_types : type b a. (b, a) instr -> int =
  function
  | Drop ->
      0
  | Dup ->
      0
  | Swap ->
      0
  | Const _ ->
      1
  | Cons_pair ->
      1
  | Car ->
      0
  | Cdr ->
      0
  | Cons_some ->
      1
  | Cons_none _ ->
      1
  | If_none _ ->
      0
  | Left ->
      0
  | Right ->
      0
  | If_left _ ->
      0
  | Cons_list ->
      1
  | Nil ->
      1
  | If_cons _ ->
      0
  | List_map _ ->
      1
  | List_size ->
      0
  | List_iter _ ->
      1
  | Empty_set _ ->
      1
  | Set_iter _ ->
      0
  | Set_mem ->
      0
  | Set_update ->
      0
  | Set_size ->
      0
  | Empty_map _ ->
      1
  | Map_map _ ->
      1
  | Map_iter _ ->
      1
  | Map_mem ->
      0
  | Map_get ->
      0
  | Map_update ->
      0
  | Map_size ->
      0
  | Empty_big_map _ ->
      1
  | Big_map_get ->
      0
  | Big_map_update ->
      0
  | Big_map_mem ->
      0
  | Concat_string ->
      0
  | Concat_string_pair ->
      0
  | Slice_string ->
      0
  | String_size ->
      0
  | Concat_bytes ->
      0
  | Concat_bytes_pair ->
      0
  | Slice_bytes ->
      0
  | Bytes_size ->
      0
  | Add_seconds_to_timestamp ->
      0
  | Add_timestamp_to_seconds ->
      0
  | Sub_timestamp_seconds ->
      0
  | Diff_timestamps ->
      0
  | Add_tez ->
      0
  | Sub_tez ->
      0
  | Mul_teznat ->
      0
  | Mul_nattez ->
      0
  | Ediv_teznat ->
      0
  | Ediv_tez ->
      0
  | Or ->
      0
  | And ->
      0
  | Xor ->
      0
  | Not ->
      0
  | Is_nat ->
      0
  | Neg_nat ->
      0
  | Neg_int ->
      0
  | Abs_int ->
      0
  | Int_nat ->
      0
  | Add_intint ->
      0
  | Add_intnat ->
      0
  | Add_natint ->
      0
  | Add_natnat ->
      0
  | Sub_int ->
      0
  | Mul_intint ->
      0
  | Mul_intnat ->
      0
  | Mul_natint ->
      0
  | Mul_natnat ->
      0
  | Ediv_intint ->
      0
  | Ediv_intnat ->
      0
  | Ediv_natint ->
      0
  | Ediv_natnat ->
      0
  | Lsl_nat ->
      0
  | Lsr_nat ->
      0
  | Or_nat ->
      0
  | And_nat ->
      0
  | And_int_nat ->
      0
  | Xor_nat ->
      0
  | Not_nat ->
      0
  | Not_int ->
      0
  | Seq _ ->
      0
  | If _ ->
      0
  | Loop _ ->
      0
  | Loop_left _ ->
      0
  | Dip _ ->
      0
  | Exec ->
      0
  | Apply _ ->
      0
  | Lambda _ ->
      1
  | Failwith _ ->
      1
  | Nop ->
      0
  | Compare _ ->
      1
  | Eq ->
      0
  | Neq ->
      0
  | Lt ->
      0
  | Gt ->
      0
  | Le ->
      0
  | Ge ->
      0
  | Address ->
      0
  | Contract _ ->
      1
  | Transfer_tokens ->
      1
  | Create_account ->
      0
  | Implicit_account ->
      0
  | Create_contract _ ->
      1
  | Create_contract_2 _ ->
      1
  | Now ->
      0
  | Balance ->
      0
  | Check_signature ->
      0
  | Hash_key ->
      0
  | Blake2b ->
      0
  | Sha256 ->
      0
  | Sha512 ->
      0
  | Steps_to_quota ->
      0
  | Source ->
      0
  | Sender ->
      0
  | Self _ ->
      1
  | Amount ->
      0
  | Set_delegate ->
      0
  | Pack _ ->
      0
  | Unpack _ ->
      1
  | Dig _ ->
      0
  | Dug _ ->
      0
  | Dipn _ ->
      0
  | Dropn _ ->
      0
  | ChainId ->
      0

(* ---- Error helpers -------------------------------------------------------*)

let location = function
  | Prim (loc, _, _, _)
  | Int (loc, _)
  | String (loc, _)
  | Bytes (loc, _)
  | Seq (loc, _) ->
      loc

let kind = function
  | Int _ ->
      Int_kind
  | String _ ->
      String_kind
  | Bytes _ ->
      Bytes_kind
  | Prim _ ->
      Prim_kind
  | Seq _ ->
      Seq_kind

let namespace = function
  | K_parameter | K_storage | K_code ->
      Keyword_namespace
  | D_False
  | D_Elt
  | D_Left
  | D_None
  | D_Pair
  | D_Right
  | D_Some
  | D_True
  | D_Unit ->
      Constant_namespace
  | I_PACK
  | I_UNPACK
  | I_BLAKE2B
  | I_SHA256
  | I_SHA512
  | I_ABS
  | I_ADD
  | I_AMOUNT
  | I_AND
  | I_BALANCE
  | I_CAR
  | I_CDR
  | I_CHAIN_ID
  | I_CHECK_SIGNATURE
  | I_COMPARE
  | I_CONCAT
  | I_CONS
  | I_CREATE_ACCOUNT
  | I_CREATE_CONTRACT
  | I_IMPLICIT_ACCOUNT
  | I_DIP
  | I_DROP
  | I_DUP
  | I_EDIV
  | I_EMPTY_BIG_MAP
  | I_EMPTY_MAP
  | I_EMPTY_SET
  | I_EQ
  | I_EXEC
  | I_APPLY
  | I_FAILWITH
  | I_GE
  | I_GET
  | I_GT
  | I_HASH_KEY
  | I_IF
  | I_IF_CONS
  | I_IF_LEFT
  | I_IF_NONE
  | I_INT
  | I_LAMBDA
  | I_LE
  | I_LEFT
  | I_LOOP
  | I_LSL
  | I_LSR
  | I_LT
  | I_MAP
  | I_MEM
  | I_MUL
  | I_NEG
  | I_NEQ
  | I_NIL
  | I_NONE
  | I_NOT
  | I_NOW
  | I_OR
  | I_PAIR
  | I_PUSH
  | I_RIGHT
  | I_SIZE
  | I_SOME
  | I_SOURCE
  | I_SENDER
  | I_SELF
  | I_SLICE
  | I_STEPS_TO_QUOTA
  | I_SUB
  | I_SWAP
  | I_TRANSFER_TOKENS
  | I_SET_DELEGATE
  | I_UNIT
  | I_UPDATE
  | I_XOR
  | I_ITER
  | I_LOOP_LEFT
  | I_ADDRESS
  | I_CONTRACT
  | I_ISNAT
  | I_CAST
  | I_RENAME
  | I_DIG
  | I_DUG ->
      Instr_namespace
  | T_bool
  | T_contract
  | T_int
  | T_key
  | T_key_hash
  | T_lambda
  | T_list
  | T_map
  | T_big_map
  | T_nat
  | T_option
  | T_or
  | T_pair
  | T_set
  | T_signature
  | T_string
  | T_bytes
  | T_mutez
  | T_timestamp
  | T_unit
  | T_operation
  | T_address
  | T_chain_id ->
      Type_namespace

let unexpected expr exp_kinds exp_ns exp_prims =
  match expr with
  | Int (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Int_kind)
  | String (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, String_kind)
  | Bytes (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Bytes_kind)
  | Seq (loc, _) ->
      Invalid_kind (loc, Prim_kind :: exp_kinds, Seq_kind)
  | Prim (loc, name, _, _) -> (
    match (namespace name, exp_ns) with
    | (Type_namespace, Type_namespace)
    | (Instr_namespace, Instr_namespace)
    | (Constant_namespace, Constant_namespace) ->
        Invalid_primitive (loc, exp_prims, name)
    | (ns, _) ->
        Invalid_namespace (loc, name, exp_ns, ns) )

let check_kind kinds expr =
  let kind = kind expr in
  if List.mem kind kinds then return_unit
  else
    let loc = location expr in
    fail (Invalid_kind (loc, kinds, kind))

(* ---- Sets and Maps -------------------------------------------------------*)

let wrap_compare compare a b =
  let res = compare a b in
  if Compare.Int.(res = 0) then 0 else if Compare.Int.(res > 0) then 1 else -1

let rec compare_comparable :
    type a s. (a, s) comparable_struct -> a -> a -> int =
 fun kind ->
  match kind with
  | String_key _ ->
      wrap_compare Compare.String.compare
  | Bool_key _ ->
      wrap_compare Compare.Bool.compare
  | Mutez_key _ ->
      wrap_compare Tez.compare
  | Key_hash_key _ ->
      wrap_compare Signature.Public_key_hash.compare
  | Int_key _ ->
      wrap_compare Script_int.compare
  | Nat_key _ ->
      wrap_compare Script_int.compare
  | Timestamp_key _ ->
      wrap_compare Script_timestamp.compare
  | Address_key _ ->
      wrap_compare
      @@ fun (x, ex) (y, ey) ->
      let lres = Contract.compare x y in
      if Compare.Int.(lres = 0) then Compare.String.compare ex ey else lres
  | Bytes_key _ ->
      wrap_compare MBytes.compare
  | Pair_key ((tl, _), (tr, _), _) ->
      fun (lx, rx) (ly, ry) ->
        let lres = compare_comparable tl lx ly in
        if Compare.Int.(lres = 0) then compare_comparable tr rx ry else lres

let empty_set : type a. a comparable_ty -> a set =
 fun ty ->
  let module OPS = Set.Make (struct
    type t = a

    let compare = compare_comparable ty
  end) in
  ( module struct
    type elt = a

    let elt_ty = ty

    module OPS = OPS

    let boxed = OPS.empty

    let size = 0
  end )

let set_update : type a. a -> bool -> a set -> a set =
 fun v b (module Box) ->
  ( module struct
    type elt = a

    let elt_ty = Box.elt_ty

    module OPS = Box.OPS

    let boxed =
      if b then Box.OPS.add v Box.boxed else Box.OPS.remove v Box.boxed

    let size =
      let mem = Box.OPS.mem v Box.boxed in
      if mem then if b then Box.size else Box.size - 1
      else if b then Box.size + 1
      else Box.size
  end )

let set_mem : type elt. elt -> elt set -> bool =
 fun v (module Box) -> Box.OPS.mem v Box.boxed

let set_fold : type elt acc. (elt -> acc -> acc) -> elt set -> acc -> acc =
 fun f (module Box) -> Box.OPS.fold f Box.boxed

let set_size : type elt. elt set -> Script_int.n Script_int.num =
 fun (module Box) -> Script_int.(abs (of_int Box.size))

let map_key_ty : type a b. (a, b) map -> a comparable_ty =
 fun (module Box) -> Box.key_ty

let empty_map : type a b. a comparable_ty -> (a, b) map =
 fun ty ->
  let module OPS = Map.Make (struct
    type t = a

    let compare = compare_comparable ty
  end) in
  ( module struct
    type key = a

    type value = b

    let key_ty = ty

    module OPS = OPS

    let boxed = (OPS.empty, 0)
  end )

let map_get : type key value. key -> (key, value) map -> value option =
 fun k (module Box) -> Box.OPS.find_opt k (fst Box.boxed)

let map_update : type a b. a -> b option -> (a, b) map -> (a, b) map =
 fun k v (module Box) ->
  ( module struct
    type key = a

    type value = b

    let key_ty = Box.key_ty

    module OPS = Box.OPS

    let boxed =
      let (map, size) = Box.boxed in
      let contains = Box.OPS.mem k map in
      match v with
      | Some v ->
          (Box.OPS.add k v map, size + if contains then 0 else 1)
      | None ->
          (Box.OPS.remove k map, size - if contains then 1 else 0)
  end )

let map_set : type a b. a -> b -> (a, b) map -> (a, b) map =
 fun k v (module Box) ->
  ( module struct
    type key = a

    type value = b

    let key_ty = Box.key_ty

    module OPS = Box.OPS

    let boxed =
      let (map, size) = Box.boxed in
      (Box.OPS.add k v map, if Box.OPS.mem k map then size else size + 1)
  end )

let map_mem : type key value. key -> (key, value) map -> bool =
 fun k (module Box) -> Box.OPS.mem k (fst Box.boxed)

let map_fold :
    type key value acc.
    (key -> value -> acc -> acc) -> (key, value) map -> acc -> acc =
 fun f (module Box) -> Box.OPS.fold f (fst Box.boxed)

let map_size : type key value. (key, value) map -> Script_int.n Script_int.num
    =
 fun (module Box) -> Script_int.(abs (of_int (snd Box.boxed)))

(* ---- Unparsing (Typed IR -> Untyped expressions) of types -----------------*)

let rec ty_of_comparable_ty : type a s. (a, s) comparable_struct -> a ty =
  function
  | Int_key tname ->
      Int_t tname
  | Nat_key tname ->
      Nat_t tname
  | String_key tname ->
      String_t tname
  | Bytes_key tname ->
      Bytes_t tname
  | Mutez_key tname ->
      Mutez_t tname
  | Bool_key tname ->
      Bool_t tname
  | Key_hash_key tname ->
      Key_hash_t tname
  | Timestamp_key tname ->
      Timestamp_t tname
  | Address_key tname ->
      Address_t tname
  | Pair_key ((l, al), (r, ar), tname) ->
      Pair_t
        ( (ty_of_comparable_ty l, al, None),
          (ty_of_comparable_ty r, ar, None),
          tname,
          false )

let rec comparable_ty_of_ty : type a. a ty -> a comparable_ty option = function
  | Int_t tname ->
      Some (Int_key tname)
  | Nat_t tname ->
      Some (Nat_key tname)
  | String_t tname ->
      Some (String_key tname)
  | Bytes_t tname ->
      Some (Bytes_key tname)
  | Mutez_t tname ->
      Some (Mutez_key tname)
  | Bool_t tname ->
      Some (Bool_key tname)
  | Key_hash_t tname ->
      Some (Key_hash_key tname)
  | Timestamp_t tname ->
      Some (Timestamp_key tname)
  | Address_t tname ->
      Some (Address_key tname)
  | Pair_t ((l, al, _), (r, ar, _), pname, _) -> (
    match comparable_ty_of_ty r with
    | None ->
        None
    | Some rty -> (
      match comparable_ty_of_ty l with
      | None ->
          None
      | Some (Pair_key _) ->
          None (* not a comb *)
      | Some (Int_key tname) ->
          Some (Pair_key ((Int_key tname, al), (rty, ar), pname))
      | Some (Nat_key tname) ->
          Some (Pair_key ((Nat_key tname, al), (rty, ar), pname))
      | Some (String_key tname) ->
          Some (Pair_key ((String_key tname, al), (rty, ar), pname))
      | Some (Bytes_key tname) ->
          Some (Pair_key ((Bytes_key tname, al), (rty, ar), pname))
      | Some (Mutez_key tname) ->
          Some (Pair_key ((Mutez_key tname, al), (rty, ar), pname))
      | Some (Bool_key tname) ->
          Some (Pair_key ((Bool_key tname, al), (rty, ar), pname))
      | Some (Key_hash_key tname) ->
          Some (Pair_key ((Key_hash_key tname, al), (rty, ar), pname))
      | Some (Timestamp_key tname) ->
          Some (Pair_key ((Timestamp_key tname, al), (rty, ar), pname))
      | Some (Address_key tname) ->
          Some (Pair_key ((Address_key tname, al), (rty, ar), pname)) ) )
  | _ ->
      None

let add_field_annot a var = function
  | Prim (loc, prim, args, annots) ->
      Prim
        ( loc,
          prim,
          args,
          annots @ unparse_field_annot a @ unparse_var_annot var )
  | expr ->
      expr

let rec unparse_comparable_ty :
    type a s. (a, s) comparable_struct -> Script.node = function
  | Int_key tname ->
      Prim (-1, T_int, [], unparse_type_annot tname)
  | Nat_key tname ->
      Prim (-1, T_nat, [], unparse_type_annot tname)
  | String_key tname ->
      Prim (-1, T_string, [], unparse_type_annot tname)
  | Bytes_key tname ->
      Prim (-1, T_bytes, [], unparse_type_annot tname)
  | Mutez_key tname ->
      Prim (-1, T_mutez, [], unparse_type_annot tname)
  | Bool_key tname ->
      Prim (-1, T_bool, [], unparse_type_annot tname)
  | Key_hash_key tname ->
      Prim (-1, T_key_hash, [], unparse_type_annot tname)
  | Timestamp_key tname ->
      Prim (-1, T_timestamp, [], unparse_type_annot tname)
  | Address_key tname ->
      Prim (-1, T_address, [], unparse_type_annot tname)
  | Pair_key ((l, al), (r, ar), pname) ->
      let tl = add_field_annot al None (unparse_comparable_ty l) in
      let tr = add_field_annot ar None (unparse_comparable_ty r) in
      Prim (-1, T_pair, [tl; tr], unparse_type_annot pname)

let rec unparse_ty_no_lwt :
    type a. context -> a ty -> (Script.node * context) tzresult =
 fun ctxt ty ->
  Gas.consume ctxt Unparse_costs.cycle
  >>? fun ctxt ->
  let return ctxt (name, args, annot) =
    let result = Prim (-1, name, args, annot) in
    Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot)
    >>? fun ctxt -> ok (result, ctxt)
  in
  match ty with
  | Unit_t tname ->
      return ctxt (T_unit, [], unparse_type_annot tname)
  | Int_t tname ->
      return ctxt (T_int, [], unparse_type_annot tname)
  | Nat_t tname ->
      return ctxt (T_nat, [], unparse_type_annot tname)
  | String_t tname ->
      return ctxt (T_string, [], unparse_type_annot tname)
  | Bytes_t tname ->
      return ctxt (T_bytes, [], unparse_type_annot tname)
  | Mutez_t tname ->
      return ctxt (T_mutez, [], unparse_type_annot tname)
  | Bool_t tname ->
      return ctxt (T_bool, [], unparse_type_annot tname)
  | Key_hash_t tname ->
      return ctxt (T_key_hash, [], unparse_type_annot tname)
  | Key_t tname ->
      return ctxt (T_key, [], unparse_type_annot tname)
  | Timestamp_t tname ->
      return ctxt (T_timestamp, [], unparse_type_annot tname)
  | Address_t tname ->
      return ctxt (T_address, [], unparse_type_annot tname)
  | Signature_t tname ->
      return ctxt (T_signature, [], unparse_type_annot tname)
  | Operation_t tname ->
      return ctxt (T_operation, [], unparse_type_annot tname)
  | Chain_id_t tname ->
      return ctxt (T_chain_id, [], unparse_type_annot tname)
  | Contract_t (ut, tname) ->
      unparse_ty_no_lwt ctxt ut
      >>? fun (t, ctxt) ->
      return ctxt (T_contract, [t], unparse_type_annot tname)
  | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt utl
      >>? fun (utl, ctxt) ->
      let tl = add_field_annot l_field l_var utl in
      unparse_ty_no_lwt ctxt utr
      >>? fun (utr, ctxt) ->
      let tr = add_field_annot r_field r_var utr in
      return ctxt (T_pair, [tl; tr], annot)
  | Union_t ((utl, l_field), (utr, r_field), tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt utl
      >>? fun (utl, ctxt) ->
      let tl = add_field_annot l_field None utl in
      unparse_ty_no_lwt ctxt utr
      >>? fun (utr, ctxt) ->
      let tr = add_field_annot r_field None utr in
      return ctxt (T_or, [tl; tr], annot)
  | Lambda_t (uta, utr, tname) ->
      unparse_ty_no_lwt ctxt uta
      >>? fun (ta, ctxt) ->
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_lambda, [ta; tr], unparse_type_annot tname)
  | Option_t (ut, tname, _) ->
      let annot = unparse_type_annot tname in
      unparse_ty_no_lwt ctxt ut
      >>? fun (ut, ctxt) -> return ctxt (T_option, [ut], annot)
  | List_t (ut, tname, _) ->
      unparse_ty_no_lwt ctxt ut
      >>? fun (t, ctxt) -> return ctxt (T_list, [t], unparse_type_annot tname)
  | Set_t (ut, tname) ->
      let t = unparse_comparable_ty ut in
      return ctxt (T_set, [t], unparse_type_annot tname)
  | Map_t (uta, utr, tname, _) ->
      let ta = unparse_comparable_ty uta in
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_map, [ta; tr], unparse_type_annot tname)
  | Big_map_t (uta, utr, tname) ->
      let ta = unparse_comparable_ty uta in
      unparse_ty_no_lwt ctxt utr
      >>? fun (tr, ctxt) ->
      return ctxt (T_big_map, [ta; tr], unparse_type_annot tname)

let unparse_ty ctxt ty = Lwt.return (unparse_ty_no_lwt ctxt ty)

let rec strip_var_annots = function
  | (Int _ | String _ | Bytes _) as atom ->
      atom
  | Seq (loc, args) ->
      Seq (loc, List.map strip_var_annots args)
  | Prim (loc, name, args, annots) ->
      let not_var_annot s = Compare.Char.(s.[0] <> '@') in
      let annots = List.filter not_var_annot annots in
      Prim (loc, name, List.map strip_var_annots args, annots)

let serialize_ty_for_error ctxt ty =
  unparse_ty_no_lwt ctxt ty
  |> record_trace Cannot_serialize_error
  >|? fun (ty, ctxt) -> (strip_locations (strip_var_annots ty), ctxt)

let rec unparse_stack :
    type a.
    context ->
    a stack_ty ->
    ((Script.expr * Script.annot) list * context) tzresult Lwt.t =
 fun ctxt -> function
  | Empty_t ->
      return ([], ctxt)
  | Item_t (ty, rest, annot) ->
      unparse_ty ctxt ty
      >>=? fun (uty, ctxt) ->
      unparse_stack ctxt rest
      >>=? fun (urest, ctxt) ->
      return ((strip_locations uty, unparse_var_annot annot) :: urest, ctxt)

let serialize_stack_for_error ctxt stack_ty =
  trace Cannot_serialize_error (unparse_stack ctxt stack_ty)

let name_of_ty : type a. a ty -> type_annot option = function
  | Unit_t tname ->
      tname
  | Int_t tname ->
      tname
  | Nat_t tname ->
      tname
  | String_t tname ->
      tname
  | Bytes_t tname ->
      tname
  | Mutez_t tname ->
      tname
  | Bool_t tname ->
      tname
  | Key_hash_t tname ->
      tname
  | Key_t tname ->
      tname
  | Timestamp_t tname ->
      tname
  | Address_t tname ->
      tname
  | Signature_t tname ->
      tname
  | Operation_t tname ->
      tname
  | Chain_id_t tname ->
      tname
  | Contract_t (_, tname) ->
      tname
  | Pair_t (_, _, tname, _) ->
      tname
  | Union_t (_, _, tname, _) ->
      tname
  | Lambda_t (_, _, tname) ->
      tname
  | Option_t (_, tname, _) ->
      tname
  | List_t (_, tname, _) ->
      tname
  | Set_t (_, tname) ->
      tname
  | Map_t (_, _, tname, _) ->
      tname
  | Big_map_t (_, _, tname) ->
      tname

(* ---- Equality witnesses --------------------------------------------------*)

type ('ta, 'tb) eq = Eq : ('same, 'same) eq

let comparable_ty_eq :
    type ta tb.
    context ->
    ta comparable_ty ->
    tb comparable_ty ->
    (ta comparable_ty, tb comparable_ty) eq tzresult =
 fun ctxt ta tb ->
  match (ta, tb) with
  | (Int_key _, Int_key _) ->
      Ok Eq
  | (Nat_key _, Nat_key _) ->
      Ok Eq
  | (String_key _, String_key _) ->
      Ok Eq
  | (Bytes_key _, Bytes_key _) ->
      Ok Eq
  | (Mutez_key _, Mutez_key _) ->
      Ok Eq
  | (Bool_key _, Bool_key _) ->
      Ok Eq
  | (Key_hash_key _, Key_hash_key _) ->
      Ok Eq
  | (Timestamp_key _, Timestamp_key _) ->
      Ok Eq
  | (Address_key _, Address_key _) ->
      Ok Eq
  | (_, _) ->
      serialize_ty_for_error ctxt (ty_of_comparable_ty ta)
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt (ty_of_comparable_ty tb)
      >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))

let record_inconsistent ctxt ta tb =
  record_trace_eval (fun () ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >|? fun (tb, _ctxt) -> Inconsistent_types (ta, tb))

let record_inconsistent_type_annotations ctxt loc ta tb =
  record_trace_eval (fun () ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >|? fun (tb, _ctxt) -> Inconsistent_type_annotations (loc, ta, tb))

let rec ty_eq :
    type ta tb.
    context -> ta ty -> tb ty -> ((ta ty, tb ty) eq * context) tzresult =
 fun ctxt ta tb ->
  let ok (eq : (ta ty, tb ty) eq) ctxt nb_args :
      ((ta ty, tb ty) eq * context) tzresult =
    Gas.consume ctxt (Typecheck_costs.type_ (2 * nb_args))
    >>? fun ctxt -> Ok (eq, ctxt)
  in
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match (ta, tb) with
  | (Unit_t _, Unit_t _) ->
      ok Eq ctxt 0
  | (Int_t _, Int_t _) ->
      ok Eq ctxt 0
  | (Nat_t _, Nat_t _) ->
      ok Eq ctxt 0
  | (Key_t _, Key_t _) ->
      ok Eq ctxt 0
  | (Key_hash_t _, Key_hash_t _) ->
      ok Eq ctxt 0
  | (String_t _, String_t _) ->
      ok Eq ctxt 0
  | (Bytes_t _, Bytes_t _) ->
      ok Eq ctxt 0
  | (Signature_t _, Signature_t _) ->
      ok Eq ctxt 0
  | (Mutez_t _, Mutez_t _) ->
      ok Eq ctxt 0
  | (Timestamp_t _, Timestamp_t _) ->
      ok Eq ctxt 0
  | (Chain_id_t _, Chain_id_t _) ->
      ok Eq ctxt 0
  | (Address_t _, Address_t _) ->
      ok Eq ctxt 0
  | (Bool_t _, Bool_t _) ->
      ok Eq ctxt 0
  | (Operation_t _, Operation_t _) ->
      ok Eq ctxt 0
  | (Map_t (tal, tar, _, _), Map_t (tbl, tbr, _, _)) ->
      comparable_ty_eq ctxt tal tbl
      >>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Big_map_t (tal, tar, _), Big_map_t (tbl, tbr, _)) ->
      comparable_ty_eq ctxt tal tbl
      >>? (fun Eq -> ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Set_t (ea, _), Set_t (eb, _)) ->
      comparable_ty_eq ctxt ea eb
      >>? (fun Eq -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | ( Pair_t ((tal, _, _), (tar, _, _), _, _),
      Pair_t ((tbl, _, _), (tbr, _, _), _, _) ) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Union_t ((tal, _), (tar, _), _, _), Union_t ((tbl, _), (tbr, _), _, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Lambda_t (tal, tar, _), Lambda_t (tbl, tbr, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) ->
            ty_eq ctxt tar tbr >>? fun (Eq, ctxt) -> ok Eq ctxt 2)
      |> record_inconsistent ctxt ta tb
  | (Contract_t (tal, _), Contract_t (tbl, _)) ->
      ty_eq ctxt tal tbl
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (Option_t (tva, _, _), Option_t (tvb, _, _)) ->
      ty_eq ctxt tva tvb
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (List_t (tva, _, _), List_t (tvb, _, _)) ->
      ty_eq ctxt tva tvb
      >>? (fun (Eq, ctxt) -> ok Eq ctxt 1)
      |> record_inconsistent ctxt ta tb
  | (_, _) ->
      serialize_ty_for_error ctxt ta
      >>? fun (ta, ctxt) ->
      serialize_ty_for_error ctxt tb
      >>? fun (tb, _ctxt) -> error (Inconsistent_types (ta, tb))

let rec stack_ty_eq :
    type ta tb.
    context ->
    int ->
    ta stack_ty ->
    tb stack_ty ->
    ((ta stack_ty, tb stack_ty) eq * context) tzresult =
 fun ctxt lvl ta tb ->
  match (ta, tb) with
  | (Item_t (tva, ra, _), Item_t (tvb, rb, _)) ->
      ty_eq ctxt tva tvb
      |> record_trace (Bad_stack_item lvl)
      >>? fun (Eq, ctxt) ->
      stack_ty_eq ctxt (lvl + 1) ra rb
      >>? fun (Eq, ctxt) ->
      (Ok (Eq, ctxt) : ((ta stack_ty, tb stack_ty) eq * context) tzresult)
  | (Empty_t, Empty_t) ->
      Ok (Eq, ctxt)
  | (_, _) ->
      error Bad_stack_length

let merge_comparable_types :
    type ta.
    legacy:bool ->
    ta comparable_ty ->
    ta comparable_ty ->
    ta comparable_ty tzresult =
 fun ~legacy ta tb ->
  match (ta, tb) with
  | (Int_key annot_a, Int_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Int_key annot
  | (Nat_key annot_a, Nat_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Nat_key annot
  | (String_key annot_a, String_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> String_key annot
  | (Bytes_key annot_a, Bytes_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bytes_key annot
  | (Mutez_key annot_a, Mutez_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Mutez_key annot
  | (Bool_key annot_a, Bool_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b >|? fun annot -> Bool_key annot
  | (Key_hash_key annot_a, Key_hash_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Key_hash_key annot
  | (Timestamp_key annot_a, Timestamp_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Timestamp_key annot
  | (Address_key annot_a, Address_key annot_b) ->
      merge_type_annot ~legacy annot_a annot_b
      >|? fun annot -> Address_key annot
  | (_, _) ->
      assert false

(* FIXME: fix injectivity of some types *)

let merge_types :
    type b.
    legacy:bool ->
    context ->
    Script.location ->
    b ty ->
    b ty ->
    (b ty * context) tzresult =
 fun ~legacy ->
  let rec help : type a. context -> a ty -> a ty -> (a ty * context) tzresult =
   fun ctxt ty1 ty2 ->
    match (ty1, ty2) with
    | (Unit_t tn1, Unit_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Unit_t tname, ctxt)
    | (Int_t tn1, Int_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Int_t tname, ctxt)
    | (Nat_t tn1, Nat_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Nat_t tname, ctxt)
    | (Key_t tn1, Key_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Key_t tname, ctxt)
    | (Key_hash_t tn1, Key_hash_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Key_hash_t tname, ctxt)
    | (String_t tn1, String_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (String_t tname, ctxt)
    | (Bytes_t tn1, Bytes_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bytes_t tname, ctxt)
    | (Signature_t tn1, Signature_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Signature_t tname, ctxt)
    | (Mutez_t tn1, Mutez_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Mutez_t tname, ctxt)
    | (Timestamp_t tn1, Timestamp_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Timestamp_t tname, ctxt)
    | (Address_t tn1, Address_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Address_t tname, ctxt)
    | (Bool_t tn1, Bool_t tn2) ->
        merge_type_annot ~legacy tn1 tn2 >|? fun tname -> (Bool_t tname, ctxt)
    | (Chain_id_t tn1, Chain_id_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Chain_id_t tname, ctxt)
    | (Operation_t tn1, Operation_t tn2) ->
        merge_type_annot ~legacy tn1 tn2
        >|? fun tname -> (Operation_t tname, ctxt)
    | (Map_t (tal, tar, tn1, has_big_map), Map_t (tbl, tbr, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tar tbr
        >>? fun (value, ctxt) ->
        ty_eq ctxt tar value
        >>? fun (Eq, ctxt) ->
        merge_comparable_types ~legacy tal tbl
        >|? fun tk -> (Map_t (tk, value, tname, has_big_map), ctxt)
    | (Big_map_t (tal, tar, tn1), Big_map_t (tbl, tbr, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tar tbr
        >>? fun (value, ctxt) ->
        ty_eq ctxt tar value
        >>? fun (Eq, ctxt) ->
        merge_comparable_types ~legacy tal tbl
        >|? fun tk -> (Big_map_t (tk, value, tname), ctxt)
    | (Set_t (ea, tn1), Set_t (eb, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_comparable_types ~legacy ea eb
        >|? fun e -> (Set_t (e, tname), ctxt)
    | ( Pair_t
          ((tal, l_field1, l_var1), (tar, r_field1, r_var1), tn1, has_big_map),
        Pair_t ((tbl, l_field2, l_var2), (tbr, r_field2, r_var2), tn2, _) ) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_field_annot ~legacy l_field1 l_field2
        >>? fun l_field ->
        merge_field_annot ~legacy r_field1 r_field2
        >>? fun r_field ->
        let l_var = merge_var_annot l_var1 l_var2 in
        let r_var = merge_var_annot r_var1 r_var2 in
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) ->
        ( Pair_t
            ( (left_ty, l_field, l_var),
              (right_ty, r_field, r_var),
              tname,
              has_big_map ),
          ctxt )
    | ( Union_t ((tal, tal_annot), (tar, tar_annot), tn1, has_big_map),
        Union_t ((tbl, tbl_annot), (tbr, tbr_annot), tn2, _) ) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        merge_field_annot ~legacy tal_annot tbl_annot
        >>? fun left_annot ->
        merge_field_annot ~legacy tar_annot tbr_annot
        >>? fun right_annot ->
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) ->
        ( Union_t
            ((left_ty, left_annot), (right_ty, right_annot), tname, has_big_map),
          ctxt )
    | (Lambda_t (tal, tar, tn1), Lambda_t (tbl, tbr, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tal tbl
        >>? fun (left_ty, ctxt) ->
        help ctxt tar tbr
        >|? fun (right_ty, ctxt) -> (Lambda_t (left_ty, right_ty, tname), ctxt)
    | (Contract_t (tal, tn1), Contract_t (tbl, tn2)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tal tbl
        >|? fun (arg_ty, ctxt) -> (Contract_t (arg_ty, tname), ctxt)
    | (Option_t (tva, tn1, has_big_map), Option_t (tvb, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tva tvb
        >|? fun (ty, ctxt) -> (Option_t (ty, tname, has_big_map), ctxt)
    | (List_t (tva, tn1, has_big_map), List_t (tvb, tn2, _)) ->
        merge_type_annot ~legacy tn1 tn2
        >>? fun tname ->
        help ctxt tva tvb
        >|? fun (ty, ctxt) -> (List_t (ty, tname, has_big_map), ctxt)
    | (_, _) ->
        assert false
  in
  fun ctxt loc ty1 ty2 ->
    record_inconsistent_type_annotations ctxt loc ty1 ty2 (help ctxt ty1 ty2)

let merge_stacks :
    type ta.
    legacy:bool ->
    Script.location ->
    context ->
    ta stack_ty ->
    ta stack_ty ->
    (ta stack_ty * context) tzresult =
 fun ~legacy loc ->
  let rec help :
      type a.
      context -> a stack_ty -> a stack_ty -> (a stack_ty * context) tzresult =
   fun ctxt stack1 stack2 ->
    match (stack1, stack2) with
    | (Empty_t, Empty_t) ->
        ok (Empty_t, ctxt)
    | (Item_t (ty1, rest1, annot1), Item_t (ty2, rest2, annot2)) ->
        let annot = merge_var_annot annot1 annot2 in
        merge_types ~legacy ctxt loc ty1 ty2
        >>? fun (ty, ctxt) ->
        help ctxt rest1 rest2
        >|? fun (rest, ctxt) -> (Item_t (ty, rest, annot), ctxt)
  in
  help

let has_big_map : type t. t ty -> bool = function
  | Unit_t _ ->
      false
  | Int_t _ ->
      false
  | Nat_t _ ->
      false
  | Signature_t _ ->
      false
  | String_t _ ->
      false
  | Bytes_t _ ->
      false
  | Mutez_t _ ->
      false
  | Key_hash_t _ ->
      false
  | Key_t _ ->
      false
  | Timestamp_t _ ->
      false
  | Address_t _ ->
      false
  | Bool_t _ ->
      false
  | Lambda_t (_, _, _) ->
      false
  | Set_t (_, _) ->
      false
  | Big_map_t (_, _, _) ->
      true
  | Contract_t (_, _) ->
      false
  | Operation_t _ ->
      false
  | Chain_id_t _ ->
      false
  | Pair_t (_, _, _, has_big_map) ->
      has_big_map
  | Union_t (_, _, _, has_big_map) ->
      has_big_map
  | Option_t (_, _, has_big_map) ->
      has_big_map
  | List_t (_, _, has_big_map) ->
      has_big_map
  | Map_t (_, _, _, has_big_map) ->
      has_big_map

(* ---- Type checker results -------------------------------------------------*)

type 'bef judgement =
  | Typed : ('bef, 'aft) descr -> 'bef judgement
  | Failed : {
      descr : 'aft. 'aft stack_ty -> ('bef, 'aft) descr;
    }
      -> 'bef judgement

(* ---- Type checker (Untyped expressions -> Typed IR) ----------------------*)

type ('t, 'f, 'b) branch = {
  branch : 'r. ('t, 'r) descr -> ('f, 'r) descr -> ('b, 'r) descr;
}
[@@unboxed]

let merge_branches :
    type bef a b.
    legacy:bool ->
    context ->
    int ->
    a judgement ->
    b judgement ->
    (a, b, bef) branch ->
    (bef judgement * context) tzresult Lwt.t =
 fun ~legacy ctxt loc btr bfr {branch} ->
  match (btr, bfr) with
  | (Typed ({aft = aftbt; _} as dbt), Typed ({aft = aftbf; _} as dbf)) ->
      let unmatched_branches () =
        serialize_stack_for_error ctxt aftbt
        >>=? fun (aftbt, ctxt) ->
        serialize_stack_for_error ctxt aftbf
        >>|? fun (aftbf, _ctxt) -> Unmatched_branches (loc, aftbt, aftbf)
      in
      trace_eval
        unmatched_branches
        ( Lwt.return (stack_ty_eq ctxt 1 aftbt aftbf)
        >>=? fun (Eq, ctxt) ->
        Lwt.return (merge_stacks ~legacy loc ctxt aftbt aftbf)
        >>=? fun (merged_stack, ctxt) ->
        return
          ( Typed
              (branch
                 {dbt with aft = merged_stack}
                 {dbf with aft = merged_stack}),
            ctxt ) )
  | (Failed {descr = descrt}, Failed {descr = descrf}) ->
      let descr ret = branch (descrt ret) (descrf ret) in
      return (Failed {descr}, ctxt)
  | (Typed dbt, Failed {descr = descrf}) ->
      return (Typed (branch dbt (descrf dbt.aft)), ctxt)
  | (Failed {descr = descrt}, Typed dbf) ->
      return (Typed (branch (descrt dbf.aft) dbf), ctxt)

let rec parse_comparable_ty :
    context -> Script.node -> (ex_comparable_ty * context) tzresult =
 fun ctxt ty ->
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  Gas.consume ctxt (Typecheck_costs.type_ 0)
  >>? fun ctxt ->
  match ty with
  | Prim (loc, T_int, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Int_key tname), ctxt)
  | Prim (loc, T_nat, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Nat_key tname), ctxt)
  | Prim (loc, T_string, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (String_key tname), ctxt)
  | Prim (loc, T_bytes, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Bytes_key tname), ctxt)
  | Prim (loc, T_mutez, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Mutez_key tname), ctxt)
  | Prim (loc, T_bool, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Bool_key tname), ctxt)
  | Prim (loc, T_key_hash, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Key_hash_key tname), ctxt)
  | Prim (loc, T_timestamp, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Timestamp_key tname), ctxt)
  | Prim (loc, T_address, [], annot) ->
      parse_type_annot loc annot
      >|? fun tname -> (Ex_comparable_ty (Address_key tname), ctxt)
  | Prim
      ( loc,
        ( ( T_int
          | T_nat
          | T_string
          | T_mutez
          | T_bool
          | T_key
          | T_address
          | T_timestamp ) as prim ),
        l,
        _ ) ->
      error (Invalid_arity (loc, prim, 0, List.length l))
  | Prim
      ( loc,
        ( T_pair
        | T_or
        | T_set
        | T_map
        | T_list
        | T_option
        | T_lambda
        | T_unit
        | T_signature
        | T_contract ),
        _,
        _ ) ->
      error (Comparable_type_expected (loc, Micheline.strip_locations ty))
  | expr ->
      error
      @@ unexpected
           expr
           []
           Type_namespace
           [ T_int;
             T_nat;
             T_string;
             T_mutez;
             T_bool;
             T_key;
             T_key_hash;
             T_timestamp ]

and parse_packable_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:false
    ~allow_operation:false
    ~allow_contract:legacy

and parse_parameter_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:true
    ~allow_operation:false
    ~allow_contract:true

and parse_any_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy ->
  parse_ty
    ctxt
    ~legacy
    ~allow_big_map:true
    ~allow_operation:true
    ~allow_contract:true

and parse_ty :
    context ->
    legacy:bool ->
    allow_big_map:bool ->
    allow_operation:bool ->
    allow_contract:bool ->
    Script.node ->
    (ex_ty * context) tzresult =
 fun ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract node ->
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match node with
  | Prim (loc, T_unit, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Unit_t ty_name), ctxt)
  | Prim (loc, T_int, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Int_t ty_name), ctxt)
  | Prim (loc, T_nat, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Nat_t ty_name), ctxt)
  | Prim (loc, T_string, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (String_t ty_name), ctxt)
  | Prim (loc, T_bytes, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Bytes_t ty_name), ctxt)
  | Prim (loc, T_mutez, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Mutez_t ty_name), ctxt)
  | Prim (loc, T_bool, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Bool_t ty_name), ctxt)
  | Prim (loc, T_key, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Key_t ty_name), ctxt)
  | Prim (loc, T_key_hash, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Key_hash_t ty_name), ctxt)
  | Prim (loc, T_timestamp, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Timestamp_t ty_name), ctxt)
  | Prim (loc, T_address, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Address_t ty_name), ctxt)
  | Prim (loc, T_signature, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Signature_t ty_name), ctxt)
  | Prim (loc, T_operation, [], annot) ->
      if allow_operation then
        parse_type_annot loc annot
        >>? fun ty_name ->
        Gas.consume ctxt (Typecheck_costs.type_ 0)
        >|? fun ctxt -> (Ex_ty (Operation_t ty_name), ctxt)
      else error (Unexpected_operation loc)
  | Prim (loc, T_chain_id, [], annot) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 0)
      >|? fun ctxt -> (Ex_ty (Chain_id_t ty_name), ctxt)
  | Prim (loc, T_contract, [utl], annot) ->
      if allow_contract then
        parse_parameter_ty ctxt ~legacy utl
        >>? fun (Ex_ty tl, ctxt) ->
        parse_type_annot loc annot
        >>? fun ty_name ->
        Gas.consume ctxt (Typecheck_costs.type_ 1)
        >|? fun ctxt -> (Ex_ty (Contract_t (tl, ty_name)), ctxt)
      else error (Unexpected_contract loc)
  | Prim (loc, T_pair, [utl; utr], annot) ->
      extract_field_annot utl
      >>? fun (utl, left_field) ->
      extract_field_annot utr
      >>? fun (utr, right_field) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
      >>? fun (Ex_ty tl, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt ->
      ( Ex_ty
          (Pair_t
             ( (tl, left_field, None),
               (tr, right_field, None),
               ty_name,
               has_big_map tl || has_big_map tr )),
        ctxt )
  | Prim (loc, T_or, [utl; utr], annot) ->
      extract_field_annot utl
      >>? fun (utl, left_constr) ->
      extract_field_annot utr
      >>? fun (utr, right_constr) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utl
      >>? fun (Ex_ty tl, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt ->
      ( Ex_ty
          (Union_t
             ( (tl, left_constr),
               (tr, right_constr),
               ty_name,
               has_big_map tl || has_big_map tr )),
        ctxt )
  | Prim (loc, T_lambda, [uta; utr], annot) ->
      parse_any_ty ctxt ~legacy uta
      >>? fun (Ex_ty ta, ctxt) ->
      parse_any_ty ctxt ~legacy utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Lambda_t (ta, tr, ty_name)), ctxt)
  | Prim (loc, T_option, [ut], annot) ->
      ( if legacy then
        (* legacy semantics with (broken) field annotations *)
        extract_field_annot ut
        >>? fun (ut, _some_constr) ->
        parse_composed_type_annot loc annot
        >>? fun (ty_name, _none_constr, _) -> ok (ut, ty_name)
      else parse_type_annot loc annot >>? fun ty_name -> ok (ut, ty_name) )
      >>? fun (ut, ty_name) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
      >>? fun (Ex_ty t, ctxt) ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Option_t (t, ty_name, has_big_map t)), ctxt)
  | Prim (loc, T_list, [ut], annot) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract ut
      >>? fun (Ex_ty t, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 1)
      >|? fun ctxt -> (Ex_ty (List_t (t, ty_name, has_big_map t)), ctxt)
  | Prim (loc, T_set, [ut], annot) ->
      parse_comparable_ty ctxt ut
      >>? fun (Ex_comparable_ty t, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 1)
      >|? fun ctxt -> (Ex_ty (Set_t (t, ty_name)), ctxt)
  | Prim (loc, T_map, [uta; utr], annot) ->
      parse_comparable_ty ctxt uta
      >>? fun (Ex_comparable_ty ta, ctxt) ->
      parse_ty ctxt ~legacy ~allow_big_map ~allow_operation ~allow_contract utr
      >>? fun (Ex_ty tr, ctxt) ->
      parse_type_annot loc annot
      >>? fun ty_name ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (Ex_ty (Map_t (ta, tr, ty_name, has_big_map tr)), ctxt)
  | Prim (loc, T_big_map, args, annot) when allow_big_map ->
      parse_big_map_ty ctxt ~legacy loc args annot
      >>? fun (big_map_ty, ctxt) ->
      Gas.consume ctxt (Typecheck_costs.type_ 2)
      >|? fun ctxt -> (big_map_ty, ctxt)
  | Prim (loc, T_big_map, _, _) ->
      error (Unexpected_big_map loc)
  | Prim
      ( loc,
        ( ( T_unit
          | T_signature
          | T_int
          | T_nat
          | T_string
          | T_bytes
          | T_mutez
          | T_bool
          | T_key
          | T_key_hash
          | T_timestamp
          | T_address ) as prim ),
        l,
        _ ) ->
      error (Invalid_arity (loc, prim, 0, List.length l))
  | Prim (loc, ((T_set | T_list | T_option | T_contract) as prim), l, _) ->
      error (Invalid_arity (loc, prim, 1, List.length l))
  | Prim (loc, ((T_pair | T_or | T_map | T_lambda) as prim), l, _) ->
      error (Invalid_arity (loc, prim, 2, List.length l))
  | expr ->
      error
      @@ unexpected
           expr
           []
           Type_namespace
           [ T_pair;
             T_or;
             T_set;
             T_map;
             T_list;
             T_option;
             T_lambda;
             T_unit;
             T_signature;
             T_contract;
             T_int;
             T_nat;
             T_operation;
             T_string;
             T_bytes;
             T_mutez;
             T_bool;
             T_key;
             T_key_hash;
             T_timestamp;
             T_chain_id ]

and parse_big_map_ty ctxt ~legacy big_map_loc args map_annot =
  Gas.consume ctxt Typecheck_costs.cycle
  >>? fun ctxt ->
  match args with
  | [key_ty; value_ty] ->
      parse_comparable_ty ctxt key_ty
      >>? fun (Ex_comparable_ty key_ty, ctxt) ->
      parse_packable_ty ctxt ~legacy value_ty
      >>? fun (Ex_ty value_ty, ctxt) ->
      parse_type_annot big_map_loc map_annot
      >|? fun map_name ->
      let big_map_ty = Big_map_t (key_ty, value_ty, map_name) in
      (Ex_ty big_map_ty, ctxt)
  | args ->
      error @@ Invalid_arity (big_map_loc, T_big_map, 2, List.length args)

and parse_storage_ty :
    context -> legacy:bool -> Script.node -> (ex_ty * context) tzresult =
 fun ctxt ~legacy node ->
  match node with
  | Prim
      ( loc,
        T_pair,
        [Prim (big_map_loc, T_big_map, args, map_annot); remaining_storage],
        storage_annot )
    when legacy -> (
    match storage_annot with
    | [] ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          node
    | [single]
      when Compare.Int.(String.length single > 0)
           && Compare.Char.(single.[0] = '%') ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          node
    | _ ->
        (* legacy semantics of big maps used the wrong annotation parser *)
        Gas.consume ctxt Typecheck_costs.cycle
        >>? fun ctxt ->
        parse_big_map_ty ctxt ~legacy big_map_loc args map_annot
        >>? fun (Ex_ty big_map_ty, ctxt) ->
        parse_ty
          ctxt
          ~legacy
          ~allow_big_map:true
          ~allow_operation:false
          ~allow_contract:legacy
          remaining_storage
        >>? fun (Ex_ty remaining_storage, ctxt) ->
        parse_composed_type_annot loc storage_annot
        >>? fun (ty_name, map_field, storage_field) ->
        Gas.consume ctxt (Typecheck_costs.type_ 5)
        >|? fun ctxt ->
        ( Ex_ty
            (Pair_t
               ( (big_map_ty, map_field, None),
                 (remaining_storage, storage_field, None),
                 ty_name,
                 true )),
          ctxt ) )
  | _ ->
      parse_ty
        ctxt
        ~legacy
        ~allow_big_map:true
        ~allow_operation:false
        ~allow_contract:legacy
        node

let check_packable ~legacy loc root =
  let rec check : type t. t ty -> unit tzresult = function
    | Big_map_t _ ->
        error (Unexpected_big_map loc)
    | Operation_t _ ->
        error (Unexpected_operation loc)
    | Unit_t _ ->
        ok ()
    | Int_t _ ->
        ok ()
    | Nat_t _ ->
        ok ()
    | Signature_t _ ->
        ok ()
    | String_t _ ->
        ok ()
    | Bytes_t _ ->
        ok ()
    | Mutez_t _ ->
        ok ()
    | Key_hash_t _ ->
        ok ()
    | Key_t _ ->
        ok ()
    | Timestamp_t _ ->
        ok ()
    | Address_t _ ->
        ok ()
    | Bool_t _ ->
        ok ()
    | Chain_id_t _ ->
        ok ()
    | Pair_t ((l_ty, _, _), (r_ty, _, _), _, _) ->
        check l_ty >>? fun () -> check r_ty
    | Union_t ((l_ty, _), (r_ty, _), _, _) ->
        check l_ty >>? fun () -> check r_ty
    | Option_t (v_ty, _, _) ->
        check v_ty
    | List_t (elt_ty, _, _) ->
        check elt_ty
    | Set_t (_, _) ->
        ok ()
    | Map_t (_, elt_ty, _, _) ->
        check elt_ty
    | Lambda_t (_l_ty, _r_ty, _) ->
        ok ()
    | Contract_t (_, _) when legacy ->
        ok ()
    | Contract_t (_, _) ->
        error (Unexpected_contract loc)
  in
  check root

type ex_script = Ex_script : ('a, 'c) script -> ex_script

type _ dig_proof_argument =
  | Dig_proof_argument :
      ( ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * ('x ty * var_annot option)
      * 'aft stack_ty )
      -> 'bef dig_proof_argument

type (_, _) dug_proof_argument =
  | Dug_proof_argument :
      ( ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * unit
      * 'aft stack_ty )
      -> ('bef, 'x) dug_proof_argument

type _ dipn_proof_argument =
  | Dipn_proof_argument :
      ( ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      * (context * ('fbef, 'faft) descr)
      * 'aft stack_ty )
      -> 'bef dipn_proof_argument

type _ dropn_proof_argument =
  | Dropn_proof_argument :
      ( ('rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      * 'rest stack_ty
      * 'aft stack_ty )
      -> 'bef dropn_proof_argument

(* Lwt versions *)
let parse_var_annot loc ?default annot =
  Lwt.return (parse_var_annot loc ?default annot)

let parse_entrypoint_annot loc ?default annot =
  Lwt.return (parse_entrypoint_annot loc ?default annot)

let parse_constr_annot loc ?if_special_first ?if_special_second annot =
  Lwt.return
    (parse_constr_annot loc ?if_special_first ?if_special_second annot)

let parse_two_var_annot loc annot = Lwt.return (parse_two_var_annot loc annot)

let parse_destr_annot loc annot ~default_accessor ~field_name ~pair_annot
    ~value_annot =
  Lwt.return
    (parse_destr_annot
       loc
       annot
       ~default_accessor
       ~field_name
       ~pair_annot
       ~value_annot)

let parse_var_type_annot loc annot =
  Lwt.return (parse_var_type_annot loc annot)

let find_entrypoint (type full) (full : full ty) ~root_name entrypoint =
  let rec find_entrypoint :
      type t. t ty -> string -> (Script.node -> Script.node) * ex_ty =
   fun t entrypoint ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) -> (
        if
          match al with
          | None ->
              false
          | Some (`Field_annot l) ->
              Compare.String.(l = entrypoint)
        then ((fun e -> Prim (0, D_Left, [e], [])), Ex_ty tl)
        else if
          match ar with
          | None ->
              false
          | Some (`Field_annot r) ->
              Compare.String.(r = entrypoint)
        then ((fun e -> Prim (0, D_Right, [e], [])), Ex_ty tr)
        else
          try
            let (f, t) = find_entrypoint tl entrypoint in
            ((fun e -> Prim (0, D_Left, [f e], [])), t)
          with Not_found ->
            let (f, t) = find_entrypoint tr entrypoint in
            ((fun e -> Prim (0, D_Right, [f e], [])), t) )
    | _ ->
        raise Not_found
  in
  let entrypoint =
    if Compare.String.(entrypoint = "") then "default" else entrypoint
  in
  if Compare.Int.(String.length entrypoint > 31) then
    error (Entrypoint_name_too_long entrypoint)
  else
    match root_name with
    | Some root_name when Compare.String.(entrypoint = root_name) ->
        ok ((fun e -> e), Ex_ty full)
    | _ -> (
      try ok (find_entrypoint full entrypoint)
      with Not_found -> (
        match entrypoint with
        | "default" ->
            ok ((fun e -> e), Ex_ty full)
        | _ ->
            error (No_such_entrypoint entrypoint) ) )

let find_entrypoint_for_type (type full exp) ~(full : full ty)
    ~(expected : exp ty) ~root_name entrypoint ctxt :
    (context * string * exp ty) tzresult =
  match (entrypoint, root_name) with
  | ("default", Some "root") -> (
    match find_entrypoint full ~root_name entrypoint with
    | Error _ as err ->
        err
    | Ok (_, Ex_ty ty) -> (
      match ty_eq ctxt expected ty with
      | Ok (Eq, ctxt) ->
          ok (ctxt, "default", (ty : exp ty))
      | Error _ ->
          ty_eq ctxt expected full
          >>? fun (Eq, ctxt) -> ok (ctxt, "root", (full : exp ty)) ) )
  | _ ->
      find_entrypoint full ~root_name entrypoint
      >>? fun (_, Ex_ty ty) ->
      ty_eq ctxt expected ty
      >>? fun (Eq, ctxt) -> ok (ctxt, entrypoint, (ty : exp ty))

module Entrypoints = Set.Make (String)

exception Duplicate of string

exception Too_long of string

let well_formed_entrypoints (type full) (full : full ty) ~root_name =
  let merge path annot (type t) (ty : t ty) reachable
      ((first_unreachable, all) as acc) =
    match annot with
    | None | Some (`Field_annot "") -> (
        if reachable then acc
        else
          match ty with
          | Union_t _ ->
              acc
          | _ -> (
            match first_unreachable with
            | None ->
                (Some (List.rev path), all)
            | Some _ ->
                acc ) )
    | Some (`Field_annot name) ->
        if Compare.Int.(String.length name > 31) then raise (Too_long name)
        else if Entrypoints.mem name all then raise (Duplicate name)
        else (first_unreachable, Entrypoints.add name all)
  in
  let rec check :
      type t.
      t ty ->
      prim list ->
      bool ->
      prim list option * Entrypoints.t ->
      prim list option * Entrypoints.t =
   fun t path reachable acc ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) ->
        let acc = merge (D_Left :: path) al tl reachable acc in
        let acc = merge (D_Right :: path) ar tr reachable acc in
        let acc =
          check
            tl
            (D_Left :: path)
            (match al with Some _ -> true | None -> reachable)
            acc
        in
        check
          tr
          (D_Right :: path)
          (match ar with Some _ -> true | None -> reachable)
          acc
    | _ ->
        acc
  in
  try
    let (init, reachable) =
      match root_name with
      | None | Some "" ->
          (Entrypoints.empty, false)
      | Some name ->
          (Entrypoints.singleton name, true)
    in
    let (first_unreachable, all) = check full [] reachable (None, init) in
    if not (Entrypoints.mem "default" all) then ok ()
    else
      match first_unreachable with
      | None ->
          ok ()
      | Some path ->
          error (Unreachable_entrypoint path)
  with
  | Duplicate name ->
      error (Duplicate_entrypoint name)
  | Too_long name ->
      error (Entrypoint_name_too_long name)

let rec parse_data :
    type a.
    ?type_logger:type_logger ->
    context ->
    legacy:bool ->
    a ty ->
    Script.node ->
    (a * context) tzresult Lwt.t =
 fun ?type_logger ctxt ~legacy ty script_data ->
  Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
  >>=? fun ctxt ->
  let error () =
    Lwt.return (serialize_ty_for_error ctxt ty)
    >>|? fun (ty, _ctxt) ->
    Invalid_constant (location script_data, strip_locations script_data, ty)
  in
  let traced body = trace_eval error body in
  let parse_items ?type_logger loc ctxt expr key_type value_type items
      item_wrapper =
    let length = List.length items in
    fold_left_s
      (fun (last_value, map, ctxt) item ->
        Lwt.return (Gas.consume ctxt (Typecheck_costs.map_element length))
        >>=? fun ctxt ->
        match item with
        | Prim (_, D_Elt, [k; v], _) ->
            parse_comparable_data ?type_logger ctxt key_type k
            >>=? fun (k, ctxt) ->
            parse_data ?type_logger ctxt ~legacy value_type v
            >>=? fun (v, ctxt) ->
            ( match last_value with
            | Some value ->
                if Compare.Int.(0 <= compare_comparable key_type value k) then
                  if Compare.Int.(0 = compare_comparable key_type value k) then
                    fail (Duplicate_map_keys (loc, strip_locations expr))
                  else fail (Unordered_map_keys (loc, strip_locations expr))
                else return_unit
            | None ->
                return_unit )
            >>=? fun () ->
            return (Some k, map_update k (Some (item_wrapper v)) map, ctxt)
        | Prim (loc, D_Elt, l, _) ->
            fail @@ Invalid_arity (loc, D_Elt, 2, List.length l)
        | Prim (loc, name, _, _) ->
            fail @@ Invalid_primitive (loc, [D_Elt], name)
        | Int _ | String _ | Bytes _ | Seq _ ->
            error () >>=? fail)
      (None, empty_map key_type, ctxt)
      items
    |> traced
    >>|? fun (_, items, ctxt) -> (items, ctxt)
  in
  match (ty, script_data) with
  (* Unit *)
  | (Unit_t _, Prim (loc, D_Unit, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.unit)
      >>|? fun ctxt -> ((() : a), ctxt)
  | (Unit_t _, Prim (loc, D_Unit, l, _)) ->
      traced (fail (Invalid_arity (loc, D_Unit, 0, List.length l)))
  | (Unit_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Unit]))
  (* Booleans *)
  | (Bool_t _, Prim (loc, D_True, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
      >>|? fun ctxt -> (true, ctxt)
  | (Bool_t _, Prim (loc, D_False, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.bool)
      >>|? fun ctxt -> (false, ctxt)
  | (Bool_t _, Prim (loc, ((D_True | D_False) as c), l, _)) ->
      traced (fail (Invalid_arity (loc, c, 0, List.length l)))
  | (Bool_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_True; D_False]))
  (* Strings *)
  | (String_t _, String (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.string (String.length v)))
      >>=? fun ctxt ->
      let rec check_printable_ascii i =
        if Compare.Int.(i < 0) then true
        else
          match v.[i] with
          | '\n' | '\x20' .. '\x7E' ->
              check_printable_ascii (i - 1)
          | _ ->
              false
      in
      if check_printable_ascii (String.length v - 1) then return (v, ctxt)
      else error () >>=? fail
  | (String_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [String_kind], kind expr)))
  (* Byte sequences *)
  | (Bytes_t _, Bytes (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v)))
      >>=? fun ctxt -> return (v, ctxt)
  | (Bytes_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Bytes_kind], kind expr)))
  (* Integers *)
  | (Int_t _, Int (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt -> return (Script_int.of_zint v, ctxt)
  | (Nat_t _, Int (_, v)) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt ->
      let v = Script_int.of_zint v in
      if Compare.Int.(Script_int.compare v Script_int.zero >= 0) then
        return (Script_int.abs v, ctxt)
      else error () >>=? fail
  | (Int_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  | (Nat_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  (* Tez amounts *)
  | (Mutez_t _, Int (_, v)) -> (
      Lwt.return
        ( Gas.consume ctxt Typecheck_costs.tez
        >>? fun ctxt ->
        Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64 )
      >>=? fun ctxt ->
      try
        match Tez.of_mutez (Z.to_int64 v) with
        | None ->
            raise Exit
        | Some tez ->
            return (tez, ctxt)
      with _ -> error () >>=? fail )
  | (Mutez_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Int_kind], kind expr)))
  (* Timestamps *)
  | (Timestamp_t _, Int (_, v))
  (* As unparsed with [Optimized] or out of bounds [Readable]. *) ->
      Lwt.return (Gas.consume ctxt (Typecheck_costs.z v))
      >>=? fun ctxt -> return (Script_timestamp.of_zint v, ctxt)
  | (Timestamp_t _, String (_, s)) (* As unparsed with [Redable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.string_timestamp)
      >>=? fun ctxt ->
      match Script_timestamp.of_string s with
      | Some v ->
          return (v, ctxt)
      | None ->
          error () >>=? fail )
  | (Timestamp_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Int_kind], kind expr)))
  (* IDs *)
  | (Key_t _, Bytes (_, bytes)) -> (
      (* As unparsed with [Optimized]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes Signature.Public_key.encoding bytes
      with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_t _, String (_, s)) -> (
      (* As unparsed with [Readable]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key)
      >>=? fun ctxt ->
      match Signature.Public_key.of_b58check_opt s with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  | (Key_hash_t _, Bytes (_, bytes)) -> (
      (* As unparsed with [Optimized]. *)
      Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding bytes
      with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_hash_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.key_hash)
      >>=? fun ctxt ->
      match Signature.Public_key_hash.of_b58check_opt s with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Key_hash_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Signatures *)
  | (Signature_t _, Bytes (_, bytes)) (* As unparsed with [Optimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
      >>=? fun ctxt ->
      match Data_encoding.Binary.of_bytes Signature.encoding bytes with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Signature_t _, String (_, s)) (* As unparsed with [Readable]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.signature)
      >>=? fun ctxt ->
      match Signature.of_b58check_opt s with
      | Some s ->
          return (s, ctxt)
      | None ->
          error () >>=? fail )
  | (Signature_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Operations *)
  | (Operation_t _, _) ->
      (* operations cannot appear in parameters or storage,
           the protocol should never parse the bytes of an operation *)
      assert false
  (* Chain_ids *)
  | (Chain_id_t _, Bytes (_, bytes)) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
      >>=? fun ctxt ->
      match Data_encoding.Binary.of_bytes Chain_id.encoding bytes with
      | Some k ->
          return (k, ctxt)
      | None ->
          error () >>=? fail )
  | (Chain_id_t _, String (_, s)) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.chain_id)
      >>=? fun ctxt ->
      match Chain_id.of_b58check_opt s with
      | Some s ->
          return (s, ctxt)
      | None ->
          error () >>=? fail )
  | (Chain_id_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Addresses *)
  | (Address_t _, Bytes (loc, bytes)) (* As unparsed with [O[ptimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes
          Data_encoding.(tup2 Contract.encoding Variable.string)
          bytes
      with
      | Some (c, entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            fail (Entrypoint_name_too_long entrypoint)
          else
            ( match entrypoint with
            | "" ->
                return "default"
            | "default" ->
                fail (Unexpected_annotation loc)
            | name ->
                return name )
            >>=? fun entrypoint -> return ((c, entrypoint), ctxt)
      | None ->
          error () >>=? fail )
  | (Address_t _, String (loc, s)) (* As unparsed with [Readable]. *) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      ( match String.index_opt s '%' with
      | None ->
          return (s, "default")
      | Some pos -> (
          let len = String.length s - pos - 1 in
          let name = String.sub s (pos + 1) len in
          if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
          else
            match (String.sub s 0 pos, name) with
            | (_, "default") ->
                traced (fail (Unexpected_annotation loc))
            | addr_and_name ->
                return addr_and_name ) )
      >>=? fun (addr, entrypoint) ->
      Lwt.return (Contract.of_b58check addr)
      >>=? fun c -> return ((c, entrypoint), ctxt)
  | (Address_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Contracts *)
  | (Contract_t (ty, _), Bytes (loc, bytes))
  (* As unparsed with [Optimized]. *) -> (
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      match
        Data_encoding.Binary.of_bytes
          Data_encoding.(tup2 Contract.encoding Variable.string)
          bytes
      with
      | Some (c, entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            fail (Entrypoint_name_too_long entrypoint)
          else
            ( match entrypoint with
            | "" ->
                return "default"
            | "default" ->
                traced (fail (Unexpected_annotation loc))
            | name ->
                return name )
            >>=? fun entrypoint ->
            traced (parse_contract ~legacy ctxt loc ty c ~entrypoint)
            >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
      | None ->
          error () >>=? fail )
  | (Contract_t (ty, _), String (loc, s)) (* As unparsed with [Readable]. *) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.contract)
      >>=? fun ctxt ->
      ( match String.index_opt s '%' with
      | None ->
          return (s, "default")
      | Some pos -> (
          let len = String.length s - pos - 1 in
          let name = String.sub s (pos + 1) len in
          if Compare.Int.(len > 31) then fail (Entrypoint_name_too_long name)
          else
            match (String.sub s 0 pos, name) with
            | (_, "default") ->
                traced (fail (Unexpected_annotation loc))
            | addr_and_name ->
                return addr_and_name ) )
      >>=? fun (addr, entrypoint) ->
      traced (Lwt.return (Contract.of_b58check addr))
      >>=? fun c ->
      parse_contract ~legacy ctxt loc ty c ~entrypoint
      >>=? fun (ctxt, _) -> return ((ty, (c, entrypoint)), ctxt)
  | (Contract_t _, expr) ->
      traced
        (fail
           (Invalid_kind (location expr, [String_kind; Bytes_kind], kind expr)))
  (* Pairs *)
  | (Pair_t ((ta, _, _), (tb, _, _), _, _), Prim (loc, D_Pair, [va; vb], annot))
    ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.pair)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy ta va
      >>=? fun (va, ctxt) ->
      parse_data ?type_logger ctxt ~legacy tb vb
      >>=? fun (vb, ctxt) -> return ((va, vb), ctxt)
  | (Pair_t _, Prim (loc, D_Pair, l, _)) ->
      fail @@ Invalid_arity (loc, D_Pair, 2, List.length l)
  | (Pair_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Pair]))
  (* Unions *)
  | (Union_t ((tl, _), _, _, _), Prim (loc, D_Left, [v], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.union)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy tl v
      >>=? fun (v, ctxt) -> return (L v, ctxt)
  | (Union_t _, Prim (loc, D_Left, l, _)) ->
      fail @@ Invalid_arity (loc, D_Left, 1, List.length l)
  | (Union_t (_, (tr, _), _, _), Prim (loc, D_Right, [v], annot)) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.union)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy tr v
      >>=? fun (v, ctxt) -> return (R v, ctxt)
  | (Union_t _, Prim (loc, D_Right, l, _)) ->
      fail @@ Invalid_arity (loc, D_Right, 1, List.length l)
  | (Union_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Left; D_Right]))
  (* Lambdas *)
  | (Lambda_t (ta, tr, _ty_name), (Seq (_loc, _) as script_instr)) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.lambda)
      >>=? fun ctxt ->
      traced
      @@ parse_returning
           Lambda
           ?type_logger
           ctxt
           ~legacy
           (ta, Some (`Var_annot "@arg"))
           tr
           script_instr
  | (Lambda_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Options *)
  | (Option_t (t, _, _), Prim (loc, D_Some, [v], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.some)
      >>=? fun ctxt ->
      traced @@ parse_data ?type_logger ctxt ~legacy t v
      >>=? fun (v, ctxt) -> return (Some v, ctxt)
  | (Option_t _, Prim (loc, D_Some, l, _)) ->
      fail @@ Invalid_arity (loc, D_Some, 1, List.length l)
  | (Option_t (_, _, _), Prim (loc, D_None, [], annot)) ->
      (if legacy then return () else fail_unexpected_annot loc annot)
      >>=? fun () ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.none)
      >>=? fun ctxt -> return (None, ctxt)
  | (Option_t _, Prim (loc, D_None, l, _)) ->
      fail @@ Invalid_arity (loc, D_None, 0, List.length l)
  | (Option_t _, expr) ->
      traced (fail (unexpected expr [] Constant_namespace [D_Some; D_None]))
  (* Lists *)
  | (List_t (t, _ty_name, _), Seq (_loc, items)) ->
      traced
      @@ fold_right_s
           (fun v (rest, ctxt) ->
             Lwt.return (Gas.consume ctxt Typecheck_costs.list_element)
             >>=? fun ctxt ->
             parse_data ?type_logger ctxt ~legacy t v
             >>=? fun (v, ctxt) -> return (v :: rest, ctxt))
           items
           ([], ctxt)
  | (List_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Sets *)
  | (Set_t (t, _ty_name), (Seq (loc, vs) as expr)) ->
      let length = List.length vs in
      traced
      @@ fold_left_s
           (fun (last_value, set, ctxt) v ->
             Lwt.return (Gas.consume ctxt (Typecheck_costs.set_element length))
             >>=? fun ctxt ->
             parse_comparable_data ?type_logger ctxt t v
             >>=? fun (v, ctxt) ->
             ( match last_value with
             | Some value ->
                 if Compare.Int.(0 <= compare_comparable t value v) then
                   if Compare.Int.(0 = compare_comparable t value v) then
                     fail (Duplicate_set_values (loc, strip_locations expr))
                   else fail (Unordered_set_values (loc, strip_locations expr))
                 else return_unit
             | None ->
                 return_unit )
             >>=? fun () ->
             Lwt.return
               (Gas.consume
                  ctxt
                  (Michelson_v1_gas.Cost_of.Legacy.set_update v false set))
             >>=? fun ctxt -> return (Some v, set_update v true set, ctxt))
           (None, empty_set t, ctxt)
           vs
      >>|? fun (_, set, ctxt) -> (set, ctxt)
  | (Set_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  (* Maps *)
  | (Map_t (tk, tv, _ty_name, _), (Seq (loc, vs) as expr)) ->
      parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> x)
  | (Map_t _, expr) ->
      traced (fail (Invalid_kind (location expr, [Seq_kind], kind expr)))
  | (Big_map_t (tk, tv, _ty_name), (Seq (loc, vs) as expr)) ->
      parse_items ?type_logger loc ctxt expr tk tv vs (fun x -> Some x)
      >>|? fun (diff, ctxt) ->
      ( {id = None; diff; key_type = ty_of_comparable_ty tk; value_type = tv},
        ctxt )
  | (Big_map_t (tk, tv, _ty_name), Int (loc, id)) -> (
      Big_map.exists ctxt id
      >>=? function
      | (_, None) ->
          traced (fail (Invalid_big_map (loc, id)))
      | (ctxt, Some (btk, btv)) ->
          Lwt.return
            ( parse_comparable_ty ctxt (Micheline.root btk)
            >>? fun (Ex_comparable_ty btk, ctxt) ->
            parse_packable_ty ctxt ~legacy (Micheline.root btv)
            >>? fun (Ex_ty btv, ctxt) ->
            comparable_ty_eq ctxt tk btk
            >>? fun Eq ->
            ty_eq ctxt tv btv
            >>? fun (Eq, ctxt) ->
            ok
              ( {
                  id = Some id;
                  diff = empty_map tk;
                  key_type = ty_of_comparable_ty tk;
                  value_type = tv;
                },
                ctxt ) ) )
  | (Big_map_t (_tk, _tv, _), expr) ->
      traced
        (fail (Invalid_kind (location expr, [Seq_kind; Int_kind], kind expr)))

and parse_comparable_data :
    type a.
    ?type_logger:type_logger ->
    context ->
    a comparable_ty ->
    Script.node ->
    (a * context) tzresult Lwt.t =
 fun ?type_logger ctxt ty script_data ->
  parse_data
    ?type_logger
    ctxt
    ~legacy:false
    (ty_of_comparable_ty ty)
    script_data

and parse_returning :
    type arg ret.
    ?type_logger:type_logger ->
    tc_context ->
    context ->
    legacy:bool ->
    arg ty * var_annot option ->
    ret ty ->
    Script.node ->
    ((arg, ret) lambda * context) tzresult Lwt.t =
 fun ?type_logger tc_context ctxt ~legacy (arg, arg_annot) ret script_instr ->
  parse_instr
    ?type_logger
    tc_context
    ctxt
    ~legacy
    script_instr
    (Item_t (arg, Empty_t, arg_annot))
  >>=? function
  | (Typed ({loc; aft = Item_t (ty, Empty_t, _) as stack_ty; _} as descr), ctxt)
    ->
      trace_eval
        (fun () ->
          Lwt.return (serialize_ty_for_error ctxt ret)
          >>=? fun (ret, ctxt) ->
          serialize_stack_for_error ctxt stack_ty
          >>|? fun (stack_ty, _ctxt) -> Bad_return (loc, stack_ty, ret))
        ( Lwt.return (ty_eq ctxt ty ret)
        >>=? fun (Eq, ctxt) ->
        Lwt.return (merge_types ~legacy ctxt loc ty ret)
        >>=? fun (_ret, ctxt) ->
        return ((Lam (descr, script_instr) : (arg, ret) lambda), ctxt) )
  | (Typed {loc; aft = stack_ty; _}, ctxt) ->
      Lwt.return (serialize_ty_for_error ctxt ret)
      >>=? fun (ret, ctxt) ->
      serialize_stack_for_error ctxt stack_ty
      >>=? fun (stack_ty, _ctxt) -> fail (Bad_return (loc, stack_ty, ret))
  | (Failed {descr}, ctxt) ->
      return
        ( ( Lam (descr (Item_t (ret, Empty_t, None)), script_instr)
            : (arg, ret) lambda ),
          ctxt )

and parse_int32 (n : (location, prim) Micheline.node) : int tzresult =
  let error' () =
    Invalid_syntactic_constant
      ( location n,
        strip_locations n,
        "a positive 32-bit integer (between 0 and "
        ^ Int32.to_string Int32.max_int
        ^ ")" )
  in
  match n with
  | Micheline.Int (_, n') -> (
    try
      let n'' = Z.to_int n' in
      if
        Compare.Int.(0 <= n'')
        && Compare.Int.(n'' <= Int32.to_int Int32.max_int)
      then ok n''
      else error @@ error' ()
    with _ -> error @@ error' () )
  | _ ->
      error @@ error' ()

and parse_instr :
    type bef.
    ?type_logger:type_logger ->
    tc_context ->
    context ->
    legacy:bool ->
    Script.node ->
    bef stack_ty ->
    (bef judgement * context) tzresult Lwt.t =
 fun ?type_logger tc_context ctxt ~legacy script_instr stack_ty ->
  let _check_item check loc name n m =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n) @@ Lwt.return check
  in
  let check_item_ty (type a b) ctxt (exp : a ty) (got : b ty) loc name n m :
      ((a, b) eq * a ty * context) tzresult Lwt.t =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n)
    @@ Lwt.return
         ( ty_eq ctxt exp got
         >>? fun (Eq, ctxt) ->
         merge_types ~legacy ctxt loc exp got
         >>? fun (ty, ctxt) -> ok ((Eq : (a, b) eq), (ty : a ty), ctxt) )
  in
  let check_item_comparable_ty (type a b) (exp : a comparable_ty)
      (got : b comparable_ty) loc name n m :
      ((a, b) eq * a comparable_ty) tzresult Lwt.t =
    trace_eval (fun () ->
        serialize_stack_for_error ctxt stack_ty
        >>|? fun (stack_ty, _ctxt) -> Bad_stack (loc, name, m, stack_ty))
    @@ trace (Bad_stack_item n)
    @@ Lwt.return
         ( comparable_ty_eq ctxt exp got
         >>? fun Eq ->
         merge_comparable_types ~legacy exp got
         >>? fun ty -> ok ((Eq : (a, b) eq), (ty : a comparable_ty)) )
  in
  let log_stack ctxt loc stack_ty aft =
    match (type_logger, script_instr) with
    | (None, _) | (Some _, (Seq (-1, _) | Int _ | String _ | Bytes _)) ->
        return_unit
    | (Some log, (Prim _ | Seq _)) ->
        (* Unparsing for logging done in an unlimited context as this
             is used only by the client and not the protocol *)
        let ctxt = Gas.set_unlimited ctxt in
        unparse_stack ctxt stack_ty
        >>=? fun (stack_ty, _) ->
        unparse_stack ctxt aft
        >>=? fun (aft, _) -> log loc stack_ty aft ; return_unit
  in
  let outer_return = return in
  let return :
      type bef.
      context -> bef judgement -> (bef judgement * context) tzresult Lwt.t =
   fun ctxt judgement ->
    match judgement with
    | Typed {instr; loc; aft; _} ->
        let maximum_type_size = Constants.michelson_maximum_type_size ctxt in
        let type_size =
          type_size_of_stack_head
            aft
            ~up_to:(number_of_generated_growing_types instr)
        in
        if Compare.Int.(type_size > maximum_type_size) then
          fail (Type_too_large (loc, type_size, maximum_type_size))
        else return (judgement, ctxt)
    | Failed _ ->
        return (judgement, ctxt)
  in
  let typed ctxt loc instr aft =
    log_stack ctxt loc stack_ty aft
    >>=? fun () ->
    Lwt.return @@ Gas.consume ctxt (Typecheck_costs.instr instr)
    >>=? fun ctxt -> return ctxt (Typed {loc; instr; bef = stack_ty; aft})
  in
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.cycle
  >>=? fun ctxt ->
  match (script_instr, stack_ty) with
  (* stack ops *)
  | (Prim (loc, I_DROP, [], annot), Item_t (_, rest, _)) ->
      ( fail_unexpected_annot loc annot >>=? fun () -> typed ctxt loc Drop rest
        : (bef judgement * context) tzresult Lwt.t )
  | (Prim (loc, I_DROP, [n], result_annot), whole_stack) ->
      Lwt.return (parse_int32 n)
      >>=? fun whole_n ->
      let rec make_proof_argument :
          type tstk.
          int -> tstk stack_ty -> tstk dropn_proof_argument tzresult Lwt.t =
       fun n stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) ->
            outer_return @@ Dropn_proof_argument (Rest, rest, rest)
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) rest
            >>=? fun (Dropn_proof_argument (n', stack_after_drops, aft')) ->
            outer_return
            @@ Dropn_proof_argument
                 (Prefix n', stack_after_drops, Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt whole_stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DROP, whole_n, whole_stack))
      in
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument whole_n whole_stack
      >>=? fun (Dropn_proof_argument (n', stack_after_drops, _aft)) ->
      typed ctxt loc (Dropn (whole_n, n')) stack_after_drops
  | (Prim (loc, I_DROP, (_ :: _ :: _ as l), _), _) ->
      (* Technically, the arities 0 and 1 are allowed but the error only mentions 1.
           However, DROP is equivalent to DROP 1 so hinting at an arity of 1 makes sense. *)
      fail (Invalid_arity (loc, I_DROP, 1, List.length l))
  | (Prim (loc, I_DUP, [], annot), Item_t (v, rest, stack_annot)) ->
      parse_var_annot loc annot ~default:stack_annot
      >>=? fun annot ->
      typed ctxt loc Dup (Item_t (v, Item_t (v, rest, stack_annot), annot))
  | (Prim (loc, I_DIG, [n], result_annot), stack) ->
      let rec make_proof_argument :
          type tstk.
          int -> tstk stack_ty -> tstk dig_proof_argument tzresult Lwt.t =
       fun n stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, Item_t (v, rest, annot)) ->
            outer_return @@ Dig_proof_argument (Rest, (v, annot), rest)
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) rest
            >>=? fun (Dig_proof_argument (n', (x, xv), aft')) ->
            outer_return
            @@ Dig_proof_argument (Prefix n', (x, xv), Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DIG, 1, whole_stack))
      in
      Lwt.return (parse_int32 n)
      >>=? fun n ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument n stack
      >>=? fun (Dig_proof_argument (n', (x, stack_annot), aft)) ->
      typed ctxt loc (Dig (n, n')) (Item_t (x, aft, stack_annot))
  | (Prim (loc, I_DIG, (([] | _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_DIG, 1, List.length l))
  | (Prim (loc, I_DUG, [n], result_annot), Item_t (x, whole_stack, stack_annot))
    ->
      Lwt.return (parse_int32 n)
      >>=? fun whole_n ->
      let rec make_proof_argument :
          type tstk x.
          int ->
          x ty ->
          var_annot option ->
          tstk stack_ty ->
          (tstk, x) dug_proof_argument tzresult Lwt.t =
       fun n x stack_annot stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) ->
            outer_return
            @@ Dug_proof_argument (Rest, (), Item_t (x, rest, stack_annot))
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) x stack_annot rest
            >>=? fun (Dug_proof_argument (n', (), aft')) ->
            outer_return
            @@ Dug_proof_argument (Prefix n', (), Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt whole_stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DUG, whole_n, whole_stack))
      in
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument whole_n x stack_annot whole_stack
      >>=? fun (Dug_proof_argument (n', (), aft)) ->
      typed ctxt loc (Dug (whole_n, n')) aft
  | (Prim (loc, I_DUG, [_], result_annot), (Empty_t as stack)) ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, I_DUG, 1, stack))
  | (Prim (loc, I_DUG, (([] | _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_DUG, 1, List.length l))
  | ( Prim (loc, I_SWAP, [], annot),
      Item_t (v, Item_t (w, rest, stack_annot), cur_top_annot) ) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      typed
        ctxt
        loc
        Swap
        (Item_t (w, Item_t (v, rest, cur_top_annot), stack_annot))
  | (Prim (loc, I_PUSH, [t; d], annot), stack) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_data ?type_logger ctxt ~legacy t d
      >>=? fun (v, ctxt) -> typed ctxt loc (Const v) (Item_t (t, stack, annot))
  | (Prim (loc, I_UNIT, [], annot), stack) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed ctxt loc (Const ()) (Item_t (Unit_t ty_name, stack, annot))
  (* options *)
  | (Prim (loc, I_SOME, [], annot), Item_t (t, rest, _)) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        Cons_some
        (Item_t (Option_t (t, ty_name, has_big_map t), rest, annot))
  | (Prim (loc, I_NONE, [t], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Cons_none t)
        (Item_t (Option_t (t, ty_name, has_big_map t), stack, annot))
  | ( Prim (loc, I_IF_NONE, [bt; bf], annot),
      (Item_t (Option_t (t, _, _), rest, option_annot) as bef) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let annot = gen_access_annot option_annot default_some_annot in
      parse_instr ?type_logger tc_context ctxt ~legacy bt rest
      >>=? fun (btr, ctxt) ->
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bf
        (Item_t (t, rest, annot))
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_none (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  (* pairs *)
  | ( Prim (loc, I_PAIR, [], annot),
      Item_t (a, Item_t (b, rest, snd_annot), fst_annot) ) ->
      parse_constr_annot
        loc
        annot
        ~if_special_first:(var_to_field_annot fst_annot)
        ~if_special_second:(var_to_field_annot snd_annot)
      >>=? fun (annot, ty_name, l_field, r_field) ->
      typed
        ctxt
        loc
        Cons_pair
        (Item_t
           ( Pair_t
               ( (a, l_field, fst_annot),
                 (b, r_field, snd_annot),
                 ty_name,
                 has_big_map a || has_big_map b ),
             rest,
             annot ))
  | ( Prim (loc, I_CAR, [], annot),
      Item_t
        (Pair_t ((a, expected_field_annot, a_annot), _, _, _), rest, pair_annot)
    ) ->
      parse_destr_annot
        loc
        annot
        ~pair_annot
        ~value_annot:a_annot
        ~field_name:expected_field_annot
        ~default_accessor:default_car_annot
      >>=? fun (annot, field_annot) ->
      Lwt.return @@ check_correct_field field_annot expected_field_annot
      >>=? fun () -> typed ctxt loc Car (Item_t (a, rest, annot))
  | ( Prim (loc, I_CDR, [], annot),
      Item_t
        (Pair_t (_, (b, expected_field_annot, b_annot), _, _), rest, pair_annot)
    ) ->
      parse_destr_annot
        loc
        annot
        ~pair_annot
        ~value_annot:b_annot
        ~field_name:expected_field_annot
        ~default_accessor:default_cdr_annot
      >>=? fun (annot, field_annot) ->
      Lwt.return @@ check_correct_field field_annot expected_field_annot
      >>=? fun () -> typed ctxt loc Cdr (Item_t (b, rest, annot))
  (* unions *)
  | (Prim (loc, I_LEFT, [tr], annot), Item_t (tl, rest, stack_annot)) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tr
      >>=? fun (Ex_ty tr, ctxt) ->
      parse_constr_annot
        loc
        annot
        ~if_special_first:(var_to_field_annot stack_annot)
      >>=? fun (annot, tname, l_field, r_field) ->
      typed
        ctxt
        loc
        Left
        (Item_t
           ( Union_t
               ( (tl, l_field),
                 (tr, r_field),
                 tname,
                 has_big_map tl || has_big_map tr ),
             rest,
             annot ))
  | (Prim (loc, I_RIGHT, [tl], annot), Item_t (tr, rest, stack_annot)) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tl
      >>=? fun (Ex_ty tl, ctxt) ->
      parse_constr_annot
        loc
        annot
        ~if_special_second:(var_to_field_annot stack_annot)
      >>=? fun (annot, tname, l_field, r_field) ->
      typed
        ctxt
        loc
        Right
        (Item_t
           ( Union_t
               ( (tl, l_field),
                 (tr, r_field),
                 tname,
                 has_big_map tl || has_big_map tr ),
             rest,
             annot ))
  | ( Prim (loc, I_IF_LEFT, [bt; bf], annot),
      ( Item_t (Union_t ((tl, l_field), (tr, r_field), _, _), rest, union_annot)
      as bef ) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let left_annot =
        gen_access_annot union_annot l_field ~default:default_left_annot
      in
      let right_annot =
        gen_access_annot union_annot r_field ~default:default_right_annot
      in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bt
        (Item_t (tl, rest, left_annot))
      >>=? fun (btr, ctxt) ->
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bf
        (Item_t (tr, rest, right_annot))
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_left (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  (* lists *)
  | (Prim (loc, I_NIL, [t], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy t
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        Nil
        (Item_t (List_t (t, ty_name, has_big_map t), stack, annot))
  | ( Prim (loc, I_CONS, [], annot),
      Item_t (tv, Item_t (List_t (t, ty_name, has_big_map), rest, _), _) ) ->
      check_item_ty ctxt tv t loc I_CONS 1 2
      >>=? fun (Eq, t, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Cons_list
        (Item_t (List_t (t, ty_name, has_big_map), rest, annot))
  | ( Prim (loc, I_IF_CONS, [bt; bf], annot),
      (Item_t (List_t (t, ty_name, has_big_map), rest, list_annot) as bef) ) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let hd_annot = gen_access_annot list_annot default_hd_annot in
      let tl_annot = gen_access_annot list_annot default_tl_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        bt
        (Item_t
           ( t,
             Item_t (List_t (t, ty_name, has_big_map), rest, tl_annot),
             hd_annot ))
      >>=? fun (btr, ctxt) ->
      parse_instr ?type_logger tc_context ctxt ~legacy bf rest
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf =
        {loc; instr = If_cons (ibt, ibf); bef; aft = ibt.aft}
      in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  | (Prim (loc, I_SIZE, [], annot), Item_t (List_t _, rest, _)) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      typed ctxt loc List_size (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_MAP, [body], annot),
      Item_t (List_t (elt, _, _), starting_rest, list_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_type_annot loc annot
      >>=? fun (ret_annot, list_ty_name) ->
      let elt_annot = gen_access_annot list_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, starting_rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
          let invalid_map_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
          in
          trace_eval
            invalid_map_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
            >>=? fun (rest, ctxt) ->
            typed
              ctxt
              loc
              (List_map ibody)
              (Item_t
                 (List_t (ret, list_ty_name, has_big_map ret), rest, ret_annot))
            )
      | Typed {aft; _} ->
          serialize_stack_for_error ctxt aft
          >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
      | Failed _ ->
          fail (Invalid_map_block_fail loc) )
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (List_t (elt, _, _), rest, list_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let elt_annot = gen_access_annot list_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (List_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (List_iter (descr rest)) rest )
  (* sets *)
  | (Prim (loc, I_EMPTY_SET, [t], annot), rest) ->
      Lwt.return @@ parse_comparable_ty ctxt t
      >>=? fun (Ex_comparable_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      typed ctxt loc (Empty_set t) (Item_t (Set_t (t, tname), rest, annot))
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (Set_t (comp_elt, _), rest, set_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let elt_annot = gen_access_annot set_annot default_elt_annot in
      let elt = ty_of_comparable_ty comp_elt in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (elt, rest, elt_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (Set_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (Set_iter (descr rest)) rest )
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (v, Item_t (Set_t (elt, _), rest, _), _) ) ->
      let elt = ty_of_comparable_ty elt in
      parse_var_type_annot loc annot
      >>=? fun (annot, tname) ->
      check_item_ty ctxt elt v loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      typed ctxt loc Set_mem (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( v,
          Item_t (Bool_t _, Item_t (Set_t (elt, tname), rest, set_annot), _),
          _ ) ) -> (
    match comparable_ty_of_ty v with
    | None ->
        unparse_ty ctxt v
        >>=? fun (v, _ctxt) ->
        fail (Comparable_type_expected (loc, Micheline.strip_locations v))
    | Some v ->
        parse_var_annot loc annot ~default:set_annot
        >>=? fun annot ->
        check_item_comparable_ty elt v loc I_UPDATE 1 3
        >>=? fun (Eq, elt) ->
        typed ctxt loc Set_update (Item_t (Set_t (elt, tname), rest, annot)) )
  | (Prim (loc, I_SIZE, [], annot), Item_t (Set_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Set_size (Item_t (Nat_t None, rest, annot))
  (* maps *)
  | (Prim (loc, I_EMPTY_MAP, [tk; tv], annot), stack) ->
      Lwt.return @@ parse_comparable_ty ctxt tk
      >>=? fun (Ex_comparable_ty tk, ctxt) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy tv
      >>=? fun (Ex_ty tv, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Empty_map (tk, tv))
        (Item_t (Map_t (tk, tv, ty_name, has_big_map tv), stack, annot))
  | ( Prim (loc, I_MAP, [body], annot),
      Item_t (Map_t (ck, elt, _, _), starting_rest, _map_annot) ) -> (
      let k = ty_of_comparable_ty ck in
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_type_annot loc annot
      >>=? fun (ret_annot, ty_name) ->
      let k_name = field_to_var_annot default_key_annot in
      let e_name = field_to_var_annot default_elt_annot in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t
           ( Pair_t
               ((k, None, k_name), (elt, None, e_name), None, has_big_map elt),
             starting_rest,
             None ))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft = Item_t (ret, rest, _); _} as ibody) ->
          let invalid_map_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>|? fun (aft, _ctxt) -> Invalid_map_body (loc, aft)
          in
          trace_eval
            invalid_map_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 rest starting_rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt rest starting_rest
            >>=? fun (rest, ctxt) ->
            typed
              ctxt
              loc
              (Map_map ibody)
              (Item_t
                 (Map_t (ck, ret, ty_name, has_big_map ret), rest, ret_annot))
            )
      | Typed {aft; _} ->
          serialize_stack_for_error ctxt aft
          >>=? fun (aft, _ctxt) -> fail (Invalid_map_body (loc, aft))
      | Failed _ ->
          fail (Invalid_map_block_fail loc) )
  | ( Prim (loc, I_ITER, [body], annot),
      Item_t (Map_t (comp_elt, element_ty, _, _), rest, _map_annot) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let k_name = field_to_var_annot default_key_annot in
      let e_name = field_to_var_annot default_elt_annot in
      let key = ty_of_comparable_ty comp_elt in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t
           ( Pair_t
               ( (key, None, k_name),
                 (element_ty, None, e_name),
                 None,
                 has_big_map element_ty ),
             rest,
             None ))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as ibody) ->
          let invalid_iter_body () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt rest
            >>|? fun (rest, _ctxt) -> Invalid_iter_body (loc, rest, aft)
          in
          trace_eval
            invalid_iter_body
            ( Lwt.return @@ stack_ty_eq ctxt 1 aft rest
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt aft rest
            >>=? fun (rest, ctxt) -> typed ctxt loc (Map_iter ibody) rest )
      | Failed {descr} ->
          typed ctxt loc (Map_iter (descr rest)) rest )
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (vk, Item_t (Map_t (ck, _, _, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Map_mem (Item_t (Bool_t None, rest, annot))
  | ( Prim (loc, I_GET, [], annot),
      Item_t (vk, Item_t (Map_t (ck, elt, _, has_big_map), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_GET 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Map_get
        (Item_t (Option_t (elt, None, has_big_map), rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( vk,
          Item_t
            ( Option_t (vv, _, _),
              Item_t (Map_t (ck, v, map_name, has_big_map), rest, map_annot),
              _ ),
          _ ) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_UPDATE 1 3
      >>=? fun (Eq, _, ctxt) ->
      check_item_ty ctxt vv v loc I_UPDATE 2 3
      >>=? fun (Eq, v, ctxt) ->
      parse_var_annot loc annot ~default:map_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Map_update
        (Item_t (Map_t (ck, v, map_name, has_big_map), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (Map_t (_, _, _, _), rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Map_size (Item_t (Nat_t None, rest, annot))
  (* big_map *)
  | (Prim (loc, I_EMPTY_BIG_MAP, [tk; tv], annot), stack) ->
      Lwt.return @@ parse_comparable_ty ctxt tk
      >>=? fun (Ex_comparable_ty tk, ctxt) ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy tv
      >>=? fun (Ex_ty tv, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      typed
        ctxt
        loc
        (Empty_big_map (tk, tv))
        (Item_t (Big_map_t (tk, tv, ty_name), stack, annot))
  | ( Prim (loc, I_MEM, [], annot),
      Item_t (set_key, Item_t (Big_map_t (map_key, _, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty map_key in
      check_item_ty ctxt set_key k loc I_MEM 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Big_map_mem (Item_t (Bool_t None, rest, annot))
  | ( Prim (loc, I_GET, [], annot),
      Item_t (vk, Item_t (Big_map_t (ck, elt, _), rest, _), _) ) ->
      let k = ty_of_comparable_ty ck in
      check_item_ty ctxt vk k loc I_GET 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Big_map_get
        (Item_t (Option_t (elt, None, has_big_map elt), rest, annot))
  | ( Prim (loc, I_UPDATE, [], annot),
      Item_t
        ( set_key,
          Item_t
            ( Option_t (set_value, _, _),
              Item_t (Big_map_t (map_key, map_value, map_name), rest, map_annot),
              _ ),
          _ ) ) ->
      let k = ty_of_comparable_ty map_key in
      check_item_ty ctxt set_key k loc I_UPDATE 1 3
      >>=? fun (Eq, _, ctxt) ->
      check_item_ty ctxt set_value map_value loc I_UPDATE 2 3
      >>=? fun (Eq, map_value, ctxt) ->
      parse_var_annot loc annot ~default:map_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Big_map_update
        (Item_t (Big_map_t (map_key, map_value, map_name), rest, annot))
  (* control *)
  | (Seq (loc, []), stack) ->
      typed ctxt loc Nop stack
  | (Seq (loc, [single]), stack) -> (
      parse_instr ?type_logger tc_context ctxt ~legacy single stack
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ({aft; _} as instr) ->
          let nop = {bef = aft; loc; aft; instr = Nop} in
          typed ctxt loc (Seq (instr, nop)) aft
      | Failed {descr; _} ->
          let descr aft =
            let nop = {bef = aft; loc; aft; instr = Nop} in
            let descr = descr aft in
            {descr with instr = Seq (descr, nop)}
          in
          return ctxt (Failed {descr}) )
  | (Seq (loc, hd :: tl), stack) -> (
      parse_instr ?type_logger tc_context ctxt ~legacy hd stack
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Failed _ ->
          fail (Fail_not_in_tail_position (Micheline.location hd))
      | Typed ({aft = middle; _} as ihd) -> (
          parse_instr
            ?type_logger
            tc_context
            ctxt
            ~legacy
            (Seq (-1, tl))
            middle
          >>=? fun (judgement, ctxt) ->
          match judgement with
          | Failed {descr} ->
              let descr ret =
                {loc; instr = Seq (ihd, descr ret); bef = stack; aft = ret}
              in
              return ctxt (Failed {descr})
          | Typed itl ->
              typed ctxt loc (Seq (ihd, itl)) itl.aft ) )
  | (Prim (loc, I_IF, [bt; bf], annot), (Item_t (Bool_t _, rest, _) as bef)) ->
      check_kind [Seq_kind] bt
      >>=? fun () ->
      check_kind [Seq_kind] bf
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      parse_instr ?type_logger tc_context ctxt ~legacy bt rest
      >>=? fun (btr, ctxt) ->
      parse_instr ?type_logger tc_context ctxt ~legacy bf rest
      >>=? fun (bfr, ctxt) ->
      let branch ibt ibf = {loc; instr = If (ibt, ibf); bef; aft = ibt.aft} in
      merge_branches ~legacy ctxt loc btr bfr {branch}
      >>=? fun (judgement, ctxt) -> return ctxt judgement
  | ( Prim (loc, I_LOOP, [body], annot),
      (Item_t (Bool_t _, rest, _stack_annot) as stack) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      parse_instr ?type_logger tc_context ctxt ~legacy body rest
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ibody ->
          let unmatched_branches () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt stack
            >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
          in
          trace_eval
            unmatched_branches
            ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
            >>=? fun (_stack, ctxt) -> typed ctxt loc (Loop ibody) rest )
      | Failed {descr} ->
          let ibody = descr stack in
          typed ctxt loc (Loop ibody) rest )
  | ( Prim (loc, I_LOOP_LEFT, [body], annot),
      ( Item_t (Union_t ((tl, l_field), (tr, _), _, _), rest, union_annot) as
      stack ) ) -> (
      check_kind [Seq_kind] body
      >>=? fun () ->
      parse_var_annot loc annot
      >>=? fun annot ->
      let l_annot =
        gen_access_annot union_annot l_field ~default:default_left_annot
      in
      parse_instr
        ?type_logger
        tc_context
        ctxt
        ~legacy
        body
        (Item_t (tl, rest, l_annot))
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed ibody ->
          let unmatched_branches () =
            serialize_stack_for_error ctxt ibody.aft
            >>=? fun (aft, ctxt) ->
            serialize_stack_for_error ctxt stack
            >>|? fun (stack, _ctxt) -> Unmatched_branches (loc, aft, stack)
          in
          trace_eval
            unmatched_branches
            ( Lwt.return @@ stack_ty_eq ctxt 1 ibody.aft stack
            >>=? fun (Eq, ctxt) ->
            Lwt.return @@ merge_stacks ~legacy loc ctxt ibody.aft stack
            >>=? fun (_stack, ctxt) ->
            typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
      | Failed {descr} ->
          let ibody = descr stack in
          typed ctxt loc (Loop_left ibody) (Item_t (tr, rest, annot)) )
  | (Prim (loc, I_LAMBDA, [arg; ret; code], annot), stack) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy arg
      >>=? fun (Ex_ty arg, ctxt) ->
      Lwt.return @@ parse_any_ty ctxt ~legacy ret
      >>=? fun (Ex_ty ret, ctxt) ->
      check_kind [Seq_kind] code
      >>=? fun () ->
      parse_var_annot loc annot
      >>=? fun annot ->
      parse_returning
        Lambda
        ?type_logger
        ctxt
        ~legacy
        (arg, default_arg_annot)
        ret
        code
      >>=? fun (lambda, ctxt) ->
      typed
        ctxt
        loc
        (Lambda lambda)
        (Item_t (Lambda_t (arg, ret, None), stack, annot))
  | ( Prim (loc, I_EXEC, [], annot),
      Item_t (arg, Item_t (Lambda_t (param, ret, _), rest, _), _) ) ->
      check_item_ty ctxt arg param loc I_EXEC 1 2
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Exec (Item_t (ret, rest, annot))
  | ( Prim (loc, I_APPLY, [], annot),
      Item_t
        ( capture,
          Item_t
            ( Lambda_t
                ( Pair_t ((capture_ty, _, _), (arg_ty, _, _), lam_annot, _),
                  ret,
                  _ ),
              rest,
              _ ),
          _ ) ) ->
      Lwt.return @@ check_packable ~legacy:false loc capture_ty
      >>=? fun () ->
      check_item_ty ctxt capture capture_ty loc I_APPLY 1 2
      >>=? fun (Eq, capture_ty, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        (Apply capture_ty)
        (Item_t (Lambda_t (arg_ty, ret, lam_annot), rest, annot))
  | (Prim (loc, I_DIP, [code], annot), Item_t (v, rest, stack_annot)) -> (
      fail_unexpected_annot loc annot
      >>=? fun () ->
      check_kind [Seq_kind] code
      >>=? fun () ->
      parse_instr
        ?type_logger
        (add_dip v stack_annot tc_context)
        ctxt
        ~legacy
        code
        rest
      >>=? fun (judgement, ctxt) ->
      match judgement with
      | Typed descr ->
          typed ctxt loc (Dip descr) (Item_t (v, descr.aft, stack_annot))
      | Failed _ ->
          fail (Fail_not_in_tail_position loc) )
  | (Prim (loc, I_DIP, [n; code], result_annot), stack)
    when match parse_int32 n with Ok _ -> true | Error _ -> false ->
      let rec make_proof_argument :
          type tstk.
          int
          (* -> (fbef stack_ty -> (fbef judgement * context) tzresult Lwt.t) *) ->
          tc_context ->
          tstk stack_ty ->
          tstk dipn_proof_argument tzresult Lwt.t =
       fun n inner_tc_context stk ->
        match (Compare.Int.(n = 0), stk) with
        | (true, rest) -> (
            parse_instr ?type_logger inner_tc_context ctxt ~legacy code rest
            >>=? fun (judgement, ctxt) ->
            match judgement with
            | Typed descr ->
                outer_return
                @@ Dipn_proof_argument (Rest, (ctxt, descr), descr.aft)
            | Failed _ ->
                fail (Fail_not_in_tail_position loc) )
        | (false, Item_t (v, rest, annot)) ->
            make_proof_argument (n - 1) (add_dip v annot tc_context) rest
            >>=? fun (Dipn_proof_argument (n', descr, aft')) ->
            outer_return
            @@ Dipn_proof_argument (Prefix n', descr, Item_t (v, aft', annot))
        | (_, _) ->
            serialize_stack_for_error ctxt stack
            >>=? fun (whole_stack, _ctxt) ->
            fail (Bad_stack (loc, I_DIP, 1, whole_stack))
      in
      Lwt.return (parse_int32 n)
      >>=? fun n ->
      fail_unexpected_annot loc result_annot
      >>=? fun () ->
      make_proof_argument n tc_context stack
      >>=? fun (Dipn_proof_argument (n', (new_ctxt, descr), aft)) ->
      (* TODO: which context should be used in the next line? new_ctxt or the old ctxt? *)
      typed new_ctxt loc (Dipn (n, n', descr)) aft
  | (Prim (loc, I_DIP, (([] | _ :: _ :: _ :: _) as l), _), _) ->
      (* Technically, the arities 1 and 2 are allowed but the error only mentions 2.
           However, DIP {code} is equivalent to DIP 1 {code} so hinting at an arity of 2 makes sense. *)
      fail (Invalid_arity (loc, I_DIP, 2, List.length l))
  | (Prim (loc, I_FAILWITH, [], annot), Item_t (v, _rest, _)) ->
      fail_unexpected_annot loc annot
      >>=? fun () ->
      let descr aft = {loc; instr = Failwith v; bef = stack_ty; aft} in
      log_stack ctxt loc stack_ty Empty_t
      >>=? fun () -> return ctxt (Failed {descr})
  (* timestamp operations *)
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Add_timestamp_to_seconds
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t _, Item_t (Timestamp_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Add_seconds_to_timestamp
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Timestamp_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Sub_timestamp_seconds
        (Item_t (Timestamp_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Timestamp_t tn1, Item_t (Timestamp_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Diff_timestamps (Item_t (Int_t tname, rest, annot))
  (* string operations *)
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (String_t tn1, Item_t (String_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Concat_string_pair (Item_t (String_t tname, rest, annot))
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (List_t (String_t tname, _, _), rest, list_annot) ) ->
      parse_var_annot ~default:list_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Concat_string (Item_t (String_t tname, rest, annot))
  | ( Prim (loc, I_SLICE, [], annot),
      Item_t
        ( Nat_t _,
          Item_t (Nat_t _, Item_t (String_t tname, rest, string_annot), _),
          _ ) ) ->
      parse_var_annot
        ~default:(gen_access_annot string_annot default_slice_annot)
        loc
        annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Slice_string
        (Item_t (Option_t (String_t tname, None, false), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (String_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc String_size (Item_t (Nat_t None, rest, annot))
  (* bytes operations *)
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (Bytes_t tn1, Item_t (Bytes_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Concat_bytes_pair (Item_t (Bytes_t tname, rest, annot))
  | ( Prim (loc, I_CONCAT, [], annot),
      Item_t (List_t (Bytes_t tname, _, _), rest, list_annot) ) ->
      parse_var_annot ~default:list_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Concat_bytes (Item_t (Bytes_t tname, rest, annot))
  | ( Prim (loc, I_SLICE, [], annot),
      Item_t
        ( Nat_t _,
          Item_t (Nat_t _, Item_t (Bytes_t tname, rest, bytes_annot), _),
          _ ) ) ->
      parse_var_annot
        ~default:(gen_access_annot bytes_annot default_slice_annot)
        loc
        annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Slice_bytes
        (Item_t (Option_t (Bytes_t tname, None, false), rest, annot))
  | (Prim (loc, I_SIZE, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Bytes_size (Item_t (Nat_t None, rest, annot))
  (* currency operations *)
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_tez (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Sub_tez (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      (* no type name check *)
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_teznat (Item_t (Mutez_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t _, Item_t (Mutez_t tname, rest, _), _) ) ->
      (* no type name check *)
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_nattez (Item_t (Mutez_t tname, rest, annot))
  (* boolean operations *)
  | ( Prim (loc, I_OR, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc Or (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc And (Item_t (Bool_t tname, rest, annot))
  | ( Prim (loc, I_XOR, [], annot),
      Item_t (Bool_t tn1, Item_t (Bool_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname -> typed ctxt loc Xor (Item_t (Bool_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Bool_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Not (Item_t (Bool_t tname, rest, annot))
  (* integer operations *)
  | (Prim (loc, I_ABS, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Abs_int (Item_t (Nat_t None, rest, annot))
  | (Prim (loc, I_ISNAT, [], annot), Item_t (Int_t _, rest, int_annot)) ->
      parse_var_annot loc annot ~default:int_annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Is_nat
        (Item_t (Option_t (Nat_t None, None, false), rest, annot))
  | (Prim (loc, I_INT, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Int_nat (Item_t (Int_t None, rest, annot))
  | (Prim (loc, I_NEG, [], annot), Item_t (Int_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Neg_int (Item_t (Int_t tname, rest, annot))
  | (Prim (loc, I_NEG, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Neg_nat (Item_t (Int_t None, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_intint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Add_intnat (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Add_natint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_ADD, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Add_natnat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sub_int (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_SUB, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun _tname ->
      typed ctxt loc Sub_int (Item_t (Int_t None, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Mul_intint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_intnat (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t _, Item_t (Int_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Mul_natint (Item_t (Int_t tname, rest, annot))
  | ( Prim (loc, I_MUL, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Mul_natnat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Mutez_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_teznat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Mutez_t tname, None, None),
                     (Mutez_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Mutez_t tn1, Item_t (Mutez_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_tez
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Nat_t None, None, None),
                     (Mutez_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Int_t tn1, Item_t (Int_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_intint
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t tname, None, None),
                     (Nat_t None, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Int_t tname, Item_t (Nat_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_intnat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t tname, None, None),
                     (Nat_t None, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Nat_t tname, Item_t (Int_t _, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Ediv_natint
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Int_t None, None, None),
                     (Nat_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_EDIV, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed
        ctxt
        loc
        Ediv_natnat
        (Item_t
           ( Option_t
               ( Pair_t
                   ( (Nat_t tname, None, None),
                     (Nat_t tname, None, None),
                     None,
                     false ),
                 None,
                 false ),
             rest,
             annot ))
  | ( Prim (loc, I_LSL, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Lsl_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_LSR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Lsr_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_OR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Or_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc And_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_AND, [], annot),
      Item_t (Int_t _, Item_t (Nat_t tname, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc And_int_nat (Item_t (Nat_t tname, rest, annot))
  | ( Prim (loc, I_XOR, [], annot),
      Item_t (Nat_t tn1, Item_t (Nat_t tn2, rest, _), _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      Lwt.return @@ merge_type_annot ~legacy tn1 tn2
      >>=? fun tname ->
      typed ctxt loc Xor_nat (Item_t (Nat_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Int_t tname, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Not_int (Item_t (Int_t tname, rest, annot))
  | (Prim (loc, I_NOT, [], annot), Item_t (Nat_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Not_nat (Item_t (Int_t None, rest, annot))
  (* comparison *)
  | (Prim (loc, I_COMPARE, [], annot), Item_t (t1, Item_t (t2, rest, _), _))
    -> (
      parse_var_annot loc annot
      >>=? fun annot ->
      check_item_ty ctxt t1 t2 loc I_COMPARE 1 2
      >>=? fun (Eq, t, ctxt) ->
      match comparable_ty_of_ty t with
      | None ->
          Lwt.return (serialize_ty_for_error ctxt t)
          >>=? fun (t, _ctxt) -> fail (Comparable_type_expected (loc, t))
      | Some key ->
          typed ctxt loc (Compare key) (Item_t (Int_t None, rest, annot)) )
  (* comparators *)
  | (Prim (loc, I_EQ, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Eq (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_NEQ, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Neq (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_LT, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Lt (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_GT, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Gt (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_LE, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Le (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_GE, [], annot), Item_t (Int_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot -> typed ctxt loc Ge (Item_t (Bool_t None, rest, annot))
  (* annotations *)
  | (Prim (loc, I_CAST, [cast_t], annot), Item_t (t, stack, item_annot)) ->
      parse_var_annot loc annot ~default:item_annot
      >>=? fun annot ->
      Lwt.return @@ parse_any_ty ctxt ~legacy cast_t
      >>=? fun (Ex_ty cast_t, ctxt) ->
      Lwt.return @@ ty_eq ctxt cast_t t
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc cast_t t
      >>=? fun (_, ctxt) -> typed ctxt loc Nop (Item_t (cast_t, stack, annot))
  | (Prim (loc, I_RENAME, [], annot), Item_t (t, stack, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      (* can erase annot *)
      typed ctxt loc Nop (Item_t (t, stack, annot))
  (* packing *)
  | (Prim (loc, I_PACK, [], annot), Item_t (t, rest, unpacked_annot)) ->
      Lwt.return
        (check_packable
           ~legacy:true
           (* allow to pack contracts for hash/signature checks *) loc
           t)
      >>=? fun () ->
      parse_var_annot
        loc
        annot
        ~default:(gen_access_annot unpacked_annot default_pack_annot)
      >>=? fun annot ->
      typed ctxt loc (Pack t) (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_UNPACK, [ty], annot), Item_t (Bytes_t _, rest, packed_annot))
    ->
      Lwt.return @@ parse_packable_ty ctxt ~legacy ty
      >>=? fun (Ex_ty t, ctxt) ->
      parse_var_type_annot loc annot
      >>=? fun (annot, ty_name) ->
      let annot =
        default_annot
          annot
          ~default:(gen_access_annot packed_annot default_unpack_annot)
      in
      typed
        ctxt
        loc
        (Unpack t)
        (Item_t
           ( Option_t (t, ty_name, false (* cannot unpack big_maps *)),
             rest,
             annot ))
  (* protocol *)
  | ( Prim (loc, I_ADDRESS, [], annot),
      Item_t (Contract_t _, rest, contract_annot) ) ->
      parse_var_annot
        loc
        annot
        ~default:(gen_access_annot contract_annot default_addr_annot)
      >>=? fun annot ->
      typed ctxt loc Address (Item_t (Address_t None, rest, annot))
  | ( Prim (loc, I_CONTRACT, [ty], annot),
      Item_t (Address_t _, rest, addr_annot) ) ->
      Lwt.return @@ parse_parameter_ty ctxt ~legacy ty
      >>=? fun (Ex_ty t, ctxt) ->
      parse_entrypoint_annot
        loc
        annot
        ~default:(gen_access_annot addr_annot default_contract_annot)
      >>=? fun (annot, entrypoint) ->
      ( Lwt.return
      @@
      match entrypoint with
      | None ->
          Ok "default"
      | Some (`Field_annot "default") ->
          error (Unexpected_annotation loc)
      | Some (`Field_annot entrypoint) ->
          if Compare.Int.(String.length entrypoint > 31) then
            error (Entrypoint_name_too_long entrypoint)
          else Ok entrypoint )
      >>=? fun entrypoint ->
      typed
        ctxt
        loc
        (Contract (t, entrypoint))
        (Item_t (Option_t (Contract_t (t, None), None, false), rest, annot))
  | ( Prim (loc, I_TRANSFER_TOKENS, [], annot),
      Item_t (p, Item_t (Mutez_t _, Item_t (Contract_t (cp, _), rest, _), _), _)
    ) ->
      check_item_ty ctxt p cp loc I_TRANSFER_TOKENS 1 4
      >>=? fun (Eq, _, ctxt) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Transfer_tokens (Item_t (Operation_t None, rest, annot))
  | ( Prim (loc, I_SET_DELEGATE, [], annot),
      Item_t (Option_t (Key_hash_t _, _, _), rest, _) ) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Set_delegate (Item_t (Operation_t None, rest, annot))
  | ( Prim (loc, I_CREATE_ACCOUNT, [], annot),
      Item_t
        ( Key_hash_t _,
          Item_t
            ( Option_t (Key_hash_t _, _, _),
              Item_t (Bool_t _, Item_t (Mutez_t _, rest, _), _),
              _ ),
          _ ) ) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_two_var_annot loc annot
        >>=? fun (op_annot, addr_annot) ->
        typed
          ctxt
          loc
          Create_account
          (Item_t
             ( Operation_t None,
               Item_t (Address_t None, rest, addr_annot),
               op_annot ))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_CREATE_ACCOUNT)
  | (Prim (loc, I_IMPLICIT_ACCOUNT, [], annot), Item_t (Key_hash_t _, rest, _))
    ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed
        ctxt
        loc
        Implicit_account
        (Item_t (Contract_t (Unit_t None, None), rest, annot))
  | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
      Item_t
        ( Key_hash_t _,
          Item_t
            ( Option_t (Key_hash_t _, _, _),
              Item_t
                ( Bool_t _,
                  Item_t
                    ( Bool_t _,
                      Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
                      _ ),
                  _ ),
              _ ),
          _ ) ) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_two_var_annot loc annot
        >>=? fun (op_annot, addr_annot) ->
        let cannonical_code = fst @@ Micheline.extract_locations code in
        Lwt.return @@ parse_toplevel ~legacy cannonical_code
        >>=? fun (arg_type, storage_type, code_field, root_name) ->
        trace
          (Ill_formed_type
             (Some "parameter", cannonical_code, location arg_type))
          (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
        >>=? fun (Ex_ty arg_type, ctxt) ->
        ( if legacy then Error_monad.return ()
        else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
        >>=? fun () ->
        trace
          (Ill_formed_type
             (Some "storage", cannonical_code, location storage_type))
          (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
        >>=? fun (Ex_ty storage_type, ctxt) ->
        let arg_annot =
          default_annot
            (type_to_var_annot (name_of_ty arg_type))
            ~default:default_param_annot
        in
        let storage_annot =
          default_annot
            (type_to_var_annot (name_of_ty storage_type))
            ~default:default_storage_annot
        in
        let arg_type_full =
          Pair_t
            ( (arg_type, None, arg_annot),
              (storage_type, None, storage_annot),
              None,
              has_big_map arg_type || has_big_map storage_type )
        in
        let ret_type_full =
          Pair_t
            ( (List_t (Operation_t None, None, false), None, None),
              (storage_type, None, None),
              None,
              has_big_map storage_type )
        in
        trace
          (Ill_typed_contract (cannonical_code, []))
          (parse_returning
             (Toplevel
                {
                  storage_type;
                  param_type = arg_type;
                  root_name;
                  legacy_create_contract_literal = true;
                })
             ctxt
             ~legacy
             ?type_logger
             (arg_type_full, None)
             ret_type_full
             code_field)
        >>=? fun ( ( Lam
                       ( { bef = Item_t (arg, Empty_t, _);
                           aft = Item_t (ret, Empty_t, _);
                           _ },
                         _ ) as lambda ),
                   ctxt ) ->
        Lwt.return @@ ty_eq ctxt arg arg_type_full
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
        >>=? fun (_, ctxt) ->
        Lwt.return @@ ty_eq ctxt ret ret_type_full
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
        >>=? fun (_, ctxt) ->
        Lwt.return @@ ty_eq ctxt storage_type ginit
        >>=? fun (Eq, ctxt) ->
        Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
        >>=? fun (_, ctxt) ->
        typed
          ctxt
          loc
          (Create_contract (storage_type, arg_type, lambda, root_name))
          (Item_t
             ( Operation_t None,
               Item_t (Address_t None, rest, addr_annot),
               op_annot ))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_CREATE_CONTRACT)
  | ( Prim (loc, I_CREATE_CONTRACT, [(Seq _ as code)], annot),
      (* Removed the instruction's arguments manager, spendable and delegatable *)
    Item_t
      ( Option_t (Key_hash_t _, _, _),
        Item_t (Mutez_t _, Item_t (ginit, rest, _), _),
        _ ) ) ->
      parse_two_var_annot loc annot
      >>=? fun (op_annot, addr_annot) ->
      let cannonical_code = fst @@ Micheline.extract_locations code in
      Lwt.return @@ parse_toplevel ~legacy cannonical_code
      >>=? fun (arg_type, storage_type, code_field, root_name) ->
      trace
        (Ill_formed_type (Some "parameter", cannonical_code, location arg_type))
        (Lwt.return @@ parse_parameter_ty ctxt ~legacy arg_type)
      >>=? fun (Ex_ty arg_type, ctxt) ->
      ( if legacy then Error_monad.return ()
      else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
      >>=? fun () ->
      trace
        (Ill_formed_type
           (Some "storage", cannonical_code, location storage_type))
        (Lwt.return @@ parse_storage_ty ctxt ~legacy storage_type)
      >>=? fun (Ex_ty storage_type, ctxt) ->
      let arg_annot =
        default_annot
          (type_to_var_annot (name_of_ty arg_type))
          ~default:default_param_annot
      in
      let storage_annot =
        default_annot
          (type_to_var_annot (name_of_ty storage_type))
          ~default:default_storage_annot
      in
      let arg_type_full =
        Pair_t
          ( (arg_type, None, arg_annot),
            (storage_type, None, storage_annot),
            None,
            has_big_map arg_type || has_big_map storage_type )
      in
      let ret_type_full =
        Pair_t
          ( (List_t (Operation_t None, None, false), None, None),
            (storage_type, None, None),
            None,
            has_big_map storage_type )
      in
      trace
        (Ill_typed_contract (cannonical_code, []))
        (parse_returning
           (Toplevel
              {
                storage_type;
                param_type = arg_type;
                root_name;
                legacy_create_contract_literal = false;
              })
           ctxt
           ~legacy
           ?type_logger
           (arg_type_full, None)
           ret_type_full
           code_field)
      >>=? fun ( ( Lam
                     ( { bef = Item_t (arg, Empty_t, _);
                         aft = Item_t (ret, Empty_t, _);
                         _ },
                       _ ) as lambda ),
                 ctxt ) ->
      Lwt.return @@ ty_eq ctxt arg arg_type_full
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc arg arg_type_full
      >>=? fun (_, ctxt) ->
      Lwt.return @@ ty_eq ctxt ret ret_type_full
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc ret ret_type_full
      >>=? fun (_, ctxt) ->
      Lwt.return @@ ty_eq ctxt storage_type ginit
      >>=? fun (Eq, ctxt) ->
      Lwt.return @@ merge_types ~legacy ctxt loc storage_type ginit
      >>=? fun (_, ctxt) ->
      typed
        ctxt
        loc
        (Create_contract_2 (storage_type, arg_type, lambda, root_name))
        (Item_t
           ( Operation_t None,
             Item_t (Address_t None, rest, addr_annot),
             op_annot ))
  | (Prim (loc, I_NOW, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_now_annot
      >>=? fun annot ->
      typed ctxt loc Now (Item_t (Timestamp_t None, stack, annot))
  | (Prim (loc, I_AMOUNT, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_amount_annot
      >>=? fun annot ->
      typed ctxt loc Amount (Item_t (Mutez_t None, stack, annot))
  | (Prim (loc, I_CHAIN_ID, [], annot), stack) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc ChainId (Item_t (Chain_id_t None, stack, annot))
  | (Prim (loc, I_BALANCE, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_balance_annot
      >>=? fun annot ->
      typed ctxt loc Balance (Item_t (Mutez_t None, stack, annot))
  | (Prim (loc, I_HASH_KEY, [], annot), Item_t (Key_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Hash_key (Item_t (Key_hash_t None, rest, annot))
  | ( Prim (loc, I_CHECK_SIGNATURE, [], annot),
      Item_t
        (Key_t _, Item_t (Signature_t _, Item_t (Bytes_t _, rest, _), _), _) )
    ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Check_signature (Item_t (Bool_t None, rest, annot))
  | (Prim (loc, I_BLAKE2B, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Blake2b (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_SHA256, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sha256 (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_SHA512, [], annot), Item_t (Bytes_t _, rest, _)) ->
      parse_var_annot loc annot
      >>=? fun annot ->
      typed ctxt loc Sha512 (Item_t (Bytes_t None, rest, annot))
  | (Prim (loc, I_STEPS_TO_QUOTA, [], annot), stack) ->
      if legacy then
        (* For existing contracts, this instruction is still allowed *)
        parse_var_annot loc annot ~default:default_steps_annot
        >>=? fun annot ->
        typed ctxt loc Steps_to_quota (Item_t (Nat_t None, stack, annot))
      else
        (* For new contracts this instruction is not allowed anymore *)
        fail (Deprecated_instruction I_STEPS_TO_QUOTA)
  | (Prim (loc, I_SOURCE, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_source_annot
      >>=? fun annot ->
      typed ctxt loc Source (Item_t (Address_t None, stack, annot))
  | (Prim (loc, I_SENDER, [], annot), stack) ->
      parse_var_annot loc annot ~default:default_sender_annot
      >>=? fun annot ->
      typed ctxt loc Sender (Item_t (Address_t None, stack, annot))
  | (Prim (loc, I_SELF, [], annot), stack) ->
      parse_entrypoint_annot loc annot ~default:default_self_annot
      >>=? fun (annot, entrypoint) ->
      let entrypoint =
        Option.unopt_map
          ~f:(fun (`Field_annot annot) -> annot)
          ~default:"default"
          entrypoint
      in
      let rec get_toplevel_type :
          tc_context -> (bef judgement * context) tzresult Lwt.t = function
        | Lambda ->
            fail (Self_in_lambda loc)
        | Dip (_, prev) ->
            get_toplevel_type prev
        | Toplevel
            {param_type; root_name; legacy_create_contract_literal = false} ->
            Lwt.return (find_entrypoint param_type ~root_name entrypoint)
            >>=? fun (_, Ex_ty param_type) ->
            typed
              ctxt
              loc
              (Self (param_type, entrypoint))
              (Item_t (Contract_t (param_type, None), stack, annot))
        | Toplevel
            {param_type; root_name = _; legacy_create_contract_literal = true}
          ->
            typed
              ctxt
              loc
              (Self (param_type, "default"))
              (Item_t (Contract_t (param_type, None), stack, annot))
      in
      get_toplevel_type tc_context
  (* Primitive parsing errors *)
  | ( Prim
        ( loc,
          ( ( I_DUP
            | I_SWAP
            | I_SOME
            | I_UNIT
            | I_PAIR
            | I_CAR
            | I_CDR
            | I_CONS
            | I_CONCAT
            | I_SLICE
            | I_MEM
            | I_UPDATE
            | I_MAP
            | I_GET
            | I_EXEC
            | I_FAILWITH
            | I_SIZE
            | I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_OR
            | I_AND
            | I_XOR
            | I_NOT
            | I_ABS
            | I_NEG
            | I_LSL
            | I_LSR
            | I_COMPARE
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE
            | I_TRANSFER_TOKENS
            | I_CREATE_ACCOUNT
            | I_SET_DELEGATE
            | I_NOW
            | I_IMPLICIT_ACCOUNT
            | I_AMOUNT
            | I_BALANCE
            | I_CHECK_SIGNATURE
            | I_HASH_KEY
            | I_SOURCE
            | I_SENDER
            | I_BLAKE2B
            | I_SHA256
            | I_SHA512
            | I_STEPS_TO_QUOTA
            | I_ADDRESS ) as name ),
          (_ :: _ as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 0, List.length l))
  | ( Prim
        ( loc,
          ( ( I_NONE
            | I_LEFT
            | I_RIGHT
            | I_NIL
            | I_MAP
            | I_ITER
            | I_EMPTY_SET
            | I_DIP
            | I_LOOP
            | I_LOOP_LEFT
            | I_CONTRACT ) as name ),
          (([] | _ :: _ :: _) as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 1, List.length l))
  | ( Prim
        ( loc,
          ( (I_PUSH | I_IF_NONE | I_IF_LEFT | I_IF_CONS | I_EMPTY_MAP | I_IF)
          as name ),
          (([] | [_] | _ :: _ :: _ :: _) as l),
          _ ),
      _ ) ->
      fail (Invalid_arity (loc, name, 2, List.length l))
  | (Prim (loc, I_LAMBDA, (([] | [_] | _ :: _ :: _ :: _ :: _) as l), _), _) ->
      fail (Invalid_arity (loc, I_LAMBDA, 3, List.length l))
  (* Stack errors *)
  | ( Prim
        ( loc,
          ( ( I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_AND
            | I_OR
            | I_XOR
            | I_LSL
            | I_LSR ) as name ),
          [],
          _ ),
      Item_t (ta, Item_t (tb, _, _), _) ) ->
      Lwt.return @@ serialize_ty_for_error ctxt ta
      >>=? fun (ta, ctxt) ->
      Lwt.return @@ serialize_ty_for_error ctxt tb
      >>=? fun (tb, _ctxt) -> fail (Undefined_binop (loc, name, ta, tb))
  | ( Prim
        ( loc,
          ( ( I_NEG
            | I_ABS
            | I_NOT
            | I_CONCAT
            | I_SIZE
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE ) as name ),
          [],
          _ ),
      Item_t (t, _, _) ) ->
      Lwt.return @@ serialize_ty_for_error ctxt t
      >>=? fun (t, _ctxt) -> fail (Undefined_unop (loc, name, t))
  | (Prim (loc, ((I_UPDATE | I_SLICE) as name), [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 3, stack))
  | (Prim (loc, I_CREATE_CONTRACT, _, _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_CREATE_CONTRACT, 7, stack))
  | (Prim (loc, I_CREATE_ACCOUNT, [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_CREATE_ACCOUNT, 4, stack))
  | (Prim (loc, I_TRANSFER_TOKENS, [], _), stack) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) ->
      fail (Bad_stack (loc, I_TRANSFER_TOKENS, 4, stack))
  | ( Prim
        ( loc,
          ( ( I_DROP
            | I_DUP
            | I_CAR
            | I_CDR
            | I_SOME
            | I_BLAKE2B
            | I_SHA256
            | I_SHA512
            | I_DIP
            | I_IF_NONE
            | I_LEFT
            | I_RIGHT
            | I_IF_LEFT
            | I_IF
            | I_LOOP
            | I_IF_CONS
            | I_IMPLICIT_ACCOUNT
            | I_NEG
            | I_ABS
            | I_INT
            | I_NOT
            | I_HASH_KEY
            | I_EQ
            | I_NEQ
            | I_LT
            | I_GT
            | I_LE
            | I_GE ) as name ),
          _,
          _ ),
      stack ) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 1, stack))
  | ( Prim
        ( loc,
          ( ( I_SWAP
            | I_PAIR
            | I_CONS
            | I_GET
            | I_MEM
            | I_EXEC
            | I_CHECK_SIGNATURE
            | I_ADD
            | I_SUB
            | I_MUL
            | I_EDIV
            | I_AND
            | I_OR
            | I_XOR
            | I_LSL
            | I_LSR ) as name ),
          _,
          _ ),
      stack ) ->
      serialize_stack_for_error ctxt stack
      >>=? fun (stack, _ctxt) -> fail (Bad_stack (loc, name, 2, stack))
  (* Generic parsing errors *)
  | (expr, _) ->
      fail
      @@ unexpected
           expr
           [Seq_kind]
           Instr_namespace
           [ I_DROP;
             I_DUP;
             I_DIG;
             I_DUG;
             I_SWAP;
             I_SOME;
             I_UNIT;
             I_PAIR;
             I_CAR;
             I_CDR;
             I_CONS;
             I_MEM;
             I_UPDATE;
             I_MAP;
             I_ITER;
             I_GET;
             I_EXEC;
             I_FAILWITH;
             I_SIZE;
             I_CONCAT;
             I_ADD;
             I_SUB;
             I_MUL;
             I_EDIV;
             I_OR;
             I_AND;
             I_XOR;
             I_NOT;
             I_ABS;
             I_INT;
             I_NEG;
             I_LSL;
             I_LSR;
             I_COMPARE;
             I_EQ;
             I_NEQ;
             I_LT;
             I_GT;
             I_LE;
             I_GE;
             I_TRANSFER_TOKENS;
             I_CREATE_ACCOUNT;
             I_CREATE_CONTRACT;
             I_NOW;
             I_AMOUNT;
             I_BALANCE;
             I_IMPLICIT_ACCOUNT;
             I_CHECK_SIGNATURE;
             I_BLAKE2B;
             I_SHA256;
             I_SHA512;
             I_HASH_KEY;
             I_STEPS_TO_QUOTA;
             I_PUSH;
             I_NONE;
             I_LEFT;
             I_RIGHT;
             I_NIL;
             I_EMPTY_SET;
             I_DIP;
             I_LOOP;
             I_IF_NONE;
             I_IF_LEFT;
             I_IF_CONS;
             I_EMPTY_MAP;
             I_IF;
             I_SOURCE;
             I_SENDER;
             I_SELF;
             I_LAMBDA ]

and parse_contract :
    type arg.
    legacy:bool ->
    context ->
    Script.location ->
    arg ty ->
    Contract.t ->
    entrypoint:string ->
    (context * arg typed_contract) tzresult Lwt.t =
 fun ~legacy ctxt loc arg contract ~entrypoint ->
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
  >>=? fun ctxt ->
  Contract.exists ctxt contract
  >>=? function
  | false ->
      fail (Invalid_contract (loc, contract))
  | true -> (
      Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
      >>=? fun ctxt ->
      trace (Invalid_contract (loc, contract))
      @@ Contract.get_script_code ctxt contract
      >>=? fun (ctxt, code) ->
      match code with
      | None ->
          Lwt.return
            ( ty_eq ctxt arg (Unit_t None)
            >>? fun (Eq, ctxt) ->
            match entrypoint with
            | "default" ->
                let contract : arg typed_contract =
                  (arg, (contract, entrypoint))
                in
                ok (ctxt, contract)
            | entrypoint ->
                error (No_such_entrypoint entrypoint) )
      | Some code ->
          Script.force_decode ctxt code
          >>=? fun (code, ctxt) ->
          Lwt.return
            ( parse_toplevel ~legacy:true code
            >>? fun (arg_type, _, _, root_name) ->
            parse_parameter_ty ctxt ~legacy:true arg_type
            >>? fun (Ex_ty targ, ctxt) ->
            let return ctxt targ entrypoint =
              merge_types ~legacy ctxt loc targ arg
              >>? fun (arg, ctxt) ->
              let contract : arg typed_contract =
                (arg, (contract, entrypoint))
              in
              ok (ctxt, contract)
            in
            find_entrypoint_for_type
              ~full:targ
              ~expected:arg
              ~root_name
              entrypoint
              ctxt
            >>? fun (ctxt, entrypoint, targ) ->
            merge_types ~legacy ctxt loc targ arg
            >>? fun (targ, ctxt) -> return ctxt targ entrypoint ) )

(* Same as the one above, but does not fail when the contact is missing or
   if the expected type doesn't match the actual one. In that case None is
   returned and some overapproximation of the typechecking gas is consumed.
   This can still fail on gas exhaustion. *)
and parse_contract_for_script :
    type arg.
    legacy:bool ->
    context ->
    Script.location ->
    arg ty ->
    Contract.t ->
    entrypoint:string ->
    (context * arg typed_contract option) tzresult Lwt.t =
 fun ~legacy ctxt loc arg contract ~entrypoint ->
  Lwt.return @@ Gas.consume ctxt Typecheck_costs.contract_exists
  >>=? fun ctxt ->
  Contract.exists ctxt contract
  >>=? function
  | false ->
      return (ctxt, None)
  | true -> (
      Lwt.return @@ Gas.consume ctxt Typecheck_costs.get_script
      >>=? fun ctxt ->
      trace (Invalid_contract (loc, contract))
      @@ Contract.get_script_code ctxt contract
      >>=? fun (ctxt, code) ->
      match code with
      (* can only fail because of gas *)
      | None -> (
        match entrypoint with
        | "default" ->
            Lwt.return
              ( match ty_eq ctxt arg (Unit_t None) with
              | Ok (Eq, ctxt) ->
                  let contract : arg typed_contract =
                    (arg, (contract, entrypoint))
                  in
                  ok (ctxt, Some contract)
              | Error _ ->
                  Gas.consume ctxt Typecheck_costs.cycle
                  >>? fun ctxt -> ok (ctxt, None) )
        | _ ->
            return (ctxt, None) )
      | Some code ->
          Script.force_decode ctxt code
          >>=? fun (code, ctxt) ->
          (* can only fail because of gas *)
          Lwt.return
            ( match parse_toplevel ~legacy:true code with
            | Error _ ->
                error (Invalid_contract (loc, contract))
            | Ok (arg_type, _, _, root_name) -> (
              match parse_parameter_ty ctxt ~legacy:true arg_type with
              | Error _ ->
                  error (Invalid_contract (loc, contract))
              | Ok (Ex_ty targ, ctxt) -> (
                match
                  find_entrypoint_for_type
                    ~full:targ
                    ~expected:arg
                    ~root_name
                    entrypoint
                    ctxt
                  >>? fun (ctxt, entrypoint, targ) ->
                  merge_types ~legacy ctxt loc targ arg
                  >>? fun (targ, ctxt) ->
                  merge_types ~legacy ctxt loc targ arg
                  >>? fun (arg, ctxt) ->
                  let contract : arg typed_contract =
                    (arg, (contract, entrypoint))
                  in
                  ok (ctxt, Some contract)
                with
                | Ok res ->
                    ok res
                | Error _ ->
                    (* overapproximation by checking if targ = targ,
                                                       can only fail because of gas *)
                    ty_eq ctxt targ targ
                    >>? fun (Eq, ctxt) ->
                    merge_types ~legacy ctxt loc targ targ
                    >>? fun (_, ctxt) -> ok (ctxt, None) ) ) ) )

and parse_toplevel :
    legacy:bool ->
    Script.expr ->
    (Script.node * Script.node * Script.node * string option) tzresult =
 fun ~legacy toplevel ->
  record_trace (Ill_typed_contract (toplevel, []))
  @@
  match root toplevel with
  | Int (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], Int_kind))
  | String (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], String_kind))
  | Bytes (loc, _) ->
      error (Invalid_kind (loc, [Seq_kind], Bytes_kind))
  | Prim (loc, _, _, _) ->
      error (Invalid_kind (loc, [Seq_kind], Prim_kind))
  | Seq (_, fields) -> (
      let rec find_fields p s c fields =
        match fields with
        | [] ->
            ok (p, s, c)
        | Int (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Int_kind))
        | String (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], String_kind))
        | Bytes (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Bytes_kind))
        | Seq (loc, _) :: _ ->
            error (Invalid_kind (loc, [Prim_kind], Seq_kind))
        | Prim (loc, K_parameter, [arg], annot) :: rest -> (
          match p with
          | None ->
              find_fields (Some (arg, loc, annot)) s c rest
          | Some _ ->
              error (Duplicate_field (loc, K_parameter)) )
        | Prim (loc, K_storage, [arg], annot) :: rest -> (
          match s with
          | None ->
              find_fields p (Some (arg, loc, annot)) c rest
          | Some _ ->
              error (Duplicate_field (loc, K_storage)) )
        | Prim (loc, K_code, [arg], annot) :: rest -> (
          match c with
          | None ->
              find_fields p s (Some (arg, loc, annot)) rest
          | Some _ ->
              error (Duplicate_field (loc, K_code)) )
        | Prim (loc, ((K_parameter | K_storage | K_code) as name), args, _)
          :: _ ->
            error (Invalid_arity (loc, name, 1, List.length args))
        | Prim (loc, name, _, _) :: _ ->
            let allowed = [K_parameter; K_storage; K_code] in
            error (Invalid_primitive (loc, allowed, name))
      in
      find_fields None None None fields
      >>? function
      | (None, _, _) ->
          error (Missing_field K_parameter)
      | (Some _, None, _) ->
          error (Missing_field K_storage)
      | (Some _, Some _, None) ->
          error (Missing_field K_code)
      | (Some (p, ploc, pannot), Some (s, sloc, sannot), Some (c, cloc, carrot))
        ->
          let maybe_root_name =
            (* root name can be attached to either the parameter
                 primitive or the toplevel constructor *)
            Script_ir_annot.extract_field_annot p
            >>? fun (p, root_name) ->
            match root_name with
            | Some (`Field_annot root_name) ->
                ok (p, pannot, Some root_name)
            | None -> (
              match pannot with
              | [single]
                when Compare.Int.(String.length single > 0)
                     && Compare.Char.(single.[0] = '%') ->
                  ok
                    ( p,
                      [],
                      Some (String.sub single 1 (String.length single - 1)) )
              | _ ->
                  ok (p, pannot, None) )
          in
          if legacy then
            (* legacy semantics ignores spurious annotations *)
            let (p, root_name) =
              match maybe_root_name with
              | Ok (p, _, root_name) ->
                  (p, root_name)
              | Error _ ->
                  (p, None)
            in
            ok (p, s, c, root_name)
          else
            (* only one field annot is allowed to set the root entrypoint name *)
            maybe_root_name
            >>? fun (p, pannot, root_name) ->
            Script_ir_annot.error_unexpected_annot ploc pannot
            >>? fun () ->
            Script_ir_annot.error_unexpected_annot cloc carrot
            >>? fun () ->
            Script_ir_annot.error_unexpected_annot sloc sannot
            >>? fun () -> ok (p, s, c, root_name) )

let parse_script :
    ?type_logger:type_logger ->
    context ->
    legacy:bool ->
    Script.t ->
    (ex_script * context) tzresult Lwt.t =
 fun ?type_logger ctxt ~legacy {code; storage} ->
  Script.force_decode ctxt code
  >>=? fun (code, ctxt) ->
  Script.force_decode ctxt storage
  >>=? fun (storage, ctxt) ->
  Lwt.return @@ parse_toplevel ~legacy code
  >>=? fun (arg_type, storage_type, code_field, root_name) ->
  trace
    (Ill_formed_type (Some "parameter", code, location arg_type))
    (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
  >>=? fun (Ex_ty arg_type, ctxt) ->
  ( if legacy then return ()
  else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
  >>=? fun () ->
  trace
    (Ill_formed_type (Some "storage", code, location storage_type))
    (Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
  >>=? fun (Ex_ty storage_type, ctxt) ->
  let arg_annot =
    default_annot
      (type_to_var_annot (name_of_ty arg_type))
      ~default:default_param_annot
  in
  let storage_annot =
    default_annot
      (type_to_var_annot (name_of_ty storage_type))
      ~default:default_storage_annot
  in
  let arg_type_full =
    Pair_t
      ( (arg_type, None, arg_annot),
        (storage_type, None, storage_annot),
        None,
        has_big_map arg_type || has_big_map storage_type )
  in
  let ret_type_full =
    Pair_t
      ( (List_t (Operation_t None, None, false), None, None),
        (storage_type, None, None),
        None,
        has_big_map storage_type )
  in
  trace_eval
    (fun () ->
      Lwt.return @@ serialize_ty_for_error ctxt storage_type
      >>|? fun (storage_type, _ctxt) ->
      Ill_typed_data (None, storage, storage_type))
    (parse_data ?type_logger ctxt ~legacy storage_type (root storage))
  >>=? fun (storage, ctxt) ->
  trace
    (Ill_typed_contract (code, []))
    (parse_returning
       (Toplevel
          {
            storage_type;
            param_type = arg_type;
            root_name;
            legacy_create_contract_literal = false;
          })
       ctxt
       ~legacy
       ?type_logger
       (arg_type_full, None)
       ret_type_full
       code_field)
  >>=? fun (code, ctxt) ->
  return (Ex_script {code; arg_type; storage; storage_type; root_name}, ctxt)

let typecheck_code :
    context -> Script.expr -> (type_map * context) tzresult Lwt.t =
 fun ctxt code ->
  let legacy = false in
  Lwt.return @@ parse_toplevel ~legacy code
  >>=? fun (arg_type, storage_type, code_field, root_name) ->
  let type_map = ref [] in
  trace
    (Ill_formed_type (Some "parameter", code, location arg_type))
    (Lwt.return (parse_parameter_ty ctxt ~legacy arg_type))
  >>=? fun (Ex_ty arg_type, ctxt) ->
  ( if legacy then return ()
  else Lwt.return (well_formed_entrypoints ~root_name arg_type) )
  >>=? fun () ->
  trace
    (Ill_formed_type (Some "storage", code, location storage_type))
    (Lwt.return (parse_storage_ty ctxt ~legacy storage_type))
  >>=? fun (Ex_ty storage_type, ctxt) ->
  let arg_annot =
    default_annot
      (type_to_var_annot (name_of_ty arg_type))
      ~default:default_param_annot
  in
  let storage_annot =
    default_annot
      (type_to_var_annot (name_of_ty storage_type))
      ~default:default_storage_annot
  in
  let arg_type_full =
    Pair_t
      ( (arg_type, None, arg_annot),
        (storage_type, None, storage_annot),
        None,
        has_big_map arg_type || has_big_map storage_type )
  in
  let ret_type_full =
    Pair_t
      ( (List_t (Operation_t None, None, false), None, None),
        (storage_type, None, None),
        None,
        has_big_map storage_type )
  in
  let result =
    parse_returning
      (Toplevel
         {
           storage_type;
           param_type = arg_type;
           root_name;
           legacy_create_contract_literal = false;
         })
      ctxt
      ~legacy
      ~type_logger:(fun loc bef aft ->
        type_map := (loc, (bef, aft)) :: !type_map)
      (arg_type_full, None)
      ret_type_full
      code_field
  in
  trace (Ill_typed_contract (code, !type_map)) result
  >>=? fun (Lam _, ctxt) -> return (!type_map, ctxt)

let typecheck_data :
    ?type_logger:type_logger ->
    context ->
    Script.expr * Script.expr ->
    context tzresult Lwt.t =
 fun ?type_logger ctxt (data, exp_ty) ->
  let legacy = false in
  trace
    (Ill_formed_type (None, exp_ty, 0))
    (Lwt.return @@ parse_packable_ty ctxt ~legacy (root exp_ty))
  >>=? fun (Ex_ty exp_ty, ctxt) ->
  trace_eval
    (fun () ->
      Lwt.return @@ serialize_ty_for_error ctxt exp_ty
      >>|? fun (exp_ty, _ctxt) -> Ill_typed_data (None, data, exp_ty))
    (parse_data ?type_logger ctxt ~legacy exp_ty (root data))
  >>=? fun (_, ctxt) -> return ctxt

module Entrypoints_map = Map.Make (String)

let list_entrypoints (type full) (full : full ty) ctxt ~root_name =
  let merge path annot (type t) (ty : t ty) reachable
      ((unreachables, all) as acc) =
    match annot with
    | None | Some (`Field_annot "") -> (
        ok
        @@
        if reachable then acc
        else
          match ty with
          | Union_t _ ->
              acc
          | _ ->
              (List.rev path :: unreachables, all) )
    | Some (`Field_annot name) ->
        if Compare.Int.(String.length name > 31) then
          ok (List.rev path :: unreachables, all)
        else if Entrypoints_map.mem name all then
          ok (List.rev path :: unreachables, all)
        else
          unparse_ty_no_lwt ctxt ty
          >>? fun (unparsed_ty, _) ->
          ok
            ( unreachables,
              Entrypoints_map.add name (List.rev path, unparsed_ty) all )
  in
  let rec fold_tree :
      type t.
      t ty ->
      prim list ->
      bool ->
      prim list list * (prim list * Script.node) Entrypoints_map.t ->
      (prim list list * (prim list * Script.node) Entrypoints_map.t) tzresult =
   fun t path reachable acc ->
    match t with
    | Union_t ((tl, al), (tr, ar), _, _) ->
        merge (D_Left :: path) al tl reachable acc
        >>? fun acc ->
        merge (D_Right :: path) ar tr reachable acc
        >>? fun acc ->
        fold_tree
          tl
          (D_Left :: path)
          (match al with Some _ -> true | None -> reachable)
          acc
        >>? fun acc ->
        fold_tree
          tr
          (D_Right :: path)
          (match ar with Some _ -> true | None -> reachable)
          acc
    | _ ->
        ok acc
  in
  unparse_ty_no_lwt ctxt full
  >>? fun (unparsed_full, _) ->
  let (init, reachable) =
    match root_name with
    | None | Some "" ->
        (Entrypoints_map.empty, false)
    | Some name ->
        (Entrypoints_map.singleton name ([], unparsed_full), true)
  in
  fold_tree full [] reachable ([], init)

(* ---- Unparsing (Typed IR -> Untyped expressions) --------------------------*)

let rec unparse_data :
    type a.
    context ->
    unparsing_mode ->
    a ty ->
    a ->
    (Script.node * context) tzresult Lwt.t =
 fun ctxt mode ty a ->
  Lwt.return (Gas.consume ctxt Unparse_costs.cycle)
  >>=? fun ctxt ->
  match (ty, a) with
  | (Unit_t _, ()) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.unit)
      >>=? fun ctxt -> return (Prim (-1, D_Unit, [], []), ctxt)
  | (Int_t _, v) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
      >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
  | (Nat_t _, v) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.int v))
      >>=? fun ctxt -> return (Int (-1, Script_int.to_zint v), ctxt)
  | (String_t _, s) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.string s))
      >>=? fun ctxt -> return (String (-1, s), ctxt)
  | (Bytes_t _, s) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.bytes s))
      >>=? fun ctxt -> return (Bytes (-1, s), ctxt)
  | (Bool_t _, true) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.bool)
      >>=? fun ctxt -> return (Prim (-1, D_True, [], []), ctxt)
  | (Bool_t _, false) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.bool)
      >>=? fun ctxt -> return (Prim (-1, D_False, [], []), ctxt)
  | (Timestamp_t _, t) -> (
      Lwt.return (Gas.consume ctxt (Unparse_costs.timestamp t))
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          return (Int (-1, Script_timestamp.to_zint t), ctxt)
      | Readable -> (
        match Script_timestamp.to_notation t with
        | None ->
            return (Int (-1, Script_timestamp.to_zint t), ctxt)
        | Some s ->
            return (String (-1, s), ctxt) ) )
  | (Address_t _, (c, entrypoint)) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.contract)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let entrypoint =
            match entrypoint with "default" -> "" | name -> name
          in
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Data_encoding.(tup2 Contract.encoding Variable.string)
              (c, entrypoint)
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          let notation =
            match entrypoint with
            | "default" ->
                Contract.to_b58check c
            | entrypoint ->
                Contract.to_b58check c ^ "%" ^ entrypoint
          in
          return (String (-1, notation), ctxt) )
  | (Contract_t _, (_, (c, entrypoint))) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.contract)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let entrypoint =
            match entrypoint with "default" -> "" | name -> name
          in
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Data_encoding.(tup2 Contract.encoding Variable.string)
              (c, entrypoint)
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          let notation =
            match entrypoint with
            | "default" ->
                Contract.to_b58check c
            | entrypoint ->
                Contract.to_b58check c ^ "%" ^ entrypoint
          in
          return (String (-1, notation), ctxt) )
  | (Signature_t _, s) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.signature)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes = Data_encoding.Binary.to_bytes_exn Signature.encoding s in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.to_b58check s), ctxt) )
  | (Mutez_t _, v) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.tez)
      >>=? fun ctxt -> return (Int (-1, Z.of_int64 (Tez.to_mutez v)), ctxt)
  | (Key_t _, k) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.key)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes =
            Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding k
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.Public_key.to_b58check k), ctxt) )
  | (Key_hash_t _, k) -> (
      Lwt.return (Gas.consume ctxt Unparse_costs.key_hash)
      >>=? fun ctxt ->
      match mode with
      | Optimized ->
          let bytes =
            Data_encoding.Binary.to_bytes_exn
              Signature.Public_key_hash.encoding
              k
          in
          return (Bytes (-1, bytes), ctxt)
      | Readable ->
          return (String (-1, Signature.Public_key_hash.to_b58check k), ctxt) )
  | (Operation_t _, (op, _big_map_diff)) ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn
          Operation.internal_operation_encoding
          op
      in
      Lwt.return (Gas.consume ctxt (Unparse_costs.operation bytes))
      >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
  | (Chain_id_t _, chain_id) ->
      let bytes =
        Data_encoding.Binary.to_bytes_exn Chain_id.encoding chain_id
      in
      Lwt.return (Gas.consume ctxt (Unparse_costs.chain_id bytes))
      >>=? fun ctxt -> return (Bytes (-1, bytes), ctxt)
  | (Pair_t ((tl, _, _), (tr, _, _), _, _), (l, r)) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.pair)
      >>=? fun ctxt ->
      unparse_data ctxt mode tl l
      >>=? fun (l, ctxt) ->
      unparse_data ctxt mode tr r
      >>=? fun (r, ctxt) -> return (Prim (-1, D_Pair, [l; r], []), ctxt)
  | (Union_t ((tl, _), _, _, _), L l) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.union)
      >>=? fun ctxt ->
      unparse_data ctxt mode tl l
      >>=? fun (l, ctxt) -> return (Prim (-1, D_Left, [l], []), ctxt)
  | (Union_t (_, (tr, _), _, _), R r) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.union)
      >>=? fun ctxt ->
      unparse_data ctxt mode tr r
      >>=? fun (r, ctxt) -> return (Prim (-1, D_Right, [r], []), ctxt)
  | (Option_t (t, _, _), Some v) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.some)
      >>=? fun ctxt ->
      unparse_data ctxt mode t v
      >>=? fun (v, ctxt) -> return (Prim (-1, D_Some, [v], []), ctxt)
  | (Option_t _, None) ->
      Lwt.return (Gas.consume ctxt Unparse_costs.none)
      >>=? fun ctxt -> return (Prim (-1, D_None, [], []), ctxt)
  | (List_t (t, _, _), items) ->
      fold_left_s
        (fun (l, ctxt) element ->
          Lwt.return (Gas.consume ctxt Unparse_costs.list_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode t element
          >>=? fun (unparsed, ctxt) -> return (unparsed :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      return (Micheline.Seq (-1, List.rev items), ctxt)
  | (Set_t (t, _), set) ->
      let t = ty_of_comparable_ty t in
      fold_left_s
        (fun (l, ctxt) item ->
          Lwt.return (Gas.consume ctxt Unparse_costs.set_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode t item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        (set_fold (fun e acc -> e :: acc) set [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Map_t (kt, vt, _, _), map) ->
      let kt = ty_of_comparable_ty kt in
      fold_left_s
        (fun (l, ctxt) (k, v) ->
          Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode kt k
          >>=? fun (key, ctxt) ->
          unparse_data ctxt mode vt v
          >>=? fun (value, ctxt) ->
          return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
        ([], ctxt)
        (map_fold (fun k v acc -> (k, v) :: acc) map [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Big_map_t (kt, vt, _), {id = None; diff = (module Diff); _}) ->
      (* this branch is to allow roundtrip of big map literals *)
      let kt = ty_of_comparable_ty kt in
      fold_left_s
        (fun (l, ctxt) (k, v) ->
          Lwt.return (Gas.consume ctxt Unparse_costs.map_element)
          >>=? fun ctxt ->
          unparse_data ctxt mode kt k
          >>=? fun (key, ctxt) ->
          unparse_data ctxt mode vt v
          >>=? fun (value, ctxt) ->
          return (Prim (-1, D_Elt, [key; value], []) :: l, ctxt))
        ([], ctxt)
        (Diff.OPS.fold
           (fun k v acc ->
             match v with None -> acc | Some v -> (k, v) :: acc)
           (fst Diff.boxed)
           [])
      >>=? fun (items, ctxt) -> return (Micheline.Seq (-1, items), ctxt)
  | (Big_map_t (_kt, _kv, _), {id = Some id; diff = (module Diff); _}) ->
      if Compare.Int.(Diff.OPS.cardinal (fst Diff.boxed) = 0) then
        return (Micheline.Int (-1, id), ctxt)
      else
        (* this can only be the result of an execution and the map
             must have been flushed at this point *)
        assert false
  | (Lambda_t _, Lam (_, original_code)) ->
      unparse_code ctxt mode original_code

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
and unparse_code ctxt mode =
  let legacy = true in
  function
  | Prim (loc, I_PUSH, [ty; data], annot) ->
      Lwt.return (parse_packable_ty ctxt ~legacy ty)
      >>=? fun (Ex_ty t, ctxt) ->
      parse_data ctxt ~legacy t data
      >>=? fun (data, ctxt) ->
      unparse_data ctxt mode t data
      >>=? fun (data, ctxt) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot))
      >>=? fun ctxt -> return (Prim (loc, I_PUSH, [ty; data], annot), ctxt)
  | Seq (loc, items) ->
      fold_left_s
        (fun (l, ctxt) item ->
          unparse_code ctxt mode item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      Lwt.return
        (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items)))
      >>=? fun ctxt -> return (Micheline.Seq (loc, List.rev items), ctxt)
  | Prim (loc, prim, items, annot) ->
      fold_left_s
        (fun (l, ctxt) item ->
          unparse_code ctxt mode item
          >>=? fun (item, ctxt) -> return (item :: l, ctxt))
        ([], ctxt)
        items
      >>=? fun (items, ctxt) ->
      Lwt.return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot))
      >>=? fun ctxt -> return (Prim (loc, prim, List.rev items, annot), ctxt)
  | (Int _ | String _ | Bytes _) as atom ->
      return (atom, ctxt)

(* Gas accounting may not be perfect in this function, as it is only called by RPCs. *)
let unparse_script ctxt mode {code; arg_type; storage; storage_type; root_name}
    =
  let (Lam (_, original_code)) = code in
  unparse_code ctxt mode original_code
  >>=? fun (code, ctxt) ->
  unparse_data ctxt mode storage_type storage
  >>=? fun (storage, ctxt) ->
  unparse_ty ctxt arg_type
  >>=? fun (arg_type, ctxt) ->
  unparse_ty ctxt storage_type
  >>=? fun (storage_type, ctxt) ->
  let arg_type =
    add_field_annot
      (Option.map ~f:(fun n -> `Field_annot n) root_name)
      None
      arg_type
  in
  let open Micheline in
  let code =
    Seq
      ( -1,
        [ Prim (-1, K_parameter, [arg_type], []);
          Prim (-1, K_storage, [storage_type], []);
          Prim (-1, K_code, [code], []) ] )
  in
  Lwt.return
    ( Gas.consume ctxt (Unparse_costs.seq_cost 3)
    >>? fun ctxt ->
    Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
    >>? fun ctxt ->
    Gas.consume ctxt (Unparse_costs.prim_cost 1 [])
    >>? fun ctxt -> Gas.consume ctxt (Unparse_costs.prim_cost 1 []) )
  >>=? fun ctxt ->
  return
    ( {
        code = lazy_expr (strip_locations code);
        storage = lazy_expr (strip_locations storage);
      },
      ctxt )

let pack_data ctxt typ data =
  unparse_data ctxt Optimized typ data
  >>=? fun (unparsed, ctxt) ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      expr_encoding
      (Micheline.strip_locations unparsed)
  in
  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
  >>=? fun ctxt ->
  let bytes = MBytes.concat "" [MBytes.of_string "\005"; bytes] in
  Lwt.return @@ Gas.consume ctxt (Script.serialized_cost bytes)
  >>=? fun ctxt -> return (bytes, ctxt)

let hash_data ctxt typ data =
  pack_data ctxt typ data
  >>=? fun (bytes, ctxt) ->
  Lwt.return
  @@ Gas.consume
       ctxt
       (Michelson_v1_gas.Cost_of.Legacy.hash bytes Script_expr_hash.size)
  >>=? fun ctxt -> return (Script_expr_hash.(hash_bytes [bytes]), ctxt)

(* ---------------- Big map -------------------------------------------------*)

let empty_big_map tk tv =
  {
    id = None;
    diff = empty_map tk;
    key_type = ty_of_comparable_ty tk;
    value_type = tv;
  }

let big_map_mem ctxt key {id; diff; key_type; _} =
  match (map_get key diff, id) with
  | (None, None) ->
      return (false, ctxt)
  | (None, Some id) ->
      hash_data ctxt key_type key
      >>=? fun (hash, ctxt) ->
      Alpha_context.Big_map.mem ctxt id hash
      >>=? fun (ctxt, res) -> return (res, ctxt)
  | (Some None, _) ->
      return (false, ctxt)
  | (Some (Some _), _) ->
      return (true, ctxt)

let big_map_get ctxt key {id; diff; key_type; value_type} =
  match (map_get key diff, id) with
  | (Some x, _) ->
      return (x, ctxt)
  | (None, None) ->
      return (None, ctxt)
  | (None, Some id) -> (
      hash_data ctxt key_type key
      >>=? fun (hash, ctxt) ->
      Alpha_context.Big_map.get_opt ctxt id hash
      >>=? function
      | (ctxt, None) ->
          return (None, ctxt)
      | (ctxt, Some value) ->
          parse_data ctxt ~legacy:true value_type (Micheline.root value)
          >>=? fun (x, ctxt) -> return (Some x, ctxt) )

let big_map_update key value ({diff; _} as map) =
  {map with diff = map_set key value diff}

module Ids = Set.Make (Compare.Z)

type big_map_ids = Ids.t

let no_big_map_id = Ids.empty

let diff_of_big_map ctxt fresh mode ~ids {id; key_type; value_type; diff} =
  Lwt.return
    (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff))
  >>=? fun ctxt ->
  ( match id with
  | Some id ->
      if Ids.mem id ids then
        fresh ctxt
        >>=? fun (ctxt, duplicate) ->
        return (ctxt, [Contract.Copy (id, duplicate)], duplicate)
      else
        (* The first occurence encountered of a big_map reuses the
             ID. This way, the payer is only charged for the diff.
             For this to work, this diff has to be put at the end of
             the global diff, otherwise the duplicates will use the
             updated version as a base. This is true because we add
             this diff first in the accumulator of
             `extract_big_map_updates`, and this accumulator is not
             reversed before being flattened. *)
        return (ctxt, [], id)
  | None ->
      fresh ctxt
      >>=? fun (ctxt, id) ->
      unparse_ty ctxt key_type
      >>=? fun (kt, ctxt) ->
      unparse_ty ctxt value_type
      >>=? fun (kv, ctxt) ->
      return
        ( ctxt,
          [ Contract.Alloc
              {
                big_map = id;
                key_type = Micheline.strip_locations kt;
                value_type = Micheline.strip_locations kv;
              } ],
          id ) )
  >>=? fun (ctxt, init, big_map) ->
  let pairs = map_fold (fun key value acc -> (key, value) :: acc) diff [] in
  fold_left_s
    (fun (acc, ctxt) (key, value) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      hash_data ctxt key_type key
      >>=? fun (diff_key_hash, ctxt) ->
      unparse_data ctxt mode key_type key
      >>=? fun (key_node, ctxt) ->
      let diff_key = Micheline.strip_locations key_node in
      ( match value with
      | None ->
          return (None, ctxt)
      | Some x ->
          unparse_data ctxt mode value_type x
          >>=? fun (node, ctxt) ->
          return (Some (Micheline.strip_locations node), ctxt) )
      >>=? fun (diff_value, ctxt) ->
      let diff_item =
        Contract.Update {big_map; diff_key; diff_key_hash; diff_value}
      in
      return (diff_item :: acc, ctxt))
    ([], ctxt)
    pairs
  >>=? fun (diff, ctxt) -> return (init @ diff, big_map, ctxt)

let rec extract_big_map_updates :
    type a.
    context ->
    (context -> (context * Big_map.id) tzresult Lwt.t) ->
    unparsing_mode ->
    Ids.t ->
    Contract.big_map_diff list ->
    a ty ->
    a ->
    (context * a * Ids.t * Contract.big_map_diff list) tzresult Lwt.t =
 fun ctxt fresh mode ids acc ty x ->
  match (ty, x) with
  | (Big_map_t (_, _, _), map) ->
      diff_of_big_map ctxt fresh mode ids map
      >>=? fun (diff, id, ctxt) ->
      let (module Map) = map.diff in
      let map = {map with diff = empty_map Map.key_ty; id = Some id} in
      return (ctxt, map, Ids.add id ids, diff :: acc)
  | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc tyl xl
      >>=? fun (ctxt, xl, ids, acc) ->
      extract_big_map_updates ctxt fresh mode ids acc tyr xr
      >>=? fun (ctxt, xr, ids, acc) -> return (ctxt, (xl, xr), ids, acc)
  | (Union_t ((ty, _), (_, _), _, true), L x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, L x, ids, acc)
  | (Union_t ((_, _), (ty, _), _, true), R x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, R x, ids, acc)
  | (Option_t (ty, _, true), Some x) ->
      Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
      >>=? fun ctxt ->
      extract_big_map_updates ctxt fresh mode ids acc ty x
      >>=? fun (ctxt, x, ids, acc) -> return (ctxt, Some x, ids, acc)
  | (List_t (ty, _, true), l) ->
      fold_left_s
        (fun (ctxt, l, ids, acc) x ->
          Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
          >>=? fun ctxt ->
          extract_big_map_updates ctxt fresh mode ids acc ty x
          >>=? fun (ctxt, x, ids, acc) -> return (ctxt, x :: l, ids, acc))
        (ctxt, [], ids, acc)
        l
      >>=? fun (ctxt, l, ids, acc) -> return (ctxt, List.rev l, ids, acc)
  | (Map_t (_, ty, _, true), ((module M) as m)) ->
      Lwt.return
        (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m))
      >>=? fun ctxt ->
      fold_left_s
        (fun (ctxt, m, ids, acc) (k, x) ->
          Lwt.return (Gas.consume ctxt Typecheck_costs.cycle)
          >>=? fun ctxt ->
          extract_big_map_updates ctxt fresh mode ids acc ty x
          >>=? fun (ctxt, x, ids, acc) ->
          return (ctxt, M.OPS.add k x m, ids, acc))
        (ctxt, M.OPS.empty, ids, acc)
        (M.OPS.bindings (fst M.boxed))
      >>=? fun (ctxt, m, ids, acc) ->
      let module M = struct
        module OPS = M.OPS

        type key = M.key

        type value = M.value

        let key_ty = M.key_ty

        let boxed = (m, snd M.boxed)
      end in
      return
        ( ctxt,
          (module M : Boxed_map with type key = M.key and type value = M.value),
          ids,
          acc )
  | (Option_t (_, _, true), None) ->
      return (ctxt, None, ids, acc)
  | (List_t (_, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Map_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Option_t (_, _, false), None) ->
      return (ctxt, None, ids, acc)
  | (Pair_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Union_t (_, _, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Option_t (_, _, false), v) ->
      return (ctxt, v, ids, acc)
  | (Chain_id_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Set_t (_, _), v) ->
      return (ctxt, v, ids, acc)
  | (Unit_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Int_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Nat_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Signature_t _, v) ->
      return (ctxt, v, ids, acc)
  | (String_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Bytes_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Mutez_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Key_hash_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Key_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Timestamp_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Address_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Bool_t _, v) ->
      return (ctxt, v, ids, acc)
  | (Lambda_t (_, _, _), v) ->
      return (ctxt, v, ids, acc)
  | (Contract_t (_, _), v) ->
      return (ctxt, v, ids, acc)
  | (Operation_t _, _) ->
      assert false

(* called only on parameters and storage, which cannot contain operations *)

let collect_big_maps ctxt ty x =
  let rec collect :
      type a. context -> a ty -> a -> Ids.t -> (Ids.t * context) tzresult =
   fun ctxt ty x acc ->
    match (ty, x) with
    | (Big_map_t (_, _, _), {id = Some id}) ->
        Gas.consume ctxt Typecheck_costs.cycle
        >>? fun ctxt -> ok (Ids.add id acc, ctxt)
    | (Pair_t ((tyl, _, _), (tyr, _, _), _, true), (xl, xr)) ->
        collect ctxt tyl xl acc >>? fun (acc, ctxt) -> collect ctxt tyr xr acc
    | (Union_t ((ty, _), (_, _), _, true), L x) ->
        collect ctxt ty x acc
    | (Union_t ((_, _), (ty, _), _, true), R x) ->
        collect ctxt ty x acc
    | (Option_t (ty, _, true), Some x) ->
        collect ctxt ty x acc
    | (List_t (ty, _, true), l) ->
        List.fold_left
          (fun acc x -> acc >>? fun (acc, ctxt) -> collect ctxt ty x acc)
          (ok (acc, ctxt))
          l
    | (Map_t (_, ty, _, true), m) ->
        map_fold
          (fun _ v acc -> acc >>? fun (acc, ctxt) -> collect ctxt ty v acc)
          m
          (ok (acc, ctxt))
    | (List_t (_, _, false), _) ->
        ok (acc, ctxt)
    | (Map_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Big_map_t (_, _, _), {id = None}) ->
        ok (acc, ctxt)
    | (Option_t (_, _, true), None) ->
        ok (acc, ctxt)
    | (Option_t (_, _, false), _) ->
        ok (acc, ctxt)
    | (Union_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Pair_t (_, _, _, false), _) ->
        ok (acc, ctxt)
    | (Chain_id_t _, _) ->
        ok (acc, ctxt)
    | (Set_t (_, _), _) ->
        ok (acc, ctxt)
    | (Unit_t _, _) ->
        ok (acc, ctxt)
    | (Int_t _, _) ->
        ok (acc, ctxt)
    | (Nat_t _, _) ->
        ok (acc, ctxt)
    | (Signature_t _, _) ->
        ok (acc, ctxt)
    | (String_t _, _) ->
        ok (acc, ctxt)
    | (Bytes_t _, _) ->
        ok (acc, ctxt)
    | (Mutez_t _, _) ->
        ok (acc, ctxt)
    | (Key_hash_t _, _) ->
        ok (acc, ctxt)
    | (Key_t _, _) ->
        ok (acc, ctxt)
    | (Timestamp_t _, _) ->
        ok (acc, ctxt)
    | (Address_t _, _) ->
        ok (acc, ctxt)
    | (Bool_t _, _) ->
        ok (acc, ctxt)
    | (Lambda_t (_, _, _), _) ->
        ok (acc, ctxt)
    | (Contract_t (_, _), _) ->
        ok (acc, ctxt)
    | (Operation_t _, _) ->
        assert false
   (* called only on parameters and storage, which cannot contain operations *)
  in
  Lwt.return (collect ctxt ty x no_big_map_id)

let extract_big_map_diff ctxt mode ~temporary ~to_duplicate ~to_update ty v =
  let to_duplicate = Ids.diff to_duplicate to_update in
  let fresh =
    if temporary then fun c -> return (Big_map.fresh_temporary c)
    else Big_map.fresh
  in
  extract_big_map_updates ctxt fresh mode to_duplicate [] ty v
  >>=? fun (ctxt, v, alive, diffs) ->
  let diffs =
    if temporary then diffs
    else
      let dead = Ids.diff to_update alive in
      Ids.fold (fun id acc -> Contract.Clear id :: acc) dead [] :: diffs
  in
  match diffs with
  | [] ->
      return (v, None, ctxt)
  | diffs ->
      return (v, Some (List.flatten diffs (* do not reverse *)), ctxt)

let list_of_big_map_ids ids = Ids.elements ids
src/proto_alpha/lib_protocol/script_ir_translator.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Micheline.

Import Script.

Import Script_typed_ir.

Import Script_tc_errors.

Import Script_ir_annot.

(* ❌ This kind of module is not handled. *)
unhandled_module

(* ❌ This kind of module is not handled. *)
unhandled_module

Inductive ex_comparable_ty : Type :=
| Ex_comparable_ty : forall {a : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) -> ex_comparable_ty.

Inductive ex_ty : Type :=
| Ex_ty : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.ty a) ->
  ex_ty.

Inductive ex_stack_ty : Type :=
| Ex_stack_ty : forall {a : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) -> ex_stack_ty.

Inductive tc_context : Type :=
| Lambda : tc_context
| Dip : forall {a : Type}, (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
  -> tc_context -> tc_context
| Toplevel : forall {param sto : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty sto) ->
  (Tezos_raw_protocol_alpha.Script_typed_ir.ty param) -> (option string) -> bool
  -> tc_context.

Inductive unparsing_mode : Type :=
| Optimized : unparsing_mode
| Readable : unparsing_mode.

Definition type_logger :=
  Z ->
    (list
      (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
        Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) ->
      (list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) -> unit.

Definition add_dip {A : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (prev : tc_context) : tc_context :=
  match prev with
  | Lambda | Toplevel _ =>
    Dip
      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty
        Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t annot) prev
  | Dip stack _ =>
    Dip (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty stack annot) prev
  end.

Fixpoint comparable_type_size {a t : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct t a) : Z :=
  match ty with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key _ (t, _) _ =>
    op_plus 1 (comparable_type_size t)
  end.

Fixpoint type_size {t : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) : Z :=
  match ty with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (l, _, _) (r, _, _) _ _ =>
    op_plus (op_plus 1 (type_size l)) (type_size r)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (l, _) (r, _) _ _ =>
    op_plus (op_plus 1 (type_size l)) (type_size r)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t arg ret _ =>
    op_plus (op_plus 1 (type_size arg)) (type_size ret)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _ =>
    op_plus 1 (type_size t)
  | Tezos_raw_protocol_alpha.Script_typed_ir.List_t t _ _ =>
    op_plus 1 (type_size t)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_t k _ =>
    op_plus 1 (comparable_type_size k)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_t k v _ _ =>
    op_plus (op_plus 1 (comparable_type_size k)) (type_size v)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t k v _ =>
    op_plus (op_plus 1 (comparable_type_size k)) (type_size v)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t arg _ =>
    op_plus 1 (type_size arg)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _ => 1
  end.

Fixpoint type_size_of_stack_head {st : Type}
  (stack : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty st) (up_to : Z)
  : Z :=
  match stack with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Item_t head tail _annot =>
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        up_to 0 then
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
        (type_size head) (type_size_of_stack_head tail (op_minus up_to 1))
    else
      0
  end.

Definition number_of_generated_growing_types {a b : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.instr b a)
  : Z :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Drop => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Dup => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Swap => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Const _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Car => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Cdr => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.If_none _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Left => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Right => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.If_left _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nil => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.If_cons _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.List_map _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.List_size => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.List_iter _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_update => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_size => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map _ _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_map _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_get => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_update => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_size => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map _ _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_size => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Or => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.And => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Xor => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Not => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.And_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Not_int => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Seq _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.If _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Loop _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Dip _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Exec => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Apply _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Failwith _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nop => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Compare _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Eq => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Neq => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lt => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Gt => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Le => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Ge => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Contract _ _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Create_account => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract _ _ _ _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2 _ _ _ _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Now => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Balance => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Sha256 => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Sha512 => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Source => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Sender => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Self _ _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Amount => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pack _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Unpack _ => 1
  | Tezos_raw_protocol_alpha.Script_typed_ir.Dig _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Dug _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Dipn _ _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.Dropn _ _ => 0
  | Tezos_raw_protocol_alpha.Script_typed_ir.ChainId => 0
  end.

Definition location {A B : Type}
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B) : A :=
  let
    'Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc _ _ _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.String loc _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc _ :=
    function_parameter in
  loc.

Definition kind {A B : Type}
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_raw_protocol_alpha.Script_tc_errors.kind :=
  match function_parameter with
  | Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ =>
    Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _ =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ _ _ =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _ =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind
  end.

Definition namespace
  (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_raw_protocol_alpha.Script_tc_errors.namespace :=
  match function_parameter with
  |
    Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter |
      Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage |
      Tezos_raw_protocol_alpha.Alpha_context.Script.K_code =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Keyword_namespace
  |
    Tezos_raw_protocol_alpha.Alpha_context.Script.D_False |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_None |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_True |
      Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
  |
    Tezos_raw_protocol_alpha.Alpha_context.Script.I_PACK |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNPACK |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHAIN_ID |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_BIG_MAP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_APPLY |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SELF |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SET_DELEGATE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP_LEFT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADDRESS |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONTRACT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ISNAT |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAST |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_RENAME |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG |
      Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace
  |
    Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_int |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_key |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_list |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_map |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_option |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_or |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_set |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_string |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_address |
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id =>
    Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace
  end.

Definition unexpected
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_raw_protocol_alpha.Alpha_context.Script.location
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  (exp_kinds : list Tezos_raw_protocol_alpha.Script_tc_errors.kind)
  (exp_ns : Tezos_raw_protocol_alpha.Script_tc_errors.namespace)
  (exp_prims : list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
  match expr with
  | Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
      (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
      Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.String loc _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
      (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
      Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
      (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
      Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc _ =>
    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind loc
      (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind exp_kinds)
      Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind
  | Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name _ _ =>
    match ((namespace name), exp_ns) with
    |
      (Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace,
        Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace) |
        (Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace,
          Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace) |
        (Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace,
          Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
        loc exp_prims name
    | (ns, _) =>
      Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_namespace
        loc name exp_ns ns
    end
  end.

Definition check_kind {A : Type}
  (kinds : list Tezos_raw_protocol_alpha.Script_tc_errors.kind)
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_raw_protocol_alpha.Alpha_context.Script.location A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let kind := kind expr in
  if List.mem kind kinds then
    return_unit
  else
    let loc := location expr in
    fail
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
        loc kinds kind).

Definition wrap_compare {A B : Type}
  (compare :
    A ->
      B ->
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (a : A) (b : B) : Z :=
  let res := compare a b in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      res 0 then
    0
  else
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
        res 0 then
      1
    else
      (-1).

Fixpoint compare_comparable {a s : Type}
  (kind : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
  : a -> a -> Z :=
  match kind with
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_key _ =>
    wrap_compare
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _ =>
    wrap_compare
      Tezos_protocol_environment_alpha__Environment.Compare.Bool.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _ =>
    wrap_compare Tez.compare
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _ =>
    wrap_compare Signature.Public_key_hash.compare
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _ =>
    wrap_compare Script_int.compare
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _ =>
    wrap_compare Script_int.compare
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _ =>
    wrap_compare Script_timestamp.compare
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _ =>
    op_atat wrap_compare
      (fun function_parameter =>
        let '(x, ex) := function_parameter in
        fun function_parameter =>
          let '(y, ey) := function_parameter in
          let lres := Contract.compare x y in
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              lres 0 then
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
              ex ey
          else
            lres)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _ =>
    wrap_compare MBytes.compare
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (tl, _) (tr, _) _ =>
    fun function_parameter =>
      let '(lx, rx) := function_parameter in
      fun function_parameter =>
        let '(ly, ry) := function_parameter in
        let lres := compare_comparable tl lx ly in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            lres 0 then
          compare_comparable tr rx ry
        else
          lres
  end.

Definition empty_set {a : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
  : Tezos_raw_protocol_alpha.Script_typed_ir.set a :=
  let OPS :=
    (* ❌ Applications of functors are not supported for first-class module values *)
    unsupported_functor_application in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty := ty;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS := OPS;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed := OPS.empty;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size := 0
      |}.

Definition set_update {a : Type}
  (v : a) (b : bool) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set a)
  : Tezos_raw_protocol_alpha.Script_typed_ir.set a :=
  let Box := projT2 Box in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.elt_ty);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed :=
        if b then
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.add)
            v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed)
        else
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.remove)
            v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size :=
        let mem :=
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
            v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed) in
        if mem then
          if b then
            Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)
          else
            op_minus
              Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size) 1
        else
          if b then
            op_plus
              Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size) 1
          else
            Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)
      |}.

Definition set_mem {elt : Type}
  (v : elt) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt) : bool :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
    v Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed).

Definition set_fold {acc elt : Type}
  (f : elt -> acc -> acc)
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt) : acc -> acc :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.OPS).(Tezos_protocol_environment_alpha__Environment.SET.S.fold)
    f Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.boxed).

Definition set_size {elt : Type}
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.set elt)
  : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
    Tezos_raw_protocol_alpha.Alpha_context.Script_int.n :=
  let Box := projT2 Box in
  abs (of_int Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_set.size)).

Definition map_key_ty {a b : Type}
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
  : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty).

Definition empty_map {a b : Type}
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
  : Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
  let OPS :=
    (* ❌ Applications of functors are not supported for first-class module values *)
    unsupported_functor_application in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty := ty;
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS := OPS;
      (* ❌ This kind of definition of value for first-class modules is not handled *)
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed := unhandled
      |}.

Definition map_get {key value : Type}
  (k : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
  : option value :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.find_opt)
    k (fst Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).

Definition map_update {a b : Type}
  (k : a) (v : option b)
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
  : Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
  let Box := projT2 Box in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed :=
        let '(map, size) :=
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed) in
        let contains :=
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
            k map in
        match v with
        | Some v =>
          ((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
            k v map),
            (op_plus size
              (if contains then
                0
              else
                1)))
        | None =>
          ((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.remove)
            k map),
            (op_minus size
              (if contains then
                1
              else
                0)))
        end
      |}.

Definition map_set {a b : Type}
  (k : a) (v : b) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map a b)
  : Tezos_raw_protocol_alpha.Script_typed_ir.map a b :=
  let Box := projT2 Box in
  existT _ _
    {|
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS :=
        Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
      Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed :=
        let '(map, size) :=
          Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed) in
        ((Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
          k v map),
          (if
            Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
              k map then
            size
          else
            op_plus size 1))
      |}.

Definition map_mem {key value : Type}
  (k : key) (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
  : bool :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
    k (fst Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).

Definition map_fold {acc key value : Type}
  (f : key -> value -> acc -> acc)
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value) : acc -> acc :=
  let Box := projT2 Box in
  Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.fold)
    f (fst Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)).

Definition map_size {key value : Type}
  (Box : Tezos_raw_protocol_alpha.Script_typed_ir.map key value)
  : Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
    Tezos_raw_protocol_alpha.Alpha_context.Script_int.n :=
  let Box := projT2 Box in
  abs
    (of_int (snd Box.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))).

Fixpoint ty_of_comparable_ty {a s : Type}
  (function_parameter :
    Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
  : Tezos_raw_protocol_alpha.Script_typed_ir.ty a :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (l, al) (r, ar) tname =>
    Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
      ((ty_of_comparable_ty l), al, None) ((ty_of_comparable_ty r), ar, None)
      tname false
  end.

Fixpoint comparable_ty_of_ty {a : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  : option (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a) :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname =>
    Some (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname)
  |
    Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (l, al, _) (r, ar, _) pname
      _ =>
    match comparable_ty_of_ty r with
    | None => None
    | Some rty =>
      match comparable_ty_of_ty l with
      | None => None
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key _ _ _) => None
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname), al)
            (rty, ar) pname)
      | Some (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname) =>
        Some
          (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key
            ((Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname), al)
            (rty, ar) pname)
      end
    end
  | _ => None
  end.

Definition add_field_annot {A B : Type}
  (a : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (var : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
  match function_parameter with
  |
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
      annots =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim args
      (op_at annots (op_at (unparse_field_annot a) (unparse_var_annot var)))
  | expr => expr
  end.

Fixpoint unparse_comparable_ty {a s : Type}
  (function_parameter :
    Tezos_raw_protocol_alpha.Script_typed_ir.comparable_struct a s)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_int []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_string []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_address []
      (unparse_type_annot tname)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_key (l, al) (r, ar) pname =>
    let tl := add_field_annot al None (unparse_comparable_ty l) in
    let tr := add_field_annot ar None (unparse_comparable_ty r) in
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1)
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
      (cons tl (cons tr [])) (unparse_type_annot pname)
  end.

Fixpoint unparse_ty_no_lwt {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  op_gtgtquestion (Gas.consume ctxt Unparse_costs.cycle)
    (fun ctxt =>
      let _return {B : Type}
        (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
        (function_parameter :
        B *
          (list
            (Tezos_protocol_environment_alpha__Environment.Micheline.node Z B))
          * Tezos_protocol_environment_alpha__Environment.Micheline.annot)
        : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node Z B) *
            Tezos_raw_protocol_alpha__Alpha_context.context) :=
        let '(name, args, annot) := function_parameter in
        let result :=
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim (-1) name
            args annot in
        op_gtgtquestion
          (Gas.consume ctxt (Unparse_costs.prim_cost (List.length args) annot))
          (fun ctxt => ok (result, ctxt)) in
      match ty with
      | Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_int, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_string, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_key, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_address, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tname =>
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id, [],
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t ut tname =>
        op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            let '(t, ctxt) := function_parameter in
            _return ctxt
              (Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract,
                (cons t []), (unparse_type_annot tname)))
      |
        Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (utl, l_field, l_var)
          (utr, r_field, r_var) tname _ =>
        let annot := unparse_type_annot tname in
        op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
          (fun function_parameter =>
            let '(utl, ctxt) := function_parameter in
            let tl := add_field_annot l_field l_var utl in
            op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
              (fun function_parameter =>
                let '(utr, ctxt) := function_parameter in
                let tr := add_field_annot r_field r_var utr in
                _return ctxt
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair,
                    (cons tl (cons tr [])), annot)))
      |
        Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (utl, l_field)
          (utr, r_field) tname _ =>
        let annot := unparse_type_annot tname in
        op_gtgtquestion (unparse_ty_no_lwt ctxt utl)
          (fun function_parameter =>
            let '(utl, ctxt) := function_parameter in
            let tl := add_field_annot l_field None utl in
            op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
              (fun function_parameter =>
                let '(utr, ctxt) := function_parameter in
                let tr := add_field_annot r_field None utr in
                _return ctxt
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.T_or,
                    (cons tl (cons tr [])), annot)))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t uta utr tname =>
        op_gtgtquestion (unparse_ty_no_lwt ctxt uta)
          (fun function_parameter =>
            let '(ta, ctxt) := function_parameter in
            op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
              (fun function_parameter =>
                let '(tr, ctxt) := function_parameter in
                _return ctxt
                  (Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda,
                    (cons ta (cons tr [])), (unparse_type_annot tname))))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ut tname _ =>
        let annot := unparse_type_annot tname in
        op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            let '(ut, ctxt) := function_parameter in
            _return ctxt
              (Tezos_raw_protocol_alpha.Alpha_context.Script.T_option,
                (cons ut []), annot))
      | Tezos_raw_protocol_alpha.Script_typed_ir.List_t ut tname _ =>
        op_gtgtquestion (unparse_ty_no_lwt ctxt ut)
          (fun function_parameter =>
            let '(t, ctxt) := function_parameter in
            _return ctxt
              (Tezos_raw_protocol_alpha.Alpha_context.Script.T_list,
                (cons t []), (unparse_type_annot tname)))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Set_t ut tname =>
        let t := unparse_comparable_ty ut in
        _return ctxt
          (Tezos_raw_protocol_alpha.Alpha_context.Script.T_set, (cons t []),
            (unparse_type_annot tname))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Map_t uta utr tname _ =>
        let ta := unparse_comparable_ty uta in
        op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
          (fun function_parameter =>
            let '(tr, ctxt) := function_parameter in
            _return ctxt
              (Tezos_raw_protocol_alpha.Alpha_context.Script.T_map,
                (cons ta (cons tr [])), (unparse_type_annot tname)))
      | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t uta utr tname =>
        let ta := unparse_comparable_ty uta in
        op_gtgtquestion (unparse_ty_no_lwt ctxt utr)
          (fun function_parameter =>
            let '(tr, ctxt) := function_parameter in
            _return ctxt
              (Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map,
                (cons ta (cons tr [])), (unparse_type_annot tname)))
      end).

Definition unparse_ty {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  Lwt._return (unparse_ty_no_lwt ctxt ty).

Fixpoint strip_var_annots {A B : Type}
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
  match function_parameter with
  |
    (Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as atom
    => atom
  | Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc args =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
      (List.map strip_var_annots args)
  |
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name args
      annots =>
    let not_var_annot (s : string) : bool :=
      Tezos_protocol_environment_alpha__Environment.Compare.Char.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
        (String.get s 0) "@" % char in
    let annots := List.filter not_var_annot annots in
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name
      (List.map strip_var_annots args) annots
  end.

Definition serialize_ty_for_error {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  op_gtpipequestion
    (op_pipegt (unparse_ty_no_lwt ctxt ty)
      (record_trace
        Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_error))
    (fun function_parameter =>
      let '(ty, ctxt) := function_parameter in
      ((strip_locations (strip_var_annots ty)), ctxt)).

Fixpoint unparse_stack {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t => _return ([], ctxt)
  | Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty rest annot =>
    op_gtgteqquestion (unparse_ty ctxt ty)
      (fun function_parameter =>
        let '(uty, ctxt) := function_parameter in
        op_gtgteqquestion (unparse_stack ctxt rest)
          (fun function_parameter =>
            let '(urest, ctxt) := function_parameter in
            _return
              ((cons ((strip_locations uty), (unparse_var_annot annot)) urest),
                ctxt)))
  end.

Definition serialize_stack_for_error {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (stack_ty : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list
        (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
          Tezos_raw_protocol_alpha.Alpha_context.Script.annot)) *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  trace
    Tezos_protocol_environment_alpha__Environment.Error_monad.Cannot_serialize_error
    (unparse_stack ctxt stack_ty).

Definition name_of_ty {a : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  : option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ tname _ => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ tname _ => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ tname _ => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ tname _ => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ tname => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ tname _ => tname
  | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ tname => tname
  end.

Inductive eq : forall (ta tb : Type), Type :=
| Eq : forall {same : Type}, eq same same.

Definition comparable_ty_eq {ta tb : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty tb)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (eq (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty tb)) :=
  match (ta, tb) with
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Int_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.String_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.String_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Address_key _) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok Eq
  | (_, _) =>
    op_gtgtquestion (serialize_ty_for_error ctxt (ty_of_comparable_ty ta))
      (fun function_parameter =>
        let '(ta, ctxt) := function_parameter in
        op_gtgtquestion (serialize_ty_for_error ctxt (ty_of_comparable_ty tb))
          (fun function_parameter =>
            let '(tb, _ctxt) := function_parameter in
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
                ta tb)))
  end.

Definition record_inconsistent {A B C : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  : (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C :=
  record_trace_eval
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion (serialize_ty_for_error ctxt ta)
        (fun function_parameter =>
          let '(ta, ctxt) := function_parameter in
          op_gtpipequestion (serialize_ty_for_error ctxt tb)
            (fun function_parameter =>
              let '(tb, _ctxt) := function_parameter in
              Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
                ta tb))).

Definition record_inconsistent_type_annotations {A B C : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  : (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C :=
  record_trace_eval
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgtquestion (serialize_ty_for_error ctxt ta)
        (fun function_parameter =>
          let '(ta, ctxt) := function_parameter in
          op_gtpipequestion (serialize_ty_for_error ctxt tb)
            (fun function_parameter =>
              let '(tb, _ctxt) := function_parameter in
              Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_type_annotations
                loc ta tb))).

Fixpoint ty_eq {ta tb : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let ok
    (eq :
    eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) (ctxt :
    Tezos_raw_protocol_alpha__Alpha_context.context) (nb_args : Z)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.ty ta)
        (Tezos_raw_protocol_alpha.Script_typed_ir.ty tb)) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    op_gtgtquestion
      (Gas.consume ctxt (Typecheck_costs.type_ (op_star 2 nb_args)))
      (fun ctxt =>
        Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (eq, ctxt))
    in
  op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      match (ta, tb) with
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.String_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _) =>
        ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _) =>
        ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _) => ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _) =>
        ok Eq ctxt 0
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tal tar _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tbl tbr _ _) =>
        op_pipegt
          (op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tal tar _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tbl tbr _) =>
        op_pipegt
          (op_gtgtquestion (comparable_ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t ea _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Set_t eb _) =>
        op_pipegt
          (op_gtgtquestion (comparable_ty_eq ctxt ea eb)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tal, _, _) (tar, _, _)
          _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tbl, _, _)
            (tbr, _, _) _ _) =>
        op_pipegt
          (op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tal, _) (tar, _) _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tbl, _) (tbr, _) _ _)
        =>
        op_pipegt
          (op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tal tar _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tbl tbr _) =>
        op_pipegt
          (op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar tbr)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  ok Eq ctxt 2))) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tal _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tbl _) =>
        op_pipegt
          (op_gtgtquestion (ty_eq ctxt tal tbl)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tva _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tvb _ _) =>
        op_pipegt
          (op_gtgtquestion (ty_eq ctxt tva tvb)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.List_t tva _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.List_t tvb _ _) =>
        op_pipegt
          (op_gtgtquestion (ty_eq ctxt tva tvb)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              ok Eq ctxt 1)) (record_inconsistent ctxt ta tb)
      | (_, _) =>
        op_gtgtquestion (serialize_ty_for_error ctxt ta)
          (fun function_parameter =>
            let '(ta, ctxt) := function_parameter in
            op_gtgtquestion (serialize_ty_for_error ctxt tb)
              (fun function_parameter =>
                let '(tb, _ctxt) := function_parameter in
                error
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_types
                    ta tb)))
      end).

Fixpoint stack_ty_eq {ta tb : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (lvl : Z)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tb)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((eq (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta)
      (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tb)) *
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match (ta, tb) with
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tva ra _,
      Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tvb rb _) =>
    op_gtgtquestion
      (op_pipegt (ty_eq ctxt tva tvb)
        (record_trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
            lvl)))
      (fun function_parameter =>
        let '(Eq, ctxt) := function_parameter in
        op_gtgtquestion (stack_ty_eq ctxt (op_plus lvl 1) ra rb)
          (fun function_parameter =>
            let '(Eq, ctxt) := function_parameter in
            Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
              (Eq, ctxt)))
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t,
      Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t) =>
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (Eq, ctxt)
  | (_, _) =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_length
  end.

Definition merge_comparable_types {ta : Type}
  (legacy : bool)
  (ta : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
  (tb : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty ta) :=
  match (ta, tb) with
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Int_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Int_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.String_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.String_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.String_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key annot)
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key annot_a,
      Tezos_raw_protocol_alpha.Script_typed_ir.Address_key annot_b) =>
    op_gtpipequestion (merge_type_annot legacy annot_a annot_b)
      (fun annot => Tezos_raw_protocol_alpha.Script_typed_ir.Address_key annot)
  | (_, _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition merge_types {b : Type} (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.context ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.location ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
        (Tezos_raw_protocol_alpha.Script_typed_ir.ty b) ->
          Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_typed_ir.ty b) *
              Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let fix help {a : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (ty1 :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (ty2 :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((Tezos_raw_protocol_alpha.Script_typed_ir.ty a) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    match (ty1, ty2) with
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Key_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Address_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tn2) =>
      op_gtpipequestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          ((Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t tname), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tal tar tn1 has_big_map,
        Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tbl tbr tn2 _) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtgtquestion (help ctxt tar tbr)
            (fun function_parameter =>
              let '(value, ctxt) := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar value)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  op_gtpipequestion (merge_comparable_types legacy tal tbl)
                    (fun tk =>
                      ((Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tk value
                        tname has_big_map), ctxt)))))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tal tar tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tbl tbr tn2) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtgtquestion (help ctxt tar tbr)
            (fun function_parameter =>
              let '(value, ctxt) := function_parameter in
              op_gtgtquestion (ty_eq ctxt tar value)
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  op_gtpipequestion (merge_comparable_types legacy tal tbl)
                    (fun tk =>
                      ((Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk
                        value tname), ctxt)))))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t ea tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Set_t eb tn2) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtpipequestion (merge_comparable_types legacy ea eb)
            (fun e =>
              ((Tezos_raw_protocol_alpha.Script_typed_ir.Set_t e tname), ctxt)))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tal, l_field1, l_var1)
        (tar, r_field1, r_var1) tn1 has_big_map,
        Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tbl, l_field2, l_var2)
          (tbr, r_field2, r_var2) tn2 _) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtgtquestion (merge_field_annot legacy l_field1 l_field2)
            (fun l_field =>
              op_gtgtquestion (merge_field_annot legacy r_field1 r_field2)
                (fun r_field =>
                  let l_var := merge_var_annot l_var1 l_var2 in
                  let r_var := merge_var_annot r_var1 r_var2 in
                  op_gtgtquestion (help ctxt tal tbl)
                    (fun function_parameter =>
                      let '(left_ty, ctxt) := function_parameter in
                      op_gtpipequestion (help ctxt tar tbr)
                        (fun function_parameter =>
                          let '(right_ty, ctxt) := function_parameter in
                          ((Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                            (left_ty, l_field, l_var) (right_ty, r_field, r_var)
                            tname has_big_map), ctxt))))))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tal, tal_annot)
        (tar, tar_annot) tn1 has_big_map,
        Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tbl, tbl_annot)
          (tbr, tbr_annot) tn2 _) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtgtquestion (merge_field_annot legacy tal_annot tbl_annot)
            (fun left_annot =>
              op_gtgtquestion (merge_field_annot legacy tar_annot tbr_annot)
                (fun right_annot =>
                  op_gtgtquestion (help ctxt tal tbl)
                    (fun function_parameter =>
                      let '(left_ty, ctxt) := function_parameter in
                      op_gtpipequestion (help ctxt tar tbr)
                        (fun function_parameter =>
                          let '(right_ty, ctxt) := function_parameter in
                          ((Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
                            (left_ty, left_annot) (right_ty, right_annot) tname
                            has_big_map), ctxt))))))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tal tar tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t tbl tbr tn2) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtgtquestion (help ctxt tal tbl)
            (fun function_parameter =>
              let '(left_ty, ctxt) := function_parameter in
              op_gtpipequestion (help ctxt tar tbr)
                (fun function_parameter =>
                  let '(right_ty, ctxt) := function_parameter in
                  ((Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t left_ty
                    right_ty tname), ctxt))))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tal tn1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tbl tn2) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtpipequestion (help ctxt tal tbl)
            (fun function_parameter =>
              let '(arg_ty, ctxt) := function_parameter in
              ((Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t arg_ty tname),
                ctxt)))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tva tn1 has_big_map,
        Tezos_raw_protocol_alpha.Script_typed_ir.Option_t tvb tn2 _) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtpipequestion (help ctxt tva tvb)
            (fun function_parameter =>
              let '(ty, ctxt) := function_parameter in
              ((Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ty tname
                has_big_map), ctxt)))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.List_t tva tn1 has_big_map,
        Tezos_raw_protocol_alpha.Script_typed_ir.List_t tvb tn2 _) =>
      op_gtgtquestion (merge_type_annot legacy tn1 tn2)
        (fun tname =>
          op_gtpipequestion (help ctxt tva tvb)
            (fun function_parameter =>
              let '(ty, ctxt) := function_parameter in
              ((Tezos_raw_protocol_alpha.Script_typed_ir.List_t ty tname
                has_big_map), ctxt)))
    | (_, _) =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  fun ctxt =>
    fun loc =>
      fun ty1 =>
        fun ty2 =>
          record_inconsistent_type_annotations ctxt loc ty1 ty2
            (help ctxt ty1 ty2).

Definition merge_stacks {ta : Type}
  (legacy : bool) (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  : Tezos_raw_protocol_alpha.Alpha_context.context ->
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) ->
        Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty ta) *
            Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let fix help {a : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (stack1 :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) (stack2 :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty a) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    match (stack1, stack2) with
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t,
        Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t) =>
      ok (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t, ctxt)
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty1 rest1 annot1,
        Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty2 rest2 annot2) =>
      let annot := merge_var_annot annot1 annot2 in
      op_gtgtquestion (merge_types legacy ctxt loc ty1 ty2)
        (fun function_parameter =>
          let '(ty, ctxt) := function_parameter in
          op_gtpipequestion (help ctxt rest1 rest2)
            (fun function_parameter =>
              let '(rest, ctxt) := function_parameter in
              ((Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ty rest annot),
                ctxt)))
    end in
  help.

Definition has_big_map {t : Type}
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) : bool :=
  match function_parameter with
  | Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.String_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _ => true
  | Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _ => false
  | Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ has_big_map =>
    has_big_map
  | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ has_big_map =>
    has_big_map
  | Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ has_big_map =>
    has_big_map
  | Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ has_big_map =>
    has_big_map
  | Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ has_big_map =>
    has_big_map
  end.

Inductive judgement (bef : Type) : Type :=
| Typed : forall {aft : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) -> judgement bef
| Failed : forall {aft : Type},
  (((Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft) ->
    Tezos_raw_protocol_alpha.Script_typed_ir.descr bef aft) * (aft)) ->
  judgement bef.

Arguments Typed {_}.
Arguments Failed {_}.

Record branch {t f b : Type} := {
  branch :
    ((Tezos_raw_protocol_alpha.Script_typed_ir.descr t r) ->
      (Tezos_raw_protocol_alpha.Script_typed_ir.descr f r) ->
        Tezos_raw_protocol_alpha.Script_typed_ir.descr b r) * (r) }.
Arguments branch : clear implicits.

Definition merge_branches {a b bef : Type}
  (legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Z) (btr : judgement a) (bfr : judgement b)
  (function_parameter : branch a b bef)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let '{| branch := branch |} := function_parameter in
  match (btr, bfr) with
  | (Typed ({| aft := aftbt |} as dbt), Typed ({| aft := aftbf |} as dbf)) =>
    let unmatched_branches (function_parameter : unit)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
      let 'tt := function_parameter in
      op_gtgteqquestion (serialize_stack_for_error ctxt aftbt)
        (fun function_parameter =>
          let '(aftbt, ctxt) := function_parameter in
          op_gtgtpipequestion (serialize_stack_for_error ctxt aftbf)
            (fun function_parameter =>
              let '(aftbf, _ctxt) := function_parameter in
              Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
                loc aftbt aftbf)) in
    trace_eval unmatched_branches
      (op_gtgteqquestion (Lwt._return (stack_ty_eq ctxt 1 aftbt aftbf))
        (fun function_parameter =>
          let '(Eq, ctxt) := function_parameter in
          op_gtgteqquestion
            (Lwt._return (merge_stacks legacy loc ctxt aftbt aftbf))
            (fun function_parameter =>
              let '(merged_stack, ctxt) := function_parameter in
              _return
                ((Typed
                  (branch
                    (* ❌ Record substitution not handled *)
                    record_substitution
                    (* ❌ Record substitution not handled *)
                    record_substitution)), ctxt))))
  | (Failed {| descr := descrt |}, Failed {| descr := descrf |}) =>
    let descr {D : Type}
      (ret : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty D)
      : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef D :=
      branch (descrt ret) (descrf ret) in
    _return ((Failed {| descr := descr |}), ctxt)
  | (Typed dbt, Failed {| descr := descrf |}) =>
    _return ((Typed (branch dbt (descrf (aft dbt)))), ctxt)
  | (Failed {| descr := descrt |}, Typed dbf) =>
    _return ((Typed (branch (descrt (aft dbf)) dbf)), ctxt)
  end.

Fixpoint parse_comparable_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_comparable_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      op_gtgtquestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
        (fun ctxt =>
          match ty with
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_int [] annot =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Int_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat [] annot =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_string [] annot =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.String_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes [] annot =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez [] annot =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool [] annot =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash [] annot
            =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp [] annot
            =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.T_address [] annot
            =>
            op_gtpipequestion (parse_type_annot loc annot)
              (fun tname =>
                ((Ex_comparable_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Address_key tname)),
                  ctxt))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              ((Tezos_raw_protocol_alpha.Alpha_context.Script.T_int |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_string |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_key |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_address |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp) as
                prim) l _ =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
                loc prim 0 (List.length l))
          |
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              (Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_or |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_set |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_map |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_list |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_option |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature |
                Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract) _ _ =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
                loc (Micheline.strip_locations ty))
          | expr =>
            op_atat error
              (unexpected expr []
                Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_int
                  (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat
                    (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_string
                      (cons
                        Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez
                        (cons
                          Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool
                          (cons
                            Tezos_raw_protocol_alpha.Alpha_context.Script.T_key
                            (cons
                              Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash
                              (cons
                                Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp
                                [])))))))))
          end))

with parse_packable_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  parse_ty ctxt legacy false false legacy

with parse_parameter_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  parse_ty ctxt legacy true false true

with parse_any_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  parse_ty ctxt legacy true true true

with parse_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (allow_big_map : bool) (allow_operation : bool) (allow_contract : bool)
  (node : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      match node with
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_int [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_string [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.String_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_key [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_address [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation [] annot =>
        if allow_operation then
          op_gtgtquestion (parse_type_annot loc annot)
            (fun ty_name =>
              op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
                (fun ctxt =>
                  ((Ex_ty
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                      ty_name)), ctxt)))
        else
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
              loc)
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id [] annot =>
        op_gtgtquestion (parse_type_annot loc annot)
          (fun ty_name =>
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 0))
              (fun ctxt =>
                ((Ex_ty
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t ty_name)),
                  ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract (cons utl [])
          annot =>
        if allow_contract then
          op_gtgtquestion (parse_parameter_ty ctxt legacy utl)
            (fun function_parameter =>
              let '(Ex_ty tl, ctxt) := function_parameter in
              op_gtgtquestion (parse_type_annot loc annot)
                (fun ty_name =>
                  op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 1))
                    (fun ctxt =>
                      ((Ex_ty
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t tl
                          ty_name)), ctxt))))
        else
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_contract
              loc)
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
          (cons utl (cons utr [])) annot =>
        op_gtgtquestion (extract_field_annot utl)
          (fun function_parameter =>
            let '(utl, left_field) := function_parameter in
            op_gtgtquestion (extract_field_annot utr)
              (fun function_parameter =>
                let '(utr, right_field) := function_parameter in
                op_gtgtquestion
                  (parse_ty ctxt legacy allow_big_map allow_operation
                    allow_contract utl)
                  (fun function_parameter =>
                    let '(Ex_ty tl, ctxt) := function_parameter in
                    op_gtgtquestion
                      (parse_ty ctxt legacy allow_big_map allow_operation
                        allow_contract utr)
                      (fun function_parameter =>
                        let '(Ex_ty tr, ctxt) := function_parameter in
                        op_gtgtquestion (parse_type_annot loc annot)
                          (fun ty_name =>
                            op_gtpipequestion
                              (Gas.consume ctxt (Typecheck_costs.type_ 2))
                              (fun ctxt =>
                                ((Ex_ty
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                                    (tl, left_field, None)
                                    (tr, right_field, None) ty_name
                                    (op_pipepipe (has_big_map tl)
                                      (has_big_map tr)))), ctxt)))))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_or
          (cons utl (cons utr [])) annot =>
        op_gtgtquestion (extract_field_annot utl)
          (fun function_parameter =>
            let '(utl, left_constr) := function_parameter in
            op_gtgtquestion (extract_field_annot utr)
              (fun function_parameter =>
                let '(utr, right_constr) := function_parameter in
                op_gtgtquestion
                  (parse_ty ctxt legacy allow_big_map allow_operation
                    allow_contract utl)
                  (fun function_parameter =>
                    let '(Ex_ty tl, ctxt) := function_parameter in
                    op_gtgtquestion
                      (parse_ty ctxt legacy allow_big_map allow_operation
                        allow_contract utr)
                      (fun function_parameter =>
                        let '(Ex_ty tr, ctxt) := function_parameter in
                        op_gtgtquestion (parse_type_annot loc annot)
                          (fun ty_name =>
                            op_gtpipequestion
                              (Gas.consume ctxt (Typecheck_costs.type_ 2))
                              (fun ctxt =>
                                ((Ex_ty
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
                                    (tl, left_constr) (tr, right_constr) ty_name
                                    (op_pipepipe (has_big_map tl)
                                      (has_big_map tr)))), ctxt)))))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda
          (cons uta (cons utr [])) annot =>
        op_gtgtquestion (parse_any_ty ctxt legacy uta)
          (fun function_parameter =>
            let '(Ex_ty ta, ctxt) := function_parameter in
            op_gtgtquestion (parse_any_ty ctxt legacy utr)
              (fun function_parameter =>
                let '(Ex_ty tr, ctxt) := function_parameter in
                op_gtgtquestion (parse_type_annot loc annot)
                  (fun ty_name =>
                    op_gtpipequestion
                      (Gas.consume ctxt (Typecheck_costs.type_ 2))
                      (fun ctxt =>
                        ((Ex_ty
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t ta
                            tr ty_name)), ctxt)))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_option (cons ut [])
          annot =>
        op_gtgtquestion
          (if legacy then
            op_gtgtquestion (extract_field_annot ut)
              (fun function_parameter =>
                let '(ut, _some_constr) := function_parameter in
                op_gtgtquestion (parse_composed_type_annot loc annot)
                  (fun function_parameter =>
                    let '(ty_name, _none_constr, _) := function_parameter in
                    ok (ut, ty_name)))
          else
            op_gtgtquestion (parse_type_annot loc annot)
              (fun ty_name => ok (ut, ty_name)))
          (fun function_parameter =>
            let '(ut, ty_name) := function_parameter in
            op_gtgtquestion
              (parse_ty ctxt legacy allow_big_map allow_operation allow_contract
                ut)
              (fun function_parameter =>
                let '(Ex_ty t, ctxt) := function_parameter in
                op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 2))
                  (fun ctxt =>
                    ((Ex_ty
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t
                        ty_name (has_big_map t))), ctxt))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_list (cons ut [])
          annot =>
        op_gtgtquestion
          (parse_ty ctxt legacy allow_big_map allow_operation allow_contract ut)
          (fun function_parameter =>
            let '(Ex_ty t, ctxt) := function_parameter in
            op_gtgtquestion (parse_type_annot loc annot)
              (fun ty_name =>
                op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 1))
                  (fun ctxt =>
                    ((Ex_ty
                      (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
                        (has_big_map t))), ctxt))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_set (cons ut []) annot
        =>
        op_gtgtquestion (parse_comparable_ty ctxt ut)
          (fun function_parameter =>
            let '(Ex_comparable_ty t, ctxt) := function_parameter in
            op_gtgtquestion (parse_type_annot loc annot)
              (fun ty_name =>
                op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 1))
                  (fun ctxt =>
                    ((Ex_ty
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t ty_name)),
                      ctxt))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_map
          (cons uta (cons utr [])) annot =>
        op_gtgtquestion (parse_comparable_ty ctxt uta)
          (fun function_parameter =>
            let '(Ex_comparable_ty ta, ctxt) := function_parameter in
            op_gtgtquestion
              (parse_ty ctxt legacy allow_big_map allow_operation allow_contract
                utr)
              (fun function_parameter =>
                let '(Ex_ty tr, ctxt) := function_parameter in
                op_gtgtquestion (parse_type_annot loc annot)
                  (fun ty_name =>
                    op_gtpipequestion
                      (Gas.consume ctxt (Typecheck_costs.type_ 2))
                      (fun ctxt =>
                        ((Ex_ty
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ta tr
                            ty_name (has_big_map tr))), ctxt)))))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map args annot =>
        op_gtgtquestion (parse_big_map_ty ctxt legacy loc args annot)
          (fun function_parameter =>
            let '(big_map_ty, ctxt) := function_parameter in
            op_gtpipequestion (Gas.consume ctxt (Typecheck_costs.type_ 2))
              (fun ctxt => (big_map_ty, ctxt)))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map _ _ =>
        error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
            loc)
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_int |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_string |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_key |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_address) as prim) l
          _ =>
        error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc prim 0 (List.length l))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.T_set |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_list |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_option |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract) as prim) l
          _ =>
        error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc prim 1 (List.length l))
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_or |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_map |
            Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda) as prim) l _
        =>
        error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc prim 2 (List.length l))
      | expr =>
        op_atat error
          (unexpected expr []
            Tezos_raw_protocol_alpha.Script_tc_errors.Type_namespace
            (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_or
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_set
                  (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_map
                    (cons Tezos_raw_protocol_alpha.Alpha_context.Script.T_list
                      (cons
                        Tezos_raw_protocol_alpha.Alpha_context.Script.T_option
                        (cons
                          Tezos_raw_protocol_alpha.Alpha_context.Script.T_lambda
                          (cons
                            Tezos_raw_protocol_alpha.Alpha_context.Script.T_unit
                            (cons
                              Tezos_raw_protocol_alpha.Alpha_context.Script.T_signature
                              (cons
                                Tezos_raw_protocol_alpha.Alpha_context.Script.T_contract
                                (cons
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.T_int
                                  (cons
                                    Tezos_raw_protocol_alpha.Alpha_context.Script.T_nat
                                    (cons
                                      Tezos_raw_protocol_alpha.Alpha_context.Script.T_operation
                                      (cons
                                        Tezos_raw_protocol_alpha.Alpha_context.Script.T_string
                                        (cons
                                          Tezos_raw_protocol_alpha.Alpha_context.Script.T_bytes
                                          (cons
                                            Tezos_raw_protocol_alpha.Alpha_context.Script.T_mutez
                                            (cons
                                              Tezos_raw_protocol_alpha.Alpha_context.Script.T_bool
                                              (cons
                                                Tezos_raw_protocol_alpha.Alpha_context.Script.T_key
                                                (cons
                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.T_key_hash
                                                  (cons
                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.T_timestamp
                                                    (cons
                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.T_chain_id
                                                      []))))))))))))))))))))))
      end)

with parse_big_map_ty
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (legacy : bool)
  (big_map_loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (args :
    list
      (Tezos_protocol_environment_alpha__Environment.Micheline.node
        Tezos_raw_protocol_alpha.Alpha_context.Script.location
        Tezos_raw_protocol_alpha.Alpha_context.Script.prim))
  (map_annot : Tezos_protocol_environment_alpha__Environment.Micheline.annot)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_ty * Tezos_raw_protocol_alpha__Alpha_context.context) :=
  op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
    (fun ctxt =>
      match args with
      | cons key_ty (cons value_ty []) =>
        op_gtgtquestion (parse_comparable_ty ctxt key_ty)
          (fun function_parameter =>
            let '(Ex_comparable_ty key_ty, ctxt) := function_parameter in
            op_gtgtquestion (parse_packable_ty ctxt legacy value_ty)
              (fun function_parameter =>
                let '(Ex_ty value_ty, ctxt) := function_parameter in
                op_gtpipequestion (parse_type_annot big_map_loc map_annot)
                  (fun map_name =>
                    let big_map_ty :=
                      Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t key_ty
                        value_ty map_name in
                    ((Ex_ty big_map_ty), ctxt))))
      | args =>
        op_atat error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            big_map_loc Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map
            2 (List.length args))
      end)

with parse_storage_ty
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (node : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (ex_ty * Tezos_raw_protocol_alpha.Alpha_context.context) :=
  match node with
  |
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
      Tezos_raw_protocol_alpha.Alpha_context.Script.T_pair
      (cons
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
          big_map_loc Tezos_raw_protocol_alpha.Alpha_context.Script.T_big_map
          args map_annot) (cons remaining_storage [])) storage_annot =>
    match storage_annot with
    | [] => parse_ty ctxt legacy true false legacy node
    | cons single [] => parse_ty ctxt legacy true false legacy node
    | _ =>
      op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
        (fun ctxt =>
          op_gtgtquestion
            (parse_big_map_ty ctxt legacy big_map_loc args map_annot)
            (fun function_parameter =>
              let '(Ex_ty big_map_ty, ctxt) := function_parameter in
              op_gtgtquestion
                (parse_ty ctxt legacy true false legacy remaining_storage)
                (fun function_parameter =>
                  let '(Ex_ty remaining_storage, ctxt) := function_parameter in
                  op_gtgtquestion (parse_composed_type_annot loc storage_annot)
                    (fun function_parameter =>
                      let '(ty_name, map_field, storage_field) :=
                        function_parameter in
                      op_gtpipequestion
                        (Gas.consume ctxt (Typecheck_costs.type_ 5))
                        (fun ctxt =>
                          ((Ex_ty
                            (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                              (big_map_ty, map_field, None)
                              (remaining_storage, storage_field, None) ty_name
                              true)), ctxt))))))
    end
  | _ => parse_ty ctxt legacy true false legacy node
  end.

Definition check_packable {A : Type}
  (legacy : bool) (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (root : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  let fix check {t : Type}
    (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.ty t)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
    match function_parameter with
    | Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_big_map
          loc)
    | Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_operation
          loc)
    | Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.String_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _ => ok tt
    |
      Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (l_ty, _, _) (r_ty, _, _)
        _ _ =>
      op_gtgtquestion (check l_ty)
        (fun function_parameter =>
          let 'tt := function_parameter in
          check r_ty)
    | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (l_ty, _) (r_ty, _) _ _
      =>
      op_gtgtquestion (check l_ty)
        (fun function_parameter =>
          let 'tt := function_parameter in
          check r_ty)
    | Tezos_raw_protocol_alpha.Script_typed_ir.Option_t v_ty _ _ => check v_ty
    | Tezos_raw_protocol_alpha.Script_typed_ir.List_t elt_ty _ _ => check elt_ty
    | Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ elt_ty _ _ =>
      check elt_ty
    | Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _l_ty _r_ty _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _ => ok tt
    | Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_contract
          loc)
    end in
  check root.

Inductive ex_script : Type :=
| Ex_script : forall {a c : Type},
  (Tezos_raw_protocol_alpha.Script_typed_ir.script a c) -> ex_script.

Inductive dig_proof_argument : forall (_ : Type), Type :=
| Dig_proof_argument : forall {aft bef rest x : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    (x * rest) rest bef aft) *
    ((Tezos_raw_protocol_alpha.Script_typed_ir.ty x) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dig_proof_argument bef.

Inductive dug_proof_argument : forall (_ _ : Type), Type :=
| Dug_proof_argument : forall {aft bef rest x : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    rest (x * rest) bef aft) * unit *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dug_proof_argument bef x.

Inductive dipn_proof_argument : forall (_ : Type), Type :=
| Dipn_proof_argument : forall {aft bef faft fbef : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    fbef faft bef aft) *
    (Tezos_raw_protocol_alpha.Alpha_context.context *
      (Tezos_raw_protocol_alpha.Script_typed_ir.descr fbef faft)) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dipn_proof_argument bef.

Inductive dropn_proof_argument : forall (_ : Type), Type :=
| Dropn_proof_argument : forall {aft bef rest : Type},
  ((Tezos_raw_protocol_alpha.Script_typed_ir.stack_prefix_preservation_witness
    rest rest bef aft) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty rest) *
    (Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty aft)) ->
  dropn_proof_argument bef.

Definition parse_var_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)) :=
  Lwt._return (parse_var_annot loc default annot).

Definition parse_entrypoint_annot
  (loc : Z)
  (default : option (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  Lwt._return (parse_entrypoint_annot loc default annot).

Definition parse_constr_annot
  (loc : Z)
  (if_special_first :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (if_special_second :
    option (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))
  (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  Lwt._return (parse_constr_annot loc if_special_first if_special_second annot).

Definition parse_two_var_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))) :=
  Lwt._return (parse_two_var_annot loc annot).

Definition parse_destr_annot
  (loc : Z) (annot : list string)
  (default_accessor :
    option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (field_name : option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot)
  (pair_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  (value_annot : option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.field_annot))) :=
  Lwt._return
    (parse_destr_annot loc annot default_accessor field_name pair_annot
      value_annot).

Definition parse_var_type_annot (loc : Z) (annot : list string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) *
        (option Tezos_raw_protocol_alpha.Script_typed_ir.type_annot))) :=
  Lwt._return (parse_var_type_annot loc annot).

Definition find_entrypoint {A : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (root_name :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (entrypoint :
    Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty) :=
  let fix find_entrypoint {t : Type}
    (t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (entrypoint : string)
    : (Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_raw_protocol_alpha.Alpha_context.Script.node) * ex_ty :=
    match t with
    | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
      if
        match al with
        | None => false
        | Some (Field_annot l) =>
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            l entrypoint
        end then
        ((fun e =>
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left (cons e []) []),
          (Ex_ty tl))
      else
        if
          match ar with
          | None => false
          | Some (Field_annot r) =>
            Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              r entrypoint
          end then
          ((fun e =>
            Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
              Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right (cons e [])
              []), (Ex_ty tr))
        else
          (* ❌ Try-with are not handled *)
          try
            (let '(f, t) := find_entrypoint tl entrypoint in
            ((fun e =>
              Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
                Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
                (cons (f e) []) []), t))
    | _ => raise OCaml.Not_found
    end in
  let entrypoint :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        entrypoint "" % string then
      "default" % string
    else
      entrypoint in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
      (String.length entrypoint) 31 then
    error
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
        entrypoint)
  else
    match root_name with
    | Some root_name => ok ((fun e => e), (Ex_ty full))
    | _ =>
      (* ❌ Try-with are not handled *)
      try (ok (find_entrypoint full entrypoint))
    end.

Definition find_entrypoint_for_type {A B : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (expected : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  (root_name :
    option
      Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (entrypoint :
    Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.context * string *
      (Tezos_raw_protocol_alpha.Script_typed_ir.ty B)) :=
  match (entrypoint, root_name) with
  | ("default" % string, Some "root" % string) =>
    match find_entrypoint full root_name entrypoint with
    | (Tezos_protocol_environment_alpha__Environment.Pervasives.Error _) as err
      => err
    | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (_, Ex_ty ty)
      =>
      match ty_eq ctxt expected ty with
      | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok (Eq, ctxt)
        => ok (ctxt, "default" % string, ty)
      | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
        op_gtgtquestion (ty_eq ctxt expected full)
          (fun function_parameter =>
            let '(Eq, ctxt) := function_parameter in
            ok (ctxt, "root" % string, full))
      end
    end
  | _ =>
    op_gtgtquestion (find_entrypoint full root_name entrypoint)
      (fun function_parameter =>
        let '(_, Ex_ty ty) := function_parameter in
        op_gtgtquestion (ty_eq ctxt expected ty)
          (fun function_parameter =>
            let '(Eq, ctxt) := function_parameter in
            ok (ctxt, entrypoint, ty)))
  end.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ The definition of exceptions is not handled. *)
exception

(* ❌ The definition of exceptions is not handled. *)
exception

Definition well_formed_entrypoints {A : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (root_name :
    option Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.elt))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit :=
  let merge {B C : Type}
    (path : list B) (annot : option variant) (ty :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (reachable : bool)
    (function_parameter :
    (option (list B)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
    : (option (list B)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
    let '(first_unreachable, all) as acc := function_parameter in
    match annot with
    | None | Some (Field_annot "" % string) =>
      if reachable then
        acc
      else
        match ty with
        | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _ => acc
        | _ =>
          match first_unreachable with
          | None => ((Some (List.rev path)), all)
          | Some _ => acc
          end
        end
    | Some (Field_annot name) =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
          (String.length name) 31 then
        raise (Too_long name)
      else
        if
          Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
            name all then
          raise (Duplicate name)
        else
          (first_unreachable,
            (Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.add)
              name all))
    end in
  let fix check {t : Type}
    (t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (path :
    list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (reachable : bool)
    (acc :
    (option (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
    : (option (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
    match t with
    | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
      let acc :=
        merge (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left path)
          al tl reachable acc in
      let acc :=
        merge (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right path)
          ar tr reachable acc in
      let acc :=
        check tl
          (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left path)
          match al with
          | Some _ => true
          | None => reachable
          end acc in
      check tr (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right path)
        match ar with
        | Some _ => true
        | None => reachable
        end acc
    | _ => acc
    end in
  (* ❌ Try-with are not handled *)
  try
    (let '(init, reachable) :=
      match root_name with
      | None | Some "" % string =>
        (Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.empty),
          false)
      | Some name =>
        ((Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.singleton)
          name), true)
      end in
    let '(first_unreachable, all) := check full [] reachable (None, init) in
    if
      not
        (Entrypoints.(Tezos_protocol_environment_alpha__Environment.SET.S.mem)
          "default" % string all) then
      ok tt
    else
      match first_unreachable with
      | None => ok tt
      | Some path =>
        error
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unreachable_entrypoint
            path)
      end).

Fixpoint parse_data {a : Type}
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  (script_data : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (a * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
    (fun ctxt =>
      let error (function_parameter : unit)
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
        let 'tt := function_parameter in
        op_gtgtpipequestion (Lwt._return (serialize_ty_for_error ctxt ty))
          (fun function_parameter =>
            let '(ty, _ctxt) := function_parameter in
            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_constant
              (location script_data) (strip_locations script_data) ty) in
      let traced {B : Type}
        (body :
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B))
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
        trace_eval error body in
      let parse_items {B C D E : Type}
        (type_logger : option type_logger) (loc :
        Tezos_raw_protocol_alpha.Alpha_context.Script.location) (ctxt :
        Tezos_raw_protocol_alpha__Alpha_context.context) (expr :
        Tezos_protocol_environment_alpha__Environment.Micheline.node B
          Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (key_type :
        Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty C) (value_type :
        Tezos_raw_protocol_alpha.Script_typed_ir.ty D) (items :
        list
          (Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) (item_wrapper :
        D -> E)
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            ((Tezos_raw_protocol_alpha.Script_typed_ir.map C E) *
              Tezos_raw_protocol_alpha__Alpha_context.context)) :=
        let length := List.length items in
        op_gtgtpipequestion
          (op_pipegt
            (fold_left_s
              (fun function_parameter =>
                let '(last_value, map, ctxt) := function_parameter in
                fun item =>
                  op_gtgteqquestion
                    (Lwt._return
                      (Gas.consume ctxt (Typecheck_costs.map_element length)))
                    (fun ctxt =>
                      match item with
                      |
                        Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          _ Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
                          (cons k (cons v [])) _ =>
                        op_gtgteqquestion
                          (parse_comparable_data type_logger ctxt key_type k)
                          (fun function_parameter =>
                            let '(k, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (parse_data type_logger ctxt legacy value_type v)
                              (fun function_parameter =>
                                let '(v, ctxt) := function_parameter in
                                op_gtgteqquestion
                                  match last_value with
                                  | Some value =>
                                    if
                                      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
                                        0 (compare_comparable key_type value k)
                                      then
                                      if
                                        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                                          0
                                          (compare_comparable key_type value k)
                                        then
                                        fail
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_map_keys
                                            loc (strip_locations expr))
                                      else
                                        fail
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_map_keys
                                            loc (strip_locations expr))
                                    else
                                      return_unit
                                  | None => return_unit
                                  end
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    _return
                                      ((Some k),
                                        (map_update k (Some (item_wrapper v))
                                          map), ctxt))))
                      |
                        Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          loc
                          Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt l
                          _ =>
                        op_atat fail
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
                            loc
                            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
                            2 (List.length l))
                      |
                        Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          loc name _ _ =>
                        op_atat fail
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
                            loc
                            (cons
                              Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
                              []) name)
                      |
                        Tezos_protocol_environment_alpha__Environment.Micheline.Int
                          _ _ |
                          Tezos_protocol_environment_alpha__Environment.Micheline.String
                            _ _ |
                          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                            _ _ |
                          Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                            _ _ => op_gtgteqquestion (error tt) fail
                      end)) (None, (empty_map key_type), ctxt) items) traced)
          (fun function_parameter =>
            let '(_, items, ctxt) := function_parameter in
            (items, ctxt)) in
      match (ty, script_data) with
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit [] annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgtpipequestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.unit))
              (fun ctxt => (tt, ctxt)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit l _) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
              loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit 0
              (List.length l)))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, expr) =>
        traced
          (fail
            (unexpected expr []
              Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit [])))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_True [] annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgtpipequestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.bool))
              (fun ctxt => (true, ctxt)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_False [] annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgtpipequestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.bool))
              (fun ctxt => (false, ctxt)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            ((Tezos_raw_protocol_alpha.Alpha_context.Script.D_True |
              Tezos_raw_protocol_alpha.Alpha_context.Script.D_False) as c) l _)
        =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
              loc c 0 (List.length l)))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, expr) =>
        traced
          (fail
            (unexpected expr []
              Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_True
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_False []))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String _ v) =>
        op_gtgteqquestion
          (Lwt._return
            (Gas.consume ctxt (Typecheck_costs.string (String.length v))))
          (fun ctxt =>
            let fix check_printable_ascii
              (i :
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
              : bool :=
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                  i 0 then
                true
              else
                match String.get v i with
                |
                  "010" % char |
                    " " % char |
                      "!" % char |
                        """" % char |
                          "#" % char |
                            "$" % char |
                              "%" % char |
                                "&" % char |
                                  "'" % char |
                                    "(" % char |
                                      ")" % char |
                                        "*" % char |
                                          "+" % char |
                                            "," % char |
                                              "-" % char |
                                                "." % char |
                                                  "/" % char |
                                                    "0" % char |
                                                      "1" % char |
                                                        "2" % char |
                                                          "3" % char |
                                                            "4" % char |
                                                              "5" % char |
                                                                "6" % char |
                                                                  "7" % char |
                                                                    "8" % char |
                                                                      "9" % char
                                                                        |
                                                                        ":" %
                                                                          char |
                                                                          ";" %
                                                                            char
                                                                            |
                                                                            "<"
                                                                              %
                                                                              char
                                                                              |
                                                                              "="
                                                                                %
                                                                                char
                                                                                |
                                                                                ">"
                                                                                  %
                                                                                  char
                                                                                  |
                                                                                  "?"
                                                                                    %
                                                                                    char
                                                                                    |
                                                                                    "@"
                                                                                      %
                                                                                      char
                                                                                      |
                                                                                      "A"
                                                                                        %
                                                                                        char
                                                                                        |
                                                                                        "B"
                                                                                          %
                                                                                          char
                                                                                          |
                                                                                          "C"
                                                                                            %
                                                                                            char
                                                                                            |
                                                                                            "D"
                                                                                              %
                                                                                              char
                                                                                              |
                                                                                              "E"
                                                                                                %
                                                                                                char
                                                                                                |
                                                                                                "F"
                                                                                                  %
                                                                                                  char
                                                                                                  |
                                                                                                  "G"
                                                                                                    %
                                                                                                    char
                                                                                                    |
                                                                                                    "H"
                                                                                                      %
                                                                                                      char
                                                                                                      |
                                                                                                      "I"
                                                                                                        %
                                                                                                        char
                                                                                                        |
                                                                                                        "J"
                                                                                                          %
                                                                                                          char
                                                                                                          |
                                                                                                          "K"
                                                                                                            %
                                                                                                            char
                                                                                                            |
                                                                                                            "L"
                                                                                                              %
                                                                                                              char
                                                                                                              |
                                                                                                              "M"
                                                                                                                %
                                                                                                                char
                                                                                                                |
                                                                                                                "N"
                                                                                                                  %
                                                                                                                  char
                                                                                                                  |
                                                                                                                  "O"
                                                                                                                    %
                                                                                                                    char
                                                                                                                    |
                                                                                                                    "P"
                                                                                                                      %
                                                                                                                      char
                                                                                                                      |
                                                                                                                      "Q"
                                                                                                                        %
                                                                                                                        char
                                                                                                                        |
                                                                                                                        "R"
                                                                                                                          %
                                                                                                                          char
                                                                                                                          |
                                                                                                                          "S"
                                                                                                                            %
                                                                                                                            char
                                                                                                                            |
                                                                                                                            "T"
                                                                                                                              %
                                                                                                                              char
                                                                                                                              |
                                                                                                                              "U"
                                                                                                                                %
                                                                                                                                char
                                                                                                                                |
                                                                                                                                "V"
                                                                                                                                  %
                                                                                                                                  char
                                                                                                                                  |
                                                                                                                                  "W"
                                                                                                                                    %
                                                                                                                                    char
                                                                                                                                    |
                                                                                                                                    "X"
                                                                                                                                      %
                                                                                                                                      char
                                                                                                                                      |
                                                                                                                                      "Y"
                                                                                                                                        %
                                                                                                                                        char
                                                                                                                                        |
                                                                                                                                        "Z"
                                                                                                                                          %
                                                                                                                                          char
                                                                                                                                          |
                                                                                                                                          "["
                                                                                                                                            %
                                                                                                                                            char
                                                                                                                                            |
                                                                                                                                            "\"
                                                                                                                                              %
                                                                                                                                              char
                                                                                                                                              |
                                                                                                                                              "]"
                                                                                                                                                %
                                                                                                                                                char
                                                                                                                                                |
                                                                                                                                                "^"
                                                                                                                                                  %
                                                                                                                                                  char
                                                                                                                                                  |
                                                                                                                                                  "_"
                                                                                                                                                    %
                                                                                                                                                    char
                                                                                                                                                    |
                                                                                                                                                    "`"
                                                                                                                                                      %
                                                                                                                                                      char
                                                                                                                                                      |
                                                                                                                                                      "a"
                                                                                                                                                        %
                                                                                                                                                        char
                                                                                                                                                        |
                                                                                                                                                        "b"
                                                                                                                                                          %
                                                                                                                                                          char
                                                                                                                                                          |
                                                                                                                                                          "c"
                                                                                                                                                            %
                                                                                                                                                            char
                                                                                                                                                            |
                                                                                                                                                            "d"
                                                                                                                                                              %
                                                                                                                                                              char
                                                                                                                                                              |
                                                                                                                                                              "e"
                                                                                                                                                                %
                                                                                                                                                                char
                                                                                                                                                                |
                                                                                                                                                                "f"
                                                                                                                                                                  %
                                                                                                                                                                  char
                                                                                                                                                                  |
                                                                                                                                                                  "g"
                                                                                                                                                                    %
                                                                                                                                                                    char
                                                                                                                                                                    |
                                                                                                                                                                    "h"
                                                                                                                                                                      %
                                                                                                                                                                      char
                                                                                                                                                                      |
                                                                                                                                                                      "i"
                                                                                                                                                                        %
                                                                                                                                                                        char
                                                                                                                                                                        |
                                                                                                                                                                        "j"
                                                                                                                                                                          %
                                                                                                                                                                          char
                                                                                                                                                                          |
                                                                                                                                                                          "k"
                                                                                                                                                                            %
                                                                                                                                                                            char
                                                                                                                                                                            |
                                                                                                                                                                            "l"
                                                                                                                                                                              %
                                                                                                                                                                              char
                                                                                                                                                                              |
                                                                                                                                                                              "m"
                                                                                                                                                                                %
                                                                                                                                                                                char
                                                                                                                                                                                |
                                                                                                                                                                                "n"
                                                                                                                                                                                  %
                                                                                                                                                                                  char
                                                                                                                                                                                  |
                                                                                                                                                                                  "o"
                                                                                                                                                                                    %
                                                                                                                                                                                    char
                                                                                                                                                                                    |
                                                                                                                                                                                    "p"
                                                                                                                                                                                      %
                                                                                                                                                                                      char
                                                                                                                                                                                      |
                                                                                                                                                                                      "q"
                                                                                                                                                                                        %
                                                                                                                                                                                        char
                                                                                                                                                                                        |
                                                                                                                                                                                        "r"
                                                                                                                                                                                          %
                                                                                                                                                                                          char
                                                                                                                                                                                          |
                                                                                                                                                                                          "s"
                                                                                                                                                                                            %
                                                                                                                                                                                            char
                                                                                                                                                                                            |
                                                                                                                                                                                            "t"
                                                                                                                                                                                              %
                                                                                                                                                                                              char
                                                                                                                                                                                              |
                                                                                                                                                                                              "u"
                                                                                                                                                                                                %
                                                                                                                                                                                                char
                                                                                                                                                                                                |
                                                                                                                                                                                                "v"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  char
                                                                                                                                                                                                  |
                                                                                                                                                                                                  "w"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    char
                                                                                                                                                                                                    |
                                                                                                                                                                                                    "x"
                                                                                                                                                                                                      %
                                                                                                                                                                                                      char
                                                                                                                                                                                                      |
                                                                                                                                                                                                      "y"
                                                                                                                                                                                                        %
                                                                                                                                                                                                        char
                                                                                                                                                                                                        |
                                                                                                                                                                                                        "z"
                                                                                                                                                                                                          %
                                                                                                                                                                                                          char
                                                                                                                                                                                                          |
                                                                                                                                                                                                          "{"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            char
                                                                                                                                                                                                            |
                                                                                                                                                                                                            "|"
                                                                                                                                                                                                              %
                                                                                                                                                                                                              char
                                                                                                                                                                                                              |
                                                                                                                                                                                                              "}"
                                                                                                                                                                                                                %
                                                                                                                                                                                                                char
                                                                                                                                                                                                                |
                                                                                                                                                                                                                "~"
                                                                                                                                                                                                                  %
                                                                                                                                                                                                                  char
                  => check_printable_ascii (op_minus i 1)
                | _ => false
                end in
            if check_printable_ascii (op_minus (String.length v) 1) then
              _return (v, ctxt)
            else
              op_gtgteqquestion (error tt) fail)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ v) =>
        op_gtgteqquestion
          (Lwt._return
            (Gas.consume ctxt (Typecheck_costs.string (MBytes.length v))))
          (fun ctxt => _return (v, ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Typecheck_costs.z v)))
          (fun ctxt => _return ((Script_int.of_zint v), ctxt))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Typecheck_costs.z v)))
          (fun ctxt =>
            let v := Script_int.of_zint v in
            if
              Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
                (Script_int.compare v Script_int.zero) 0 then
              _return ((Script_int.abs v), ctxt)
            else
              op_gtgteqquestion (error tt) fail)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind [])
              (kind expr)))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
        op_gtgteqquestion
          (Lwt._return
            (op_gtgtquestion (Gas.consume ctxt Typecheck_costs.tez)
              (fun ctxt =>
                Gas.consume ctxt Michelson_v1_gas.Cost_of.Legacy.z_to_int64)))
          (fun ctxt =>
            (* ❌ Try-with are not handled *)
            try
              match Tez.of_mutez (Z.to_int64 v) with
              | None => raise Exit
              | Some tez => _return (tez, ctxt)
              end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Int _ v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Typecheck_costs.z v)))
          (fun ctxt => _return ((Script_timestamp.of_zint v), ctxt))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.string_timestamp))
          (fun ctxt =>
            match Script_timestamp.of_string s with
            | Some v => _return (v, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind []))
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
        =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.key))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes Signature.Public_key.encoding string
              with
            | Some k => _return (k, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.key))
          (fun ctxt =>
            match Signature.Public_key.of_b58check_opt s with
            | Some k => _return (k, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
        =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.key_hash))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes Signature.Public_key_hash.encoding
                string with
            | Some k => _return (k, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.key_hash))
          (fun ctxt =>
            match Signature.Public_key_hash.of_b58check_opt s with
            | Some k => _return (k, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
        =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.signature))
          (fun ctxt =>
            match Data_encoding.Binary.of_bytes Signature.encoding string with
            | Some k => _return (k, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.signature))
          (fun ctxt =>
            match Signature.of_b58check_opt s with
            | Some s => _return (s, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
              (kind expr)))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _, _) =>
        (* ❌ Assert instruction is not handled. *)
        assert false
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ bytes)
        =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.chain_id))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)
                string with
            | Some k => _return (k, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String _ s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.chain_id))
          (fun ctxt =>
            match
              Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.of_b58check_opt)
                s with
            | Some s => _return (s, ctxt)
            | None => op_gtgteqquestion (error tt) fail
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc
            bytes) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                (tup2 Contract.encoding Variable.string) string with
            | Some (c, entrypoint) =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                  (String.length entrypoint) 31 then
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
                    entrypoint)
              else
                op_gtgteqquestion
                  match entrypoint with
                  | "" % string => _return "default" % string
                  | "default" % string =>
                    fail
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                        loc)
                  | name => _return name
                  end (fun entrypoint => _return ((c, entrypoint), ctxt))
            | None => op_gtgteqquestion (error tt) fail
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String loc s)
        =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            op_gtgteqquestion
              match String.index_opt s "%" % char with
              | None => _return (s, "default" % string)
              | Some pos =>
                let len := op_minus (op_minus (String.length s) pos) 1 in
                let name := String.sub s (op_plus pos 1) len in
                if
                  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                    len 31 then
                  fail
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
                      name)
                else
                  match ((String.sub s 0 pos), name) with
                  | (_, "default" % string) =>
                    traced
                      (fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                          loc))
                  | addr_and_name => _return addr_and_name
                  end
              end
              (fun function_parameter =>
                let '(addr, entrypoint) := function_parameter in
                op_gtgteqquestion (Lwt._return (Contract.of_b58check addr))
                  (fun c => _return ((c, entrypoint), ctxt))))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t ty _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc
            bytes) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            match
              Data_encoding.Binary.of_bytes
                (tup2 Contract.encoding Variable.string) string with
            | Some (c, entrypoint) =>
              if
                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                  (String.length entrypoint) 31 then
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
                    entrypoint)
              else
                op_gtgteqquestion
                  match entrypoint with
                  | "" % string => _return "default" % string
                  | "default" % string =>
                    traced
                      (fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                          loc))
                  | name => _return name
                  end
                  (fun entrypoint =>
                    op_gtgteqquestion
                      (traced (parse_contract legacy ctxt loc ty c entrypoint))
                      (fun function_parameter =>
                        let '(ctxt, _) := function_parameter in
                        _return ((ty, (c, entrypoint)), ctxt)))
            | None => op_gtgteqquestion (error tt) fail
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t ty _,
          Tezos_protocol_environment_alpha__Environment.Micheline.String loc s)
        =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.contract))
          (fun ctxt =>
            op_gtgteqquestion
              match String.index_opt s "%" % char with
              | None => _return (s, "default" % string)
              | Some pos =>
                let len := op_minus (op_minus (String.length s) pos) 1 in
                let name := String.sub s (op_plus pos 1) len in
                if
                  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                    len 31 then
                  fail
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
                      name)
                else
                  match ((String.sub s 0 pos), name) with
                  | (_, "default" % string) =>
                    traced
                      (fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                          loc))
                  | addr_and_name => _return addr_and_name
                  end
              end
              (fun function_parameter =>
                let '(addr, entrypoint) := function_parameter in
                op_gtgteqquestion
                  (traced (Lwt._return (Contract.of_b58check addr)))
                  (fun c =>
                    op_gtgteqquestion
                      (parse_contract legacy ctxt loc ty c entrypoint)
                      (fun function_parameter =>
                        let '(ctxt, _) := function_parameter in
                        _return ((ty, (c, entrypoint)), ctxt)))))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.String_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind []))
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (ta, _, _) (tb, _, _) _
          _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair
            (cons va (cons vb [])) annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.pair))
              (fun ctxt =>
                op_gtgteqquestion
                  (op_atat traced (parse_data type_logger ctxt legacy ta va))
                  (fun function_parameter =>
                    let '(va, ctxt) := function_parameter in
                    op_gtgteqquestion (parse_data type_logger ctxt legacy tb vb)
                      (fun function_parameter =>
                        let '(vb, ctxt) := function_parameter in
                        _return ((va, vb), ctxt)))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair l _) =>
        op_atat fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair 2
            (List.length l))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ _, expr) =>
        traced
          (fail
            (unexpected expr []
              Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair [])))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, _) _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left (cons v [])
            annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.union))
              (fun ctxt =>
                op_gtgteqquestion
                  (op_atat traced (parse_data type_logger ctxt legacy tl v))
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    _return
                      ((Tezos_raw_protocol_alpha.Script_typed_ir.L v), ctxt))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left l _) =>
        op_atat fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left 1
            (List.length l))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ (tr, _) _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right (cons v [])
            annot) =>
        op_gtgteqquestion (fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.union))
              (fun ctxt =>
                op_gtgteqquestion
                  (op_atat traced (parse_data type_logger ctxt legacy tr v))
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    _return
                      ((Tezos_raw_protocol_alpha.Script_typed_ir.R v), ctxt))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right l _) =>
        op_atat fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right 1
            (List.length l))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _, expr) =>
        traced
          (fail
            (unexpected expr []
              Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right []))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t ta tr _ty_name,
          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq _loc _)
            as script_instr) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Typecheck_costs.lambda))
          (fun ctxt =>
            op_atat traced
              (parse_returning type_logger Lambda ctxt legacy
                (ta,
                  (Some
                    (* ❌ Variants not supported *)
                    variant)) tr script_instr))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some (cons v [])
            annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.some))
              (fun ctxt =>
                op_gtgteqquestion
                  (op_atat traced (parse_data type_logger ctxt legacy t v))
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    _return ((Some v), ctxt))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some l _) =>
        op_atat fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some 1
            (List.length l))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_None [] annot) =>
        op_gtgteqquestion
          (if legacy then
            _return tt
          else
            fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.none))
              (fun ctxt => _return (None, ctxt)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.D_None l _) =>
        op_atat fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.D_None 0
            (List.length l))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _, expr) =>
        traced
          (fail
            (unexpected expr []
              Tezos_raw_protocol_alpha.Script_tc_errors.Constant_namespace
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_None []))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t _ty_name _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Seq _loc items)
        =>
        op_atat traced
          (fold_right_s
            (fun v =>
              fun function_parameter =>
                let '(rest, ctxt) := function_parameter in
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Typecheck_costs.list_element))
                  (fun ctxt =>
                    op_gtgteqquestion (parse_data type_logger ctxt legacy t v)
                      (fun function_parameter =>
                        let '(v, ctxt) := function_parameter in
                        _return ((cons v rest), ctxt)))) items ([], ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t _ty_name,
          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc vs)
            as expr) =>
        let length := List.length vs in
        op_gtgtpipequestion
          (op_atat traced
            (fold_left_s
              (fun function_parameter =>
                let '(last_value, set, ctxt) := function_parameter in
                fun v =>
                  op_gtgteqquestion
                    (Lwt._return
                      (Gas.consume ctxt (Typecheck_costs.set_element length)))
                    (fun ctxt =>
                      op_gtgteqquestion
                        (parse_comparable_data type_logger ctxt t v)
                        (fun function_parameter =>
                          let '(v, ctxt) := function_parameter in
                          op_gtgteqquestion
                            match last_value with
                            | Some value =>
                              if
                                Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
                                  0 (compare_comparable t value v) then
                                if
                                  Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                                    0 (compare_comparable t value v) then
                                  fail
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_set_values
                                      loc (strip_locations expr))
                                else
                                  fail
                                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Unordered_set_values
                                      loc (strip_locations expr))
                              else
                                return_unit
                            | None => return_unit
                            end
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (Lwt._return
                                  (Gas.consume ctxt
                                    (Michelson_v1_gas.Cost_of.Legacy.set_update
                                      v false set)))
                                (fun ctxt =>
                                  _return
                                    ((Some v), (set_update v true set), ctxt))))))
              (None, (empty_set t), ctxt) vs))
          (fun function_parameter =>
            let '(_, set, ctxt) := function_parameter in
            (set, ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tk tv _ty_name _,
          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc vs)
            as expr) =>
        parse_items type_logger loc ctxt expr tk tv vs (fun x => x)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
              (kind expr)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk tv _ty_name,
          (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc vs)
            as expr) =>
        op_gtgtpipequestion
          (parse_items type_logger loc ctxt expr tk tv vs (fun x => Some x))
          (fun function_parameter =>
            let '(diff, ctxt) := function_parameter in
            ({| id := None; diff := diff; key_type := ty_of_comparable_ty tk;
              value_type := tv |}, ctxt))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk tv _ty_name,
          Tezos_protocol_environment_alpha__Environment.Micheline.Int loc id) =>
        op_gtgteqquestion (Big_map._exists ctxt id)
          (fun function_parameter =>
            match function_parameter with
            | (_, None) =>
              traced
                (fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_big_map
                    loc id))
            | (ctxt, Some (btk, btv)) =>
              Lwt._return
                (op_gtgtquestion (parse_comparable_ty ctxt (Micheline.root btk))
                  (fun function_parameter =>
                    let '(Ex_comparable_ty btk, ctxt) := function_parameter in
                    op_gtgtquestion
                      (parse_packable_ty ctxt legacy (Micheline.root btv))
                      (fun function_parameter =>
                        let '(Ex_ty btv, ctxt) := function_parameter in
                        op_gtgtquestion (comparable_ty_eq ctxt tk btk)
                          (fun function_parameter =>
                            let 'Eq := function_parameter in
                            op_gtgtquestion (ty_eq ctxt tv btv)
                              (fun function_parameter =>
                                let '(Eq, ctxt) := function_parameter in
                                ok
                                  ({| id := Some id; diff := empty_map tk;
                                    key_type := ty_of_comparable_ty tk;
                                    value_type := tv |}, ctxt))))))
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _tk _tv _, expr) =>
        traced
          (fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              (location expr)
              (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind []))
              (kind expr)))
      end)

with parse_comparable_data {a : Type}
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty a)
  (script_data : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (a * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  parse_data type_logger ctxt false (ty_of_comparable_ty ty) script_data

with parse_returning {arg ret : Type}
  (type_logger : option type_logger) (tc_context : tc_context)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (function_parameter :
    (Tezos_raw_protocol_alpha.Script_typed_ir.ty arg) *
      (option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot))
  : (Tezos_raw_protocol_alpha.Script_typed_ir.ty ret) ->
    Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((Tezos_raw_protocol_alpha.Script_typed_ir.lambda arg ret) *
            Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let '(arg, arg_annot) := function_parameter in
  fun ret =>
    fun script_instr =>
      op_gtgteqquestion
        (parse_instr type_logger tc_context ctxt legacy script_instr
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t arg
            Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t arg_annot))
        (fun function_parameter =>
          match function_parameter with
          |
            (Typed
              ({|
                loc := loc;
                  aft :=
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                      ty
                      Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                      _) as stack_ty
                  |} as descr), ctxt) =>
            trace_eval
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (Lwt._return (serialize_ty_for_error ctxt ret))
                  (fun function_parameter =>
                    let '(ret, ctxt) := function_parameter in
                    op_gtgtpipequestion
                      (serialize_stack_for_error ctxt stack_ty)
                      (fun function_parameter =>
                        let '(stack_ty, _ctxt) := function_parameter in
                        Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
                          loc stack_ty ret)))
              (op_gtgteqquestion (Lwt._return (ty_eq ctxt ty ret))
                (fun function_parameter =>
                  let '(Eq, ctxt) := function_parameter in
                  op_gtgteqquestion
                    (Lwt._return (merge_types legacy ctxt loc ty ret))
                    (fun function_parameter =>
                      let '(_ret, ctxt) := function_parameter in
                      _return
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Lam descr
                          script_instr), ctxt))))
          | (Typed {| loc := loc; aft := stack_ty |}, ctxt) =>
            op_gtgteqquestion (Lwt._return (serialize_ty_for_error ctxt ret))
              (fun function_parameter =>
                let '(ret, ctxt) := function_parameter in
                op_gtgteqquestion (serialize_stack_for_error ctxt stack_ty)
                  (fun function_parameter =>
                    let '(stack_ty, _ctxt) := function_parameter in
                    fail
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_return
                        loc stack_ty ret)))
          | (Failed {| descr := descr |}, ctxt) =>
            _return
              ((Tezos_raw_protocol_alpha.Script_typed_ir.Lam
                (descr
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret
                    Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t None))
                script_instr), ctxt)
          end)

with parse_int32
  (n :
    Tezos_protocol_environment_alpha__Environment.Micheline.node
      Tezos_raw_protocol_alpha.Alpha_context.Script.location
      Tezos_raw_protocol_alpha.Alpha_context.Script.prim)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z :=
  let error' (function_parameter : unit)
    : Tezos_protocol_environment_alpha__Environment.Error_monad.error :=
    let 'tt := function_parameter in
    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_syntactic_constant
      (location n) (strip_locations n)
      (op_caret "a positive 32-bit integer (between 0 and " % string
        (op_caret (Int32.to_string Int32.max_int) ")" % string)) in
  match n with
  | Tezos_protocol_environment_alpha__Environment.Micheline.Int _ n' =>
    (* ❌ Try-with are not handled *)
    try
      (let n'' := Z.to_int n' in
      if
        op_andand
          (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
            0 n'')
          (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
            n'' (Int32.to_int Int32.max_int)) then
        ok n''
      else
        op_atat error (error' tt))
  | _ => op_atat error (error' tt)
  end

with parse_instr {bef : Type}
  (type_logger : option type_logger) (tc_context : tc_context)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (script_instr : Tezos_raw_protocol_alpha.Alpha_context.Script.node)
  (stack_ty : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty bef)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let _check_item {B : Type}
    (check :
    Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) (loc :
    Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
    Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
    op_atat
      (trace_eval
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtpipequestion (serialize_stack_for_error ctxt stack_ty)
            (fun function_parameter =>
              let '(stack_ty, _ctxt) := function_parameter in
              Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc name m stack_ty)))
      (op_atat
        (trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
            n)) (Lwt._return check)) in
  let check_item_ty {B C : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (exp :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty B) (got :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (loc :
    Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
    Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((eq B C) * (Tezos_raw_protocol_alpha.Script_typed_ir.ty B) *
          Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    op_atat
      (trace_eval
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtpipequestion (serialize_stack_for_error ctxt stack_ty)
            (fun function_parameter =>
              let '(stack_ty, _ctxt) := function_parameter in
              Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc name m stack_ty)))
      (op_atat
        (trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
            n))
        (Lwt._return
          (op_gtgtquestion (ty_eq ctxt exp got)
            (fun function_parameter =>
              let '(Eq, ctxt) := function_parameter in
              op_gtgtquestion (merge_types legacy ctxt loc exp got)
                (fun function_parameter =>
                  let '(ty, ctxt) := function_parameter in
                  ok (Eq, ty, ctxt)))))) in
  let check_item_comparable_ty {B C : Type}
    (exp : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty B) (got :
    Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty C) (loc :
    Tezos_raw_protocol_alpha.Alpha_context.Script.location) (name :
    Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (n : Z) (m : Z)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((eq B C) * (Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty B))) :=
    op_atat
      (trace_eval
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgtpipequestion (serialize_stack_for_error ctxt stack_ty)
            (fun function_parameter =>
              let '(stack_ty, _ctxt) := function_parameter in
              Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc name m stack_ty)))
      (op_atat
        (trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack_item
            n))
        (Lwt._return
          (op_gtgtquestion (comparable_ty_eq ctxt exp got)
            (fun function_parameter =>
              let 'Eq := function_parameter in
              op_gtgtquestion (merge_comparable_types legacy exp got)
                (fun ty => ok (Eq, ty)))))) in
  let log_stack {B C : Type}
    (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (loc : Z) (stack_ty
    : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B) (aft :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty C)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
    match (type_logger, script_instr) with
    |
      (None, _) |
        (Some _,
          Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1) _ |
            Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
            Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
            Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _)
      => return_unit
    |
      (Some log,
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ _ _ |
          Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _) =>
      let ctxt := Gas.set_unlimited ctxt in
      op_gtgteqquestion (unparse_stack ctxt stack_ty)
        (fun function_parameter =>
          let '(stack_ty, _) := function_parameter in
          op_gtgteqquestion (unparse_stack ctxt aft)
            (fun function_parameter =>
              let '(aft, _) := function_parameter in
              (* ❌ Sequences of instructions are not handled (operator ";") *)
              let _ := log loc stack_ty aft in
              return_unit))
    end in
  let outer_return := _return in
  let _return
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (judgement :
    judgement bef)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    match judgement with
    | Typed {| loc := loc; aft := aft; instr := instr |} =>
      let maximum_type_size := Constants.michelson_maximum_type_size ctxt in
      let type_size :=
        type_size_of_stack_head aft (number_of_generated_growing_types instr) in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
          type_size maximum_type_size then
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Type_too_large
            loc type_size maximum_type_size)
      else
        _return (judgement, ctxt)
    | Failed _ => _return (judgement, ctxt)
    end in
  let typed {B : Type}
    (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context) (loc : Z) (instr :
    Tezos_raw_protocol_alpha.Script_typed_ir.instr bef B) (aft :
    Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((judgement bef) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
    op_gtgteqquestion (log_stack ctxt loc stack_ty aft)
      (fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion
          (op_atat Lwt._return (Gas.consume ctxt (Typecheck_costs.instr instr)))
          (fun ctxt =>
            _return ctxt
              (Typed
                {| loc := loc; bef := stack_ty; aft := aft; instr := instr |})))
    in
  op_gtgteqquestion
    (op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
    (fun ctxt =>
      match (script_instr, stack_ty) with
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t _ rest _) =>
        op_gtgteqquestion (fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Drop rest)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP (cons n [])
          result_annot, whole_stack) =>
        op_gtgteqquestion (Lwt._return (parse_int32 n))
          (fun whole_n =>
            let fix make_proof_argument {tstk : Type}
              (n : Z) (stk :
              Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  (dropn_proof_argument tstk)) :=
              match
                ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  n 0), stk) with
              | (true, rest) =>
                op_atat outer_return
                  (Dropn_proof_argument
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Rest, rest, rest))
              |
                (false,
                  Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
                =>
                op_gtgteqquestion (make_proof_argument (op_minus n 1) rest)
                  (fun function_parameter =>
                    let 'Dropn_proof_argument (n', stack_after_drops, aft') :=
                      function_parameter in
                    op_atat outer_return
                      (Dropn_proof_argument
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
                          stack_after_drops,
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
                            aft' annot))))
              | (_, _) =>
                op_gtgteqquestion (serialize_stack_for_error ctxt whole_stack)
                  (fun function_parameter =>
                    let '(whole_stack, _ctxt) := function_parameter in
                    fail
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                        loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP
                        whole_n whole_stack))
              end in
            op_gtgteqquestion (fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (make_proof_argument whole_n whole_stack)
                  (fun function_parameter =>
                    let 'Dropn_proof_argument (n', stack_after_drops, _aft) :=
                      function_parameter in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Dropn whole_n n')
                      stack_after_drops)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP
          ((cons _ (cons _ _)) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP 1
            (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest stack_annot) =>
        op_gtgteqquestion (parse_var_annot loc (Some stack_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Dup
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
                (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest
                  stack_annot) annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG (cons n [])
          result_annot, stack) =>
        let fix make_proof_argument {tstk : Type}
          (n : Z) (stk : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (dig_proof_argument tstk)) :=
          match
            ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              n 0), stk) with
          | (true, Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
            =>
            op_atat outer_return
              (Dig_proof_argument
                (Tezos_raw_protocol_alpha.Script_typed_ir.Rest, (v, annot), rest))
          |
            (false, Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
            =>
            op_gtgteqquestion (make_proof_argument (op_minus n 1) rest)
              (fun function_parameter =>
                let 'Dig_proof_argument (n', (x, xv), aft') :=
                  function_parameter in
                op_atat outer_return
                  (Dig_proof_argument
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
                      (x, xv),
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v aft'
                        annot))))
          | (_, _) =>
            op_gtgteqquestion (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                let '(whole_stack, _ctxt) := function_parameter in
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                    loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG 1
                    whole_stack))
          end in
        op_gtgteqquestion (Lwt._return (parse_int32 n))
          (fun n =>
            op_gtgteqquestion (fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (make_proof_argument n stack)
                  (fun function_parameter =>
                    let 'Dig_proof_argument (n', (x, stack_annot), aft) :=
                      function_parameter in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Dig n n')
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t x aft
                        stack_annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG
          (([] | cons _ (cons _ _)) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG 1
            (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG (cons n [])
          result_annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t x whole_stack
            stack_annot) =>
        op_gtgteqquestion (Lwt._return (parse_int32 n))
          (fun whole_n =>
            let fix make_proof_argument {tstk x : Type}
              (n : Z) (x : Tezos_raw_protocol_alpha.Script_typed_ir.ty x)
              (stack_annot :
              option Tezos_raw_protocol_alpha.Script_typed_ir.var_annot) (stk :
              Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  (dug_proof_argument tstk x)) :=
              match
                ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                  n 0), stk) with
              | (true, rest) =>
                op_atat outer_return
                  (Dug_proof_argument
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Rest, tt,
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t x rest
                        stack_annot)))
              |
                (false,
                  Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
                =>
                op_gtgteqquestion
                  (make_proof_argument (op_minus n 1) x stack_annot rest)
                  (fun function_parameter =>
                    let 'Dug_proof_argument (n', tt, aft') := function_parameter
                      in
                    op_atat outer_return
                      (Dug_proof_argument
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
                          tt,
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
                            aft' annot))))
              | (_, _) =>
                op_gtgteqquestion (serialize_stack_for_error ctxt whole_stack)
                  (fun function_parameter =>
                    let '(whole_stack, _ctxt) := function_parameter in
                    fail
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                        loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG
                        whole_n whole_stack))
              end in
            op_gtgteqquestion (fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (make_proof_argument whole_n x stack_annot whole_stack)
                  (fun function_parameter =>
                    let 'Dug_proof_argument (n', tt, aft) := function_parameter
                      in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Dug whole_n n')
                      aft)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG (cons _ [])
          result_annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t as stack) =>
        op_gtgteqquestion (fail_unexpected_annot loc result_annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                let '(stack, _ctxt) := function_parameter in
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                    loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG 1
                    stack)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG
          (([] | cons _ (cons _ _)) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG 1
            (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t w rest stack_annot)
            cur_top_annot) =>
        op_gtgteqquestion (fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Swap
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t w
                (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest
                  cur_top_annot) stack_annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
          (cons t (cons d [])) annot, stack) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (parse_packable_ty ctxt legacy t))
              (fun function_parameter =>
                let '(Ex_ty t, ctxt) := function_parameter in
                op_gtgteqquestion (parse_data type_logger ctxt legacy t d)
                  (fun function_parameter =>
                    let '(v, ctxt) := function_parameter in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Const v)
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack
                        annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT [] annot, stack)
        =>
        op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, ty_name) := function_parameter in
            typed ctxt loc (Tezos_raw_protocol_alpha.Script_typed_ir.Const tt)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t ty_name) stack
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t rest _) =>
        op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, ty_name) := function_parameter in
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Cons_some
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t ty_name
                  (has_big_map t)) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE (cons t []) annot,
          stack) =>
        op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy t))
          (fun function_parameter =>
            let '(Ex_ty t, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, ty_name) := function_parameter in
                typed ctxt loc
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Cons_none t)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t ty_name
                      (has_big_map t)) stack annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE
          (cons bt (cons bf [])) annot,
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _) rest
            option_annot) as bef) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (check_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let annot :=
                      gen_access_annot option_annot None default_some_annot in
                    op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt rest)
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t
                              rest annot))
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Type}
                              (ibt :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                op_dollar57 B) (ibf :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                (op_dollar58 * op_dollar57) B)
                              : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                ((option op_dollar58) * op_dollar57) B :=
                              {| loc := loc; bef := bef; aft := aft ibt;
                                instr :=
                                  Tezos_raw_protocol_alpha.Script_typed_ir.If_none
                                    ibt ibf |} in
                            op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                _return ctxt judgement))))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t a
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t b rest snd_annot)
            fst_annot) =>
        op_gtgteqquestion
          (parse_constr_annot loc (Some (var_to_field_annot fst_annot))
            (Some (var_to_field_annot snd_annot)) annot)
          (fun function_parameter =>
            let '(annot, ty_name, l_field, r_field) := function_parameter in
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Cons_pair
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                  (a, l_field, fst_annot) (b, r_field, snd_annot) ty_name
                  (op_pipepipe (has_big_map a) (has_big_map b))) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
              (a, expected_field_annot, a_annot) _ _ _) rest pair_annot) =>
        op_gtgteqquestion
          (parse_destr_annot loc annot default_car_annot expected_field_annot
            pair_annot a_annot)
          (fun function_parameter =>
            let '(annot, field_annot) := function_parameter in
            op_gtgteqquestion
              (op_atat Lwt._return
                (check_correct_field field_annot expected_field_annot))
              (fun function_parameter =>
                let 'tt := function_parameter in
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Car
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t a rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _
              (b, expected_field_annot, b_annot) _ _) rest pair_annot) =>
        op_gtgteqquestion
          (parse_destr_annot loc annot default_cdr_annot expected_field_annot
            pair_annot b_annot)
          (fun function_parameter =>
            let '(annot, field_annot) := function_parameter in
            op_gtgteqquestion
              (op_atat Lwt._return
                (check_correct_field field_annot expected_field_annot))
              (fun function_parameter =>
                let 'tt := function_parameter in
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Cdr
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t b rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT (cons tr [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tl rest stack_annot)
        =>
        op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy tr))
          (fun function_parameter =>
            let '(Ex_ty tr, ctxt) := function_parameter in
            op_gtgteqquestion
              (parse_constr_annot loc (Some (var_to_field_annot stack_annot))
                None annot)
              (fun function_parameter =>
                let '(annot, tname, l_field, r_field) := function_parameter in
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Left
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
                      (tl, l_field) (tr, r_field) tname
                      (op_pipepipe (has_big_map tl) (has_big_map tr))) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT (cons tl [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tr rest stack_annot)
        =>
        op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy tl))
          (fun function_parameter =>
            let '(Ex_ty tl, ctxt) := function_parameter in
            op_gtgteqquestion
              (parse_constr_annot loc None
                (Some (var_to_field_annot stack_annot)) annot)
              (fun function_parameter =>
                let '(annot, tname, l_field, r_field) := function_parameter in
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Right
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t
                      (tl, l_field) (tr, r_field) tname
                      (op_pipepipe (has_big_map tl) (has_big_map tr))) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT
          (cons bt (cons bf [])) annot,
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, l_field)
              (tr, r_field) _ _) rest union_annot) as bef) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (check_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let left_annot :=
                      gen_access_annot union_annot (Some default_left_annot)
                        l_field in
                    let right_annot :=
                      gen_access_annot union_annot (Some default_right_annot)
                        r_field in
                    op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tl rest
                          left_annot))
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tr
                              rest right_annot))
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Type}
                              (ibt :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                (op_dollar77 * op_dollar76) B) (ibf :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                (op_dollar78 * op_dollar76) B)
                              : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                ((Tezos_raw_protocol_alpha.Script_typed_ir.union
                                  op_dollar77 op_dollar78) * op_dollar76) B :=
                              {| loc := loc; bef := bef; aft := aft ibt;
                                instr :=
                                  Tezos_raw_protocol_alpha.Script_typed_ir.If_left
                                    ibt ibf |} in
                            op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                _return ctxt judgement))))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL (cons t []) annot,
          stack) =>
        op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy t))
          (fun function_parameter =>
            let '(Ex_ty t, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, ty_name) := function_parameter in
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Nil
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
                      (has_big_map t)) stack annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tv
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
                has_big_map) rest _) _) =>
        op_gtgteqquestion
          (check_item_ty ctxt tv t loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS 1 2)
          (fun function_parameter =>
            let '(Eq, t, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Cons_list
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
                      has_big_map) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS
          (cons bt (cons bf [])) annot,
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t ty_name
              has_big_map) rest list_annot) as bef) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (check_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    let hd_annot :=
                      gen_access_annot list_annot None default_hd_annot in
                    let tl_annot :=
                      gen_access_annot list_annot None default_tl_annot in
                    op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t
                              ty_name has_big_map) rest tl_annot) hd_annot))
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            rest)
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Type}
                              (ibt :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                (op_dollar86 *
                                  ((list op_dollar86) * op_dollar85)) B) (ibf :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                op_dollar85 B)
                              : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                ((list op_dollar86) * op_dollar85) B :=
                              {| loc := loc; bef := bef; aft := aft ibt;
                                instr :=
                                  Tezos_raw_protocol_alpha.Script_typed_ir.If_cons
                                    ibt ibf |} in
                            op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                _return ctxt judgement))))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ _) rest _) =>
        op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, tname) := function_parameter in
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.List_size
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP (cons body [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t elt _ _)
            starting_rest list_annot) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(ret_annot, list_ty_name) := function_parameter in
                let elt_annot :=
                  gen_access_annot list_annot None default_elt_annot in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t elt
                      starting_rest elt_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    |
                      Typed
                        ({|
                          aft := Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret rest _
                            |} as ibody) =>
                      let invalid_map_body (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgtpipequestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, _ctxt) := function_parameter in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
                              loc aft) in
                      trace_eval invalid_map_body
                        (op_gtgteqquestion
                          (op_atat Lwt._return
                            (stack_ty_eq ctxt 1 rest starting_rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt rest starting_rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.List_map
                                    ibody)
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                    (Tezos_raw_protocol_alpha.Script_typed_ir.List_t
                                      ret list_ty_name (has_big_map ret)) rest
                                    ret_annot))))
                    | Typed {| aft := aft |} =>
                      op_gtgteqquestion (serialize_stack_for_error ctxt aft)
                        (fun function_parameter =>
                          let '(aft, _ctxt) := function_parameter in
                          fail
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
                              loc aft))
                    | Failed _ =>
                      fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_block_fail
                          loc)
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER (cons body [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t elt _ _) rest
            list_annot) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                let elt_annot :=
                  gen_access_annot list_annot None default_elt_annot in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t elt rest
                      elt_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ({| aft := aft |} as ibody) =>
                      let invalid_iter_body (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            op_gtgtpipequestion
                              (serialize_stack_for_error ctxt rest)
                              (fun function_parameter =>
                                let '(rest, _ctxt) := function_parameter in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_iter_body
                                  loc rest aft)) in
                      trace_eval invalid_iter_body
                        (op_gtgteqquestion
                          (op_atat Lwt._return (stack_ty_eq ctxt 1 aft rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt aft rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.List_iter
                                    ibody) rest)))
                    | Failed {| descr := descr |} =>
                      typed ctxt loc
                        (Tezos_raw_protocol_alpha.Script_typed_ir.List_iter
                          (descr rest)) rest
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET (cons t [])
          annot, rest) =>
        op_gtgteqquestion (op_atat Lwt._return (parse_comparable_ty ctxt t))
          (fun function_parameter =>
            let '(Ex_comparable_ty t, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, tname) := function_parameter in
                typed ctxt loc
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_set t)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t tname)
                    rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER (cons body [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t comp_elt _) rest
            set_annot) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                let elt_annot :=
                  gen_access_annot set_annot None default_elt_annot in
                let elt := ty_of_comparable_ty comp_elt in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t elt rest
                      elt_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ({| aft := aft |} as ibody) =>
                      let invalid_iter_body (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            op_gtgtpipequestion
                              (serialize_stack_for_error ctxt rest)
                              (fun function_parameter =>
                                let '(rest, _ctxt) := function_parameter in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_iter_body
                                  loc rest aft)) in
                      trace_eval invalid_iter_body
                        (op_gtgteqquestion
                          (op_atat Lwt._return (stack_ty_eq ctxt 1 aft rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt aft rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter
                                    ibody) rest)))
                    | Failed {| descr := descr |} =>
                      typed ctxt loc
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Set_iter
                          (descr rest)) rest
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t elt _) rest _) _)
        =>
        let elt := ty_of_comparable_ty elt in
        op_gtgteqquestion (parse_var_type_annot loc annot)
          (fun function_parameter =>
            let '(annot, tname) := function_parameter in
            op_gtgteqquestion
              (check_item_ty ctxt elt v loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM 1 2)
              (fun function_parameter =>
                let '(Eq, _, ctxt) := function_parameter in
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Set_mem
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t elt tname) rest
                set_annot) _) _) =>
        match comparable_ty_of_ty v with
        | None =>
          op_gtgteqquestion (unparse_ty ctxt v)
            (fun function_parameter =>
              let '(v, _ctxt) := function_parameter in
              fail
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
                  loc (Micheline.strip_locations v)))
        | Some v =>
          op_gtgteqquestion (parse_var_annot loc (Some set_annot) annot)
            (fun annot =>
              op_gtgteqquestion
                (check_item_comparable_ty elt v loc
                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 1 3)
                (fun function_parameter =>
                  let '(Eq, elt) := function_parameter in
                  typed ctxt loc
                    Tezos_raw_protocol_alpha.Script_typed_ir.Set_update
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t elt tname)
                      rest annot)))
        end
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Set_size
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP
          (cons tk (cons tv [])) annot, stack) =>
        op_gtgteqquestion (op_atat Lwt._return (parse_comparable_ty ctxt tk))
          (fun function_parameter =>
            let '(Ex_comparable_ty tk, ctxt) := function_parameter in
            op_gtgteqquestion
              (op_atat Lwt._return (parse_any_ty ctxt legacy tv))
              (fun function_parameter =>
                let '(Ex_ty tv, ctxt) := function_parameter in
                op_gtgteqquestion (parse_var_type_annot loc annot)
                  (fun function_parameter =>
                    let '(annot, ty_name) := function_parameter in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_map tk tv)
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t tk tv
                          ty_name (has_big_map tv)) stack annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP (cons body [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck elt _ _)
            starting_rest _map_annot) =>
        let k := ty_of_comparable_ty ck in
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(ret_annot, ty_name) := function_parameter in
                let k_name := field_to_var_annot default_key_annot in
                let e_name := field_to_var_annot default_elt_annot in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                        (k, None, k_name) (elt, None, e_name) None
                        (has_big_map elt)) starting_rest None))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    |
                      Typed
                        ({|
                          aft := Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret rest _
                            |} as ibody) =>
                      let invalid_map_body (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgtpipequestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, _ctxt) := function_parameter in
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
                              loc aft) in
                      trace_eval invalid_map_body
                        (op_gtgteqquestion
                          (op_atat Lwt._return
                            (stack_ty_eq ctxt 1 rest starting_rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt rest starting_rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Map_map
                                    ibody)
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                    (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t
                                      ck ret ty_name (has_big_map ret)) rest
                                    ret_annot))))
                    | Typed {| aft := aft |} =>
                      op_gtgteqquestion (serialize_stack_for_error ctxt aft)
                        (fun function_parameter =>
                          let '(aft, _ctxt) := function_parameter in
                          fail
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_body
                              loc aft))
                    | Failed _ =>
                      fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_map_block_fail
                          loc)
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER (cons body [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t comp_elt element_ty
              _ _) rest _map_annot) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                let k_name := field_to_var_annot default_key_annot in
                let e_name := field_to_var_annot default_elt_annot in
                let key := ty_of_comparable_ty comp_elt in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                        (key, None, k_name) (element_ty, None, e_name) None
                        (has_big_map element_ty)) rest None))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ({| aft := aft |} as ibody) =>
                      let invalid_iter_body (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            op_gtgtpipequestion
                              (serialize_stack_for_error ctxt rest)
                              (fun function_parameter =>
                                let '(rest, _ctxt) := function_parameter in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_iter_body
                                  loc rest aft)) in
                      trace_eval invalid_iter_body
                        (op_gtgteqquestion
                          (op_atat Lwt._return (stack_ty_eq ctxt 1 aft rest))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt aft rest))
                              (fun function_parameter =>
                                let '(rest, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter
                                    ibody) rest)))
                    | Failed {| descr := descr |} =>
                      typed ctxt loc
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Map_iter
                          (descr rest)) rest
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck _ _ _) rest _)
            _) =>
        let k := ty_of_comparable_ty ck in
        op_gtgteqquestion
          (check_item_ty ctxt vk k loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Map_mem
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck elt _
                has_big_map) rest _) _) =>
        let k := ty_of_comparable_ty ck in
        op_gtgteqquestion
          (check_item_ty ctxt vk k loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Map_get
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t elt None
                      has_big_map) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t vv _ _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck v map_name
                  has_big_map) rest map_annot) _) _) =>
        let k := ty_of_comparable_ty ck in
        op_gtgteqquestion
          (check_item_ty ctxt vk k loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 1 3)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion
              (check_item_ty ctxt vv v loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 2 3)
              (fun function_parameter =>
                let '(Eq, v, ctxt) := function_parameter in
                op_gtgteqquestion (parse_var_annot loc (Some map_annot) annot)
                  (fun annot =>
                    typed ctxt loc
                      Tezos_raw_protocol_alpha.Script_typed_ir.Map_update
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t ck v
                          map_name has_big_map) rest annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Map_size
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_BIG_MAP
          (cons tk (cons tv [])) annot, stack) =>
        op_gtgteqquestion (op_atat Lwt._return (parse_comparable_ty ctxt tk))
          (fun function_parameter =>
            let '(Ex_comparable_ty tk, ctxt) := function_parameter in
            op_gtgteqquestion
              (op_atat Lwt._return (parse_packable_ty ctxt legacy tv))
              (fun function_parameter =>
                let '(Ex_ty tv, ctxt) := function_parameter in
                op_gtgteqquestion (parse_var_type_annot loc annot)
                  (fun function_parameter =>
                    let '(annot, ty_name) := function_parameter in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Empty_big_map tk
                        tv)
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t tk
                          tv ty_name) stack annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t set_key
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t map_key _ _)
              rest _) _) =>
        let k := ty_of_comparable_ty map_key in
        op_gtgteqquestion
          (check_item_ty ctxt set_key k loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_mem
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t vk
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t ck elt _) rest
              _) _) =>
        let k := ty_of_comparable_ty ck in
        op_gtgteqquestion
          (check_item_ty ctxt vk k loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_get
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t elt None
                      (has_big_map elt)) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t set_key
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t set_value _ _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t map_key
                  map_value map_name) rest map_annot) _) _) =>
        let k := ty_of_comparable_ty map_key in
        op_gtgteqquestion
          (check_item_ty ctxt set_key k loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 1 3)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion
              (check_item_ty ctxt set_value map_value loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE 2 3)
              (fun function_parameter =>
                let '(Eq, map_value, ctxt) := function_parameter in
                op_gtgteqquestion (parse_var_annot loc (Some map_annot) annot)
                  (fun annot =>
                    typed ctxt loc
                      Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_update
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t
                          map_key map_value map_name) rest annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc [],
          stack) =>
        typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Nop stack
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
          (cons single []), stack) =>
        op_gtgteqquestion
          (parse_instr type_logger tc_context ctxt legacy single stack)
          (fun function_parameter =>
            let '(judgement, ctxt) := function_parameter in
            match judgement with
            | Typed ({| aft := aft |} as instr) =>
              let nop :=
                {| loc := loc; bef := aft; aft := aft;
                  instr := Tezos_raw_protocol_alpha.Script_typed_ir.Nop |} in
              typed ctxt loc
                (Tezos_raw_protocol_alpha.Script_typed_ir.Seq instr nop) aft
            | Failed {| descr := descr |} =>
              let descr {B : Type}
                (aft : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
                : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
                let nop :=
                  {| loc := loc; bef := aft; aft := aft;
                    instr := Tezos_raw_protocol_alpha.Script_typed_ir.Nop |} in
                let descr := descr aft in
                (* ❌ Record substitution not handled *)
                record_substitution in
              _return ctxt (Failed {| descr := descr |})
            end)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
          (cons hd tl), stack) =>
        op_gtgteqquestion
          (parse_instr type_logger tc_context ctxt legacy hd stack)
          (fun function_parameter =>
            let '(judgement, ctxt) := function_parameter in
            match judgement with
            | Failed _ =>
              fail
                (Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
                  (Micheline.location hd))
            | Typed ({| aft := middle |} as ihd) =>
              op_gtgteqquestion
                (parse_instr type_logger tc_context ctxt legacy
                  (Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                    (-1) tl) middle)
                (fun function_parameter =>
                  let '(judgement, ctxt) := function_parameter in
                  match judgement with
                  | Failed {| descr := descr |} =>
                    let descr {B : Type}
                      (ret :
                      Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
                      : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
                      {| loc := loc; bef := stack; aft := ret;
                        instr :=
                          Tezos_raw_protocol_alpha.Script_typed_ir.Seq ihd
                            (descr ret) |} in
                    _return ctxt (Failed {| descr := descr |})
                  | Typed itl =>
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Seq ihd itl)
                      (aft itl)
                  end)
            end)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF
          (cons bt (cons bf [])) annot,
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _) rest _) as bef)
        =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bt)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (check_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) bf)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (fail_unexpected_annot loc annot)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion
                      (parse_instr type_logger tc_context ctxt legacy bt rest)
                      (fun function_parameter =>
                        let '(btr, ctxt) := function_parameter in
                        op_gtgteqquestion
                          (parse_instr type_logger tc_context ctxt legacy bf
                            rest)
                          (fun function_parameter =>
                            let '(bfr, ctxt) := function_parameter in
                            let branch {B : Type}
                              (ibt :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                op_dollar169 B) (ibf :
                              Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                op_dollar169 B)
                              : Tezos_raw_protocol_alpha.Script_typed_ir.descr
                                (bool * op_dollar169) B :=
                              {| loc := loc; bef := bef; aft := aft ibt;
                                instr :=
                                  Tezos_raw_protocol_alpha.Script_typed_ir.If
                                    ibt ibf |} in
                            op_gtgteqquestion
                              (merge_branches legacy ctxt loc btr bfr
                                {| branch := branch |})
                              (fun function_parameter =>
                                let '(judgement, ctxt) := function_parameter in
                                _return ctxt judgement))))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP (cons body [])
          annot,
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _) rest
            _stack_annot) as stack) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (fail_unexpected_annot loc annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body rest)
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ibody =>
                      let unmatched_branches (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            op_gtgtpipequestion
                              (serialize_stack_for_error ctxt stack)
                              (fun function_parameter =>
                                let '(stack, _ctxt) := function_parameter in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
                                  loc aft stack)) in
                      trace_eval unmatched_branches
                        (op_gtgteqquestion
                          (op_atat Lwt._return
                            (stack_ty_eq ctxt 1 (aft ibody) stack))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt (aft ibody) stack))
                              (fun function_parameter =>
                                let '(_stack, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Loop
                                    ibody) rest)))
                    | Failed {| descr := descr |} =>
                      let ibody := descr stack in
                      typed ctxt loc
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Loop ibody)
                        rest
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP_LEFT
          (cons body []) annot,
          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, l_field)
              (tr, _) _ _) rest union_annot) as stack) =>
        op_gtgteqquestion
          (check_kind
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind []) body)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                let l_annot :=
                  gen_access_annot union_annot (Some default_left_annot) l_field
                  in
                op_gtgteqquestion
                  (parse_instr type_logger tc_context ctxt legacy body
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tl rest
                      l_annot))
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed ibody =>
                      let unmatched_branches (function_parameter : unit)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            Tezos_protocol_environment_alpha__Environment.Error_monad.error) :=
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (serialize_stack_for_error ctxt (aft ibody))
                          (fun function_parameter =>
                            let '(aft, ctxt) := function_parameter in
                            op_gtgtpipequestion
                              (serialize_stack_for_error ctxt stack)
                              (fun function_parameter =>
                                let '(stack, _ctxt) := function_parameter in
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Unmatched_branches
                                  loc aft stack)) in
                      trace_eval unmatched_branches
                        (op_gtgteqquestion
                          (op_atat Lwt._return
                            (stack_ty_eq ctxt 1 (aft ibody) stack))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            op_gtgteqquestion
                              (op_atat Lwt._return
                                (merge_stacks legacy loc ctxt (aft ibody) stack))
                              (fun function_parameter =>
                                let '(_stack, ctxt) := function_parameter in
                                typed ctxt loc
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left
                                    ibody)
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                    tr rest annot))))
                    | Failed {| descr := descr |} =>
                      let ibody := descr stack in
                      typed ctxt loc
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Loop_left
                          ibody)
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tr rest
                          annot)
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA
          (cons arg (cons ret (cons code []))) annot, stack) =>
        op_gtgteqquestion (op_atat Lwt._return (parse_any_ty ctxt legacy arg))
          (fun function_parameter =>
            let '(Ex_ty arg, ctxt) := function_parameter in
            op_gtgteqquestion
              (op_atat Lwt._return (parse_any_ty ctxt legacy ret))
              (fun function_parameter =>
                let '(Ex_ty ret, ctxt) := function_parameter in
                op_gtgteqquestion
                  (check_kind
                    (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
                    code)
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    op_gtgteqquestion (parse_var_annot loc None annot)
                      (fun annot =>
                        op_gtgteqquestion
                          (parse_returning type_logger Lambda ctxt legacy
                            (arg, default_arg_annot) ret code)
                          (fun function_parameter =>
                            let '(lambda, ctxt) := function_parameter in
                            typed ctxt loc
                              (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda
                                lambda)
                              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t
                                  arg ret None) stack annot))))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t arg
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t param ret _)
              rest _) _) =>
        op_gtgteqquestion
          (check_item_ty ctxt arg param loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC 1 2)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Exec
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ret rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_APPLY [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t capture
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                  (capture_ty, _, _) (arg_ty, _, _) lam_annot _) ret _) rest _)
            _) =>
        op_gtgteqquestion
          (op_atat Lwt._return (check_packable false loc capture_ty))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (check_item_ty ctxt capture capture_ty loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_APPLY 1 2)
              (fun function_parameter =>
                let '(Eq, capture_ty, ctxt) := function_parameter in
                op_gtgteqquestion (parse_var_annot loc None annot)
                  (fun annot =>
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Apply capture_ty)
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t
                          arg_ty ret lam_annot) rest annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP (cons code [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest stack_annot) =>
        op_gtgteqquestion (fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (check_kind
                (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
                code)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion
                  (parse_instr type_logger (add_dip v stack_annot tc_context)
                    ctxt legacy code rest)
                  (fun function_parameter =>
                    let '(judgement, ctxt) := function_parameter in
                    match judgement with
                    | Typed descr =>
                      typed ctxt loc
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Dip descr)
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v
                          (aft descr) stack_annot)
                    | Failed _ =>
                      fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
                          loc)
                    end)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP
          (cons n (cons code [])) result_annot, stack) =>
        let fix make_proof_argument {tstk : Type}
          (n : Z) (inner_tc_context : tc_context) (stk :
          Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty tstk)
          : Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (dipn_proof_argument tstk)) :=
          match
            ((Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              n 0), stk) with
          | (true, rest) =>
            op_gtgteqquestion
              (parse_instr type_logger inner_tc_context ctxt legacy code rest)
              (fun function_parameter =>
                let '(judgement, ctxt) := function_parameter in
                match judgement with
                | Typed descr =>
                  op_atat outer_return
                    (Dipn_proof_argument
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Rest,
                        (ctxt, descr), (aft descr)))
                | Failed _ =>
                  fail
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Fail_not_in_tail_position
                      loc)
                end)
          |
            (false, Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v rest annot)
            =>
            op_gtgteqquestion
              (make_proof_argument (op_minus n 1) (add_dip v annot tc_context)
                rest)
              (fun function_parameter =>
                let 'Dipn_proof_argument (n', descr, aft') := function_parameter
                  in
                op_atat outer_return
                  (Dipn_proof_argument
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Prefix n'),
                      descr,
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v aft'
                        annot))))
          | (_, _) =>
            op_gtgteqquestion (serialize_stack_for_error ctxt stack)
              (fun function_parameter =>
                let '(whole_stack, _ctxt) := function_parameter in
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                    loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP 1
                    whole_stack))
          end in
        op_gtgteqquestion (Lwt._return (parse_int32 n))
          (fun n =>
            op_gtgteqquestion (fail_unexpected_annot loc result_annot)
              (fun function_parameter =>
                let 'tt := function_parameter in
                op_gtgteqquestion (make_proof_argument n tc_context stack)
                  (fun function_parameter =>
                    let 'Dipn_proof_argument (n', (new_ctxt, descr), aft) :=
                      function_parameter in
                    typed new_ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Dipn n n' descr)
                      aft)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP
          (([] | cons _ (cons _ (cons _ _))) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP 2
            (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t v _rest _) =>
        op_gtgteqquestion (fail_unexpected_annot loc annot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            let descr {B : Type}
              (aft : Tezos_raw_protocol_alpha.Script_typed_ir.stack_ty B)
              : Tezos_raw_protocol_alpha.Script_typed_ir.descr bef B :=
              {| loc := loc; bef := stack_ty; aft := aft;
                instr := Tezos_raw_protocol_alpha.Script_typed_ir.Failwith v |}
              in
            op_gtgteqquestion
              (log_stack ctxt loc stack_ty
                Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t)
              (fun function_parameter =>
                let 'tt := function_parameter in
                _return ctxt (Failed {| descr := descr |})))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc
              Tezos_raw_protocol_alpha.Script_typed_ir.Add_timestamp_to_seconds
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
                rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname) rest
              _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc
              Tezos_raw_protocol_alpha.Script_typed_ir.Add_seconds_to_timestamp
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
                rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc
              Tezos_raw_protocol_alpha.Script_typed_ir.Sub_timestamp_seconds
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tname)
                rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t tn2) rest _)
            _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Diff_timestamps
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string_pair
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname)
                    rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) _ _)
            rest list_annot) =>
        op_gtgteqquestion (parse_var_annot loc (Some list_annot) annot)
          (fun annot =>
            typed ctxt loc
              Tezos_raw_protocol_alpha.Script_typed_ir.Concat_string
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) rest
                string_annot) _) _) =>
        op_gtgteqquestion
          (parse_var_annot loc
            (Some (gen_access_annot string_annot None default_slice_annot))
            annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Slice_string
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.String_t tname) None
                  false) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.String_size
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes_pair
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname)
                    rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.List_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) _ _) rest
            list_annot) =>
        op_gtgteqquestion (parse_var_annot loc (Some list_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Concat_bytes
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) rest
                bytes_annot) _) _) =>
        op_gtgteqquestion
          (parse_var_annot loc
            (Some (gen_access_annot bytes_annot None default_slice_annot)) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Slice_bytes
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t tname) None
                  false) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_size
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Add_tez
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
                    rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_tez
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
                    rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_teznat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_nattez
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Or
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.And
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Xor
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Not
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Abs_int
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ISNAT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest int_annot)
        =>
        op_gtgteqquestion (parse_var_annot loc (Some int_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Is_nat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) None
                  false) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Int_nat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Neg_int
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Neg_nat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Add_intint
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Add_intnat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Add_natint
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Add_natnat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun _tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sub_int
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intint
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_intnat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natint
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Mul_natnat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_teznat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname),
                      None, None)
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname),
                      None, None) None false) None false) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tn2) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_tez
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None),
                          None, None)
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t tname),
                          None, None) None false) None false) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intint
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname),
                          None, None)
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None),
                          None, None) None false) None false) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_intnat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname),
                      None, None)
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None),
                      None, None) None false) None false) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natint
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None),
                      None, None)
                    ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname),
                      None, None) None false) None false) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Ediv_natnat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname),
                          None, None)
                        ((Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname),
                          None, None) None false) None false) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Lsl_nat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Lsr_nat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Or_nat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.And_nat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest _) _)
        =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.And_int_nat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn1)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tn2) rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (merge_type_annot legacy tn1 tn2))
              (fun tname =>
                typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Xor_nat
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t tname) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Not_int
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t tname) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Not_nat
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t1
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t2 rest _) _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            op_gtgteqquestion
              (check_item_ty ctxt t1 t2 loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE 1 2)
              (fun function_parameter =>
                let '(Eq, t, ctxt) := function_parameter in
                match comparable_ty_of_ty t with
                | None =>
                  op_gtgteqquestion
                    (Lwt._return (serialize_ty_for_error ctxt t))
                    (fun function_parameter =>
                      let '(t, _ctxt) := function_parameter in
                      fail
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Comparable_type_expected
                          loc t))
                | Some key =>
                  typed ctxt loc
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Compare key)
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t None) rest
                      annot)
                end))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Eq
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Neq
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Lt
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Gt
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Le
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Ge
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAST (cons cast_t [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack item_annot) =>
        op_gtgteqquestion (parse_var_annot loc (Some item_annot) annot)
          (fun annot =>
            op_gtgteqquestion
              (op_atat Lwt._return (parse_any_ty ctxt legacy cast_t))
              (fun function_parameter =>
                let '(Ex_ty cast_t, ctxt) := function_parameter in
                op_gtgteqquestion (op_atat Lwt._return (ty_eq ctxt cast_t t))
                  (fun function_parameter =>
                    let '(Eq, ctxt) := function_parameter in
                    op_gtgteqquestion
                      (op_atat Lwt._return
                        (merge_types legacy ctxt loc cast_t t))
                      (fun function_parameter =>
                        let '(_, ctxt) := function_parameter in
                        typed ctxt loc
                          Tezos_raw_protocol_alpha.Script_typed_ir.Nop
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                            cast_t stack annot)))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_RENAME [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Nop
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t stack annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_PACK [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t rest unpacked_annot)
        =>
        op_gtgteqquestion (Lwt._return (check_packable true loc t))
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgteqquestion
              (parse_var_annot loc
                (Some (gen_access_annot unpacked_annot None default_pack_annot))
                annot)
              (fun annot =>
                typed ctxt loc (Tezos_raw_protocol_alpha.Script_typed_ir.Pack t)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
                    annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNPACK (cons ty [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest
            packed_annot) =>
        op_gtgteqquestion
          (op_atat Lwt._return (parse_packable_ty ctxt legacy ty))
          (fun function_parameter =>
            let '(Ex_ty t, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_type_annot loc annot)
              (fun function_parameter =>
                let '(annot, ty_name) := function_parameter in
                let annot :=
                  default_annot
                    (gen_access_annot packed_annot None default_unpack_annot)
                    annot in
                typed ctxt loc
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Unpack t)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t ty_name
                      false) rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADDRESS [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _) rest
            contract_annot) =>
        op_gtgteqquestion
          (parse_var_annot loc
            (Some (gen_access_annot contract_annot None default_addr_annot))
            annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Address
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONTRACT (cons ty [])
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _) rest
            addr_annot) =>
        op_gtgteqquestion
          (op_atat Lwt._return (parse_parameter_ty ctxt legacy ty))
          (fun function_parameter =>
            let '(Ex_ty t, ctxt) := function_parameter in
            op_gtgteqquestion
              (parse_entrypoint_annot loc
                (Some (gen_access_annot addr_annot None default_contract_annot))
                annot)
              (fun function_parameter =>
                let '(annot, entrypoint) := function_parameter in
                op_gtgteqquestion
                  (op_atat Lwt._return
                    match entrypoint with
                    | None =>
                      Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                        "default" % string
                    | Some (Field_annot "default" % string) =>
                      error
                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_annotation
                          loc)
                    | Some (Field_annot entrypoint) =>
                      if
                        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
                          (String.length entrypoint) 31 then
                        error
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Entrypoint_name_too_long
                            entrypoint)
                      else
                        Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                          entrypoint
                    end)
                  (fun entrypoint =>
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Contract t
                        entrypoint)
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                          (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t t
                            None) None false) rest annot))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS []
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t p
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t cp _) rest
                _) _) _) =>
        op_gtgteqquestion
          (check_item_ty ctxt p cp loc
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS 1 4)
          (fun function_parameter =>
            let '(Eq, _, ctxt) := function_parameter in
            op_gtgteqquestion (parse_var_annot loc None annot)
              (fun annot =>
                typed ctxt loc
                  Tezos_raw_protocol_alpha.Script_typed_ir.Transfer_tokens
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t None)
                    rest annot)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SET_DELEGATE [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _) rest
            _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Set_delegate
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT []
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
                (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _) rest _) _)
              _) _) =>
        if legacy then
          op_gtgteqquestion (parse_two_var_annot loc annot)
            (fun function_parameter =>
              let '(op_annot, addr_annot) := function_parameter in
              typed ctxt loc
                Tezos_raw_protocol_alpha.Script_typed_ir.Create_account
                (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t None)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None)
                    rest addr_annot) op_annot))
        else
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
              Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT []
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc
              Tezos_raw_protocol_alpha.Script_typed_ir.Implicit_account
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t None) None)
                rest annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
          (cons
            ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _)
              as code) []) annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
                (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _)
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ginit rest
                      _) _) _) _) _) _) =>
        if legacy then
          op_gtgteqquestion (parse_two_var_annot loc annot)
            (fun function_parameter =>
              let '(op_annot, addr_annot) := function_parameter in
              let cannonical_code :=
                op_atat fst (Micheline.extract_locations code) in
              op_gtgteqquestion
                (op_atat Lwt._return (parse_toplevel legacy cannonical_code))
                (fun function_parameter =>
                  let '(arg_type, storage_type, code_field, root_name) :=
                    function_parameter in
                  op_gtgteqquestion
                    (trace
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                        (Some "parameter" % string) cannonical_code
                        (location arg_type))
                      (op_atat Lwt._return
                        (parse_parameter_ty ctxt legacy arg_type)))
                    (fun function_parameter =>
                      let '(Ex_ty arg_type, ctxt) := function_parameter in
                      op_gtgteqquestion
                        (if legacy then
                          Error_monad._return tt
                        else
                          Lwt._return
                            (well_formed_entrypoints arg_type root_name))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (trace
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                                (Some "storage" % string) cannonical_code
                                (location storage_type))
                              (op_atat Lwt._return
                                (parse_storage_ty ctxt legacy storage_type)))
                            (fun function_parameter =>
                              let '(Ex_ty storage_type, ctxt) :=
                                function_parameter in
                              let arg_annot :=
                                default_annot default_param_annot
                                  (type_to_var_annot (name_of_ty arg_type)) in
                              let storage_annot :=
                                default_annot default_storage_annot
                                  (type_to_var_annot (name_of_ty storage_type))
                                in
                              let arg_type_full :=
                                Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                                  (arg_type, None, arg_annot)
                                  (storage_type, None, storage_annot) None
                                  (op_pipepipe (has_big_map arg_type)
                                    (has_big_map storage_type)) in
                              let ret_type_full :=
                                Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                                  ((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
                                    (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                                      None) None false), None, None)
                                  (storage_type, None, None) None
                                  (has_big_map storage_type) in
                              op_gtgteqquestion
                                (trace
                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
                                    cannonical_code [])
                                  (parse_returning type_logger
                                    (Toplevel
                                      {| storage_type := storage_type;
                                        param_type := arg_type;
                                        root_name := root_name;
                                        legacy_create_contract_literal := true
                                        |}) ctxt legacy (arg_type_full, None)
                                    ret_type_full code_field))
                                (fun function_parameter =>
                                  let
                                    '((Tezos_raw_protocol_alpha.Script_typed_ir.Lam
                                      {|
                                      bef :=
                                        Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                          arg
                                          Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                                          _;
                                        aft :=
                                          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                            ret
                                            Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                                            _
                                        |} _) as lambda, ctxt) :=
                                    function_parameter in
                                  op_gtgteqquestion
                                    (op_atat Lwt._return
                                      (ty_eq ctxt arg arg_type_full))
                                    (fun function_parameter =>
                                      let '(Eq, ctxt) := function_parameter in
                                      op_gtgteqquestion
                                        (op_atat Lwt._return
                                          (merge_types legacy ctxt loc arg
                                            arg_type_full))
                                        (fun function_parameter =>
                                          let '(_, ctxt) := function_parameter
                                            in
                                          op_gtgteqquestion
                                            (op_atat Lwt._return
                                              (ty_eq ctxt ret ret_type_full))
                                            (fun function_parameter =>
                                              let '(Eq, ctxt) :=
                                                function_parameter in
                                              op_gtgteqquestion
                                                (op_atat Lwt._return
                                                  (merge_types legacy ctxt loc
                                                    ret ret_type_full))
                                                (fun function_parameter =>
                                                  let '(_, ctxt) :=
                                                    function_parameter in
                                                  op_gtgteqquestion
                                                    (op_atat Lwt._return
                                                      (ty_eq ctxt storage_type
                                                        ginit))
                                                    (fun function_parameter =>
                                                      let '(Eq, ctxt) :=
                                                        function_parameter in
                                                      op_gtgteqquestion
                                                        (op_atat Lwt._return
                                                          (merge_types legacy
                                                            ctxt loc
                                                            storage_type ginit))
                                                        (fun function_parameter
                                                          =>
                                                          let '(_, ctxt) :=
                                                            function_parameter
                                                            in
                                                          typed ctxt loc
                                                            (Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract
                                                              storage_type
                                                              arg_type lambda
                                                              root_name)
                                                            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                                              (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                                                                None)
                                                              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                                                (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t
                                                                  None) rest
                                                                addr_annot)
                                                              op_annot)))))))))))))
        else
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
              Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
          (cons
            ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ _)
              as code) []) annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _) _ _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ginit rest _) _)
            _) =>
        op_gtgteqquestion (parse_two_var_annot loc annot)
          (fun function_parameter =>
            let '(op_annot, addr_annot) := function_parameter in
            let cannonical_code :=
              op_atat fst (Micheline.extract_locations code) in
            op_gtgteqquestion
              (op_atat Lwt._return (parse_toplevel legacy cannonical_code))
              (fun function_parameter =>
                let '(arg_type, storage_type, code_field, root_name) :=
                  function_parameter in
                op_gtgteqquestion
                  (trace
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                      (Some "parameter" % string) cannonical_code
                      (location arg_type))
                    (op_atat Lwt._return
                      (parse_parameter_ty ctxt legacy arg_type)))
                  (fun function_parameter =>
                    let '(Ex_ty arg_type, ctxt) := function_parameter in
                    op_gtgteqquestion
                      (if legacy then
                        Error_monad._return tt
                      else
                        Lwt._return (well_formed_entrypoints arg_type root_name))
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (trace
                            (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                              (Some "storage" % string) cannonical_code
                              (location storage_type))
                            (op_atat Lwt._return
                              (parse_storage_ty ctxt legacy storage_type)))
                          (fun function_parameter =>
                            let '(Ex_ty storage_type, ctxt) :=
                              function_parameter in
                            let arg_annot :=
                              default_annot default_param_annot
                                (type_to_var_annot (name_of_ty arg_type)) in
                            let storage_annot :=
                              default_annot default_storage_annot
                                (type_to_var_annot (name_of_ty storage_type)) in
                            let arg_type_full :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                                (arg_type, None, arg_annot)
                                (storage_type, None, storage_annot) None
                                (op_pipepipe (has_big_map arg_type)
                                  (has_big_map storage_type)) in
                            let ret_type_full :=
                              Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                                ((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
                                  (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                                    None) None false), None, None)
                                (storage_type, None, None) None
                                (has_big_map storage_type) in
                            op_gtgteqquestion
                              (trace
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
                                  cannonical_code [])
                                (parse_returning type_logger
                                  (Toplevel
                                    {| storage_type := storage_type;
                                      param_type := arg_type;
                                      root_name := root_name;
                                      legacy_create_contract_literal := false |})
                                  ctxt legacy (arg_type_full, None)
                                  ret_type_full code_field))
                              (fun function_parameter =>
                                let
                                  '((Tezos_raw_protocol_alpha.Script_typed_ir.Lam
                                    {|
                                    bef :=
                                      Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                        arg
                                        Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                                        _;
                                      aft :=
                                        Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                          ret
                                          Tezos_raw_protocol_alpha.Script_typed_ir.Empty_t
                                          _
                                      |} _) as lambda, ctxt) :=
                                  function_parameter in
                                op_gtgteqquestion
                                  (op_atat Lwt._return
                                    (ty_eq ctxt arg arg_type_full))
                                  (fun function_parameter =>
                                    let '(Eq, ctxt) := function_parameter in
                                    op_gtgteqquestion
                                      (op_atat Lwt._return
                                        (merge_types legacy ctxt loc arg
                                          arg_type_full))
                                      (fun function_parameter =>
                                        let '(_, ctxt) := function_parameter in
                                        op_gtgteqquestion
                                          (op_atat Lwt._return
                                            (ty_eq ctxt ret ret_type_full))
                                          (fun function_parameter =>
                                            let '(Eq, ctxt) :=
                                              function_parameter in
                                            op_gtgteqquestion
                                              (op_atat Lwt._return
                                                (merge_types legacy ctxt loc ret
                                                  ret_type_full))
                                              (fun function_parameter =>
                                                let '(_, ctxt) :=
                                                  function_parameter in
                                                op_gtgteqquestion
                                                  (op_atat Lwt._return
                                                    (ty_eq ctxt storage_type
                                                      ginit))
                                                  (fun function_parameter =>
                                                    let '(Eq, ctxt) :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (op_atat Lwt._return
                                                        (merge_types legacy ctxt
                                                          loc storage_type ginit))
                                                      (fun function_parameter =>
                                                        let '(_, ctxt) :=
                                                          function_parameter in
                                                        typed ctxt loc
                                                          (Tezos_raw_protocol_alpha.Script_typed_ir.Create_contract_2
                                                            storage_type
                                                            arg_type lambda
                                                            root_name)
                                                          (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                                            (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                                                              None)
                                                            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                                                              (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t
                                                                None) rest
                                                              addr_annot)
                                                            op_annot)))))))))))))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW [] annot, stack)
        =>
        op_gtgteqquestion (parse_var_annot loc (Some default_now_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Now
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t None)
                stack annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT [] annot, stack)
        =>
        op_gtgteqquestion
          (parse_var_annot loc (Some default_amount_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Amount
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t None) stack
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHAIN_ID [] annot,
          stack) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.ChainId
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t None) stack
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE [] annot,
          stack) =>
        op_gtgteqquestion
          (parse_var_annot loc (Some default_balance_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Balance
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t None) stack
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Hash_key
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE []
          annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _)
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
              (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _)
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) _)
            _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc
              Tezos_raw_protocol_alpha.Script_typed_ir.Check_signature
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Blake2b
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sha256
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 [] annot,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
            (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _) rest _) =>
        op_gtgteqquestion (parse_var_annot loc None annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sha512
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t None) rest
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA []
          annot, stack) =>
        if legacy then
          op_gtgteqquestion
            (parse_var_annot loc (Some default_steps_annot) annot)
            (fun annot =>
              typed ctxt loc
                Tezos_raw_protocol_alpha.Script_typed_ir.Steps_to_quota
                (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t None) stack
                  annot))
        else
          fail
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Deprecated_instruction
              Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE [] annot, stack)
        =>
        op_gtgteqquestion
          (parse_var_annot loc (Some default_source_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Source
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None) stack
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER [] annot, stack)
        =>
        op_gtgteqquestion
          (parse_var_annot loc (Some default_sender_annot) annot)
          (fun annot =>
            typed ctxt loc Tezos_raw_protocol_alpha.Script_typed_ir.Sender
              (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t None) stack
                annot))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_SELF [] annot, stack)
        =>
        op_gtgteqquestion
          (parse_entrypoint_annot loc (Some default_self_annot) annot)
          (fun function_parameter =>
            let '(annot, entrypoint) := function_parameter in
            let entrypoint :=
              Option.unopt_map
                (fun function_parameter =>
                  let 'Field_annot annot := function_parameter in
                  annot) "default" % string entrypoint in
            let fix get_toplevel_type (function_parameter : tc_context)
              : Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  ((judgement bef) *
                    Tezos_raw_protocol_alpha.Alpha_context.context)) :=
              match function_parameter with
              | Lambda =>
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Self_in_lambda
                    loc)
              | Dip _ prev => get_toplevel_type prev
              |
                Toplevel {|
                  param_type := param_type;
                    root_name := root_name;
                    legacy_create_contract_literal := false
                    |} =>
                op_gtgteqquestion
                  (Lwt._return (find_entrypoint param_type root_name entrypoint))
                  (fun function_parameter =>
                    let '(_, Ex_ty param_type) := function_parameter in
                    typed ctxt loc
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Self param_type
                        entrypoint)
                      (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t
                          param_type None) stack annot))
              |
                Toplevel {|
                  param_type := param_type;
                    root_name := _;
                    legacy_create_contract_literal := true
                    |} =>
                typed ctxt loc
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Self param_type
                    "default" % string)
                  (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t
                    (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t
                      param_type None) stack annot)
              end in
            get_toplevel_type tc_context)
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SET_DELEGATE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADDRESS) as name)
          ((cons _ _) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc name 0 (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP_LEFT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONTRACT) as name)
          (([] | cons _ (cons _ _)) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc name 1 (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF) as name)
          (([] | cons _ [] | cons _ (cons _ (cons _ _))) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc name 2 (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA
          (([] | cons _ [] | cons _ (cons _ (cons _ (cons _ _)))) as l) _, _) =>
        fail
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
            loc Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA 3
            (List.length l))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR) as name) [] _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t ta
            (Tezos_raw_protocol_alpha.Script_typed_ir.Item_t tb _ _) _) =>
        op_gtgteqquestion (op_atat Lwt._return (serialize_ty_for_error ctxt ta))
          (fun function_parameter =>
            let '(ta, ctxt) := function_parameter in
            op_gtgteqquestion
              (op_atat Lwt._return (serialize_ty_for_error ctxt tb))
              (fun function_parameter =>
                let '(tb, _ctxt) := function_parameter in
                fail
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_binop
                    loc name ta tb)))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE) as name) [] _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Item_t t _ _) =>
        op_gtgteqquestion (op_atat Lwt._return (serialize_ty_for_error ctxt t))
          (fun function_parameter =>
            let '(t, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Undefined_unop
                loc name t))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SLICE) as name) [] _,
          stack) =>
        op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc name 3 stack))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT _ _,
          stack) =>
        op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
                7 stack))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT [] _,
          stack) =>
        op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT 4
                stack))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS [] _,
          stack) =>
        op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc
                Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS
                4 stack))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256 |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512 |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE) as name) _ _,
          stack) =>
        op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc name 1 stack))
      |
        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
          ((Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL |
            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR) as name) _ _,
          stack) =>
        op_gtgteqquestion (serialize_stack_for_error ctxt stack)
          (fun function_parameter =>
            let '(stack, _ctxt) := function_parameter in
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Bad_stack
                loc name 2 stack))
      | (expr, _) =>
        op_atat fail
          (unexpected expr
            (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
            Tezos_raw_protocol_alpha.Script_tc_errors.Instr_namespace
            (cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DROP
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUP
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIG
                  (cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_DUG
                    (cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_SWAP
                      (cons Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOME
                        (cons
                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_UNIT
                          (cons
                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_PAIR
                            (cons
                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_CAR
                              (cons
                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_CDR
                                (cons
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONS
                                  (cons
                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_MEM
                                    (cons
                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_UPDATE
                                      (cons
                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_MAP
                                        (cons
                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_ITER
                                          (cons
                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GET
                                            (cons
                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_EXEC
                                              (cons
                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_FAILWITH
                                                (cons
                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_SIZE
                                                  (cons
                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_CONCAT
                                                    (cons
                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ADD
                                                      (cons
                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_SUB
                                                        (cons
                                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_MUL
                                                          (cons
                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_EDIV
                                                            (cons
                                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_OR
                                                              (cons
                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_AND
                                                                (cons
                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_XOR
                                                                  (cons
                                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOT
                                                                    (cons
                                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_ABS
                                                                      (cons
                                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_INT
                                                                        (cons
                                                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEG
                                                                          (cons
                                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSL
                                                                            (cons
                                                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_LSR
                                                                              (cons
                                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_COMPARE
                                                                                (cons
                                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_EQ
                                                                                  (cons
                                                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_NEQ
                                                                                    (cons
                                                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LT
                                                                                      (cons
                                                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_GT
                                                                                        (cons
                                                                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_LE
                                                                                          (cons
                                                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_GE
                                                                                            (cons
                                                                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_TRANSFER_TOKENS
                                                                                              (cons
                                                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_ACCOUNT
                                                                                                (cons
                                                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_CREATE_CONTRACT
                                                                                                  (cons
                                                                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_NOW
                                                                                                    (cons
                                                                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_AMOUNT
                                                                                                      (cons
                                                                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_BALANCE
                                                                                                        (cons
                                                                                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IMPLICIT_ACCOUNT
                                                                                                          (cons
                                                                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_CHECK_SIGNATURE
                                                                                                            (cons
                                                                                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_BLAKE2B
                                                                                                              (cons
                                                                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA256
                                                                                                                (cons
                                                                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_SHA512
                                                                                                                  (cons
                                                                                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_HASH_KEY
                                                                                                                    (cons
                                                                                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_STEPS_TO_QUOTA
                                                                                                                      (cons
                                                                                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
                                                                                                                        (cons
                                                                                                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_NONE
                                                                                                                          (cons
                                                                                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_LEFT
                                                                                                                            (cons
                                                                                                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_RIGHT
                                                                                                                              (cons
                                                                                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_NIL
                                                                                                                                (cons
                                                                                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_SET
                                                                                                                                  (cons
                                                                                                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_DIP
                                                                                                                                    (cons
                                                                                                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_LOOP
                                                                                                                                      (cons
                                                                                                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_NONE
                                                                                                                                        (cons
                                                                                                                                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_LEFT
                                                                                                                                          (cons
                                                                                                                                            Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF_CONS
                                                                                                                                            (cons
                                                                                                                                              Tezos_raw_protocol_alpha.Alpha_context.Script.I_EMPTY_MAP
                                                                                                                                              (cons
                                                                                                                                                Tezos_raw_protocol_alpha.Alpha_context.Script.I_IF
                                                                                                                                                (cons
                                                                                                                                                  Tezos_raw_protocol_alpha.Alpha_context.Script.I_SOURCE
                                                                                                                                                  (cons
                                                                                                                                                    Tezos_raw_protocol_alpha.Alpha_context.Script.I_SENDER
                                                                                                                                                    (cons
                                                                                                                                                      Tezos_raw_protocol_alpha.Alpha_context.Script.I_SELF
                                                                                                                                                      (cons
                                                                                                                                                        Tezos_raw_protocol_alpha.Alpha_context.Script.I_LAMBDA
                                                                                                                                                        [])))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
      end)

with parse_contract {arg : Type}
  (legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (arg : Tezos_raw_protocol_alpha.Script_typed_ir.ty arg)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (entrypoint : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract arg))) :=
  op_gtgteqquestion
    (op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.contract_exists))
    (fun ctxt =>
      op_gtgteqquestion (Contract._exists ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | false =>
            fail
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
                loc contract)
          | true =>
            op_gtgteqquestion
              (op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.get_script))
              (fun ctxt =>
                op_gtgteqquestion
                  (op_atat
                    (trace
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
                        loc contract)) (Contract.get_script_code ctxt contract))
                  (fun function_parameter =>
                    let '(ctxt, code) := function_parameter in
                    match code with
                    | None =>
                      Lwt._return
                        (op_gtgtquestion
                          (ty_eq ctxt arg
                            (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t
                              None))
                          (fun function_parameter =>
                            let '(Eq, ctxt) := function_parameter in
                            match entrypoint with
                            | "default" % string =>
                              let contract := (arg, (contract, entrypoint)) in
                              ok (ctxt, contract)
                            | entrypoint =>
                              error
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.No_such_entrypoint
                                  entrypoint)
                            end))
                    | Some code =>
                      op_gtgteqquestion (Script.force_decode ctxt code)
                        (fun function_parameter =>
                          let '(code, ctxt) := function_parameter in
                          Lwt._return
                            (op_gtgtquestion (parse_toplevel true code)
                              (fun function_parameter =>
                                let '(arg_type, _, _, root_name) :=
                                  function_parameter in
                                op_gtgtquestion
                                  (parse_parameter_ty ctxt true arg_type)
                                  (fun function_parameter =>
                                    let '(Ex_ty targ, ctxt) :=
                                      function_parameter in
                                    let _return
                                      (ctxt :
                                      Tezos_raw_protocol_alpha.Alpha_context.context)
                                      (targ :
                                      Tezos_raw_protocol_alpha.Script_typed_ir.ty
                                        arg) (entrypoint : string)
                                      : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                        (Tezos_raw_protocol_alpha.Alpha_context.context
                                          *
                                          (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract
                                            arg)) :=
                                      op_gtgtquestion
                                        (merge_types legacy ctxt loc targ arg)
                                        (fun function_parameter =>
                                          let '(arg, ctxt) := function_parameter
                                            in
                                          let contract :=
                                            (arg, (contract, entrypoint)) in
                                          ok (ctxt, contract)) in
                                    op_gtgtquestion
                                      (find_entrypoint_for_type targ arg
                                        root_name entrypoint ctxt)
                                      (fun function_parameter =>
                                        let '(ctxt, entrypoint, targ) :=
                                          function_parameter in
                                        op_gtgtquestion
                                          (merge_types legacy ctxt loc targ arg)
                                          (fun function_parameter =>
                                            let '(targ, ctxt) :=
                                              function_parameter in
                                            _return ctxt targ entrypoint))))))
                    end))
          end))

with parse_contract_for_script {arg : Type}
  (legacy : bool) (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (loc : Tezos_raw_protocol_alpha.Alpha_context.Script.location)
  (arg : Tezos_raw_protocol_alpha.Script_typed_ir.ty arg)
  (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
  (entrypoint : string)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context *
        (option (Tezos_raw_protocol_alpha.Script_typed_ir.typed_contract arg)))) :=
  op_gtgteqquestion
    (op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.contract_exists))
    (fun ctxt =>
      op_gtgteqquestion (Contract._exists ctxt contract)
        (fun function_parameter =>
          match function_parameter with
          | false => _return (ctxt, None)
          | true =>
            op_gtgteqquestion
              (op_atat Lwt._return (Gas.consume ctxt Typecheck_costs.get_script))
              (fun ctxt =>
                op_gtgteqquestion
                  (op_atat
                    (trace
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
                        loc contract)) (Contract.get_script_code ctxt contract))
                  (fun function_parameter =>
                    let '(ctxt, code) := function_parameter in
                    match code with
                    | None =>
                      match entrypoint with
                      | "default" % string =>
                        Lwt._return
                          match
                            ty_eq ctxt arg
                              (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t
                                None) with
                          |
                            Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                              (Eq, ctxt) =>
                            let contract := (arg, (contract, entrypoint)) in
                            ok (ctxt, (Some contract))
                          |
                            Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                              _ =>
                            op_gtgtquestion
                              (Gas.consume ctxt Typecheck_costs.cycle)
                              (fun ctxt => ok (ctxt, None))
                          end
                      | _ => _return (ctxt, None)
                      end
                    | Some code =>
                      op_gtgteqquestion (Script.force_decode ctxt code)
                        (fun function_parameter =>
                          let '(code, ctxt) := function_parameter in
                          Lwt._return
                            match parse_toplevel true code with
                            |
                              Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                _ =>
                              error
                                (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
                                  loc contract)
                            |
                              Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                (arg_type, _, _, root_name) =>
                              match parse_parameter_ty ctxt true arg_type with
                              |
                                Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                  _ =>
                                error
                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_contract
                                    loc contract)
                              |
                                Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                  (Ex_ty targ, ctxt) =>
                                match
                                  op_gtgtquestion
                                    (find_entrypoint_for_type targ arg root_name
                                      entrypoint ctxt)
                                    (fun function_parameter =>
                                      let '(ctxt, entrypoint, targ) :=
                                        function_parameter in
                                      op_gtgtquestion
                                        (merge_types legacy ctxt loc targ arg)
                                        (fun function_parameter =>
                                          let '(targ, ctxt) :=
                                            function_parameter in
                                          op_gtgtquestion
                                            (merge_types legacy ctxt loc targ
                                              arg)
                                            (fun function_parameter =>
                                              let '(arg, ctxt) :=
                                                function_parameter in
                                              let contract :=
                                                (arg, (contract, entrypoint)) in
                                              ok (ctxt, (Some contract))))) with
                                |
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                    res => ok res
                                |
                                  Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                    _ =>
                                  op_gtgtquestion (ty_eq ctxt targ targ)
                                    (fun function_parameter =>
                                      let '(Eq, ctxt) := function_parameter in
                                      op_gtgtquestion
                                        (merge_types legacy ctxt loc targ targ)
                                        (fun function_parameter =>
                                          let '(_, ctxt) := function_parameter
                                            in
                                          ok (ctxt, None)))
                                end
                              end
                            end)
                    end))
          end))

with parse_toplevel
  (legacy : bool)
  (toplevel : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      Tezos_raw_protocol_alpha.Alpha_context.Script.node *
      Tezos_raw_protocol_alpha.Alpha_context.Script.node * (option string)) :=
  op_atat
    (record_trace
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
        toplevel []))
    match root toplevel with
    | Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
          loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
          Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind)
    | Tezos_protocol_environment_alpha__Environment.Micheline.String loc _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
          loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
          Tezos_raw_protocol_alpha.Script_tc_errors.String_kind)
    | Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
          loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
          Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind)
    | Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc _ _ _ =>
      error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
          loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind [])
          Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind)
    | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ fields =>
      let fix find_fields
        (p :
        option
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_protocol_environment_alpha__Environment.Micheline.annot)) (s :
        option
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_protocol_environment_alpha__Environment.Micheline.annot)) (c :
        option
          ((Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.location *
            Tezos_protocol_environment_alpha__Environment.Micheline.annot))
        (fields :
        list
          (Tezos_protocol_environment_alpha__Environment.Micheline.node
            Tezos_raw_protocol_alpha.Alpha_context.Script.location
            Tezos_raw_protocol_alpha.Alpha_context.Script.prim))
        : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          ((option
            ((Tezos_protocol_environment_alpha__Environment.Micheline.node
              Tezos_raw_protocol_alpha.Alpha_context.Script.location
              Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
              Tezos_raw_protocol_alpha.Alpha_context.Script.location *
              Tezos_protocol_environment_alpha__Environment.Micheline.annot)) *
            (option
              ((Tezos_protocol_environment_alpha__Environment.Micheline.node
                Tezos_raw_protocol_alpha.Alpha_context.Script.location
                Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
                Tezos_raw_protocol_alpha.Alpha_context.Script.location *
                Tezos_protocol_environment_alpha__Environment.Micheline.annot))
            *
            (option
              ((Tezos_protocol_environment_alpha__Environment.Micheline.node
                Tezos_raw_protocol_alpha.Alpha_context.Script.location
                Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
                Tezos_raw_protocol_alpha.Alpha_context.Script.location *
                Tezos_protocol_environment_alpha__Environment.Micheline.annot))) :=
        match fields with
        | [] => ok (p, s, c)
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Int loc _)
            _ =>
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
              Tezos_raw_protocol_alpha.Script_tc_errors.Int_kind)
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.String loc
              _) _ =>
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
              Tezos_raw_protocol_alpha.Script_tc_errors.String_kind)
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Bytes loc _)
            _ =>
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
              Tezos_raw_protocol_alpha.Script_tc_errors.Bytes_kind)
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc _)
            _ =>
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_kind
              loc (cons Tezos_raw_protocol_alpha.Script_tc_errors.Prim_kind [])
              Tezos_raw_protocol_alpha.Script_tc_errors.Seq_kind)
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
              (cons arg []) annot) rest =>
          match p with
          | None => find_fields (Some (arg, loc, annot)) s c rest
          | Some _ =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
                loc Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter)
          end
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
              (cons arg []) annot) rest =>
          match s with
          | None => find_fields p (Some (arg, loc, annot)) c rest
          | Some _ =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
                loc Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage)
          end
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              Tezos_raw_protocol_alpha.Alpha_context.Script.K_code (cons arg [])
              annot) rest =>
          match c with
          | None => find_fields p s (Some (arg, loc, annot)) rest
          | Some _ =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_field
                loc Tezos_raw_protocol_alpha.Alpha_context.Script.K_code)
          end
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              ((Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter |
                Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage |
                Tezos_raw_protocol_alpha.Alpha_context.Script.K_code) as name)
              args _) _ =>
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_arity
              loc name 1 (List.length args))
        |
          cons
            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
              name _ _) _ =>
          let allowed :=
            cons Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
                (cons Tezos_raw_protocol_alpha.Alpha_context.Script.K_code []))
            in
          error
            (Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_primitive
              loc allowed name)
        end in
      op_gtgtquestion (find_fields None None None fields)
        (fun function_parameter =>
          match function_parameter with
          | (None, _, _) =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
                Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter)
          | (Some _, None, _) =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
                Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage)
          | (Some _, Some _, None) =>
            error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Missing_field
                Tezos_raw_protocol_alpha.Alpha_context.Script.K_code)
          |
            (Some (p, ploc, pannot), Some (s, sloc, sannot),
              Some (c, cloc, carrot)) =>
            let maybe_root_name :=
              op_gtgtquestion (Script_ir_annot.extract_field_annot p)
                (fun function_parameter =>
                  let '(p, root_name) := function_parameter in
                  match root_name with
                  | Some (Field_annot root_name) =>
                    ok (p, pannot, (Some root_name))
                  | None =>
                    match pannot with
                    | cons single [] =>
                      ok
                        (p, [],
                          (Some
                            (String.sub single 1
                              (op_minus (String.length single) 1))))
                    | _ => ok (p, pannot, None)
                    end
                  end) in
            if legacy then
              let '(p, root_name) :=
                match maybe_root_name with
                |
                  Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                    (p, _, root_name) => (p, root_name)
                |
                  Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                    _ => (p, None)
                end in
              ok (p, s, c, root_name)
            else
              op_gtgtquestion maybe_root_name
                (fun function_parameter =>
                  let '(p, pannot, root_name) := function_parameter in
                  op_gtgtquestion
                    (Script_ir_annot.error_unexpected_annot ploc pannot)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgtquestion
                        (Script_ir_annot.error_unexpected_annot cloc carrot)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgtquestion
                            (Script_ir_annot.error_unexpected_annot sloc sannot)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              ok (p, s, c, root_name)))))
          end)
    end.

Definition parse_script
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (legacy : bool)
  (function_parameter : Tezos_raw_protocol_alpha.Alpha_context.Script.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (ex_script * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let '{| code := code; storage := storage |} := function_parameter in
  op_gtgteqquestion (Script.force_decode ctxt code)
    (fun function_parameter =>
      let '(code, ctxt) := function_parameter in
      op_gtgteqquestion (Script.force_decode ctxt storage)
        (fun function_parameter =>
          let '(storage, ctxt) := function_parameter in
          op_gtgteqquestion (op_atat Lwt._return (parse_toplevel legacy code))
            (fun function_parameter =>
              let '(arg_type, storage_type, code_field, root_name) :=
                function_parameter in
              op_gtgteqquestion
                (trace
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                    (Some "parameter" % string) code (location arg_type))
                  (Lwt._return (parse_parameter_ty ctxt legacy arg_type)))
                (fun function_parameter =>
                  let '(Ex_ty arg_type, ctxt) := function_parameter in
                  op_gtgteqquestion
                    (if legacy then
                      _return tt
                    else
                      Lwt._return (well_formed_entrypoints arg_type root_name))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (trace
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                            (Some "storage" % string) code
                            (location storage_type))
                          (Lwt._return
                            (parse_storage_ty ctxt legacy storage_type)))
                        (fun function_parameter =>
                          let '(Ex_ty storage_type, ctxt) := function_parameter
                            in
                          let arg_annot :=
                            default_annot default_param_annot
                              (type_to_var_annot (name_of_ty arg_type)) in
                          let storage_annot :=
                            default_annot default_storage_annot
                              (type_to_var_annot (name_of_ty storage_type)) in
                          let arg_type_full :=
                            Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                              (arg_type, None, arg_annot)
                              (storage_type, None, storage_annot) None
                              (op_pipepipe (has_big_map arg_type)
                                (has_big_map storage_type)) in
                          let ret_type_full :=
                            Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                              ((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
                                (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                                  None) None false), None, None)
                              (storage_type, None, None) None
                              (has_big_map storage_type) in
                          op_gtgteqquestion
                            (trace_eval
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgtpipequestion
                                  (op_atat Lwt._return
                                    (serialize_ty_for_error ctxt storage_type))
                                  (fun function_parameter =>
                                    let '(storage_type, _ctxt) :=
                                      function_parameter in
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
                                      None storage storage_type))
                              (parse_data type_logger ctxt legacy storage_type
                                (root storage)))
                            (fun function_parameter =>
                              let '(storage, ctxt) := function_parameter in
                              op_gtgteqquestion
                                (trace
                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
                                    code [])
                                  (parse_returning type_logger
                                    (Toplevel
                                      {| storage_type := storage_type;
                                        param_type := arg_type;
                                        root_name := root_name;
                                        legacy_create_contract_literal := false
                                        |}) ctxt legacy (arg_type_full, None)
                                    ret_type_full code_field))
                                (fun function_parameter =>
                                  let '(code, ctxt) := function_parameter in
                                  _return
                                    ((Ex_script
                                      {| code := code; arg_type := arg_type;
                                        storage := storage;
                                        storage_type := storage_type;
                                        root_name := root_name |}), ctxt))))))))).

Definition typecheck_code
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (code : Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_tc_errors.type_map *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let legacy := false in
  op_gtgteqquestion (op_atat Lwt._return (parse_toplevel legacy code))
    (fun function_parameter =>
      let '(arg_type, storage_type, code_field, root_name) := function_parameter
        in
      let type_map := ref [] in
      op_gtgteqquestion
        (trace
          (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
            (Some "parameter" % string) code (location arg_type))
          (Lwt._return (parse_parameter_ty ctxt legacy arg_type)))
        (fun function_parameter =>
          let '(Ex_ty arg_type, ctxt) := function_parameter in
          op_gtgteqquestion
            (if legacy then
              _return tt
            else
              Lwt._return (well_formed_entrypoints arg_type root_name))
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (trace
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
                    (Some "storage" % string) code (location storage_type))
                  (Lwt._return (parse_storage_ty ctxt legacy storage_type)))
                (fun function_parameter =>
                  let '(Ex_ty storage_type, ctxt) := function_parameter in
                  let arg_annot :=
                    default_annot default_param_annot
                      (type_to_var_annot (name_of_ty arg_type)) in
                  let storage_annot :=
                    default_annot default_storage_annot
                      (type_to_var_annot (name_of_ty storage_type)) in
                  let arg_type_full :=
                    Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                      (arg_type, None, arg_annot)
                      (storage_type, None, storage_annot) None
                      (op_pipepipe (has_big_map arg_type)
                        (has_big_map storage_type)) in
                  let ret_type_full :=
                    Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t
                      ((Tezos_raw_protocol_alpha.Script_typed_ir.List_t
                        (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t
                          None) None false), None, None)
                      (storage_type, None, None) None (has_big_map storage_type)
                    in
                  let result :=
                    parse_returning
                      (Some
                        (fun loc =>
                          fun bef =>
                            fun aft =>
                              op_coloneq type_map
                                (cons (loc, (bef, aft))
                                  (op_exclamation type_map))))
                      (Toplevel
                        {| storage_type := storage_type; param_type := arg_type;
                          root_name := root_name;
                          legacy_create_contract_literal := false |}) ctxt
                      legacy (arg_type_full, None) ret_type_full code_field in
                  op_gtgteqquestion
                    (trace
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_contract
                        code (op_exclamation type_map)) result)
                    (fun function_parameter =>
                      let
                        '(Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ _, ctxt) :=
                        function_parameter in
                      _return ((op_exclamation type_map), ctxt)))))).

Definition typecheck_data
  (type_logger : option type_logger)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (function_parameter :
    Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.expr)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Alpha_context.context) :=
  let '(data, exp_ty) := function_parameter in
  let legacy := false in
  op_gtgteqquestion
    (trace
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_formed_type
        None exp_ty 0)
      (op_atat Lwt._return (parse_packable_ty ctxt legacy (root exp_ty))))
    (fun function_parameter =>
      let '(Ex_ty exp_ty, ctxt) := function_parameter in
      op_gtgteqquestion
        (trace_eval
          (fun function_parameter =>
            let 'tt := function_parameter in
            op_gtgtpipequestion
              (op_atat Lwt._return (serialize_ty_for_error ctxt exp_ty))
              (fun function_parameter =>
                let '(exp_ty, _ctxt) := function_parameter in
                Tezos_protocol_environment_alpha__Environment.Error_monad.Ill_typed_data
                  None data exp_ty))
          (parse_data type_logger ctxt legacy exp_ty (root data)))
        (fun function_parameter =>
          let '(_, ctxt) := function_parameter in
          _return ctxt)).

(* ❌ Applications of functors are not handled. *)
functor_application

Definition list_entrypoints {A : Type}
  (full : Tezos_raw_protocol_alpha.Script_typed_ir.ty A)
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (root_name :
    option
      Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.key))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        ((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
          Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
  let merge {B C : Type}
    (path : list B) (annot : option variant) (ty :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty C) (reachable : bool)
    (function_parameter :
    (list (list B)) *
      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        ((list B) * Tezos_raw_protocol_alpha.Alpha_context.Script.node)))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list (list B)) *
        (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
          ((list B) * Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
    let '(unreachables, all) as acc := function_parameter in
    match annot with
    | None | Some (Field_annot "" % string) =>
      op_atat ok
        (if reachable then
          acc
        else
          match ty with
          | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ _ => acc
          | _ => ((cons (List.rev path) unreachables), all)
          end)
    | Some (Field_annot name) =>
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gt)
          (String.length name) 31 then
        ok ((cons (List.rev path) unreachables), all)
      else
        if
          Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.mem)
            name all then
          ok ((cons (List.rev path) unreachables), all)
        else
          op_gtgtquestion (unparse_ty_no_lwt ctxt ty)
            (fun function_parameter =>
              let '(unparsed_ty, _) := function_parameter in
              ok
                (unreachables,
                  (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
                    name ((List.rev path), unparsed_ty) all)))
    end in
  let fix fold_tree {t : Type}
    (t : Tezos_raw_protocol_alpha.Script_typed_ir.ty t) (path :
    list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) (reachable : bool)
    (acc :
    (list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
      (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
        ((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
          Tezos_raw_protocol_alpha.Alpha_context.Script.node)))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list (list Tezos_raw_protocol_alpha.Alpha_context.Script.prim)) *
        (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.t)
          ((list Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
            Tezos_raw_protocol_alpha.Alpha_context.Script.node))) :=
    match t with
    | Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, al) (tr, ar) _ _ =>
      op_gtgtquestion
        (merge (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left path)
          al tl reachable acc)
        (fun acc =>
          op_gtgtquestion
            (merge
              (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right path)
              ar tr reachable acc)
            (fun acc =>
              op_gtgtquestion
                (fold_tree tl
                  (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
                    path)
                  match al with
                  | Some _ => true
                  | None => reachable
                  end acc)
                (fun acc =>
                  fold_tree tr
                    (cons Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right
                      path)
                    match ar with
                    | Some _ => true
                    | None => reachable
                    end acc)))
    | _ => ok acc
    end in
  op_gtgtquestion (unparse_ty_no_lwt ctxt full)
    (fun function_parameter =>
      let '(unparsed_full, _) := function_parameter in
      let '(init, reachable) :=
        match root_name with
        | None | Some "" % string =>
          (Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.empty),
            false)
        | Some name =>
          ((Entrypoints_map.(Tezos_protocol_environment_alpha__Environment.MAP.S.singleton)
            name ([], unparsed_full)), true)
        end in
      fold_tree full [] reachable ([], init)).

Fixpoint unparse_data {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : unparsing_mode) (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a)
  (a : a)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.node *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.cycle))
    (fun ctxt =>
      match (ty, a) with
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, tt) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.unit))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Unit [] []),
                ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Unparse_costs.int v)))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
                (Script_int.to_zint v)), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt (Unparse_costs.int v)))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
                (Script_int.to_zint v)), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt (Unparse_costs.string s)))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                (-1) s), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt (Unparse_costs.bytes s)))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                (-1) s), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, true) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.bool))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_True [] []),
                ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, false) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.bool))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_False [] []),
                ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, t) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt (Unparse_costs.timestamp t)))
          (fun ctxt =>
            match mode with
            | Optimized =>
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Int
                  (-1) (Script_timestamp.to_zint t)), ctxt)
            | Readable =>
              match Script_timestamp.to_notation t with
              | None =>
                _return
                  ((Tezos_protocol_environment_alpha__Environment.Micheline.Int
                    (-1) (Script_timestamp.to_zint t)), ctxt)
              | Some s =>
                _return
                  ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                    (-1) s), ctxt)
              end
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, (c, entrypoint))
        =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Unparse_costs.contract))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let entrypoint :=
                match entrypoint with
                | "default" % string => "" % string
                | name => name
                end in
              let bytes :=
                Data_encoding.Binary.to_bytes_exn
                  (tup2 Contract.encoding Variable.string) (c, entrypoint) in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                  (-1) string), ctxt)
            | Readable =>
              let notation :=
                match entrypoint with
                | "default" % string => Contract.to_b58check c
                | entrypoint =>
                  op_caret (Contract.to_b58check c)
                    (op_caret "%" % string entrypoint)
                end in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                  (-1) notation), ctxt)
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _,
          (_, (c, entrypoint))) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Unparse_costs.contract))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let entrypoint :=
                match entrypoint with
                | "default" % string => "" % string
                | name => name
                end in
              let bytes :=
                Data_encoding.Binary.to_bytes_exn
                  (tup2 Contract.encoding Variable.string) (c, entrypoint) in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                  (-1) string), ctxt)
            | Readable =>
              let notation :=
                match entrypoint with
                | "default" % string => Contract.to_b58check c
                | entrypoint =>
                  op_caret (Contract.to_b58check c)
                    (op_caret "%" % string entrypoint)
                end in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                  (-1) notation), ctxt)
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, s) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Unparse_costs.signature))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let bytes :=
                Data_encoding.Binary.to_bytes_exn Signature.encoding s in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                  (-1) string), ctxt)
            | Readable =>
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                  (-1) (Signature.to_b58check s)), ctxt)
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.tez))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
                (Z.of_int64 (Tez.to_mutez v))), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, k) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.key))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let bytes :=
                Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding
                  k in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                  (-1) string), ctxt)
            | Readable =>
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                  (-1) (Signature.Public_key.to_b58check k)), ctxt)
            end)
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, k) =>
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt Unparse_costs.key_hash))
          (fun ctxt =>
            match mode with
            | Optimized =>
              let bytes :=
                Data_encoding.Binary.to_bytes_exn
                  Signature.Public_key_hash.encoding k in
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                  (-1) string), ctxt)
            | Readable =>
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.String
                  (-1) (Signature.Public_key_hash.to_b58check k)), ctxt)
            end)
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _,
          (op, _big_map_diff)) =>
        let bytes :=
          Data_encoding.Binary.to_bytes_exn
            Operation.internal_operation_encoding op in
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt (Unparse_costs.operation string)))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                (-1) string), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, chain_id) =>
        let bytes :=
          Data_encoding.Binary.to_bytes_exn
            Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding)
            chain_id in
        op_gtgteqquestion
          (Lwt._return (Gas.consume ctxt (Unparse_costs.chain_id string)))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Bytes
                (-1) string), ctxt))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tl, _, _) (tr, _, _) _
          _, (l, r)) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.pair))
          (fun ctxt =>
            op_gtgteqquestion (unparse_data ctxt mode tl l)
              (fun function_parameter =>
                let '(l, ctxt) := function_parameter in
                op_gtgteqquestion (unparse_data ctxt mode tr r)
                  (fun function_parameter =>
                    let '(r, ctxt) := function_parameter in
                    _return
                      ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                        (-1)
                        Tezos_raw_protocol_alpha.Alpha_context.Script.D_Pair
                        (cons l (cons r [])) []), ctxt))))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (tl, _) _ _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.L l) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.union))
          (fun ctxt =>
            op_gtgteqquestion (unparse_data ctxt mode tl l)
              (fun function_parameter =>
                let '(l, ctxt) := function_parameter in
                _return
                  ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Left
                    (cons l []) []), ctxt)))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ (tr, _) _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.R r) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.union))
          (fun ctxt =>
            op_gtgteqquestion (unparse_data ctxt mode tr r)
              (fun function_parameter =>
                let '(r, ctxt) := function_parameter in
                _return
                  ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Right
                    (cons r []) []), ctxt)))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t t _ _, Some v) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.some))
          (fun ctxt =>
            op_gtgteqquestion (unparse_data ctxt mode t v)
              (fun function_parameter =>
                let '(v, ctxt) := function_parameter in
                _return
                  ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                    (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_Some
                    (cons v []) []), ctxt)))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ _, None) =>
        op_gtgteqquestion (Lwt._return (Gas.consume ctxt Unparse_costs.none))
          (fun ctxt =>
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                (-1) Tezos_raw_protocol_alpha.Alpha_context.Script.D_None [] []),
                ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.List_t t _ _, items) =>
        op_gtgteqquestion
          (fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun element =>
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Unparse_costs.list_element))
                  (fun ctxt =>
                    op_gtgteqquestion (unparse_data ctxt mode t element)
                      (fun function_parameter =>
                        let '(unparsed, ctxt) := function_parameter in
                        _return ((cons unparsed l), ctxt)))) ([], ctxt) items)
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
                (List.rev items)), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t t _, set) =>
        let t := ty_of_comparable_ty t in
        op_gtgteqquestion
          (fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun item =>
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Unparse_costs.set_element))
                  (fun ctxt =>
                    op_gtgteqquestion (unparse_data ctxt mode t item)
                      (fun function_parameter =>
                        let '(item, ctxt) := function_parameter in
                        _return ((cons item l), ctxt)))) ([], ctxt)
            (set_fold (fun e => fun acc => cons e acc) set []))
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
                items), ctxt))
      | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t kt vt _ _, map) =>
        let kt := ty_of_comparable_ty kt in
        op_gtgteqquestion
          (fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun function_parameter =>
                let '(k, v) := function_parameter in
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Unparse_costs.map_element))
                  (fun ctxt =>
                    op_gtgteqquestion (unparse_data ctxt mode kt k)
                      (fun function_parameter =>
                        let '(key, ctxt) := function_parameter in
                        op_gtgteqquestion (unparse_data ctxt mode vt v)
                          (fun function_parameter =>
                            let '(value, ctxt) := function_parameter in
                            _return
                              ((cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  (-1)
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
                                  (cons key (cons value [])) []) l), ctxt)))))
            ([], ctxt)
            (map_fold (fun k => fun v => fun acc => cons (k, v) acc) map []))
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
                items), ctxt))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t kt vt _, {|
          id := None; diff := Diff |}) =>
        let Diff := projT2 Diff in
        let kt := ty_of_comparable_ty kt in
        op_gtgteqquestion
          (fold_left_s
            (fun function_parameter =>
              let '(l, ctxt) := function_parameter in
              fun function_parameter =>
                let '(k, v) := function_parameter in
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Unparse_costs.map_element))
                  (fun ctxt =>
                    op_gtgteqquestion (unparse_data ctxt mode kt k)
                      (fun function_parameter =>
                        let '(key, ctxt) := function_parameter in
                        op_gtgteqquestion (unparse_data ctxt mode vt v)
                          (fun function_parameter =>
                            let '(value, ctxt) := function_parameter in
                            _return
                              ((cons
                                (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                                  (-1)
                                  Tezos_raw_protocol_alpha.Alpha_context.Script.D_Elt
                                  (cons key (cons value [])) []) l), ctxt)))))
            ([], ctxt)
            (Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.fold)
              (fun k =>
                fun v =>
                  fun acc =>
                    match v with
                    | None => acc
                    | Some v => cons (k, v) acc
                    end)
              (fst
                Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))
              []))
          (fun function_parameter =>
            let '(items, ctxt) := function_parameter in
            _return
              ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq (-1)
                items), ctxt))
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _kt _kv _, {|
          id := Some id; diff := Diff |}) =>
        let Diff := projT2 Diff in
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
            (Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.cardinal)
              (fst
                Diff.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)))
            0 then
          _return
            ((Tezos_protocol_environment_alpha__Environment.Micheline.Int (-1)
              id), ctxt)
        else
          (* ❌ Assert instruction is not handled. *)
          assert false
      |
        (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _,
          Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ original_code) =>
        unparse_code ctxt mode original_code
      end)

with unparse_code
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (mode : unparsing_mode)
  : Tezos_raw_protocol_alpha.Alpha_context.Script.node ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        ((Tezos_protocol_environment_alpha__Environment.Micheline.node Z
          Tezos_raw_protocol_alpha.Alpha_context.Script.prim) *
          Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  let legacy := true in
  fun function_parameter =>
    match function_parameter with
    |
      Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc
        Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
        (cons ty (cons data [])) annot =>
      op_gtgteqquestion (Lwt._return (parse_packable_ty ctxt legacy ty))
        (fun function_parameter =>
          let '(Ex_ty t, ctxt) := function_parameter in
          op_gtgteqquestion (parse_data None ctxt legacy t data)
            (fun function_parameter =>
              let '(data, ctxt) := function_parameter in
              op_gtgteqquestion (unparse_data ctxt mode t data)
                (fun function_parameter =>
                  let '(data, ctxt) := function_parameter in
                  op_gtgteqquestion
                    (Lwt._return
                      (Gas.consume ctxt (Unparse_costs.prim_cost 2 annot)))
                    (fun ctxt =>
                      _return
                        ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          loc
                          Tezos_raw_protocol_alpha.Alpha_context.Script.I_PUSH
                          (cons ty (cons data [])) annot), ctxt)))))
    | Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc items =>
      op_gtgteqquestion
        (fold_left_s
          (fun function_parameter =>
            let '(l, ctxt) := function_parameter in
            fun item =>
              op_gtgteqquestion (unparse_code ctxt mode item)
                (fun function_parameter =>
                  let '(item, ctxt) := function_parameter in
                  _return ((cons item l), ctxt))) ([], ctxt) items)
        (fun function_parameter =>
          let '(items, ctxt) := function_parameter in
          op_gtgteqquestion
            (Lwt._return
              (Gas.consume ctxt (Unparse_costs.seq_cost (List.length items))))
            (fun ctxt =>
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                  loc (List.rev items)), ctxt)))
    |
      Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc prim
        items annot =>
      op_gtgteqquestion
        (fold_left_s
          (fun function_parameter =>
            let '(l, ctxt) := function_parameter in
            fun item =>
              op_gtgteqquestion (unparse_code ctxt mode item)
                (fun function_parameter =>
                  let '(item, ctxt) := function_parameter in
                  _return ((cons item l), ctxt))) ([], ctxt) items)
        (fun function_parameter =>
          let '(items, ctxt) := function_parameter in
          op_gtgteqquestion
            (Lwt._return (Gas.consume ctxt (Unparse_costs.prim_cost 3 annot)))
            (fun ctxt =>
              _return
                ((Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                  loc prim (List.rev items) annot), ctxt)))
    |
      (Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
        Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
        Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as
        atom => _return (atom, ctxt)
    end.

Definition unparse_script {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (mode : unparsing_mode)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.script A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.Script.t *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  let '{|
    code := code;
      arg_type := arg_type;
      storage := storage;
      storage_type := storage_type;
      root_name := root_name
      |} := function_parameter in
  let 'Tezos_raw_protocol_alpha.Script_typed_ir.Lam _ original_code := code in
  op_gtgteqquestion (unparse_code ctxt mode original_code)
    (fun function_parameter =>
      let '(code, ctxt) := function_parameter in
      op_gtgteqquestion (unparse_data ctxt mode storage_type storage)
        (fun function_parameter =>
          let '(storage, ctxt) := function_parameter in
          op_gtgteqquestion (unparse_ty ctxt arg_type)
            (fun function_parameter =>
              let '(arg_type, ctxt) := function_parameter in
              op_gtgteqquestion (unparse_ty ctxt storage_type)
                (fun function_parameter =>
                  let '(storage_type, ctxt) := function_parameter in
                  let arg_type :=
                    add_field_annot
                      (Option.map
                        (fun n =>
                          (* ❌ Variants not supported *)
                          variant) root_name) None arg_type in
                  let code :=
                    Tezos_protocol_environment_alpha__Environment.Micheline.Seq
                      (-1)
                      (cons
                        (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                          (-1)
                          Tezos_raw_protocol_alpha.Alpha_context.Script.K_parameter
                          (cons arg_type []) [])
                        (cons
                          (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                            (-1)
                            Tezos_raw_protocol_alpha.Alpha_context.Script.K_storage
                            (cons storage_type []) [])
                          (cons
                            (Tezos_protocol_environment_alpha__Environment.Micheline.Prim
                              (-1)
                              Tezos_raw_protocol_alpha.Alpha_context.Script.K_code
                              (cons code []) []) []))) in
                  op_gtgteqquestion
                    (Lwt._return
                      (op_gtgtquestion
                        (Gas.consume ctxt (Unparse_costs.seq_cost 3))
                        (fun ctxt =>
                          op_gtgtquestion
                            (Gas.consume ctxt (Unparse_costs.prim_cost 1 []))
                            (fun ctxt =>
                              op_gtgtquestion
                                (Gas.consume ctxt (Unparse_costs.prim_cost 1 []))
                                (fun ctxt =>
                                  Gas.consume ctxt
                                    (Unparse_costs.prim_cost 1 []))))))
                    (fun ctxt =>
                      _return
                        ({| code := lazy_expr (strip_locations code);
                          storage := lazy_expr (strip_locations storage) |},
                          ctxt)))))).

Definition pack_data {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (typ : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (data : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.MBytes.t *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  op_gtgteqquestion (unparse_data ctxt Optimized typ data)
    (fun function_parameter =>
      let '(unparsed, ctxt) := function_parameter in
      let bytes :=
        Data_encoding.Binary.to_bytes_exn expr_encoding
          (Micheline.strip_locations unparsed) in
      op_gtgteqquestion
        (op_atat Lwt._return (Gas.consume ctxt (Script.serialized_cost string)))
        (fun ctxt =>
          let bytes :=
            MBytes.concat "" % string
              (cons (MBytes.of_string "" % string) (cons string [])) in
          op_gtgteqquestion
            (op_atat Lwt._return
              (Gas.consume ctxt (Script.serialized_cost string)))
            (fun ctxt => _return (string, ctxt)))).

Definition hash_data {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (typ : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (data : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Script_expr_hash.t *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  op_gtgteqquestion (pack_data ctxt typ data)
    (fun function_parameter =>
      let '(bytes, ctxt) := function_parameter in
      op_gtgteqquestion
        (op_atat Lwt._return
          (Gas.consume ctxt
            (Michelson_v1_gas.Cost_of.Legacy.hash string Script_expr_hash.size)))
        (fun ctxt => _return ((hash_bytes None (cons string [])), ctxt))).

Definition empty_big_map {A B : Type}
  (tk : Tezos_raw_protocol_alpha.Script_typed_ir.comparable_ty A)
  (tv : Tezos_raw_protocol_alpha.Script_typed_ir.ty B)
  : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B :=
  {| id := None; diff := empty_map tk; key_type := ty_of_comparable_ty tk;
    value_type := tv |}.

Definition big_map_mem {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (key : A)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (bool * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let '{| id := id; diff := diff; key_type := key_type |} := function_parameter
    in
  match ((map_get key diff), id) with
  | (None, None) => _return (false, ctxt)
  | (None, Some id) =>
    op_gtgteqquestion (hash_data ctxt key_type key)
      (fun function_parameter =>
        let '(hash, ctxt) := function_parameter in
        op_gtgteqquestion (Alpha_context.Big_map.mem ctxt id hash)
          (fun function_parameter =>
            let '(ctxt, res) := function_parameter in
            _return (res, ctxt)))
  | (Some None, _) => _return (false, ctxt)
  | (Some (Some _), _) => _return (true, ctxt)
  end.

Definition big_map_get {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (key : A)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((option B) * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let '{|
    id := id;
      diff := diff;
      key_type := key_type;
      value_type := value_type
      |} := function_parameter in
  match ((map_get key diff), id) with
  | (Some x, _) => _return (x, ctxt)
  | (None, None) => _return (None, ctxt)
  | (None, Some id) =>
    op_gtgteqquestion (hash_data ctxt key_type key)
      (fun function_parameter =>
        let '(hash, ctxt) := function_parameter in
        op_gtgteqquestion (Alpha_context.Big_map.get_opt ctxt id hash)
          (fun function_parameter =>
            match function_parameter with
            | (ctxt, None) => _return (None, ctxt)
            | (ctxt, Some value) =>
              op_gtgteqquestion
                (parse_data None ctxt true value_type (Micheline.root value))
                (fun function_parameter =>
                  let '(x, ctxt) := function_parameter in
                  _return ((Some x), ctxt))
            end))
  end.

Definition big_map_update {A B : Type}
  (key : A) (value : option B)
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B :=
  let '{| diff := diff |} as map := function_parameter in
  (* ❌ Record substitution not handled *)
  record_substitution.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition big_map_ids :=
  Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t).

Definition no_big_map_id
  : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) :=
  Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.empty).

Definition diff_of_big_map {A B : Type}
  (ctxt : Tezos_raw_protocol_alpha__Alpha_context.context)
  (fresh :
    Tezos_raw_protocol_alpha__Alpha_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha__Alpha_context.context *
            Tezos_raw_protocol_alpha__Alpha_context.Big_map.id)))
  (mode : unparsing_mode)
  (ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (function_parameter : Tezos_raw_protocol_alpha.Script_typed_ir.big_map A B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_item)
        * Tezos_raw_protocol_alpha__Alpha_context.Big_map.id *
        Tezos_raw_protocol_alpha__Alpha_context.context)) :=
  let '{|
    id := id;
      diff := diff;
      key_type := key_type;
      value_type := value_type
      |} := function_parameter in
  op_gtgteqquestion
    (Lwt._return
      (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list diff)))
    (fun ctxt =>
      op_gtgteqquestion
        match id with
        | Some id =>
          if
            Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.mem) id ids
            then
            op_gtgteqquestion (fresh ctxt)
              (fun function_parameter =>
                let '(ctxt, duplicate) := function_parameter in
                _return
                  (ctxt,
                    (cons
                      (Tezos_raw_protocol_alpha.Alpha_context.Contract.Copy id
                        duplicate) []), duplicate))
          else
            _return (ctxt, [], id)
        | None =>
          op_gtgteqquestion (fresh ctxt)
            (fun function_parameter =>
              let '(ctxt, id) := function_parameter in
              op_gtgteqquestion (unparse_ty ctxt key_type)
                (fun function_parameter =>
                  let '(kt, ctxt) := function_parameter in
                  op_gtgteqquestion (unparse_ty ctxt value_type)
                    (fun function_parameter =>
                      let '(kv, ctxt) := function_parameter in
                      _return
                        (ctxt,
                          (cons
                            (Tezos_raw_protocol_alpha.Alpha_context.Contract.Alloc
                              {| big_map := id;
                                key_type := Micheline.strip_locations kt;
                                value_type := Micheline.strip_locations kv |})
                            []), id))))
        end
        (fun function_parameter =>
          let '(ctxt, init, big_map) := function_parameter in
          let pairs :=
            map_fold (fun key => fun value => fun acc => cons (key, value) acc)
              diff [] in
          op_gtgteqquestion
            (fold_left_s
              (fun function_parameter =>
                let '(acc, ctxt) := function_parameter in
                fun function_parameter =>
                  let '(key, value) := function_parameter in
                  op_gtgteqquestion
                    (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
                    (fun ctxt =>
                      op_gtgteqquestion (hash_data ctxt key_type key)
                        (fun function_parameter =>
                          let '(diff_key_hash, ctxt) := function_parameter in
                          op_gtgteqquestion
                            (unparse_data ctxt mode key_type key)
                            (fun function_parameter =>
                              let '(key_node, ctxt) := function_parameter in
                              let diff_key := Micheline.strip_locations key_node
                                in
                              op_gtgteqquestion
                                match value with
                                | None => _return (None, ctxt)
                                | Some x =>
                                  op_gtgteqquestion
                                    (unparse_data ctxt mode value_type x)
                                    (fun function_parameter =>
                                      let '(node, ctxt) := function_parameter in
                                      _return
                                        ((Some (Micheline.strip_locations node)),
                                          ctxt))
                                end
                                (fun function_parameter =>
                                  let '(diff_value, ctxt) := function_parameter
                                    in
                                  let diff_item :=
                                    Tezos_raw_protocol_alpha.Alpha_context.Contract.Update
                                      {| big_map := big_map;
                                        diff_key := diff_key;
                                        diff_key_hash := diff_key_hash;
                                        diff_value := diff_value |} in
                                  _return ((cons diff_item acc), ctxt))))))
              ([], ctxt) pairs)
            (fun function_parameter =>
              let '(diff, ctxt) := function_parameter in
              _return ((op_at init diff), big_map, ctxt)))).

Fixpoint extract_big_map_updates {a : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (fresh :
    Tezos_raw_protocol_alpha.Alpha_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Alpha_context.context *
            Tezos_raw_protocol_alpha.Alpha_context.Big_map.id)))
  (mode : unparsing_mode)
  (ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (acc : list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (x : a)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Alpha_context.context * a *
        Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
        (list Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff))) :=
  match (ty, x) with
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _, map) =>
    op_gtgteqquestion (diff_of_big_map ctxt fresh mode ids map)
      (fun function_parameter =>
        let '(diff, id, ctxt) := function_parameter in
        let Map := diff map in
        let Map := projT2 Map in
        let map :=
          (* ❌ Record substitution not handled *)
          record_substitution in
        _return
          (ctxt, map,
            (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.add) id
              ids), (cons diff acc)))
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _
      true, (xl, xr)) =>
    op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        op_gtgteqquestion
          (extract_big_map_updates ctxt fresh mode ids acc tyl xl)
          (fun function_parameter =>
            let '(ctxt, xl, ids, acc) := function_parameter in
            op_gtgteqquestion
              (extract_big_map_updates ctxt fresh mode ids acc tyr xr)
              (fun function_parameter =>
                let '(ctxt, xr, ids, acc) := function_parameter in
                _return (ctxt, (xl, xr), ids, acc))))
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (ty, _) (_, _) _ true,
      Tezos_raw_protocol_alpha.Script_typed_ir.L x) =>
    op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        op_gtgteqquestion (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            let '(ctxt, x, ids, acc) := function_parameter in
            _return
              (ctxt, (Tezos_raw_protocol_alpha.Script_typed_ir.L x), ids, acc)))
  |
    (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (_, _) (ty, _) _ true,
      Tezos_raw_protocol_alpha.Script_typed_ir.R x) =>
    op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        op_gtgteqquestion (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            let '(ctxt, x, ids, acc) := function_parameter in
            _return
              (ctxt, (Tezos_raw_protocol_alpha.Script_typed_ir.R x), ids, acc)))
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ty _ true, Some x) =>
    op_gtgteqquestion (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
      (fun ctxt =>
        op_gtgteqquestion (extract_big_map_updates ctxt fresh mode ids acc ty x)
          (fun function_parameter =>
            let '(ctxt, x, ids, acc) := function_parameter in
            _return (ctxt, (Some x), ids, acc)))
  | (Tezos_raw_protocol_alpha.Script_typed_ir.List_t ty _ true, l) =>
    op_gtgteqquestion
      (fold_left_s
        (fun function_parameter =>
          let '(ctxt, l, ids, acc) := function_parameter in
          fun x =>
            op_gtgteqquestion
              (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
              (fun ctxt =>
                op_gtgteqquestion
                  (extract_big_map_updates ctxt fresh mode ids acc ty x)
                  (fun function_parameter =>
                    let '(ctxt, x, ids, acc) := function_parameter in
                    _return (ctxt, (cons x l), ids, acc)))) (ctxt, [], ids, acc)
        l)
      (fun function_parameter =>
        let '(ctxt, l, ids, acc) := function_parameter in
        _return (ctxt, (List.rev l), ids, acc))
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ ty _ true, M as m) =>
    let M := projT2 M in
    op_gtgteqquestion
      (Lwt._return
        (Gas.consume ctxt (Michelson_v1_gas.Cost_of.Legacy.map_to_list m)))
      (fun ctxt =>
        op_gtgteqquestion
          (fold_left_s
            (fun function_parameter =>
              let '(ctxt, m, ids, acc) := function_parameter in
              fun function_parameter =>
                let '(k, x) := function_parameter in
                op_gtgteqquestion
                  (Lwt._return (Gas.consume ctxt Typecheck_costs.cycle))
                  (fun ctxt =>
                    op_gtgteqquestion
                      (extract_big_map_updates ctxt fresh mode ids acc ty x)
                      (fun function_parameter =>
                        let '(ctxt, x, ids, acc) := function_parameter in
                        _return
                          (ctxt,
                            (M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
                              k x m), ids, acc))))
            (ctxt,
              M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.empty),
              ids, acc)
            (M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS).(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
              (fst M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed))))
          (fun function_parameter =>
            let '(ctxt, m, ids, acc) := function_parameter in
            let M :=
              (* ❌ The signature name of this module could not be found *)
              existT _ _
                {|
                  unknown_signature_name.OPS :=
                    M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.OPS);
                  unknown_signature_name.key_ty :=
                    M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.key_ty);
                  unknown_signature_name.boxed :=
                    (m,
                      (snd
                        M.(Tezos_raw_protocol_alpha.Script_typed_ir.Boxed_map.boxed)))
                  |} in
            _return (ctxt, M, ids, acc)))
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ true, None) =>
    _return (ctxt, None, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ false, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ false, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ false, None) =>
    _return (ctxt, None, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ false, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ false, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ false, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _, v) =>
    _return (ctxt, v, ids, acc)
  | (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _, _) =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition collect_big_maps {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (x : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
        Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let fix collect {a : Type}
    (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context) (ty :
    Tezos_raw_protocol_alpha.Script_typed_ir.ty a) (x : a) (acc :
    Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
    : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t) *
        Tezos_raw_protocol_alpha.Alpha_context.context) :=
    match (ty, x) with
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _, {|
        id := Some id |}) =>
      op_gtgtquestion (Gas.consume ctxt Typecheck_costs.cycle)
        (fun ctxt =>
          ok
            ((Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.add) id
              acc), ctxt))
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t (tyl, _, _) (tyr, _, _) _
        true, (xl, xr)) =>
      op_gtgtquestion (collect ctxt tyl xl acc)
        (fun function_parameter =>
          let '(acc, ctxt) := function_parameter in
          collect ctxt tyr xr acc)
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (ty, _) (_, _) _ true,
        Tezos_raw_protocol_alpha.Script_typed_ir.L x) => collect ctxt ty x acc
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t (_, _) (ty, _) _ true,
        Tezos_raw_protocol_alpha.Script_typed_ir.R x) => collect ctxt ty x acc
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t ty _ true, Some x) =>
      collect ctxt ty x acc
    | (Tezos_raw_protocol_alpha.Script_typed_ir.List_t ty _ true, l) =>
      List.fold_left
        (fun acc =>
          fun x =>
            op_gtgtquestion acc
              (fun function_parameter =>
                let '(acc, ctxt) := function_parameter in
                collect ctxt ty x acc)) (ok (acc, ctxt)) l
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ ty _ true, m) =>
      map_fold
        (fun function_parameter =>
          let '_ := function_parameter in
          fun v =>
            fun acc =>
              op_gtgtquestion acc
                (fun function_parameter =>
                  let '(acc, ctxt) := function_parameter in
                  collect ctxt ty v acc)) m (ok (acc, ctxt))
    | (Tezos_raw_protocol_alpha.Script_typed_ir.List_t _ _ false, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Map_t _ _ _ false, _) =>
      ok (acc, ctxt)
    |
      (Tezos_raw_protocol_alpha.Script_typed_ir.Big_map_t _ _ _, {|
        id := None |}) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ true, None) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Option_t _ _ false, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Union_t _ _ _ false, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Pair_t _ _ _ false, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Chain_id_t _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Set_t _ _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Unit_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Int_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Nat_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Signature_t _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.String_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Bytes_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Mutez_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_hash_t _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Key_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Timestamp_t _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Address_t _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Bool_t _, _) => ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Lambda_t _ _ _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Contract_t _ _, _) =>
      ok (acc, ctxt)
    | (Tezos_raw_protocol_alpha.Script_typed_ir.Operation_t _, _) =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  Lwt._return (collect ctxt ty x no_big_map_id).

Definition extract_big_map_diff {A : Type}
  (ctxt : Tezos_raw_protocol_alpha.Alpha_context.context)
  (mode : unparsing_mode) (temporary : bool)
  (to_duplicate : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (to_update : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  (ty : Tezos_raw_protocol_alpha.Script_typed_ir.ty A) (v : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A *
        (option
          (list
            Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff_item))
        * Tezos_raw_protocol_alpha.Alpha_context.context)) :=
  let to_duplicate :=
    Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.diff) to_duplicate
      to_update in
  let fresh :=
    if temporary then
      fun c => _return (Big_map.fresh_temporary c)
    else
      Big_map.fresh in
  op_gtgteqquestion
    (extract_big_map_updates ctxt fresh mode to_duplicate [] ty v)
    (fun function_parameter =>
      let '(ctxt, v, alive, diffs) := function_parameter in
      let diffs :=
        if temporary then
          diffs
        else
          let dead :=
            Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.diff)
              to_update alive in
          cons
            (Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.fold)
              (fun id =>
                fun acc =>
                  cons
                    (Tezos_raw_protocol_alpha.Alpha_context.Contract.Clear id)
                    acc) dead []) diffs in
      match diffs with
      | [] => _return (v, None, ctxt)
      | diffs => _return (v, (Some (List.flatten diffs)), ctxt)
      end).

Definition list_of_big_map_ids
  (ids : Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.t))
  : list Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.elt) :=
  Ids.(Tezos_protocol_environment_alpha__Environment.SET.S.elements) ids.

src/proto_alpha/lib_protocol/script_repr.ml 6 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type location = Micheline.canonical_location

let location_encoding = Micheline.canonical_location_encoding

type annot = Micheline.annot

type expr = Michelson_v1_primitives.prim Micheline.canonical

type lazy_expr = expr Data_encoding.lazy_t

type node = (location, Michelson_v1_primitives.prim) Micheline.node

let expr_encoding =
  Micheline.canonical_encoding_v1
    ~variant:"michelson_v1"
    Michelson_v1_primitives.prim_encoding

type error += Lazy_script_decode (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_binary_format"
    ~title:"Invalid binary format"
    ~description:
      "Could not deserialize some piece of data from its binary representation"
    Data_encoding.empty
    (function Lazy_script_decode -> Some () | _ -> None)
    (fun () -> Lazy_script_decode)

let lazy_expr_encoding = Data_encoding.lazy_encoding expr_encoding

let lazy_expr expr = Data_encoding.make_lazy expr_encoding expr

type t = {code : lazy_expr; storage : lazy_expr}

let encoding =
  let open Data_encoding in
  def "scripted.contracts"
  @@ conv
       (fun {code; storage} -> (code, storage))
       (fun (code, storage) -> {code; storage})
       (obj2 (req "code" lazy_expr_encoding) (req "storage" lazy_expr_encoding))

let int_node_size_of_numbits n = (1, 1 + ((n + 63) / 64))

let int_node_size n = int_node_size_of_numbits (Z.numbits n)

let string_node_size_of_length s = (1, 1 + ((s + 7) / 8))

let string_node_size s = string_node_size_of_length (String.length s)

let bytes_node_size_of_length s =
  (* approx cost of indirection to the C heap *)
  (2, 1 + ((s + 7) / 8) + 12)

let bytes_node_size s = bytes_node_size_of_length (MBytes.length s)

let prim_node_size_nonrec_of_lengths n_args annots =
  let annots_length =
    List.fold_left (fun acc s -> acc + String.length s) 0 annots
  in
  if Compare.Int.(annots_length = 0) then (1 + n_args, 2 + (2 * n_args))
  else (2 + n_args, 4 + (2 * n_args) + ((annots_length + 7) / 8))

let prim_node_size_nonrec args annots =
  let n_args = List.length args in
  prim_node_size_nonrec_of_lengths n_args annots

let seq_node_size_nonrec_of_length n_args = (1 + n_args, 2 + (2 * n_args))

let seq_node_size_nonrec args =
  let n_args = List.length args in
  seq_node_size_nonrec_of_length n_args

let rec node_size node =
  let open Micheline in
  match node with
  | Int (_, n) ->
      int_node_size n
  | String (_, s) ->
      string_node_size s
  | Bytes (_, s) ->
      bytes_node_size s
  | Prim (_, _, args, annot) ->
      List.fold_left
        (fun (blocks, words) node ->
          let (nblocks, nwords) = node_size node in
          (blocks + nblocks, words + nwords))
        (prim_node_size_nonrec args annot)
        args
  | Seq (_, args) ->
      List.fold_left
        (fun (blocks, words) node ->
          let (nblocks, nwords) = node_size node in
          (blocks + nblocks, words + nwords))
        (seq_node_size_nonrec args)
        args

let expr_size expr = node_size (Micheline.root expr)

let traversal_cost node =
  let (blocks, _words) = node_size node in
  Gas_limit_repr.step_cost blocks

let cost_of_size (blocks, words) =
  let open Gas_limit_repr in
  (Compare.Int.max 0 (blocks - 1) *@ alloc_cost 0)
  +@ alloc_cost words +@ step_cost blocks

let node_cost node = cost_of_size (node_size node)

let int_node_cost n = cost_of_size (int_node_size n)

let int_node_cost_of_numbits n = cost_of_size (int_node_size_of_numbits n)

let string_node_cost s = cost_of_size (string_node_size s)

let string_node_cost_of_length s = cost_of_size (string_node_size_of_length s)

let bytes_node_cost s = cost_of_size (bytes_node_size s)

let bytes_node_cost_of_length s = cost_of_size (bytes_node_size_of_length s)

let prim_node_cost_nonrec args annot =
  cost_of_size (prim_node_size_nonrec args annot)

let prim_node_cost_nonrec_of_length n_args annot =
  cost_of_size (prim_node_size_nonrec_of_lengths n_args annot)

let seq_node_cost_nonrec args = cost_of_size (seq_node_size_nonrec args)

let seq_node_cost_nonrec_of_length n_args =
  cost_of_size (seq_node_size_nonrec_of_length n_args)

let deserialized_cost expr = cost_of_size (expr_size expr)

let serialized_cost bytes =
  let open Gas_limit_repr in
  alloc_mbytes_cost (MBytes.length bytes)

let force_decode lexpr =
  let account_deserialization_cost =
    Data_encoding.apply_lazy
      ~fun_value:(fun _ -> false)
      ~fun_bytes:(fun _ -> true)
      ~fun_combine:(fun _ _ -> false)
      lexpr
  in
  match Data_encoding.force_decode lexpr with
  | Some v ->
      if account_deserialization_cost then ok (v, deserialized_cost v)
      else ok (v, Gas_limit_repr.free)
  | None ->
      error Lazy_script_decode

let force_bytes expr =
  let open Gas_limit_repr in
  let account_serialization_cost =
    Data_encoding.apply_lazy
      ~fun_value:(fun v -> Some v)
      ~fun_bytes:(fun _ -> None)
      ~fun_combine:(fun _ _ -> None)
      expr
  in
  match Data_encoding.force_bytes expr with
  | bytes -> (
    match account_serialization_cost with
    | Some v ->
        ok (bytes, traversal_cost (Micheline.root v) +@ serialized_cost bytes)
    | None ->
        ok (bytes, Gas_limit_repr.free) )
  | exception _ ->
      error Lazy_script_decode

let minimal_deserialize_cost lexpr =
  Data_encoding.apply_lazy
    ~fun_value:(fun _ -> Gas_limit_repr.free)
    ~fun_bytes:(fun b -> serialized_cost b)
    ~fun_combine:(fun c_free _ -> c_free)
    lexpr

let unit =
  Micheline.strip_locations (Prim (0, Michelson_v1_primitives.D_Unit, [], []))

let unit_parameter = lazy_expr unit

let is_unit_parameter =
  let unit_bytes = Data_encoding.force_bytes unit_parameter in
  Data_encoding.apply_lazy
    ~fun_value:(fun v ->
      match Micheline.root v with
      | Prim (_, Michelson_v1_primitives.D_Unit, [], []) ->
          true
      | _ ->
          false)
    ~fun_bytes:(fun b -> MBytes.( = ) b unit_bytes)
    ~fun_combine:(fun res _ -> res)

let rec strip_annotations node =
  let open Micheline in
  match node with
  | (Int (_, _) | String (_, _) | Bytes (_, _)) as leaf ->
      leaf
  | Prim (loc, name, args, _) ->
      Prim (loc, name, List.map strip_annotations args, [])
  | Seq (loc, args) ->
      Seq (loc, List.map strip_annotations args)
src/proto_alpha/lib_protocol/script_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition location :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location.

Definition location_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical_location :=
  Micheline.canonical_location_encoding.

Definition annot :=
  Tezos_protocol_environment_alpha__Environment.Micheline.annot.

Definition expr :=
  Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.

Definition lazy_expr :=
  Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t expr.

Definition node :=
  Tezos_protocol_environment_alpha__Environment.Micheline.node location
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim.

Definition expr_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
  Micheline.canonical_encoding_v1 "michelson_v1" % string
    Michelson_v1_primitives.prim_encoding.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition lazy_expr_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
      (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
        Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) :=
  Data_encoding.lazy_encoding expr_encoding.

Definition lazy_expr
  (expr :
    Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) :=
  Data_encoding.make_lazy expr_encoding expr.

Record t := {
  code : lazy_expr;
  storage : lazy_expr }.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding t :=
  op_atat
    (let arg := def "scripted.contracts" % string in
    fun eta => arg None None eta)
    (conv
      (fun function_parameter =>
        let '{| code := code; storage := storage |} := function_parameter in
        (code, storage))
      (fun function_parameter =>
        let '(code, storage) := function_parameter in
        {| code := code; storage := storage |}) None
      (obj2 (req None None "code" % string lazy_expr_encoding)
        (req None None "storage" % string lazy_expr_encoding))).

Definition int_node_size_of_numbits (n : Z) : Z * Z :=
  (1, (op_plus 1 (op_div (op_plus n 63) 64))).

Definition int_node_size (n : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Z * Z := int_node_size_of_numbits (Z.numbits n).

Definition string_node_size_of_length (s : Z) : Z * Z :=
  (1, (op_plus 1 (op_div (op_plus s 7) 8))).

Definition string_node_size (s : string) : Z * Z :=
  string_node_size_of_length (String.length s).

Definition bytes_node_size_of_length (s : Z) : Z * Z :=
  (2, (op_plus (op_plus 1 (op_div (op_plus s 7) 8)) 12)).

Definition bytes_node_size
  (s : Tezos_protocol_environment_alpha__Environment.MBytes.t) : Z * Z :=
  bytes_node_size_of_length (MBytes.length s).

Definition prim_node_size_nonrec_of_lengths (n_args : Z) (annots : list string)
  : Z * Z :=
  let annots_length :=
    List.fold_left (fun acc => fun s => op_plus acc (String.length s)) 0 annots
    in
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      annots_length 0 then
    ((op_plus 1 n_args), (op_plus 2 (op_star 2 n_args)))
  else
    ((op_plus 2 n_args),
      (op_plus (op_plus 4 (op_star 2 n_args))
        (op_div (op_plus annots_length 7) 8))).

Definition prim_node_size_nonrec {A : Type}
  (args : list A) (annots : list string) : Z * Z :=
  let n_args := List.length args in
  prim_node_size_nonrec_of_lengths n_args annots.

Definition seq_node_size_nonrec_of_length (n_args : Z) : Z * Z :=
  ((op_plus 1 n_args), (op_plus 2 (op_star 2 n_args))).

Definition seq_node_size_nonrec {A : Type} (args : list A) : Z * Z :=
  let n_args := List.length args in
  seq_node_size_nonrec_of_length n_args.

Fixpoint node_size {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Z * Z :=
  match node with
  | Tezos_protocol_environment_alpha__Environment.Micheline.Int _ n =>
    int_node_size n
  | Tezos_protocol_environment_alpha__Environment.Micheline.String _ s =>
    string_node_size s
  | Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ s =>
    bytes_node_size s
  | Tezos_protocol_environment_alpha__Environment.Micheline.Prim _ _ args annot
    =>
    List.fold_left
      (fun function_parameter =>
        let '(blocks, words) := function_parameter in
        fun node =>
          let '(nblocks, nwords) := node_size node in
          ((op_plus blocks nblocks), (op_plus words nwords)))
      (prim_node_size_nonrec args annot) args
  | Tezos_protocol_environment_alpha__Environment.Micheline.Seq _ args =>
    List.fold_left
      (fun function_parameter =>
        let '(blocks, words) := function_parameter in
        fun node =>
          let '(nblocks, nwords) := node_size node in
          ((op_plus blocks nblocks), (op_plus words nwords)))
      (seq_node_size_nonrec args) args
  end.

Definition expr_size {A : Type}
  (expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical A)
  : Z * Z := node_size (Micheline.root expr).

Definition traversal_cost {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  let '(blocks, _words) := node_size node in
  Gas_limit_repr.step_cost blocks.

Definition cost_of_size (function_parameter : Z * Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  let '(blocks, words) := function_parameter in
  op_plusat
    (op_plusat
      (op_starat
        (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.max)
          0 (op_minus blocks 1)) (alloc_cost 0)) (alloc_cost words))
    (step_cost blocks).

Definition node_cost {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (node_size node).

Definition int_node_cost (n : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (int_node_size n).

Definition int_node_cost_of_numbits (n : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (int_node_size_of_numbits n).

Definition string_node_cost (s : string)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (string_node_size s).

Definition string_node_cost_of_length (s : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (string_node_size_of_length s).

Definition bytes_node_cost
  (s : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (bytes_node_size s).

Definition bytes_node_cost_of_length (s : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (bytes_node_size_of_length s).

Definition prim_node_cost_nonrec {A : Type}
  (args : list A) (annot : list string)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (prim_node_size_nonrec args annot).

Definition prim_node_cost_nonrec_of_length (n_args : Z) (annot : list string)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (prim_node_size_nonrec_of_lengths n_args annot).

Definition seq_node_cost_nonrec {A : Type} (args : list A)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (seq_node_size_nonrec args).

Definition seq_node_cost_nonrec_of_length (n_args : Z)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (seq_node_size_nonrec_of_length n_args).

Definition deserialized_cost {A : Type}
  (expr : Tezos_protocol_environment_alpha__Environment.Micheline.canonical A)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  cost_of_size (expr_size expr).

Definition serialized_cost
  (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  alloc_mbytes_cost (MBytes.length string).

Definition force_decode {A : Type}
  (lexpr :
    Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
      (Tezos_protocol_environment_alpha__Environment.Micheline.canonical A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    ((Tezos_protocol_environment_alpha__Environment.Micheline.canonical A) *
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost) :=
  let account_deserialization_cost :=
    Data_encoding.apply_lazy
      (fun function_parameter =>
        let '_ := function_parameter in
        false)
      (fun function_parameter =>
        let '_ := function_parameter in
        true)
      (fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          false) lexpr in
  match Data_encoding.force_decode lexpr with
  | Some v =>
    if account_deserialization_cost then
      ok (v, (deserialized_cost v))
    else
      ok (v, Gas_limit_repr.free)
  | None =>
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Lazy_script_decode
  end.

Definition force_bytes {A : Type}
  (expr :
    Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
      (Tezos_protocol_environment_alpha__Environment.Micheline.canonical A))
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    (Tezos_protocol_environment_alpha__Environment.MBytes.t *
      Tezos_raw_protocol_alpha.Gas_limit_repr.cost) :=
  let account_serialization_cost :=
    Data_encoding.apply_lazy (fun v => Some v)
      (fun function_parameter =>
        let '_ := function_parameter in
        None)
      (fun function_parameter =>
        let '_ := function_parameter in
        fun function_parameter =>
          let '_ := function_parameter in
          None) expr in
  let 'bytes := Data_encoding.force_bytes expr in
  match account_serialization_cost with
  | Some v =>
    ok
      (string,
        (op_plusat (traversal_cost (Micheline.root v)) (serialized_cost string)))
  | None => ok (string, Gas_limit_repr.free)
  end.

Definition minimal_deserialize_cost {A : Type}
  (lexpr : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t A)
  : Tezos_raw_protocol_alpha.Gas_limit_repr.cost :=
  Data_encoding.apply_lazy
    (fun function_parameter =>
      let '_ := function_parameter in
      Gas_limit_repr.free) (fun b => serialized_cost b)
    (fun c_free =>
      fun function_parameter =>
        let '_ := function_parameter in
        c_free) lexpr.

Definition unit
  : Tezos_protocol_environment_alpha__Environment.Micheline.canonical
    Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim :=
  Micheline.strip_locations
    (Tezos_protocol_environment_alpha__Environment.Micheline.Prim 0
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Unit [] []).

Definition unit_parameter
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim) := lazy_expr unit.

Definition is_unit_parameter
  : (Tezos_protocol_environment_alpha__Environment.Data_encoding.lazy_t
    (Tezos_protocol_environment_alpha__Environment.Micheline.canonical
      Tezos_raw_protocol_alpha.Michelson_v1_primitives.prim)) -> bool :=
  let unit_bytes := Data_encoding.force_bytes unit_parameter in
  Data_encoding.apply_lazy
    (fun v =>
      match Micheline.root v with
      |
        Tezos_protocol_environment_alpha__Environment.Micheline.Prim _
          Tezos_raw_protocol_alpha.Michelson_v1_primitives.D_Unit [] [] => true
      | _ => false
      end) (fun b => MBytes.op_eq b unit_bytes)
    (fun res =>
      fun function_parameter =>
        let '_ := function_parameter in
        res).

Fixpoint strip_annotations {A B : Type}
  (node : Tezos_protocol_environment_alpha__Environment.Micheline.node A B)
  : Tezos_protocol_environment_alpha__Environment.Micheline.node A B :=
  match node with
  |
    (Tezos_protocol_environment_alpha__Environment.Micheline.Int _ _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.String _ _ |
      Tezos_protocol_environment_alpha__Environment.Micheline.Bytes _ _) as leaf
    => leaf
  | Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name args _
    =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Prim loc name
      (List.map strip_annotations args) []
  | Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc args =>
    Tezos_protocol_environment_alpha__Environment.Micheline.Seq loc
      (List.map strip_annotations args)
  end.

src/proto_alpha/lib_protocol/script_tc_errors.ml 49 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script

(* ---- Error definitions ---------------------------------------------------*)

(* Auxiliary types for error documentation *)
type namespace =
  | Type_namespace
  | Constant_namespace
  | Instr_namespace
  | Keyword_namespace

type kind = Int_kind | String_kind | Bytes_kind | Prim_kind | Seq_kind

type unparsed_stack_ty = (Script.expr * Script.annot) list

type type_map = (int * (unparsed_stack_ty * unparsed_stack_ty)) list

(* Structure errors *)
type error += Invalid_arity of Script.location * prim * int * int

type error +=
  | Invalid_namespace of Script.location * prim * namespace * namespace

type error += Invalid_primitive of Script.location * prim list * prim

type error += Invalid_kind of Script.location * kind list * kind

type error += Missing_field of prim

type error += Duplicate_field of Script.location * prim

type error += Unexpected_big_map of Script.location

type error += Unexpected_operation of Script.location

type error += Unexpected_contract of Script.location

type error += No_such_entrypoint of string

type error += Duplicate_entrypoint of string

type error += Unreachable_entrypoint of prim list

type error += Entrypoint_name_too_long of string

(* Instruction typing errors *)
type error += Fail_not_in_tail_position of Script.location

type error +=
  | Undefined_binop :
      Script.location * prim * Script.expr * Script.expr
      -> error

type error += Undefined_unop : Script.location * prim * Script.expr -> error

type error +=
  | Bad_return : Script.location * unparsed_stack_ty * Script.expr -> error

type error +=
  | Bad_stack : Script.location * prim * int * unparsed_stack_ty -> error

type error +=
  | Unmatched_branches :
      Script.location * unparsed_stack_ty * unparsed_stack_ty
      -> error

type error += Self_in_lambda of Script.location

type error += Bad_stack_length

type error += Bad_stack_item of int

type error += Inconsistent_annotations of string * string

type error +=
  | Inconsistent_type_annotations :
      Script.location * Script.expr * Script.expr
      -> error

type error += Inconsistent_field_annotations of string * string

type error += Unexpected_annotation of Script.location

type error += Ungrouped_annotations of Script.location

type error += Invalid_map_body : Script.location * unparsed_stack_ty -> error

type error += Invalid_map_block_fail of Script.location

type error +=
  | Invalid_iter_body :
      Script.location * unparsed_stack_ty * unparsed_stack_ty
      -> error

type error += Type_too_large : Script.location * int * int -> error

(* Value typing errors *)
type error +=
  | Invalid_constant : Script.location * Script.expr * Script.expr -> error

type error +=
  | Invalid_syntactic_constant :
      Script.location * Script.expr * string
      -> error

type error += Invalid_contract of Script.location * Contract.t

type error += Invalid_big_map of Script.location * Big_map.id

type error +=
  | Comparable_type_expected : Script.location * Script.expr -> error

type error += Inconsistent_types : Script.expr * Script.expr -> error

type error += Unordered_map_keys of Script.location * Script.expr

type error += Unordered_set_values of Script.location * Script.expr

type error += Duplicate_map_keys of Script.location * Script.expr

type error += Duplicate_set_values of Script.location * Script.expr

(* Toplevel errors *)
type error +=
  | Ill_typed_data : string option * Script.expr * Script.expr -> error

type error +=
  | Ill_formed_type of string option * Script.expr * Script.location

type error += Ill_typed_contract : Script.expr * type_map -> error

(* Gas related errors *)
type error += Cannot_serialize_error

(* Deprecation errors *)
type error += Deprecated_instruction of prim
src/proto_alpha/lib_protocol/script_tc_errors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Script.

Inductive namespace : Type :=
| Type_namespace : namespace
| Constant_namespace : namespace
| Instr_namespace : namespace
| Keyword_namespace : namespace.

Inductive kind : Type :=
| Int_kind : kind
| String_kind : kind
| Bytes_kind : kind
| Prim_kind : kind
| Seq_kind : kind.

Definition unparsed_stack_ty :=
  list
    (Tezos_raw_protocol_alpha.Alpha_context.Script.expr *
      Tezos_raw_protocol_alpha.Alpha_context.Script.annot).

Definition type_map := list (Z * (unparsed_stack_ty * unparsed_stack_ty)).

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension

src/proto_alpha/lib_protocol/script_tc_errors_registration.ml 9 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script
open Script_tc_errors

(* Helpers for encoding *)
let type_map_enc =
  let open Data_encoding in
  let stack_enc = list (tup2 Script.expr_encoding (list string)) in
  list
    (conv
       (fun (loc, (bef, aft)) -> (loc, bef, aft))
       (fun (loc, bef, aft) -> (loc, (bef, aft)))
       (obj3
          (req "location" Script.location_encoding)
          (req "stack_before" stack_enc)
          (req "stack_after" stack_enc)))

let stack_ty_enc =
  let open Data_encoding in
  list (obj2 (req "type" Script.expr_encoding) (dft "annots" (list string) []))

(* main registration *)
let () =
  let open Data_encoding in
  let located enc =
    merge_objs (obj1 (req "location" Script.location_encoding)) enc
  in
  let arity_enc = int8 in
  let namespace_enc =
    def
      "primitiveNamespace"
      ~title:"Primitive namespace"
      ~description:
        "One of the three possible namespaces of primitive (data constructor, \
         type name or instruction)."
    @@ string_enum
         [ ("type", Type_namespace);
           ("constant", Constant_namespace);
           ("instruction", Instr_namespace) ]
  in
  let kind_enc =
    def
      "expressionKind"
      ~title:"Expression kind"
      ~description:
        "One of the four possible kinds of expression (integer, string, \
         primitive application or sequence)."
    @@ string_enum
         [ ("integer", Int_kind);
           ("string", String_kind);
           ("bytes", Bytes_kind);
           ("primitiveApplication", Prim_kind);
           ("sequence", Seq_kind) ]
  in
  (* -- Structure errors ---------------------- *)
  (* Invalid arity *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_arity"
    ~title:"Invalid arity"
    ~description:
      "In a script or data expression, a primitive was applied to an \
       unsupported number of arguments."
    (located
       (obj3
          (req "primitive_name" Script.prim_encoding)
          (req "expected_arity" arity_enc)
          (req "wrong_arity" arity_enc)))
    (function
      | Invalid_arity (loc, name, exp, got) ->
          Some (loc, (name, exp, got))
      | _ ->
          None)
    (fun (loc, (name, exp, got)) -> Invalid_arity (loc, name, exp, got)) ;
  (* Missing field *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.missing_script_field"
    ~title:"Script is missing a field (parse error)"
    ~description:"When parsing script, a field was expected, but not provided"
    (obj1 (req "prim" prim_encoding))
    (function Missing_field prim -> Some prim | _ -> None)
    (fun prim -> Missing_field prim) ;
  (* Invalid primitive *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive"
    ~title:"Invalid primitive"
    ~description:"In a script or data expression, a primitive was unknown."
    (located
       (obj2
          (dft "expected_primitive_names" (list prim_encoding) [])
          (req "wrong_primitive_name" prim_encoding)))
    (function
      | Invalid_primitive (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
    (fun (loc, (exp, got)) -> Invalid_primitive (loc, exp, got)) ;
  (* Invalid kind *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_expression_kind"
    ~title:"Invalid expression kind"
    ~description:
      "In a script or data expression, an expression was of the wrong kind \
       (for instance a string where only a primitive applications can appear)."
    (located
       (obj2 (req "expected_kinds" (list kind_enc)) (req "wrong_kind" kind_enc)))
    (function
      | Invalid_kind (loc, exp, got) -> Some (loc, (exp, got)) | _ -> None)
    (fun (loc, (exp, got)) -> Invalid_kind (loc, exp, got)) ;
  (* Invalid namespace *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_primitive_namespace"
    ~title:"Invalid primitive namespace"
    ~description:
      "In a script or data expression, a primitive was of the wrong namespace."
    (located
       (obj3
          (req "primitive_name" prim_encoding)
          (req "expected_namespace" namespace_enc)
          (req "wrong_namespace" namespace_enc)))
    (function
      | Invalid_namespace (loc, name, exp, got) ->
          Some (loc, (name, exp, got))
      | _ ->
          None)
    (fun (loc, (name, exp, got)) -> Invalid_namespace (loc, name, exp, got)) ;
  (* Duplicate field *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_script_field"
    ~title:"Script has a duplicated field (parse error)"
    ~description:"When parsing script, a field was found more than once"
    (obj2 (req "loc" location_encoding) (req "prim" prim_encoding))
    (function Duplicate_field (loc, prim) -> Some (loc, prim) | _ -> None)
    (fun (loc, prim) -> Duplicate_field (loc, prim)) ;
  (* Unexpected big_map *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_bigmap"
    ~title:"Big map in unauthorized position (type error)"
    ~description:
      "When parsing script, a big_map type was found in a position where it \
       could end up stored inside a big_map, which is forbidden for now."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_big_map loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_big_map loc) ;
  (* Unexpected operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_operation"
    ~title:"Operation in unauthorized position (type error)"
    ~description:
      "When parsing script, an operation type was found in the storage or \
       parameter field."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_operation loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_operation loc) ;
  (* No such entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.no_such_entrypoint"
    ~title:"No such entrypoint (type error)"
    ~description:"An entrypoint was not found when calling a contract."
    (obj1 (req "entrypoint" string))
    (function No_such_entrypoint entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> No_such_entrypoint entrypoint) ;
  (* Unreachable entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unreachable_entrypoint"
    ~title:"Unreachable entrypoint (type error)"
    ~description:"An entrypoint in the contract is not reachable."
    (obj1 (req "path" (list prim_encoding)))
    (function Unreachable_entrypoint path -> Some path | _ -> None)
    (fun path -> Unreachable_entrypoint path) ;
  (* Duplicate entrypoint *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_entrypoint"
    ~title:"Duplicate entrypoint (type error)"
    ~description:"Two entrypoints have the same name."
    (obj1 (req "path" string))
    (function Duplicate_entrypoint entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> Duplicate_entrypoint entrypoint) ;
  (* Entrypoint name too long *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.entrypoint_name_too_long"
    ~title:"Entrypoint name too long (type error)"
    ~description:
      "An entrypoint name exceeds the maximum length of 31 characters."
    (obj1 (req "name" string))
    (function
      | Entrypoint_name_too_long entrypoint -> Some entrypoint | _ -> None)
    (fun entrypoint -> Entrypoint_name_too_long entrypoint) ;
  (* Unexpected contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_contract"
    ~title:"Contract in unauthorized position (type error)"
    ~description:
      "When parsing script, a contract type was found in the storage or \
       parameter field."
    (obj1 (req "loc" location_encoding))
    (function Unexpected_contract loc -> Some loc | _ -> None)
    (fun loc -> Unexpected_contract loc) ;
  (* -- Value typing errors ---------------------- *)
  (* Unordered map keys *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unordered_map_literal"
    ~title:"Invalid map key order"
    ~description:"Map keys must be in strictly increasing order"
    (obj2
       (req "location" Script.location_encoding)
       (req "item" Script.expr_encoding))
    (function Unordered_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Unordered_map_keys (loc, expr)) ;
  (* Duplicate map keys *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_map_keys"
    ~title:"Duplicate map keys"
    ~description:"Map literals cannot contain duplicated keys"
    (obj2
       (req "location" Script.location_encoding)
       (req "item" Script.expr_encoding))
    (function Duplicate_map_keys (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Duplicate_map_keys (loc, expr)) ;
  (* Unordered set values *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unordered_set_literal"
    ~title:"Invalid set value order"
    ~description:"Set values must be in strictly increasing order"
    (obj2
       (req "location" Script.location_encoding)
       (req "value" Script.expr_encoding))
    (function
      | Unordered_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Unordered_set_values (loc, expr)) ;
  (* Duplicate set values *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.duplicate_set_values_in_literal"
    ~title:"Sets literals cannot contain duplicate elements"
    ~description:
      "Set literals cannot contain duplicate elements, but a duplicae was \
       found while parsing."
    (obj2
       (req "location" Script.location_encoding)
       (req "value" Script.expr_encoding))
    (function
      | Duplicate_set_values (loc, expr) -> Some (loc, expr) | _ -> None)
    (fun (loc, expr) -> Duplicate_set_values (loc, expr)) ;
  (* -- Instruction typing errors ------------- *)
  (* Fail not in tail position *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.fail_not_in_tail_position"
    ~title:"FAIL not in tail position"
    ~description:"There is non trivial garbage code after a FAIL instruction."
    (located empty)
    (function Fail_not_in_tail_position loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Fail_not_in_tail_position loc) ;
  (* Undefined binary operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.undefined_binop"
    ~title:"Undefined binop"
    ~description:
      "A binary operation is called on operands of types over which it is not \
       defined."
    (located
       (obj3
          (req "operator_name" prim_encoding)
          (req "wrong_left_operand_type" Script.expr_encoding)
          (req "wrong_right_operand_type" Script.expr_encoding)))
    (function
      | Undefined_binop (loc, n, tyl, tyr) ->
          Some (loc, (n, tyl, tyr))
      | _ ->
          None)
    (fun (loc, (n, tyl, tyr)) -> Undefined_binop (loc, n, tyl, tyr)) ;
  (* Undefined unary operation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.undefined_unop"
    ~title:"Undefined unop"
    ~description:
      "A unary operation is called on an operand of type over which it is not \
       defined."
    (located
       (obj2
          (req "operator_name" prim_encoding)
          (req "wrong_operand_type" Script.expr_encoding)))
    (function Undefined_unop (loc, n, ty) -> Some (loc, (n, ty)) | _ -> None)
    (fun (loc, (n, ty)) -> Undefined_unop (loc, n, ty)) ;
  (* Bad return *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_return"
    ~title:"Bad return"
    ~description:"Unexpected stack at the end of a lambda or script."
    (located
       (obj2
          (req "expected_return_type" Script.expr_encoding)
          (req "wrong_stack_type" stack_ty_enc)))
    (function Bad_return (loc, sty, ty) -> Some (loc, (ty, sty)) | _ -> None)
    (fun (loc, (ty, sty)) -> Bad_return (loc, sty, ty)) ;
  (* Bad stack *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_stack"
    ~title:"Bad stack"
    ~description:"The stack has an unexpected length or contents."
    (located
       (obj3
          (req "primitive_name" prim_encoding)
          (req "relevant_stack_portion" int16)
          (req "wrong_stack_type" stack_ty_enc)))
    (function
      | Bad_stack (loc, name, s, sty) -> Some (loc, (name, s, sty)) | _ -> None)
    (fun (loc, (name, s, sty)) -> Bad_stack (loc, name, s, sty)) ;
  (* Inconsistent annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_annotations"
    ~title:"Annotations inconsistent between branches"
    ~description:"The annotations on two types could not be merged"
    (obj2 (req "annot1" string) (req "annot2" string))
    (function
      | Inconsistent_annotations (annot1, annot2) ->
          Some (annot1, annot2)
      | _ ->
          None)
    (fun (annot1, annot2) -> Inconsistent_annotations (annot1, annot2)) ;
  (* Inconsistent field annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_field_annotations"
    ~title:"Annotations for field accesses is inconsistent"
    ~description:
      "The specified field does not match the field annotation in the type"
    (obj2 (req "annot1" string) (req "annot2" string))
    (function
      | Inconsistent_field_annotations (annot1, annot2) ->
          Some (annot1, annot2)
      | _ ->
          None)
    (fun (annot1, annot2) -> Inconsistent_field_annotations (annot1, annot2)) ;
  (* Inconsistent type annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_type_annotations"
    ~title:"Types contain inconsistent annotations"
    ~description:"The two types contain annotations that do not match"
    (located
       (obj2
          (req "type1" Script.expr_encoding)
          (req "type2" Script.expr_encoding)))
    (function
      | Inconsistent_type_annotations (loc, ty1, ty2) ->
          Some (loc, (ty1, ty2))
      | _ ->
          None)
    (fun (loc, (ty1, ty2)) -> Inconsistent_type_annotations (loc, ty1, ty2)) ;
  (* Unexpected annotation *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unexpected_annotation"
    ~title:"An annotation was encountered where no annotation is expected"
    ~description:"A node in the syntax tree was impropperly annotated"
    (located empty)
    (function Unexpected_annotation loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Unexpected_annotation loc) ;
  (* Ungrouped annotations *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ungrouped_annotations"
    ~title:"Annotations of the same kind were found spread apart"
    ~description:"Annotations of the same kind must be grouped"
    (located empty)
    (function Ungrouped_annotations loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Ungrouped_annotations loc) ;
  (* Unmatched branches *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.unmatched_branches"
    ~title:"Unmatched branches"
    ~description:
      "At the join point at the end of two code branches the stacks have \
       inconsistent lengths or contents."
    (located
       (obj2
          (req "first_stack_type" stack_ty_enc)
          (req "other_stack_type" stack_ty_enc)))
    (function
      | Unmatched_branches (loc, stya, styb) ->
          Some (loc, (stya, styb))
      | _ ->
          None)
    (fun (loc, (stya, styb)) -> Unmatched_branches (loc, stya, styb)) ;
  (* Bad stack item *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.bad_stack_item"
    ~title:"Bad stack item"
    ~description:
      "The type of a stack item is unexpected (this error is always \
       accompanied by a more precise one)."
    (obj1 (req "item_level" int16))
    (function Bad_stack_item n -> Some n | _ -> None)
    (fun n -> Bad_stack_item n) ;
  (* SELF in lambda *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.self_in_lambda"
    ~title:"SELF instruction in lambda"
    ~description:"A SELF instruction was encountered in a lambda expression."
    (located empty)
    (function Self_in_lambda loc -> Some (loc, ()) | _ -> None)
    (fun (loc, ()) -> Self_in_lambda loc) ;
  (* Bad stack length *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_stack_lengths"
    ~title:"Inconsistent stack lengths"
    ~description:
      "A stack was of an unexpected length (this error is always in the \
       context of a located error)."
    empty
    (function Bad_stack_length -> Some () | _ -> None)
    (fun () -> Bad_stack_length) ;
  (* -- Value typing errors ------------------- *)
  (* Invalid constant *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_constant"
    ~title:"Invalid constant"
    ~description:"A data expression was invalid for its expected type."
    (located
       (obj2
          (req "expected_type" Script.expr_encoding)
          (req "wrong_expression" Script.expr_encoding)))
    (function
      | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
    (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
  (* Invalid syntactic constant *)
  register_error_kind
    `Permanent
    ~id:"invalidSyntacticConstantError"
    ~title:"Invalid constant (parse error)"
    ~description:"A compile-time constant was invalid for its expected form."
    (located
       (obj2
          (req "expectedForm" Script.expr_encoding)
          (req "wrongExpression" Script.expr_encoding)))
    (function
      | Invalid_constant (loc, expr, ty) -> Some (loc, (ty, expr)) | _ -> None)
    (fun (loc, (ty, expr)) -> Invalid_constant (loc, expr, ty)) ;
  (* Invalid contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_contract"
    ~title:"Invalid contract"
    ~description:
      "A script or data expression references a contract that does not exist \
       or assumes a wrong type for an existing contract."
    (located (obj1 (req "contract" Contract.encoding)))
    (function Invalid_contract (loc, c) -> Some (loc, c) | _ -> None)
    (fun (loc, c) -> Invalid_contract (loc, c)) ;
  (* Invalid big_map *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_big_map"
    ~title:"Invalid big_map"
    ~description:
      "A script or data expression references a big_map that does not exist \
       or assumes a wrong type for an existing big_map."
    (located (obj1 (req "big_map" z)))
    (function Invalid_big_map (loc, c) -> Some (loc, c) | _ -> None)
    (fun (loc, c) -> Invalid_big_map (loc, c)) ;
  (* Comparable type expected *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.comparable_type_expected"
    ~title:"Comparable type expected"
    ~description:
      "A non comparable type was used in a place where only comparable types \
       are accepted."
    (located (obj1 (req "wrong_type" Script.expr_encoding)))
    (function
      | Comparable_type_expected (loc, ty) -> Some (loc, ty) | _ -> None)
    (fun (loc, ty) -> Comparable_type_expected (loc, ty)) ;
  (* Inconsistent types *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.inconsistent_types"
    ~title:"Inconsistent types"
    ~description:
      "This is the basic type clash error, that appears in several places \
       where the equality of two types have to be proven, it is always \
       accompanied with another error that provides more context."
    (obj2
       (req "first_type" Script.expr_encoding)
       (req "other_type" Script.expr_encoding))
    (function Inconsistent_types (tya, tyb) -> Some (tya, tyb) | _ -> None)
    (fun (tya, tyb) -> Inconsistent_types (tya, tyb)) ;
  (* -- Instruction typing errors ------------------- *)
  (* Invalid map body *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_map_body"
    ~title:"Invalid map body"
    ~description:"The body of a map block did not match the expected type"
    (obj2 (req "loc" Script.location_encoding) (req "body_type" stack_ty_enc))
    (function Invalid_map_body (loc, stack) -> Some (loc, stack) | _ -> None)
    (fun (loc, stack) -> Invalid_map_body (loc, stack)) ;
  (* Invalid map block FAIL *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_map_block_fail"
    ~title:"FAIL instruction occurred as body of map block"
    ~description:
      "FAIL cannot be the only instruction in the body. The propper type of \
       the return list cannot be inferred."
    (obj1 (req "loc" Script.location_encoding))
    (function Invalid_map_block_fail loc -> Some loc | _ -> None)
    (fun loc -> Invalid_map_block_fail loc) ;
  (* Invalid ITER body *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.invalid_iter_body"
    ~title:"ITER body returned wrong stack type"
    ~description:
      "The body of an ITER instruction must result in the same stack type as \
       before the ITER."
    (obj3
       (req "loc" Script.location_encoding)
       (req "bef_stack" stack_ty_enc)
       (req "aft_stack" stack_ty_enc))
    (function
      | Invalid_iter_body (loc, bef, aft) -> Some (loc, bef, aft) | _ -> None)
    (fun (loc, bef, aft) -> Invalid_iter_body (loc, bef, aft)) ;
  (* Type too large *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.type_too_large"
    ~title:"Stack item type too large"
    ~description:"An instruction generated a type larger than the limit."
    (obj3
       (req "loc" Script.location_encoding)
       (req "type_size" uint16)
       (req "maximum_type_size" uint16))
    (function
      | Type_too_large (loc, ts, maxts) -> Some (loc, ts, maxts) | _ -> None)
    (fun (loc, ts, maxts) -> Type_too_large (loc, ts, maxts)) ;
  (* -- Toplevel errors ------------------- *)
  (* Ill typed data *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_typed_data"
    ~title:"Ill typed data"
    ~description:
      "The toplevel error thrown when trying to typecheck a data expression \
       against a given type (always followed by more precise errors)."
    (obj3
       (opt "identifier" string)
       (req "expected_type" Script.expr_encoding)
       (req "ill_typed_expression" Script.expr_encoding))
    (function
      | Ill_typed_data (name, expr, ty) -> Some (name, ty, expr) | _ -> None)
    (fun (name, ty, expr) -> Ill_typed_data (name, expr, ty)) ;
  (* Ill formed type *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_formed_type"
    ~title:"Ill formed type"
    ~description:
      "The toplevel error thrown when trying to parse a type expression \
       (always followed by more precise errors)."
    (obj3
       (opt "identifier" string)
       (req "ill_formed_expression" Script.expr_encoding)
       (req "location" Script.location_encoding))
    (function
      | Ill_formed_type (name, expr, loc) -> Some (name, expr, loc) | _ -> None)
    (fun (name, expr, loc) -> Ill_formed_type (name, expr, loc)) ;
  (* Ill typed contract *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.ill_typed_contract"
    ~title:"Ill typed contract"
    ~description:
      "The toplevel error thrown when trying to typecheck a contract code \
       against given input, output and storage types (always followed by more \
       precise errors)."
    (obj2
       (req "ill_typed_code" Script.expr_encoding)
       (req "type_map" type_map_enc))
    (function
      | Ill_typed_contract (expr, type_map) ->
          Some (expr, type_map)
      | _ ->
          None)
    (fun (expr, type_map) -> Ill_typed_contract (expr, type_map)) ;
  (* Cannot serialize error *)
  register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_error"
    ~title:"Not enough gas to serialize error"
    ~description:"The error was too big to be serialized with the provided gas"
    Data_encoding.empty
    (function Cannot_serialize_error -> Some () | _ -> None)
    (fun () -> Cannot_serialize_error) ;
  (* Deprecated instruction *)
  register_error_kind
    `Permanent
    ~id:"michelson_v1.deprecated_instruction"
    ~title:"Script is using a deprecated instruction"
    ~description:
      "A deprecated instruction usage is disallowed in newly created contracts"
    (obj1 (req "prim" prim_encoding))
    (function Deprecated_instruction prim -> Some prim | _ -> None)
    (fun prim -> Deprecated_instruction prim)
src/proto_alpha/lib_protocol/script_tc_errors_registration.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Script.

Import Script_tc_errors.

Definition type_map_enc
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list
      (Tezos_raw_protocol_alpha.Alpha_context.Script.location *
        ((list
          (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string)))
          *
          (list
            (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string)))))) :=
  let stack_enc := list None (tup2 Script.expr_encoding (list None string)) in
  list None
    (conv
      (fun function_parameter =>
        let '(loc, (bef, aft)) := function_parameter in
        (loc, bef, aft))
      (fun function_parameter =>
        let '(loc, bef, aft) := function_parameter in
        (loc, (bef, aft))) None
      (obj3 (req None None "location" % string Script.location_encoding)
        (req None None "stack_before" % string stack_enc)
        (req None None "stack_after" % string stack_enc))).

Definition stack_ty_enc
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list (Tezos_raw_protocol_alpha.Alpha_context.Script.expr * (list string))) :=
  list None
    (obj2 (req None None "type" % string Script.expr_encoding)
      (dft None None "annots" % string (list None string) [])).



src/proto_alpha/lib_protocol/script_timestamp_repr.ml 3 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = Z.t

let compare = Z.compare

let of_int64 = Z.of_int64

let of_string x =
  match Time_repr.of_notation x with
  | None -> (
    try Some (Z.of_string x) with _ -> None )
  | Some time ->
      Some (of_int64 (Time_repr.to_seconds time))

let to_notation x =
  try
    let notation = Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
    if String.equal notation "out_of_range" then None else Some notation
  with _ -> None

let to_num_str = Z.to_string

let to_string x = match to_notation x with None -> to_num_str x | Some s -> s

let diff x y = Script_int_repr.of_zint @@ Z.sub x y

let sub_delta t delta = Z.sub t (Script_int_repr.to_zint delta)

let add_delta t delta = Z.add t (Script_int_repr.to_zint delta)

let to_zint x = x

let of_zint x = x
src/proto_alpha/lib_protocol/script_timestamp_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := Tezos_protocol_environment_alpha__Environment.Z.t.

Definition compare
  : Tezos_protocol_environment_alpha__Environment.Z.t ->
    Tezos_protocol_environment_alpha__Environment.Z.t -> Z := Z.compare.

Definition of_int64
  : int64 -> Tezos_protocol_environment_alpha__Environment.Z.t := Z.of_int64.

Definition of_string (x : string)
  : option Tezos_protocol_environment_alpha__Environment.Z.t :=
  match Time_repr.of_notation x with
  | None =>
    (* ❌ Try-with are not handled *)
    try (Some (Z.of_string x))
  | Some time => Some (of_int64 (Time_repr.to_seconds time))
  end.

Definition to_notation (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : option string :=
  (* ❌ Try-with are not handled *)
  try
    (let notation := Time_repr.to_notation (Time.of_seconds (Z.to_int64 x)) in
    if String.equal notation "out_of_range" % string then
      None
    else
      Some notation).

Definition to_num_str
  : Tezos_protocol_environment_alpha__Environment.Z.t -> string := Z.to_string.

Definition to_string (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  : string :=
  match to_notation x with
  | None => to_num_str x
  | Some s => s
  end.

Definition diff
  (x : Tezos_protocol_environment_alpha__Environment.Z.t)
  (y : Tezos_protocol_environment_alpha__Environment.Z.t)
  : Tezos_raw_protocol_alpha.Script_int_repr.num
    Tezos_raw_protocol_alpha.Script_int_repr.z :=
  op_atat Script_int_repr.of_zint (Z.sub x y).

Definition sub_delta {A : Type}
  (t : Tezos_protocol_environment_alpha__Environment.Z.t)
  (delta : Tezos_raw_protocol_alpha.Script_int_repr.num A)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.sub t (Script_int_repr.to_zint delta).

Definition add_delta {A : Type}
  (t : Tezos_protocol_environment_alpha__Environment.Z.t)
  (delta : Tezos_raw_protocol_alpha.Script_int_repr.num A)
  : Tezos_protocol_environment_alpha__Environment.Z.t :=
  Z.add t (Script_int_repr.to_zint delta).

Definition to_zint {A : Type} (x : A) : A := x.

Definition of_zint {A : Type} (x : A) : A := x.

src/proto_alpha/lib_protocol/script_typed_ir.ml 256 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context
open Script_int

(* ---- Auxiliary types -----------------------------------------------------*)

type var_annot = [`Var_annot of string]

type type_annot = [`Type_annot of string]

type field_annot = [`Field_annot of string]

type annot = [var_annot | type_annot | field_annot]

type address = Contract.t * string

type ('a, 'b) pair = 'a * 'b

type ('a, 'b) union = L of 'a | R of 'b

type comb = Comb

type leaf = Leaf

type (_, _) comparable_struct =
  | Int_key : type_annot option -> (z num, _) comparable_struct
  | Nat_key : type_annot option -> (n num, _) comparable_struct
  | String_key : type_annot option -> (string, _) comparable_struct
  | Bytes_key : type_annot option -> (MBytes.t, _) comparable_struct
  | Mutez_key : type_annot option -> (Tez.t, _) comparable_struct
  | Bool_key : type_annot option -> (bool, _) comparable_struct
  | Key_hash_key : type_annot option -> (public_key_hash, _) comparable_struct
  | Timestamp_key :
      type_annot option
      -> (Script_timestamp.t, _) comparable_struct
  | Address_key : type_annot option -> (address, _) comparable_struct
  | Pair_key :
      (('a, leaf) comparable_struct * field_annot option)
      * (('b, _) comparable_struct * field_annot option)
      * type_annot option
      -> (('a, 'b) pair, comb) comparable_struct

type 'a comparable_ty = ('a, comb) comparable_struct

module type Boxed_set = sig
  type elt

  val elt_ty : elt comparable_ty

  module OPS : S.SET with type elt = elt

  val boxed : OPS.t

  val size : int
end

type 'elt set = (module Boxed_set with type elt = 'elt)

module type Boxed_map = sig
  type key

  type value

  val key_ty : key comparable_ty

  module OPS : S.MAP with type key = key

  val boxed : value OPS.t * int
end

type ('key, 'value) map =
  (module Boxed_map with type key = 'key and type value = 'value)

type operation = packed_internal_operation * Contract.big_map_diff option

type ('arg, 'storage) script = {
  code : (('arg, 'storage) pair, (operation list, 'storage) pair) lambda;
  arg_type : 'arg ty;
  storage : 'storage;
  storage_type : 'storage ty;
  root_name : string option;
}

and end_of_stack = unit

and ('arg, 'ret) lambda =
  | Lam :
      ('arg * end_of_stack, 'ret * end_of_stack) descr * Script.node
      -> ('arg, 'ret) lambda

and 'arg typed_contract = 'arg ty * address

and 'ty ty =
  | Unit_t : type_annot option -> unit ty
  | Int_t : type_annot option -> z num ty
  | Nat_t : type_annot option -> n num ty
  | Signature_t : type_annot option -> signature ty
  | String_t : type_annot option -> string ty
  | Bytes_t : type_annot option -> MBytes.t ty
  | Mutez_t : type_annot option -> Tez.t ty
  | Key_hash_t : type_annot option -> public_key_hash ty
  | Key_t : type_annot option -> public_key ty
  | Timestamp_t : type_annot option -> Script_timestamp.t ty
  | Address_t : type_annot option -> address ty
  | Bool_t : type_annot option -> bool ty
  | Pair_t :
      ('a ty * field_annot option * var_annot option)
      * ('b ty * field_annot option * var_annot option)
      * type_annot option
      * bool
      -> ('a, 'b) pair ty
  | Union_t :
      ('a ty * field_annot option)
      * ('b ty * field_annot option)
      * type_annot option
      * bool
      -> ('a, 'b) union ty
  | Lambda_t : 'arg ty * 'ret ty * type_annot option -> ('arg, 'ret) lambda ty
  | Option_t : 'v ty * type_annot option * bool -> 'v option ty
  | List_t : 'v ty * type_annot option * bool -> 'v list ty
  | Set_t : 'v comparable_ty * type_annot option -> 'v set ty
  | Map_t :
      'k comparable_ty * 'v ty * type_annot option * bool
      -> ('k, 'v) map ty
  | Big_map_t :
      'k comparable_ty * 'v ty * type_annot option
      -> ('k, 'v) big_map ty
  | Contract_t : 'arg ty * type_annot option -> 'arg typed_contract ty
  | Operation_t : type_annot option -> operation ty
  | Chain_id_t : type_annot option -> Chain_id.t ty

and 'ty stack_ty =
  | Item_t :
      'ty ty * 'rest stack_ty * var_annot option
      -> ('ty * 'rest) stack_ty
  | Empty_t : end_of_stack stack_ty

and ('key, 'value) big_map = {
  id : Z.t option;
  diff : ('key, 'value option) map;
  key_type : 'key ty;
  value_type : 'value ty;
}

(* ---- Instructions --------------------------------------------------------*)

(* The low-level, typed instructions, as a GADT whose parameters
   encode the typing rules.

   The left parameter is the typed shape of the stack before the
   instruction, the right one the shape after. Any program whose
   construction is accepted by OCaml's type-checker is guaranteed to
   be type-safe. Overloadings of the concrete syntax are already
   resolved in this representation, either by using different
   constructors or type witness parameters. *)
and ('bef, 'aft) instr =
  (* stack ops *)
  | Drop : (_ * 'rest, 'rest) instr
  | Dup : ('top * 'rest, 'top * ('top * 'rest)) instr
  | Swap : ('tip * ('top * 'rest), 'top * ('tip * 'rest)) instr
  | Const : 'ty -> ('rest, 'ty * 'rest) instr
  (* pairs *)
  | Cons_pair : ('car * ('cdr * 'rest), ('car, 'cdr) pair * 'rest) instr
  | Car : (('car, _) pair * 'rest, 'car * 'rest) instr
  | Cdr : ((_, 'cdr) pair * 'rest, 'cdr * 'rest) instr
  (* options *)
  | Cons_some : ('v * 'rest, 'v option * 'rest) instr
  | Cons_none : 'a ty -> ('rest, 'a option * 'rest) instr
  | If_none :
      ('bef, 'aft) descr * ('a * 'bef, 'aft) descr
      -> ('a option * 'bef, 'aft) instr
  (* unions *)
  | Left : ('l * 'rest, ('l, 'r) union * 'rest) instr
  | Right : ('r * 'rest, ('l, 'r) union * 'rest) instr
  | If_left :
      ('l * 'bef, 'aft) descr * ('r * 'bef, 'aft) descr
      -> (('l, 'r) union * 'bef, 'aft) instr
  (* lists *)
  | Cons_list : ('a * ('a list * 'rest), 'a list * 'rest) instr
  | Nil : ('rest, 'a list * 'rest) instr
  | If_cons :
      ('a * ('a list * 'bef), 'aft) descr * ('bef, 'aft) descr
      -> ('a list * 'bef, 'aft) instr
  | List_map :
      ('a * 'rest, 'b * 'rest) descr
      -> ('a list * 'rest, 'b list * 'rest) instr
  | List_iter : ('a * 'rest, 'rest) descr -> ('a list * 'rest, 'rest) instr
  | List_size : ('a list * 'rest, n num * 'rest) instr
  (* sets *)
  | Empty_set : 'a comparable_ty -> ('rest, 'a set * 'rest) instr
  | Set_iter : ('a * 'rest, 'rest) descr -> ('a set * 'rest, 'rest) instr
  | Set_mem : ('elt * ('elt set * 'rest), bool * 'rest) instr
  | Set_update : ('elt * (bool * ('elt set * 'rest)), 'elt set * 'rest) instr
  | Set_size : ('a set * 'rest, n num * 'rest) instr
  (* maps *)
  | Empty_map : 'a comparable_ty * 'v ty -> ('rest, ('a, 'v) map * 'rest) instr
  | Map_map :
      (('a * 'v) * 'rest, 'r * 'rest) descr
      -> (('a, 'v) map * 'rest, ('a, 'r) map * 'rest) instr
  | Map_iter :
      (('a * 'v) * 'rest, 'rest) descr
      -> (('a, 'v) map * 'rest, 'rest) instr
  | Map_mem : ('a * (('a, 'v) map * 'rest), bool * 'rest) instr
  | Map_get : ('a * (('a, 'v) map * 'rest), 'v option * 'rest) instr
  | Map_update
      : ('a * ('v option * (('a, 'v) map * 'rest)), ('a, 'v) map * 'rest) instr
  | Map_size : (('a, 'b) map * 'rest, n num * 'rest) instr
  (* big maps *)
  | Empty_big_map :
      'a comparable_ty * 'v ty
      -> ('rest, ('a, 'v) big_map * 'rest) instr
  | Big_map_mem : ('a * (('a, 'v) big_map * 'rest), bool * 'rest) instr
  | Big_map_get : ('a * (('a, 'v) big_map * 'rest), 'v option * 'rest) instr
  | Big_map_update
      : ( 'key * ('value option * (('key, 'value) big_map * 'rest)),
          ('key, 'value) big_map * 'rest )
        instr
  (* string operations *)
  | Concat_string : (string list * 'rest, string * 'rest) instr
  | Concat_string_pair : (string * (string * 'rest), string * 'rest) instr
  | Slice_string
      : (n num * (n num * (string * 'rest)), string option * 'rest) instr
  | String_size : (string * 'rest, n num * 'rest) instr
  (* bytes operations *)
  | Concat_bytes : (MBytes.t list * 'rest, MBytes.t * 'rest) instr
  | Concat_bytes_pair : (MBytes.t * (MBytes.t * 'rest), MBytes.t * 'rest) instr
  | Slice_bytes
      : (n num * (n num * (MBytes.t * 'rest)), MBytes.t option * 'rest) instr
  | Bytes_size : (MBytes.t * 'rest, n num * 'rest) instr
  (* timestamp operations *)
  | Add_seconds_to_timestamp
      : ( z num * (Script_timestamp.t * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Add_timestamp_to_seconds
      : ( Script_timestamp.t * (z num * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Sub_timestamp_seconds
      : ( Script_timestamp.t * (z num * 'rest),
          Script_timestamp.t * 'rest )
        instr
  | Diff_timestamps
      : ( Script_timestamp.t * (Script_timestamp.t * 'rest),
          z num * 'rest )
        instr
  (* tez operations *)
  | Add_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Sub_tez : (Tez.t * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Mul_teznat : (Tez.t * (n num * 'rest), Tez.t * 'rest) instr
  | Mul_nattez : (n num * (Tez.t * 'rest), Tez.t * 'rest) instr
  | Ediv_teznat
      : (Tez.t * (n num * 'rest), (Tez.t, Tez.t) pair option * 'rest) instr
  | Ediv_tez
      : (Tez.t * (Tez.t * 'rest), (n num, Tez.t) pair option * 'rest) instr
  (* boolean operations *)
  | Or : (bool * (bool * 'rest), bool * 'rest) instr
  | And : (bool * (bool * 'rest), bool * 'rest) instr
  | Xor : (bool * (bool * 'rest), bool * 'rest) instr
  | Not : (bool * 'rest, bool * 'rest) instr
  (* integer operations *)
  | Is_nat : (z num * 'rest, n num option * 'rest) instr
  | Neg_nat : (n num * 'rest, z num * 'rest) instr
  | Neg_int : (z num * 'rest, z num * 'rest) instr
  | Abs_int : (z num * 'rest, n num * 'rest) instr
  | Int_nat : (n num * 'rest, z num * 'rest) instr
  | Add_intint : (z num * (z num * 'rest), z num * 'rest) instr
  | Add_intnat : (z num * (n num * 'rest), z num * 'rest) instr
  | Add_natint : (n num * (z num * 'rest), z num * 'rest) instr
  | Add_natnat : (n num * (n num * 'rest), n num * 'rest) instr
  | Sub_int : ('s num * ('t num * 'rest), z num * 'rest) instr
  | Mul_intint : (z num * (z num * 'rest), z num * 'rest) instr
  | Mul_intnat : (z num * (n num * 'rest), z num * 'rest) instr
  | Mul_natint : (n num * (z num * 'rest), z num * 'rest) instr
  | Mul_natnat : (n num * (n num * 'rest), n num * 'rest) instr
  | Ediv_intint
      : (z num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_intnat
      : (z num * (n num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_natint
      : (n num * (z num * 'rest), (z num, n num) pair option * 'rest) instr
  | Ediv_natnat
      : (n num * (n num * 'rest), (n num, n num) pair option * 'rest) instr
  | Lsl_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Lsr_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Or_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | And_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | And_int_nat : (z num * (n num * 'rest), n num * 'rest) instr
  | Xor_nat : (n num * (n num * 'rest), n num * 'rest) instr
  | Not_nat : (n num * 'rest, z num * 'rest) instr
  | Not_int : (z num * 'rest, z num * 'rest) instr
  (* control *)
  | Seq : ('bef, 'trans) descr * ('trans, 'aft) descr -> ('bef, 'aft) instr
  | If : ('bef, 'aft) descr * ('bef, 'aft) descr -> (bool * 'bef, 'aft) instr
  | Loop : ('rest, bool * 'rest) descr -> (bool * 'rest, 'rest) instr
  | Loop_left :
      ('a * 'rest, ('a, 'b) union * 'rest) descr
      -> (('a, 'b) union * 'rest, 'b * 'rest) instr
  | Dip : ('bef, 'aft) descr -> ('top * 'bef, 'top * 'aft) instr
  | Exec : ('arg * (('arg, 'ret) lambda * 'rest), 'ret * 'rest) instr
  | Apply :
      'arg ty
      -> ( 'arg * (('arg * 'remaining, 'ret) lambda * 'rest),
           ('remaining, 'ret) lambda * 'rest )
         instr
  | Lambda : ('arg, 'ret) lambda -> ('rest, ('arg, 'ret) lambda * 'rest) instr
  | Failwith : 'a ty -> ('a * 'rest, 'aft) instr
  | Nop : ('rest, 'rest) instr
  (* comparison *)
  | Compare : 'a comparable_ty -> ('a * ('a * 'rest), z num * 'rest) instr
  (* comparators *)
  | Eq : (z num * 'rest, bool * 'rest) instr
  | Neq : (z num * 'rest, bool * 'rest) instr
  | Lt : (z num * 'rest, bool * 'rest) instr
  | Gt : (z num * 'rest, bool * 'rest) instr
  | Le : (z num * 'rest, bool * 'rest) instr
  | Ge : (z num * 'rest, bool * 'rest) instr
  (* protocol *)
  | Address : (_ typed_contract * 'rest, address * 'rest) instr
  | Contract :
      'p ty * string
      -> (address * 'rest, 'p typed_contract option * 'rest) instr
  | Transfer_tokens
      : ( 'arg * (Tez.t * ('arg typed_contract * 'rest)),
          operation * 'rest )
        instr
  | Create_account
      : ( public_key_hash * (public_key_hash option * (bool * (Tez.t * 'rest))),
          operation * (address * 'rest) )
        instr
  | Implicit_account
      : (public_key_hash * 'rest, unit typed_contract * 'rest) instr
  | Create_contract :
      'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
      -> ( public_key_hash
           * (public_key_hash option * (bool * (bool * (Tez.t * ('g * 'rest))))),
           operation * (address * 'rest) )
         instr
  | Create_contract_2 :
      'g ty * 'p ty * ('p * 'g, operation list * 'g) lambda * string option
      -> ( public_key_hash option * (Tez.t * ('g * 'rest)),
           operation * (address * 'rest) )
         instr
  | Set_delegate : (public_key_hash option * 'rest, operation * 'rest) instr
  | Now : ('rest, Script_timestamp.t * 'rest) instr
  | Balance : ('rest, Tez.t * 'rest) instr
  | Check_signature
      : (public_key * (signature * (MBytes.t * 'rest)), bool * 'rest) instr
  | Hash_key : (public_key * 'rest, public_key_hash * 'rest) instr
  | Pack : 'a ty -> ('a * 'rest, MBytes.t * 'rest) instr
  | Unpack : 'a ty -> (MBytes.t * 'rest, 'a option * 'rest) instr
  | Blake2b : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Sha256 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Sha512 : (MBytes.t * 'rest, MBytes.t * 'rest) instr
  | Steps_to_quota
      : (* TODO: check that it always returns a nat *)
      ('rest, n num * 'rest) instr
  | Source : ('rest, address * 'rest) instr
  | Sender : ('rest, address * 'rest) instr
  | Self : 'p ty * string -> ('rest, 'p typed_contract * 'rest) instr
  | Amount : ('rest, Tez.t * 'rest) instr
  | Dig :
      int * ('x * 'rest, 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('bef, 'x * 'aft) instr
  | Dug :
      int * ('rest, 'x * 'rest, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('x * 'bef, 'aft) instr
  | Dipn :
      int
      * ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      * ('fbef, 'faft) descr
      -> ('bef, 'aft) instr
  | Dropn :
      int * ('rest, 'rest, 'bef, _) stack_prefix_preservation_witness
      -> ('bef, 'rest) instr
  | ChainId : ('rest, Chain_id.t * 'rest) instr

(* Type witness for operations that work deep in the stack ignoring
   (and preserving) a prefix.

   The two right parameters are the shape of the stack with the (same)
   prefix before and after the transformation. The two left
   parameters are the shape of the stack without the prefix before and
   after. The inductive definition makes it so by construction. *)
and ('bef, 'aft, 'bef_suffix, 'aft_suffix) stack_prefix_preservation_witness =
  | Prefix :
      ('fbef, 'faft, 'bef, 'aft) stack_prefix_preservation_witness
      -> ('fbef, 'faft, 'x * 'bef, 'x * 'aft) stack_prefix_preservation_witness
  | Rest : ('bef, 'aft, 'bef, 'aft) stack_prefix_preservation_witness

and ('bef, 'aft) descr = {
  loc : Script.location;
  bef : 'bef stack_ty;
  aft : 'aft stack_ty;
  instr : ('bef, 'aft) instr;
}

type ex_big_map = Ex_bm : ('key, 'value) big_map -> ex_big_map
src/proto_alpha/lib_protocol/script_typed_ir.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Import Script_int.

Definition var_annot := variant.

Definition type_annot := variant.

Definition field_annot := variant.

Definition annot := variant.

Definition address :=
  Tezos_raw_protocol_alpha.Alpha_context.Contract.t * string.

Definition pair (a b : Type) := a * b.

Inductive union (a b : Type) : Type :=
| L : a -> union a b
| R : b -> union a b.

Arguments L {_ _}.
Arguments R {_ _}.

Inductive comb : Type :=
| Comb : comb.

Inductive leaf : Type :=
| Leaf : leaf.

Inductive comparable_struct : forall (_ _ : Type), Type :=
| Int_key : forall {A : Type}, (option type_annot) ->
  comparable_struct
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) A
| Nat_key : forall {A : Type}, (option type_annot) ->
  comparable_struct
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) A
| String_key : forall {A : Type}, (option type_annot) ->
  comparable_struct string A
| Bytes_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_protocol_environment_alpha__Environment.MBytes.t A
| Mutez_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Tez.t A
| Bool_key : forall {A : Type}, (option type_annot) -> comparable_struct bool A
| Key_hash_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_raw_protocol_alpha.Alpha_context.public_key_hash A
| Timestamp_key : forall {A : Type}, (option type_annot) ->
  comparable_struct Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t A
| Address_key : forall {A : Type}, (option type_annot) ->
  comparable_struct address A
| Pair_key : forall {C a b : Type},
  ((comparable_struct a leaf) * (option field_annot)) ->
  ((comparable_struct b C) * (option field_annot)) -> (option type_annot) ->
  comparable_struct (pair a b) comb.

Definition comparable_ty (a : Type) := comparable_struct a comb.

Module Boxed_set.
  Record signature {elt OPS_t : Type} := {
    elt := elt;
    elt_ty : comparable_ty elt;
    OPS : S.SET.signature elt OPS_t;
    boxed : OPS.(Tezos_protocol_environment_alpha__Environment.SET.S.t);
    size : Z;
  }.
  Arguments signature : clear implicits.
End Boxed_set.

Definition set (elt : Type) := {OPS_t : _ & Boxed_set.signature elt OPS_t}.

Module Boxed_map.
  Record signature {key value OPS_t : Type} := {
    key := key;
    value := value;
    key_ty : comparable_ty key;
    OPS : S.MAP.signature key OPS_t;
    boxed : (OPS.(Tezos_protocol_environment_alpha__Environment.MAP.S.t) value)
      * Z;
  }.
  Arguments signature : clear implicits.
End Boxed_map.

Definition map (key value : Type) :=
  {OPS_t : _ & Boxed_map.signature key value OPS_t}.

Definition operation :=
  Tezos_raw_protocol_alpha.Alpha_context.packed_internal_operation *
    (option Tezos_raw_protocol_alpha.Alpha_context.Contract.big_map_diff).

Reserved Notation "'end_of_stack".
Reserved Notation "'typed_contract".

Inductive lambda (arg ret : Type) : Type :=
| Lam : (descr (arg * 'end_of_stack) (ret * 'end_of_stack)) ->
  Tezos_raw_protocol_alpha.Alpha_context.Script.node -> lambda arg ret

with ty : forall (ty : Type), Type :=
| Unit_t : (option type_annot) -> ty unit
| Int_t : (option type_annot) ->
  ty
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
| Nat_t : (option type_annot) ->
  ty
    (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
| Signature_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.signature
| String_t : (option type_annot) -> ty string
| Bytes_t : (option type_annot) ->
  ty Tezos_protocol_environment_alpha__Environment.MBytes.t
| Mutez_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.Tez.t
| Key_hash_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.public_key_hash
| Key_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.public_key
| Timestamp_t : (option type_annot) ->
  ty Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t
| Address_t : (option type_annot) -> ty address
| Bool_t : (option type_annot) -> ty bool
| Pair_t : forall {a b : Type},
  ((ty a) * (option field_annot) * (option var_annot)) ->
  ((ty b) * (option field_annot) * (option var_annot)) -> (option type_annot) ->
  bool -> ty (pair a b)
| Union_t : forall {a b : Type}, ((ty a) * (option field_annot)) ->
  ((ty b) * (option field_annot)) -> (option type_annot) -> bool ->
  ty (union a b)
| Lambda_t : forall {arg ret : Type}, (ty arg) -> (ty ret) ->
  (option type_annot) -> ty (lambda arg ret)
| Option_t : forall {v : Type}, (ty v) -> (option type_annot) -> bool ->
  ty (option v)
| List_t : forall {v : Type}, (ty v) -> (option type_annot) -> bool ->
  ty (list v)
| Set_t : forall {v : Type}, (comparable_ty v) -> (option type_annot) ->
  ty (set v)
| Map_t : forall {k v : Type}, (comparable_ty k) -> (ty v) ->
  (option type_annot) -> bool -> ty (map k v)
| Big_map_t : forall {k v : Type}, (comparable_ty k) -> (ty v) ->
  (option type_annot) -> ty (big_map k v)
| Contract_t : forall {arg : Type}, (ty arg) -> (option type_annot) ->
  ty ('typed_contract arg)
| Operation_t : (option type_annot) -> ty operation
| Chain_id_t : (option type_annot) ->
  ty
    Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)

with stack_ty : forall (ty : Type), Type :=
| Item_t : forall {rest ty : Type}, (ty ty) -> (stack_ty rest) ->
  (option var_annot) -> stack_ty (ty * rest)
| Empty_t : stack_ty 'end_of_stack

with instr : forall (bef aft : Type), Type :=
| Drop : forall {A rest : Type}, instr (A * rest) rest
| Dup : forall {rest top : Type}, instr (top * rest) (top * (top * rest))
| Swap : forall {rest tip top : Type},
  instr (tip * (top * rest)) (top * (tip * rest))
| Const : forall {rest ty : Type}, ty -> instr rest (ty * rest)
| Cons_pair : forall {car cdr rest : Type},
  instr (car * (cdr * rest)) ((pair car cdr) * rest)
| Car : forall {B car rest : Type}, instr ((pair car B) * rest) (car * rest)
| Cdr : forall {A cdr rest : Type}, instr ((pair A cdr) * rest) (cdr * rest)
| Cons_some : forall {rest v : Type}, instr (v * rest) ((option v) * rest)
| Cons_none : forall {a rest : Type}, (ty a) -> instr rest ((option a) * rest)
| If_none : forall {a aft bef : Type}, (descr bef aft) -> (descr (a * bef) aft)
  -> instr ((option a) * bef) aft
| Left : forall {l r rest : Type}, instr (l * rest) ((union l r) * rest)
| Right : forall {l r rest : Type}, instr (r * rest) ((union l r) * rest)
| If_left : forall {aft bef l r : Type}, (descr (l * bef) aft) ->
  (descr (r * bef) aft) -> instr ((union l r) * bef) aft
| Cons_list : forall {a rest : Type},
  instr (a * ((list a) * rest)) ((list a) * rest)
| Nil : forall {a rest : Type}, instr rest ((list a) * rest)
| If_cons : forall {a aft bef : Type}, (descr (a * ((list a) * bef)) aft) ->
  (descr bef aft) -> instr ((list a) * bef) aft
| List_map : forall {a b rest : Type}, (descr (a * rest) (b * rest)) ->
  instr ((list a) * rest) ((list b) * rest)
| List_iter : forall {a rest : Type}, (descr (a * rest) rest) ->
  instr ((list a) * rest) rest
| List_size : forall {a rest : Type},
  instr ((list a) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_set : forall {a rest : Type}, (comparable_ty a) ->
  instr rest ((set a) * rest)
| Set_iter : forall {a rest : Type}, (descr (a * rest) rest) ->
  instr ((set a) * rest) rest
| Set_mem : forall {elt rest : Type},
  instr (elt * ((set elt) * rest)) (bool * rest)
| Set_update : forall {elt rest : Type},
  instr (elt * (bool * ((set elt) * rest))) ((set elt) * rest)
| Set_size : forall {a rest : Type},
  instr ((set a) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_map : forall {a rest v : Type}, (comparable_ty a) -> (ty v) ->
  instr rest ((map a v) * rest)
| Map_map : forall {a r rest v : Type}, (descr ((a * v) * rest) (r * rest)) ->
  instr ((map a v) * rest) ((map a r) * rest)
| Map_iter : forall {a rest v : Type}, (descr ((a * v) * rest) rest) ->
  instr ((map a v) * rest) rest
| Map_mem : forall {a rest v : Type},
  instr (a * ((map a v) * rest)) (bool * rest)
| Map_get : forall {a rest v : Type},
  instr (a * ((map a v) * rest)) ((option v) * rest)
| Map_update : forall {a rest v : Type},
  instr (a * ((option v) * ((map a v) * rest))) ((map a v) * rest)
| Map_size : forall {a b rest : Type},
  instr ((map a b) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Empty_big_map : forall {a rest v : Type}, (comparable_ty a) -> (ty v) ->
  instr rest ((big_map a v) * rest)
| Big_map_mem : forall {a rest v : Type},
  instr (a * ((big_map a v) * rest)) (bool * rest)
| Big_map_get : forall {a rest v : Type},
  instr (a * ((big_map a v) * rest)) ((option v) * rest)
| Big_map_update : forall {key rest value : Type},
  instr (key * ((option value) * ((big_map key value) * rest)))
    ((big_map key value) * rest)
| Concat_string : forall {rest : Type},
  instr ((list string) * rest) (string * rest)
| Concat_string_pair : forall {rest : Type},
  instr (string * (string * rest)) (string * rest)
| Slice_string : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * (string * rest)))
    ((option string) * rest)
| String_size : forall {rest : Type},
  instr (string * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Concat_bytes : forall {rest : Type},
  instr ((list Tezos_protocol_environment_alpha__Environment.MBytes.t) * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Concat_bytes_pair : forall {rest : Type},
  instr
    (Tezos_protocol_environment_alpha__Environment.MBytes.t *
      (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest))
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Slice_bytes : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
        (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)))
    ((option Tezos_protocol_environment_alpha__Environment.MBytes.t) * rest)
| Bytes_size : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Add_seconds_to_timestamp : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Add_timestamp_to_seconds : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Sub_timestamp_seconds : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Diff_timestamps : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_tez : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Sub_tez : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Mul_teznat : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Mul_nattez : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Ediv_teznat : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((option
      (pair Tezos_raw_protocol_alpha.Alpha_context.Tez.t
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest)
| Ediv_tez : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
        Tezos_raw_protocol_alpha.Alpha_context.Tez.t)) * rest)
| Or : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| And : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| Xor : forall {rest : Type}, instr (bool * (bool * rest)) (bool * rest)
| Not : forall {rest : Type}, instr (bool * rest) (bool * rest)
| Is_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((option
      (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)) * rest)
| Neg_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Neg_int : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Abs_int : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Int_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_intint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_intnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_natint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Add_natnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Sub_int : forall {rest s t : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num s) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num t) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_intint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_intnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_natint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Mul_natnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Ediv_intint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_intnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_natint : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.z)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Ediv_natnat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((option
      (pair
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n)
        (Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
          Tezos_raw_protocol_alpha.Alpha_context.Script_int.n))) * rest)
| Lsl_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Lsr_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Or_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| And_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| And_int_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Xor_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) *
      ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
        Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Not_nat : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Not_int : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Seq : forall {aft bef trans : Type}, (descr bef trans) -> (descr trans aft) ->
  instr bef aft
| If : forall {aft bef : Type}, (descr bef aft) -> (descr bef aft) ->
  instr (bool * bef) aft
| Loop : forall {rest : Type}, (descr rest (bool * rest)) ->
  instr (bool * rest) rest
| Loop_left : forall {a b rest : Type}, (descr (a * rest) ((union a b) * rest))
  -> instr ((union a b) * rest) (b * rest)
| Dip : forall {aft bef top : Type}, (descr bef aft) ->
  instr (top * bef) (top * aft)
| Exec : forall {arg rest ret : Type},
  instr (arg * ((lambda arg ret) * rest)) (ret * rest)
| Apply : forall {arg remaining rest ret : Type}, (ty arg) ->
  instr (arg * ((lambda (arg * remaining) ret) * rest))
    ((lambda remaining ret) * rest)
| Lambda : forall {arg rest ret : Type}, (lambda arg ret) ->
  instr rest ((lambda arg ret) * rest)
| Failwith : forall {a aft rest : Type}, (ty a) -> instr (a * rest) aft
| Nop : forall {rest : Type}, instr rest rest
| Compare : forall {a rest : Type}, (comparable_ty a) ->
  instr (a * (a * rest))
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest)
| Eq : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Neq : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Lt : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Gt : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Le : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Ge : forall {rest : Type},
  instr
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.z) * rest) (bool * rest)
| Address : forall {A rest : Type},
  instr (('typed_contract A) * rest) (address * rest)
| Contract : forall {p rest : Type}, (ty p) -> string ->
  instr (address * rest) ((option ('typed_contract p)) * rest)
| Transfer_tokens : forall {arg rest : Type},
  instr
    (arg *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t *
        (('typed_contract arg) * rest))) (operation * rest)
| Create_account : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
      ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
        (bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest))))
    (operation * (address * rest))
| Implicit_account : forall {rest : Type},
  instr (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest)
    (('typed_contract unit) * rest)
| Create_contract : forall {g p rest : Type}, (ty g) -> (ty p) ->
  (lambda (p * g) ((list operation) * g)) -> (option string) ->
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash *
      ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
        (bool *
          (bool * (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest))))))
    (operation * (address * rest))
| Create_contract_2 : forall {g p rest : Type}, (ty g) -> (ty p) ->
  (lambda (p * g) ((list operation) * g)) -> (option string) ->
  instr
    ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) *
      (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * (g * rest)))
    (operation * (address * rest))
| Set_delegate : forall {rest : Type},
  instr ((option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) * rest)
    (operation * rest)
| Now : forall {rest : Type},
  instr rest (Tezos_raw_protocol_alpha.Alpha_context.Script_timestamp.t * rest)
| Balance : forall {rest : Type},
  instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Check_signature : forall {rest : Type},
  instr
    (Tezos_raw_protocol_alpha.Alpha_context.public_key *
      (Tezos_raw_protocol_alpha.Alpha_context.signature *
        (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)))
    (bool * rest)
| Hash_key : forall {rest : Type},
  instr (Tezos_raw_protocol_alpha.Alpha_context.public_key * rest)
    (Tezos_raw_protocol_alpha.Alpha_context.public_key_hash * rest)
| Pack : forall {a rest : Type}, (ty a) ->
  instr (a * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Unpack : forall {a rest : Type}, (ty a) ->
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    ((option a) * rest)
| Blake2b : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Sha256 : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Sha512 : forall {rest : Type},
  instr (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
    (Tezos_protocol_environment_alpha__Environment.MBytes.t * rest)
| Steps_to_quota : forall {rest : Type},
  instr rest
    ((Tezos_raw_protocol_alpha.Alpha_context.Script_int.num
      Tezos_raw_protocol_alpha.Alpha_context.Script_int.n) * rest)
| Source : forall {rest : Type}, instr rest (address * rest)
| Sender : forall {rest : Type}, instr rest (address * rest)
| Self : forall {p rest : Type}, (ty p) -> string ->
  instr rest (('typed_contract p) * rest)
| Amount : forall {rest : Type},
  instr rest (Tezos_raw_protocol_alpha.Alpha_context.Tez.t * rest)
| Dig : forall {aft bef rest x : Type}, Z ->
  (stack_prefix_preservation_witness (x * rest) rest bef aft) ->
  instr bef (x * aft)
| Dug : forall {aft bef rest x : Type}, Z ->
  (stack_prefix_preservation_witness rest (x * rest) bef aft) ->
  instr (x * bef) aft
| Dipn : forall {aft bef faft fbef : Type}, Z ->
  (stack_prefix_preservation_witness fbef faft bef aft) -> (descr fbef faft) ->
  instr bef aft
| Dropn : forall {C bef rest : Type}, Z ->
  (stack_prefix_preservation_witness rest rest bef C) -> instr bef rest
| ChainId : forall {rest : Type},
  instr rest
    (Tezos_protocol_environment_alpha__Environment.Chain_id.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)
      * rest)

with stack_prefix_preservation_witness : forall
  (bef aft bef_suffix aft_suffix : Type), Type :=
| Prefix : forall {aft bef faft fbef x : Type},
  (stack_prefix_preservation_witness fbef faft bef aft) ->
  stack_prefix_preservation_witness fbef faft (x * bef) (x * aft)
| Rest : forall {aft bef : Type},
  stack_prefix_preservation_witness bef aft bef aft

where "'end_of_stack" := ( unit)

and "'typed_contract" := (fun (arg : Type) => (ty arg) * address).

Definition end_of_stack := 'end_of_stack.
Definition typed_contract := 'typed_contract.

Arguments Lam {_ _}.

Inductive ex_big_map : Type :=
| Ex_bm : forall {key value : Type}, (big_map key value) -> ex_big_map.

src/proto_alpha/lib_protocol/seed_repr.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Tezos Protocol Implementation - Random number generation *)

type seed = B of State_hash.t

type t = T of State_hash.t

type sequence = S of State_hash.t

type nonce = MBytes.t

let nonce_encoding = Data_encoding.Fixed.bytes Constants_repr.nonce_length

let init = "Laissez-faire les proprietaires."

let zero_bytes = MBytes.of_string (String.make Nonce_hash.size '\000')

let state_hash_encoding =
  let open Data_encoding in
  conv
    State_hash.to_bytes
    State_hash.of_bytes_exn
    (Fixed.bytes Nonce_hash.size)

let seed_encoding =
  let open Data_encoding in
  conv (fun (B b) -> b) (fun b -> B b) state_hash_encoding

let empty = B (State_hash.hash_bytes [MBytes.of_string init])

let nonce (B state) nonce =
  B (State_hash.hash_bytes [State_hash.to_bytes state; nonce])

let initialize_new (B state) append =
  T (State_hash.hash_bytes (State_hash.to_bytes state :: zero_bytes :: append))

let xor_higher_bits i b =
  let higher = MBytes.get_int32 b 0 in
  let r = Int32.logxor higher i in
  let res = MBytes.copy b in
  MBytes.set_int32 res 0 r ; res

let sequence (T state) n =
  State_hash.to_bytes state |> xor_higher_bits n
  |> fun b -> S (State_hash.hash_bytes [b])

let take (S state) =
  let b = State_hash.to_bytes state in
  let h = State_hash.hash_bytes [b] in
  (State_hash.to_bytes h, S h)

let take_int32 s bound =
  if Compare.Int32.(bound <= 0l) then invalid_arg "Seed_repr.take_int32"
    (* FIXME *)
  else
    let rec loop s =
      let (bytes, s) = take s in
      let r = Int32.abs (MBytes.get_int32 bytes 0) in
      let drop_if_over =
        Int32.sub Int32.max_int (Int32.rem Int32.max_int bound)
      in
      if Compare.Int32.(r >= drop_if_over) then loop s
      else
        let v = Int32.rem r bound in
        (v, s)
    in
    loop s

type error += Unexpected_nonce_length (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"unexpected_nonce_length"
    ~title:"Unexpected nonce length"
    ~description:"Nonce length is incorrect."
    ~pp:(fun ppf () ->
      Format.fprintf
        ppf
        "Nonce length is not %i bytes long as it should."
        Constants_repr.nonce_length)
    Data_encoding.empty
    (function Unexpected_nonce_length -> Some () | _ -> None)
    (fun () -> Unexpected_nonce_length)

let make_nonce nonce =
  if Compare.Int.(MBytes.length nonce <> Constants_repr.nonce_length) then
    error Unexpected_nonce_length
  else ok nonce

let hash nonce = Nonce_hash.hash_bytes [nonce]

let check_hash nonce hash =
  Compare.Int.(MBytes.length nonce = Constants_repr.nonce_length)
  && Nonce_hash.equal (Nonce_hash.hash_bytes [nonce]) hash

let nonce_hash_key_part = Nonce_hash.to_path

let initial_nonce_0 = zero_bytes

let initial_nonce_hash_0 = hash initial_nonce_0

let deterministic_seed seed = nonce seed zero_bytes

let initial_seeds n =
  let rec loop acc elt i =
    if Compare.Int.(i = 1) then List.rev (elt :: acc)
    else loop (elt :: acc) (deterministic_seed elt) (i - 1)
  in
  loop [] (B (State_hash.hash_bytes [])) n
src/proto_alpha/lib_protocol/seed_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Inductive seed : Type :=
| B : Tezos_raw_protocol_alpha.State_hash.t -> seed.

Inductive t : Type :=
| T : Tezos_raw_protocol_alpha.State_hash.t -> t.

Inductive sequence : Type :=
| S : Tezos_raw_protocol_alpha.State_hash.t -> sequence.

Definition nonce := Tezos_protocol_environment_alpha__Environment.MBytes.t.

Definition nonce_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  Data_encoding.Fixed.bytes Constants_repr.nonce_length.

Definition init : string := "Laissez-faire les proprietaires." % string.

Definition zero_bytes
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  MBytes.of_string (String.make Nonce_hash.size "000" % char).

Definition state_hash_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    Tezos_raw_protocol_alpha.State_hash.t :=
  conv State_hash.to_bytes State_hash.of_bytes_exn None
    (Fixed.bytes Nonce_hash.size).

Definition seed_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding seed :=
  conv
    (fun function_parameter =>
      let 'B b := function_parameter in
      b) (fun b => B b) None state_hash_encoding.

Definition empty : seed :=
  B (State_hash.hash_bytes None (cons (MBytes.of_string init) [])).

Definition nonce (function_parameter : seed)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t -> seed :=
  let 'B state := function_parameter in
  fun nonce =>
    B
      (State_hash.hash_bytes None
        (cons (State_hash.to_bytes state) (cons nonce []))).

Definition initialize_new (function_parameter : seed)
  : (list Tezos_protocol_environment_alpha__Environment.MBytes.t) -> t :=
  let 'B state := function_parameter in
  fun append =>
    T
      (State_hash.hash_bytes None
        (cons (State_hash.to_bytes state) (cons zero_bytes append))).

Definition xor_higher_bits
  (i : int32) (b : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  let higher := MBytes.get_int32 b 0 in
  let r := Int32.logxor higher i in
  let res := MBytes.copy b in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := MBytes.set_int32 res 0 r in
  res.

Definition sequence (function_parameter : t) : int32 -> sequence :=
  let 'T state := function_parameter in
  fun n =>
    op_pipegt (op_pipegt (State_hash.to_bytes state) (xor_higher_bits n))
      (fun b => S (State_hash.hash_bytes None (cons b []))).

Definition take (function_parameter : sequence)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t * sequence :=
  let 'S state := function_parameter in
  let b := State_hash.to_bytes state in
  let h := State_hash.hash_bytes None (cons b []) in
  ((State_hash.to_bytes h), (S h)).

Definition take_int32
  (s : sequence)
  (bound :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : int32 * sequence :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lteq)
      bound
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    invalid_arg "Seed_repr.take_int32" % string
  else
    let fix loop (s : sequence) : int32 * sequence :=
      let '(bytes, s) := take s in
      let r := Int32.abs (MBytes.get_int32 string 0) in
      let drop_if_over :=
        Int32.sub Int32.max_int (Int32.rem Int32.max_int bound) in
      if
        Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
          r drop_if_over then
        loop s
      else
        let v := Int32.rem r bound in
        (v, s) in
    loop s.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition make_nonce
  (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_ltgt)
      (MBytes.length nonce) Constants_repr.nonce_length then
    error
      Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_nonce_length
  else
    ok nonce.

Definition hash (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_raw_protocol_alpha.Nonce_hash.t :=
  Nonce_hash.hash_bytes None (cons nonce []).

Definition check_hash
  (nonce : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  (hash : Tezos_raw_protocol_alpha.Nonce_hash.t) : bool :=
  op_andand
    (Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
      (MBytes.length nonce) Constants_repr.nonce_length)
    (Nonce_hash.equal (Nonce_hash.hash_bytes None (cons nonce [])) hash).

Definition nonce_hash_key_part
  : Tezos_raw_protocol_alpha.Nonce_hash.t -> (list string) -> list string :=
  Nonce_hash.to_path.

Definition initial_nonce_0
  : Tezos_protocol_environment_alpha__Environment.MBytes.t := zero_bytes.

Definition initial_nonce_hash_0 : Tezos_raw_protocol_alpha.Nonce_hash.t :=
  hash initial_nonce_0.

Definition deterministic_seed (seed : seed) : seed := nonce seed zero_bytes.

Definition initial_seeds
  (n :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : list seed :=
  let fix loop
    (acc : list seed) (elt : seed) (i :
    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
    : list seed :=
    if
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        i 1 then
      List.rev (cons elt acc)
    else
      loop (cons elt acc) (deterministic_seed elt) (op_minus i 1) in
  loop [] (B (State_hash.hash_bytes None [])) n.

src/proto_alpha/lib_protocol/seed_storage.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Misc

type error +=
  | Unknown of {
      oldest : Cycle_repr.t;
      cycle : Cycle_repr.t;
      latest : Cycle_repr.t;
    }

(* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"seed.unknown_seed"
    ~title:"Unknown seed"
    ~description:"The requested seed is not available"
    ~pp:(fun ppf (oldest, cycle, latest) ->
      if Cycle_repr.(cycle < oldest) then
        Format.fprintf
          ppf
          "The seed for cycle %a has been cleared from the context  (oldest \
           known seed is for cycle %a)"
          Cycle_repr.pp
          cycle
          Cycle_repr.pp
          oldest
      else
        Format.fprintf
          ppf
          "The seed for cycle %a has not been computed yet  (latest known \
           seed is for cycle %a)"
          Cycle_repr.pp
          cycle
          Cycle_repr.pp
          latest)
    Data_encoding.(
      obj3
        (req "oldest" Cycle_repr.encoding)
        (req "requested" Cycle_repr.encoding)
        (req "latest" Cycle_repr.encoding))
    (function
      | Unknown {oldest; cycle; latest} ->
          Some (oldest, cycle, latest)
      | _ ->
          None)
    (fun (oldest, cycle, latest) -> Unknown {oldest; cycle; latest})

let compute_for_cycle c ~revealed cycle =
  match Cycle_repr.pred cycle with
  | None ->
      assert false (* should not happen *)
  | Some previous_cycle ->
      let levels = Level_storage.levels_with_commitments_in_cycle c revealed in
      let combine (c, random_seed, unrevealed) level =
        Storage.Seed.Nonce.get c level
        >>=? function
        | Revealed nonce ->
            Storage.Seed.Nonce.delete c level
            >>=? fun c ->
            return (c, Seed_repr.nonce random_seed nonce, unrevealed)
        | Unrevealed u ->
            Storage.Seed.Nonce.delete c level
            >>=? fun c -> return (c, random_seed, u :: unrevealed)
      in
      Storage.Seed.For_cycle.get c previous_cycle
      >>=? fun prev_seed ->
      let seed = Seed_repr.deterministic_seed prev_seed in
      fold_left_s combine (c, seed, []) levels
      >>=? fun (c, seed, unrevealed) ->
      Storage.Seed.For_cycle.init c cycle seed
      >>=? fun c -> return (c, unrevealed)

let for_cycle ctxt cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  let current_level = Level_storage.current ctxt in
  let current_cycle = current_level.cycle in
  let latest =
    if Cycle_repr.(current_cycle = root) then
      Cycle_repr.add current_cycle (preserved + 1)
    else Cycle_repr.add current_cycle preserved
  in
  let oldest =
    match Cycle_repr.sub current_cycle preserved with
    | None ->
        Cycle_repr.root
    | Some oldest ->
        oldest
  in
  fail_unless
    Cycle_repr.(oldest <= cycle && cycle <= latest)
    (Unknown {oldest; cycle; latest})
  >>=? fun () -> Storage.Seed.For_cycle.get ctxt cycle

let clear_cycle c cycle = Storage.Seed.For_cycle.delete c cycle

let init ctxt =
  let preserved = Constants_storage.preserved_cycles ctxt in
  List.fold_left2
    (fun ctxt c seed ->
      ctxt
      >>=? fun ctxt ->
      let cycle = Cycle_repr.of_int32_exn (Int32.of_int c) in
      Storage.Seed.For_cycle.init ctxt cycle seed)
    (return ctxt)
    (0 --> (preserved + 1))
    (Seed_repr.initial_seeds (preserved + 2))

let cycle_end ctxt last_cycle =
  let preserved = Constants_storage.preserved_cycles ctxt in
  ( match Cycle_repr.sub last_cycle preserved with
  | None ->
      return ctxt
  | Some cleared_cycle ->
      clear_cycle ctxt cleared_cycle )
  >>=? fun ctxt ->
  match Cycle_repr.pred last_cycle with
  | None ->
      return (ctxt, [])
  | Some revealed ->
      (* cycle with revelations *)
      let inited_seed_cycle = Cycle_repr.add last_cycle (preserved + 1) in
      compute_for_cycle ctxt ~revealed inited_seed_cycle
src/proto_alpha/lib_protocol/seed_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Misc.

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition compute_for_cycle
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (revealed : Tezos_raw_protocol_alpha.Cycle_repr.t)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.t *
        (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
  match Cycle_repr.pred cycle with
  | None =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  | Some previous_cycle =>
    let levels := Level_storage.levels_with_commitments_in_cycle c revealed in
    let combine
      (function_parameter :
      Tezos_raw_protocol_alpha.Storage.Seed.Nonce.context *
        Tezos_raw_protocol_alpha.Seed_repr.seed *
        (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))
      : Tezos_raw_protocol_alpha.Level_repr.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t *
              Tezos_raw_protocol_alpha.Seed_repr.seed *
              (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
      let '(c, random_seed, unrevealed) := function_parameter in
      fun level =>
        op_gtgteqquestion (Storage.Seed.Nonce.get c level)
          (fun function_parameter =>
            match function_parameter with
            | Tezos_raw_protocol_alpha__Storage.Seed.Revealed nonce =>
              op_gtgteqquestion (Storage.Seed.Nonce.delete c level)
                (fun c =>
                  _return (c, (Seed_repr.nonce random_seed nonce), unrevealed))
            | Tezos_raw_protocol_alpha__Storage.Seed.Unrevealed u =>
              op_gtgteqquestion (Storage.Seed.Nonce.delete c level)
                (fun c => _return (c, random_seed, (cons u unrevealed)))
            end) in
    op_gtgteqquestion (Storage.Seed.For_cycle.get c previous_cycle)
      (fun prev_seed =>
        let seed := Seed_repr.deterministic_seed prev_seed in
        op_gtgteqquestion (fold_left_s combine (c, seed, []) levels)
          (fun function_parameter =>
            let '(c, seed, unrevealed) := function_parameter in
            op_gtgteqquestion (Storage.Seed.For_cycle.init c cycle seed)
              (fun c => _return (c, unrevealed))))
  end.

Definition for_cycle
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Seed_repr.seed) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  let current_level := Level_storage.current ctxt in
  let current_cycle := cycle current_level in
  let latest :=
    if op_eq current_cycle root then
      Cycle_repr.add current_cycle (op_plus preserved 1)
    else
      Cycle_repr.add current_cycle preserved in
  let oldest :=
    match Cycle_repr.sub current_cycle preserved with
    | None => Cycle_repr.root
    | Some oldest => oldest
    end in
  op_gtgteqquestion
    (fail_unless (op_andand (op_lteq oldest cycle) (op_lteq cycle latest))
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Unknown
        {| oldest := oldest; cycle := cycle; latest := latest |}))
    (fun function_parameter =>
      let 'tt := function_parameter in
      Storage.Seed.For_cycle.get ctxt cycle).

Definition clear_cycle
  (c : Tezos_raw_protocol_alpha.Raw_context.t)
  (cycle : Tezos_raw_protocol_alpha.Cycle_repr.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Seed.For_cycle.delete c cycle.

Definition init (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  List.fold_left2
    (fun ctxt =>
      fun c =>
        fun seed =>
          op_gtgteqquestion ctxt
            (fun ctxt =>
              let cycle := Cycle_repr.of_int32_exn (Int32.of_int c) in
              Storage.Seed.For_cycle.init ctxt cycle seed)) (_return ctxt)
    (op_minusminusgt 0 (op_plus preserved 1))
    (Seed_repr.initial_seeds (op_plus preserved 2)).

Definition cycle_end
  (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  (last_cycle : Tezos_raw_protocol_alpha.Cycle_repr.cycle)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_raw_protocol_alpha.Raw_context.context *
        (list Tezos_raw_protocol_alpha__Storage.Seed.unrevealed_nonce))) :=
  let preserved := Constants_storage.preserved_cycles ctxt in
  op_gtgteqquestion
    match Cycle_repr.sub last_cycle preserved with
    | None => _return ctxt
    | Some cleared_cycle => clear_cycle ctxt cleared_cycle
    end
    (fun ctxt =>
      match Cycle_repr.pred last_cycle with
      | None => _return (ctxt, [])
      | Some revealed =>
        let inited_seed_cycle := Cycle_repr.add last_cycle (op_plus preserved 1)
          in
        compute_for_cycle ctxt revealed inited_seed_cycle
      end).

src/proto_alpha/lib_protocol/services_registration.ml 13 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

type rpc_context = {
  block_hash : Block_hash.t;
  block_header : Block_header.shell_header;
  context : Alpha_context.t;
}

let rpc_init ({block_hash; block_header; context} : Updater.rpc_context) =
  let level = block_header.level in
  let timestamp = block_header.timestamp in
  let fitness = block_header.fitness in
  Alpha_context.prepare
    ~level
    ~predecessor_timestamp:timestamp
    ~timestamp
    ~fitness
    context
  >>=? fun context -> return {block_hash; block_header; context}

let rpc_services =
  ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)

let register0_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun ctxt q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

let opt_register0_fullctxt s f =
  rpc_services :=
    RPC_directory.opt_register !rpc_services s (fun ctxt q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

let register0 s f = register0_fullctxt s (fun {context; _} -> f context)

let register0_noctxt s f =
  rpc_services := RPC_directory.register !rpc_services s (fun _ q i -> f q i)

let register1_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun (ctxt, arg) q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i)

let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x)

let register1_noctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun (_, arg) q i -> f arg q i)

let register2_fullctxt s f =
  rpc_services :=
    RPC_directory.register !rpc_services s (fun ((ctxt, arg1), arg2) q i ->
        rpc_init ctxt >>=? fun ctxt -> f ctxt arg1 arg2 q i)

let register2 s f =
  register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i)

let get_rpc_services () =
  let p =
    RPC_directory.map
      (fun c ->
        rpc_init c
        >>= function Error _ -> assert false | Ok c -> Lwt.return c.context)
      (Storage_description.build_directory Alpha_context.description)
  in
  RPC_directory.register_dynamic_directory
    !rpc_services
    RPC_path.(open_root / "context" / "raw" / "json")
    (fun _ -> Lwt.return p)
src/proto_alpha/lib_protocol/services_registration.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Record rpc_context := {
  block_hash :
    Tezos_protocol_environment_alpha__Environment.Block_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t);
  block_header :
    Tezos_raw_protocol_alpha.Alpha_context.Block_header.shell_header;
  context : Tezos_raw_protocol_alpha.Alpha_context.t }.

Definition rpc_init
  (function_parameter :
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      rpc_context) :=
  let '{|
    block_hash := block_hash;
      block_header := block_header;
      context := context
      |} := function_parameter in
  let level := level block_header in
  let timestamp := timestamp block_header in
  let fitness := fitness block_header in
  op_gtgteqquestion
    (Alpha_context.prepare context level timestamp timestamp fitness)
    (fun context =>
      _return
        {| block_hash := block_hash; block_header := block_header;
          context := context |}).

Definition rpc_services
  : Tezos_protocol_environment_alpha__Environment.Pervasives.ref
    (Tezos_protocol_environment_alpha__Environment.RPC_directory.t
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context) :=
  ref RPC_directory.empty.

Definition register0_fullctxt {A B C : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
  (f :
    rpc_context ->
      A ->
        B ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              C)) : unit :=
  op_coloneq rpc_services
    (RPC_directory.register (op_exclamation rpc_services) s
      (fun ctxt =>
        fun q =>
          fun i => op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt q i))).

Definition opt_register0_fullctxt {A B C : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
  (f :
    rpc_context ->
      A ->
        B ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (option C))) : unit :=
  op_coloneq rpc_services
    (RPC_directory.opt_register (op_exclamation rpc_services) s
      (fun ctxt =>
        fun q =>
          fun i => op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt q i))).

Definition register0 {A B C : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C)
  (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      A ->
        B ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              C)) : unit :=
  register0_fullctxt s
    (fun function_parameter =>
      let '{| context := context |} := function_parameter in
      f context).

Definition register0_noctxt {A B C D : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context A B C D)
  (f :
    B ->
      C ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D))
  : unit :=
  op_coloneq rpc_services
    (RPC_directory.register (op_exclamation rpc_services) s
      (fun function_parameter =>
        let '_ := function_parameter in
        fun q => fun i => f q i)).

Definition register1_fullctxt {A B C D : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) B
      C D)
  (f :
    rpc_context ->
      A ->
        B ->
          C ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                D)) : unit :=
  op_coloneq rpc_services
    (RPC_directory.register (op_exclamation rpc_services) s
      (fun function_parameter =>
        let '(ctxt, arg) := function_parameter in
        fun q =>
          fun i =>
            op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt arg q i))).

Definition register1 {A B C D : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      (Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) B
      C D)
  (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      A ->
        B ->
          C ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                D)) : unit :=
  register1_fullctxt s
    (fun function_parameter =>
      let '{| context := context |} := function_parameter in
      fun x => f context x).

Definition register1_noctxt {A B C D E : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context (A * B)
      C D E)
  (f :
    B ->
      C ->
        D ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              E)) : unit :=
  op_coloneq rpc_services
    (RPC_directory.register (op_exclamation rpc_services) s
      (fun function_parameter =>
        let '(_, arg) := function_parameter in
        fun q => fun i => f arg q i)).

Definition register2_fullctxt {A B C D E : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      ((Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) *
        B) C D E)
  (f :
    rpc_context ->
      A ->
        B ->
          C ->
            D ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  E)) : unit :=
  op_coloneq rpc_services
    (RPC_directory.register (op_exclamation rpc_services) s
      (fun function_parameter =>
        let '((ctxt, arg1), arg2) := function_parameter in
        fun q =>
          fun i =>
            op_gtgteqquestion (rpc_init ctxt) (fun ctxt => f ctxt arg1 arg2 q i))).

Definition register2 {A B C D E : Type}
  (s :
    Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      ((Tezos_protocol_environment_alpha__Environment.Updater.rpc_context * A) *
        B) C D E)
  (f :
    Tezos_raw_protocol_alpha.Alpha_context.t ->
      A ->
        B ->
          C ->
            D ->
              Tezos_protocol_environment_alpha__Environment.Lwt.t
                (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                  E)) : unit :=
  register2_fullctxt s
    (fun function_parameter =>
      let '{| context := context |} := function_parameter in
      fun a1 => fun a2 => fun q => fun i => f context a1 a2 q i).

Definition get_rpc_services (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.RPC_directory.directory
    Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
  let 'tt := function_parameter in
  let p :=
    RPC_directory.map
      (fun c =>
        op_gtgteq (rpc_init c)
          (fun function_parameter =>
            match function_parameter with
            | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _
              =>
              (* ❌ Assert instruction is not handled. *)
              assert false
            | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok c =>
              Lwt._return (context c)
            end))
      (Storage_description.build_directory Alpha_context.description) in
  RPC_directory.register_dynamic_directory None (op_exclamation rpc_services)
    (op_div (op_div (op_div open_root "context" % string) "raw" % string)
      "json" % string)
    (fun function_parameter =>
      let '_ := function_parameter in
      Lwt._return p).

src/proto_alpha/lib_protocol/storage.ml 103 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Storage_functors

module Int = struct
  type t = int

  let encoding = Data_encoding.uint16
end

module Int32 = struct
  type t = Int32.t

  let encoding = Data_encoding.int32
end

module Z = struct
  include Z

  let encoding = Data_encoding.z
end

module Int_index = struct
  type t = int

  let path_length = 1

  let to_path c l = string_of_int c :: l

  let of_path = function
    | [] | _ :: _ :: _ ->
        None
    | [c] ->
        int_of_string_opt c

  type 'a ipath = 'a * t

  let args =
    Storage_description.One
      {
        rpc_arg = RPC_arg.int;
        encoding = Data_encoding.int31;
        compare = Compare.Int.compare;
      }
end

module Make_index (H : Storage_description.INDEX) :
  INDEX with type t = H.t and type 'a ipath = 'a * H.t = struct
  include H

  type 'a ipath = 'a * t

  let args = Storage_description.One {rpc_arg; encoding; compare}
end

module Block_priority =
  Make_single_data_storage (Registered) (Raw_context)
    (struct
      let name = ["block_priority"]
    end)
    (Int)

(** Contracts handling *)

module Contract = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["contracts"]
      end)

  module Global_counter =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["global_counter"]
      end)
      (Z)

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Contract_repr.Index))

  let fold = Indexed_context.fold_keys

  let list = Indexed_context.keys

  module Balance =
    Indexed_context.Make_map
      (struct
        let name = ["balance"]
      end)
      (Tez_repr)

  module Frozen_balance_index =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["frozen_balance"]
         end))
         (Make_index (Cycle_repr.Index))

  module Frozen_deposits =
    Frozen_balance_index.Make_map
      (struct
        let name = ["deposits"]
      end)
      (Tez_repr)

  module Frozen_fees =
    Frozen_balance_index.Make_map
      (struct
        let name = ["fees"]
      end)
      (Tez_repr)

  module Frozen_rewards =
    Frozen_balance_index.Make_map
      (struct
        let name = ["rewards"]
      end)
      (Tez_repr)

  module Manager =
    Indexed_context.Make_map
      (struct
        let name = ["manager"]
      end)
      (Manager_repr)

  module Delegate =
    Indexed_context.Make_map
      (struct
        let name = ["delegate"]
      end)
      (Signature.Public_key_hash)

  module Inactive_delegate =
    Indexed_context.Make_set
      (Registered)
      (struct
        let name = ["inactive_delegate"]
      end)

  module Delegate_desactivation =
    Indexed_context.Make_map
      (struct
        let name = ["delegate_desactivation"]
      end)
      (Cycle_repr)

  module Delegated =
    Make_data_set_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["delegated"]
         end))
         (Make_index (Contract_repr.Index))

  module Counter =
    Indexed_context.Make_map
      (struct
        let name = ["counter"]
      end)
      (Z)

  (* Consume gas for serilization and deserialization of expr in this
     module *)
  module Make_carbonated_map_expr (N : Storage_sigs.NAME) = struct
    module I =
      Indexed_context.Make_carbonated_map
        (N)
        (struct
          type t = Script_repr.lazy_expr

          let encoding = Script_repr.lazy_expr_encoding
        end)

    type context = I.context

    type key = I.key

    type value = I.value

    let mem = I.mem

    let delete = I.delete

    let remove = I.remove

    let consume_deserialize_gas ctxt value =
      Lwt.return
      @@ ( Raw_context.check_enough_gas
             ctxt
             (Script_repr.minimal_deserialize_cost value)
         >>? fun () ->
         Script_repr.force_decode value
         >>? fun (_value, value_cost) ->
         Raw_context.consume_gas ctxt value_cost )

    let consume_serialize_gas ctxt value =
      Lwt.return
      @@ ( Script_repr.force_bytes value
         >>? fun (_value, value_cost) ->
         Raw_context.consume_gas ctxt value_cost )

    let get ctxt contract =
      I.get ctxt contract
      >>=? fun (ctxt, value) ->
      consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)

    let get_option ctxt contract =
      I.get_option ctxt contract
      >>=? fun (ctxt, value_opt) ->
      match value_opt with
      | None ->
          return (ctxt, None)
      | Some value ->
          consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)

    let set ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.set ctxt contract value

    let set_option ctxt contract value_opt =
      match value_opt with
      | None ->
          I.set_option ctxt contract None
      | Some value ->
          consume_serialize_gas ctxt value
          >>=? fun ctxt -> I.set_option ctxt contract value_opt

    let init ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.init ctxt contract value

    let init_set ctxt contract value =
      consume_serialize_gas ctxt value
      >>=? fun ctxt -> I.init_set ctxt contract value
  end

  module Code = Make_carbonated_map_expr (struct
    let name = ["code"]
  end)

  module Storage = Make_carbonated_map_expr (struct
    let name = ["storage"]
  end)

  module Paid_storage_space =
    Indexed_context.Make_map
      (struct
        let name = ["paid_bytes"]
      end)
      (Z)

  module Used_storage_space =
    Indexed_context.Make_map
      (struct
        let name = ["used_bytes"]
      end)
      (Z)

  module Roll_list =
    Indexed_context.Make_map
      (struct
        let name = ["roll_list"]
      end)
      (Roll_repr)

  module Change =
    Indexed_context.Make_map
      (struct
        let name = ["change"]
      end)
      (Tez_repr)
end

(** Big maps handling *)

module Big_map = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["big_maps"]
      end)

  module Next = struct
    include Make_single_data_storage (Registered) (Raw_context)
              (struct
                let name = ["next"]
              end)
              (Z)

    let incr ctxt =
      get ctxt
      >>=? fun i -> set ctxt (Z.succ i) >>=? fun ctxt -> return (ctxt, i)

    let init ctxt = init ctxt Z.zero
  end

  module Index = struct
    type t = Z.t

    let rpc_arg =
      let construct = Z.to_string in
      let destruct hash =
        match Z.of_string hash with
        | exception _ ->
            Error "Cannot parse big map id"
        | id ->
            Ok id
      in
      RPC_arg.make
        ~descr:"A big map identifier"
        ~name:"big_map_id"
        ~construct
        ~destruct
        ()

    let encoding =
      Data_encoding.def
        "big_map_id"
        ~title:"Big map identifier"
        ~description:"A big map identifier"
        Z.encoding

    let compare = Compare.Z.compare

    let path_length = 7

    let to_path c l =
      let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
      let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      String.sub index_key 0 2 :: String.sub index_key 2 2
      :: String.sub index_key 4 2 :: String.sub index_key 6 2
      :: String.sub index_key 8 2 :: String.sub index_key 10 2 :: Z.to_string c
      :: l

    let of_path = function
      | []
      | [_]
      | [_; _]
      | [_; _; _]
      | [_; _; _; _]
      | [_; _; _; _; _]
      | [_; _; _; _; _; _]
      | _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ :: _ ->
          None
      | [index1; index2; index3; index4; index5; index6; key] ->
          let c = Z.of_string key in
          let raw_key = Data_encoding.Binary.to_bytes_exn encoding c in
          let (`Hex index_key) = MBytes.to_hex (Raw_hashes.blake2b raw_key) in
          assert (Compare.String.(String.sub index_key 0 2 = index1)) ;
          assert (Compare.String.(String.sub index_key 2 2 = index2)) ;
          assert (Compare.String.(String.sub index_key 4 2 = index3)) ;
          assert (Compare.String.(String.sub index_key 6 2 = index4)) ;
          assert (Compare.String.(String.sub index_key 8 2 = index5)) ;
          assert (Compare.String.(String.sub index_key 10 2 = index6)) ;
          Some c
  end

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Index))

  let rpc_arg = Index.rpc_arg

  let fold = Indexed_context.fold_keys

  let list = Indexed_context.keys

  let remove_rec ctxt n = Indexed_context.remove_rec ctxt n

  let copy ctxt ~from ~to_ = Indexed_context.copy ctxt ~from ~to_

  type key = Raw_context.t * Z.t

  module Total_bytes =
    Indexed_context.Make_map
      (struct
        let name = ["total_bytes"]
      end)
      (Z)

  module Key_type =
    Indexed_context.Make_map
      (struct
        let name = ["key_type"]
      end)
      (struct
        type t = Script_repr.expr

        let encoding = Script_repr.expr_encoding
      end)

  module Value_type =
    Indexed_context.Make_map
      (struct
        let name = ["value_type"]
      end)
      (struct
        type t = Script_repr.expr

        let encoding = Script_repr.expr_encoding
      end)

  module Contents = struct
    module I =
      Storage_functors.Make_indexed_carbonated_data_storage
        (Make_subcontext (Registered) (Indexed_context.Raw_context)
           (struct
             let name = ["contents"]
           end))
           (Make_index (Script_expr_hash))
           (struct
             type t = Script_repr.expr

             let encoding = Script_repr.expr_encoding
           end)

    type context = I.context

    type key = I.key

    type value = I.value

    let mem = I.mem

    let delete = I.delete

    let remove = I.remove

    let set = I.set

    let set_option = I.set_option

    let init = I.init

    let init_set = I.init_set

    let consume_deserialize_gas ctxt value =
      Lwt.return
      @@ Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)

    let get ctxt contract =
      I.get ctxt contract
      >>=? fun (ctxt, value) ->
      consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value)

    let get_option ctxt contract =
      I.get_option ctxt contract
      >>=? fun (ctxt, value_opt) ->
      match value_opt with
      | None ->
          return (ctxt, None)
      | Some value ->
          consume_deserialize_gas ctxt value >>|? fun ctxt -> (ctxt, value_opt)
  end
end

module Delegates =
  Make_data_set_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["delegates"]
       end))
       (Make_index (Signature.Public_key_hash))

module Active_delegates_with_rolls =
  Make_data_set_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["active_delegates_with_rolls"]
       end))
       (Make_index (Signature.Public_key_hash))

module Delegates_with_frozen_balance_index =
  Make_indexed_subcontext
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["delegates_with_frozen_balance"]
       end))
       (Make_index (Cycle_repr.Index))

module Delegates_with_frozen_balance =
  Make_data_set_storage
    (Delegates_with_frozen_balance_index.Raw_context)
    (Make_index (Signature.Public_key_hash))

(** Rolls *)

module Cycle = struct
  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["cycle"]
         end))
         (Make_index (Cycle_repr.Index))

  module Last_roll =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["last_roll"]
         end))
         (Int_index)
      (Roll_repr)

  module Roll_snapshot =
    Indexed_context.Make_map
      (struct
        let name = ["roll_snapshot"]
      end)
      (Int)

  type unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  let nonce_status_encoding =
    let open Data_encoding in
    union
      [ case
          (Tag 0)
          ~title:"Unrevealed"
          (tup4
             Nonce_hash.encoding
             Signature.Public_key_hash.encoding
             Tez_repr.encoding
             Tez_repr.encoding)
          (function
            | Unrevealed {nonce_hash; delegate; rewards; fees} ->
                Some (nonce_hash, delegate, rewards, fees)
            | _ ->
                None)
          (fun (nonce_hash, delegate, rewards, fees) ->
            Unrevealed {nonce_hash; delegate; rewards; fees});
        case
          (Tag 1)
          ~title:"Revealed"
          Seed_repr.nonce_encoding
          (function Revealed nonce -> Some nonce | _ -> None)
          (fun nonce -> Revealed nonce) ]

  module Nonce =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Indexed_context.Raw_context)
         (struct
           let name = ["nonces"]
         end))
         (Make_index (Raw_level_repr.Index))
         (struct
           type t = nonce_status

           let encoding = nonce_status_encoding
         end)

  module Seed =
    Indexed_context.Make_map
      (struct
        let name = ["random_seed"]
      end)
      (struct
        type t = Seed_repr.seed

        let encoding = Seed_repr.seed_encoding
      end)
end

module Roll = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["rolls"]
      end)

  module Indexed_context =
    Make_indexed_subcontext
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["index"]
         end))
         (Make_index (Roll_repr.Index))

  module Next =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["next"]
      end)
      (Roll_repr)

  module Limbo =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["limbo"]
      end)
      (Roll_repr)

  module Delegate_roll_list =
    Wrap_indexed_data_storage
      (Contract.Roll_list)
      (struct
        type t = Signature.Public_key_hash.t

        let wrap = Contract_repr.implicit_contract

        let unwrap = Contract_repr.is_implicit
      end)

  module Successor =
    Indexed_context.Make_map
      (struct
        let name = ["successor"]
      end)
      (Roll_repr)

  module Delegate_change =
    Wrap_indexed_data_storage
      (Contract.Change)
      (struct
        type t = Signature.Public_key_hash.t

        let wrap = Contract_repr.implicit_contract

        let unwrap = Contract_repr.is_implicit
      end)

  module Snapshoted_owner_index = struct
    type t = Cycle_repr.t * int

    let path_length = Cycle_repr.Index.path_length + 1

    let to_path (c, n) s = Cycle_repr.Index.to_path c (string_of_int n :: s)

    let of_path l =
      match Misc.take Cycle_repr.Index.path_length l with
      | None | Some (_, ([] | _ :: _ :: _)) ->
          None
      | Some (l1, [l2]) -> (
        match (Cycle_repr.Index.of_path l1, int_of_string_opt l2) with
        | (None, _) | (_, None) ->
            None
        | (Some c, Some i) ->
            Some (c, i) )

    type 'a ipath = ('a * Cycle_repr.t) * int

    let left_args =
      Storage_description.One
        {
          rpc_arg = Cycle_repr.rpc_arg;
          encoding = Cycle_repr.encoding;
          compare = Cycle_repr.compare;
        }

    let right_args =
      Storage_description.One
        {
          rpc_arg = RPC_arg.int;
          encoding = Data_encoding.int31;
          compare = Compare.Int.compare;
        }

    let args = Storage_description.(Pair (left_args, right_args))
  end

  module Owner =
    Make_indexed_data_snapshotable_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["owner"]
         end))
         (Snapshoted_owner_index)
      (Make_index (Roll_repr.Index))
      (Signature.Public_key)

  module Snapshot_for_cycle = Cycle.Roll_snapshot
  module Last_for_snapshot = Cycle.Last_roll

  let clear = Indexed_context.clear
end

(** Votes *)

module Vote = struct
  module Raw_context =
    Make_subcontext (Registered) (Raw_context)
      (struct
        let name = ["votes"]
      end)

  module Current_period_kind =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["current_period_kind"]
      end)
      (struct
        type t = Voting_period_repr.kind

        let encoding = Voting_period_repr.kind_encoding
      end)

  module Participation_ema =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["participation_ema"]
      end)
      (Int32)

  module Current_proposal =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["current_proposal"]
      end)
      (Protocol_hash)

  module Listings_size =
    Make_single_data_storage (Registered) (Raw_context)
      (struct
        let name = ["listings_size"]
      end)
      (Int32)

  module Listings =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["listings"]
         end))
         (Make_index (Signature.Public_key_hash))
         (Int32)

  module Proposals =
    Make_data_set_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["proposals"]
         end))
         (Pair
            (Make_index
               (Protocol_hash))
               (Make_index (Signature.Public_key_hash)))

  module Proposals_count =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["proposals_count"]
         end))
         (Make_index (Signature.Public_key_hash))
         (Int)

  module Ballots =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ballots"]
         end))
         (Make_index (Signature.Public_key_hash))
         (struct
           type t = Vote_repr.ballot

           let encoding = Vote_repr.ballot_encoding
         end)
end

(** Seed *)

module Seed = struct
  type unrevealed_nonce = Cycle.unrevealed_nonce = {
    nonce_hash : Nonce_hash.t;
    delegate : Signature.Public_key_hash.t;
    rewards : Tez_repr.t;
    fees : Tez_repr.t;
  }

  type nonce_status = Cycle.nonce_status =
    | Unrevealed of unrevealed_nonce
    | Revealed of Seed_repr.nonce

  module Nonce = struct
    open Level_repr

    type context = Raw_context.t

    let mem ctxt l = Cycle.Nonce.mem (ctxt, l.cycle) l.level

    let get ctxt l = Cycle.Nonce.get (ctxt, l.cycle) l.level

    let get_option ctxt l = Cycle.Nonce.get_option (ctxt, l.cycle) l.level

    let set ctxt l v = Cycle.Nonce.set (ctxt, l.cycle) l.level v

    let init ctxt l v = Cycle.Nonce.init (ctxt, l.cycle) l.level v

    let init_set ctxt l v = Cycle.Nonce.init_set (ctxt, l.cycle) l.level v

    let set_option ctxt l v = Cycle.Nonce.set_option (ctxt, l.cycle) l.level v

    let delete ctxt l = Cycle.Nonce.delete (ctxt, l.cycle) l.level

    let remove ctxt l = Cycle.Nonce.remove (ctxt, l.cycle) l.level
  end

  module For_cycle = Cycle.Seed
end

(** Commitments *)

module Commitments =
  Make_indexed_data_storage
    (Make_subcontext (Registered) (Raw_context)
       (struct
         let name = ["commitments"]
       end))
       (Make_index (Blinded_public_key_hash.Index))
       (Tez_repr)

(** Ramp up security deposits... *)

module Ramp_up = struct
  module Rewards =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ramp_up"; "rewards"]
         end))
         (Make_index (Cycle_repr.Index))
         (struct
           type t = Tez_repr.t * Tez_repr.t

           let encoding =
             Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
         end)

  module Security_deposits =
    Make_indexed_data_storage
      (Make_subcontext (Registered) (Raw_context)
         (struct
           let name = ["ramp_up"; "deposits"]
         end))
         (Make_index (Cycle_repr.Index))
         (struct
           type t = Tez_repr.t * Tez_repr.t

           let encoding =
             Data_encoding.tup2 Tez_repr.encoding Tez_repr.encoding
         end)
end
src/proto_alpha/lib_protocol/storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Storage_functors.

Module Int.
  Definition t := Z.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding Z :=
    Data_encoding.uint16.
End Int.

Module Int32.
  Definition t := Tezos_protocol_environment_alpha__Environment.Int32.t.
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
    Data_encoding.int32.
End Int32.

Module Z.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      Tezos_protocol_environment_alpha__Environment.Z.t := Data_encoding.z.
End Z.

Module Int_index.
  Definition t := Z.
  
  Definition path_length : Z := 1.
  
  Definition to_path (c : Z) (l : list string) : list string :=
    cons (string_of_int c) l.
  
  Definition of_path (function_parameter : list string) : option Z :=
    match function_parameter with
    | [] | cons _ (cons _ _) => None
    | cons c [] => int_of_string_opt c
    end.
  
  Definition ipath (a : Type) := a * t.
  
  Definition args {A : Type}
    : Tezos_raw_protocol_alpha.Storage_description.args A
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
      (A *
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
    Tezos_raw_protocol_alpha.Storage_description.One
      {| rpc_arg := RPC_arg.int; encoding := Data_encoding.int31;
        compare :=
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
        |}.
End Int_index.

(* ❌ Functors are not handled. *)
functor

(* ❌ Applications of functors are not handled. *)
functor_application

Module Contract.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition fold {A : Type}
    : Indexed_context.context ->
      A ->
        (Indexed_context.key ->
          A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
    Indexed_context.fold_keys.
  
  Definition list
    : Indexed_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (list Indexed_context.key) := Indexed_context.keys.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Functors are not handled. *)
  functor
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Contract.

Module Big_map.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Module Next.
    (* ❌ Structure item `include` not handled. *)
    include
    
    Definition incr (ctxt : context)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * value)) :=
      op_gtgteqquestion (get ctxt)
        (fun i =>
          op_gtgteqquestion (set ctxt (Z.succ i))
            (fun ctxt => _return (ctxt, i))).
    
    Definition init (ctxt : context)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) := init ctxt Z.zero.
  End Next.
  
  Module Index.
    Definition t := Z.t.
    
    Definition rpc_arg
      : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg Z.t :=
      let construct := Z.to_string in
      let destruct (hash : string)
        : Tezos_protocol_environment_alpha__Environment.Pervasives.result Z.t
          string :=
        let 'id := Z.of_string hash in
        Tezos_protocol_environment_alpha__Environment.Pervasives.Ok id in
      RPC_arg.make (Some "A big map identifier" % string) "big_map_id" % string
        destruct construct tt.
    
    Definition encoding
      : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
        Tezos_protocol_environment_alpha__Environment.Z.t :=
      Data_encoding.def "big_map_id" % string
        (Some "Big map identifier" % string)
        (Some "A big map identifier" % string) Z.encoding.
    
    Definition compare
      : Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
        ->
        Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
          -> Z :=
      Tezos_protocol_environment_alpha__Environment.Compare.Z.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare).
    
    Definition path_length : Z := 7.
    
    Definition to_path
      (c : Tezos_protocol_environment_alpha__Environment.Z.t) (l : list string)
      : list string :=
      let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
      let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
      cons (String.sub index_key 0 2)
        (cons (String.sub index_key 2 2)
          (cons (String.sub index_key 4 2)
            (cons (String.sub index_key 6 2)
              (cons (String.sub index_key 8 2)
                (cons (String.sub index_key 10 2) (cons (Z.to_string c) l)))))).
    
    Definition of_path
      (function_parameter :
        list
          Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
      : option Z.t :=
      match function_parameter with
      |
        [] | cons _ [] | cons _ (cons _ []) | cons _ (cons _ (cons _ [])) |
          cons _ (cons _ (cons _ (cons _ []))) |
          cons _ (cons _ (cons _ (cons _ (cons _ [])))) |
          cons _ (cons _ (cons _ (cons _ (cons _ (cons _ []))))) |
          cons _
            (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ (cons _ _))))))) =>
        None
      |
        cons index1
          (cons index2
            (cons index3 (cons index4 (cons index5 (cons index6 (cons key []))))))
        =>
        let c := Z.of_string key in
        let raw_key := Data_encoding.Binary.to_bytes_exn encoding c in
        let 'Hex index_key := MBytes.to_hex (Raw_hashes.blake2b raw_key) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.sub index_key 0 2) index1) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.sub index_key 2 2) index2) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.sub index_key 4 2) index3) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.sub index_key 6 2) index4) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.sub index_key 8 2) index5) in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          (* ❌ Assert instruction is not handled. *)
          assert
            (Tezos_protocol_environment_alpha__Environment.Compare.String.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              (String.sub index_key 10 2) index6) in
        Some c
      end.
  End Index.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Definition rpc_arg
    : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg Z.t :=
    Index.rpc_arg.
  
  Definition fold {A : Type}
    : Indexed_context.context ->
      A ->
        (Indexed_context.key ->
          A -> Tezos_protocol_environment_alpha__Environment.Lwt.t A) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t A :=
    Indexed_context.fold_keys.
  
  Definition list
    : Indexed_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (list Indexed_context.key) := Indexed_context.keys.
  
  Definition remove_rec
    (ctxt : Indexed_context.context) (n : Indexed_context.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      Indexed_context.context := Indexed_context.remove_rec ctxt n.
  
  Definition copy
    (ctxt : Indexed_context.context) (from : Indexed_context.key)
    (to_ : Indexed_context.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Indexed_context.context) := Indexed_context.copy ctxt from to_.
  
  Definition key := Raw_context.t * Z.t.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Module Contents.
    (* ❌ Applications of functors are not handled. *)
    functor_application
    
    Definition context := I.context.
    
    Definition key := I.key.
    
    Definition value := I.value.
    
    Definition mem
      : I.context ->
        I.key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * bool)) := I.mem.
    
    Definition delete
      : I.context ->
        I.key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.delete.
    
    Definition remove
      : I.context ->
        I.key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) := I.remove.
    
    Definition set
      : I.context ->
        I.key ->
          I.value ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.set.
    
    Definition set_option
      : I.context ->
        I.key ->
          (option I.value) ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) :=
      I.set_option.
    
    Definition init
      : I.context ->
        I.key ->
          I.value ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z)) := I.init.
    
    Definition init_set
      : I.context ->
        I.key ->
          I.value ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool)) :=
      I.init_set.
    
    Definition consume_deserialize_gas
      (ctxt : Raw_context.context)
      (value : Tezos_raw_protocol_alpha.Script_repr.expr)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Raw_context.context) :=
      op_atat Lwt._return
        (Raw_context.consume_gas ctxt (Script_repr.deserialized_cost value)).
    
    Definition get (ctxt : I.context) (contract : I.key)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Raw_context.context * I.value)) :=
      op_gtgteqquestion (I.get ctxt contract)
        (fun function_parameter =>
          let '(ctxt, value) := function_parameter in
          op_gtgtpipequestion (consume_deserialize_gas ctxt value)
            (fun ctxt => (ctxt, value))).
    
    Definition get_option (ctxt : I.context) (contract : I.key)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * (option I.value))) :=
      op_gtgteqquestion (I.get_option ctxt contract)
        (fun function_parameter =>
          let '(ctxt, value_opt) := function_parameter in
          match value_opt with
          | None => _return (ctxt, None)
          | Some value =>
            op_gtgtpipequestion (consume_deserialize_gas ctxt value)
              (fun ctxt => (ctxt, value_opt))
          end).
  End Contents.
End Big_map.

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

(* ❌ Applications of functors are not handled. *)
functor_application

Module Cycle.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Record unrevealed_nonce := {
    nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
    fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
  
  Inductive nonce_status : Type :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
  
  Definition nonce_status_encoding
    : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
      nonce_status :=
    union None
      (cons
        (case "Unrevealed" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
          (tup4 Nonce_hash.encoding Signature.Public_key_hash.encoding
            Tez_repr.encoding Tez_repr.encoding)
          (fun function_parameter =>
            match function_parameter with
            |
              Unrevealed {|
                nonce_hash := nonce_hash;
                  delegate := delegate;
                  rewards := rewards;
                  fees := fees
                  |} => Some (nonce_hash, delegate, rewards, fees)
            | _ => None
            end)
          (fun function_parameter =>
            let '(nonce_hash, delegate, rewards, fees) := function_parameter in
            Unrevealed
              {| nonce_hash := nonce_hash; delegate := delegate;
                rewards := rewards; fees := fees |}))
        (cons
          (case "Revealed" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
            Seed_repr.nonce_encoding
            (fun function_parameter =>
              match function_parameter with
              | Revealed nonce => Some nonce
              | _ => None
              end) (fun nonce => Revealed nonce)) [])).
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Cycle.

Module Roll.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  Module Snapshoted_owner_index.
    Definition t := Tezos_raw_protocol_alpha.Cycle_repr.t * Z.
    
    Definition path_length : Z := op_plus Cycle_repr.Index.path_length 1.
    
    Definition to_path
      (function_parameter : Tezos_raw_protocol_alpha.Cycle_repr.Index.t * Z)
      : (list string) -> list string :=
      let '(c, n) := function_parameter in
      fun s => Cycle_repr.Index.to_path c (cons (string_of_int n) s).
    
    Definition of_path (l : list string)
      : option (Tezos_raw_protocol_alpha.Cycle_repr.Index.t * Z) :=
      match Misc.take Cycle_repr.Index.path_length l with
      | None | Some (_, [] | cons _ (cons _ _)) => None
      | Some (l1, cons l2 []) =>
        match ((Cycle_repr.Index.of_path l1), (int_of_string_opt l2)) with
        | (None, _) | (_, None) => None
        | (Some c, Some i) => Some (c, i)
        end
      end.
    
    Definition ipath (a : Type) :=
      (a * Tezos_raw_protocol_alpha.Cycle_repr.t) * Z.
    
    Definition left_args {A : Type}
      : Tezos_raw_protocol_alpha.Storage_description.args A
        Tezos_raw_protocol_alpha.Cycle_repr.cycle
        (A * Tezos_raw_protocol_alpha.Cycle_repr.cycle) :=
      Tezos_raw_protocol_alpha.Storage_description.One
        {| rpc_arg := Cycle_repr.rpc_arg; encoding := Cycle_repr.encoding;
          compare := Cycle_repr.compare |}.
    
    Definition right_args {A : Type}
      : Tezos_raw_protocol_alpha.Storage_description.args A
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)
        (A *
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
      Tezos_raw_protocol_alpha.Storage_description.One
        {| rpc_arg := RPC_arg.int; encoding := Data_encoding.int31;
          compare :=
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.compare)
          |}.
    
    Definition args {A : Type}
      : Tezos_raw_protocol_alpha.Storage_description.args A
        (Tezos_raw_protocol_alpha.Cycle_repr.cycle *
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
        ((A * Tezos_raw_protocol_alpha.Cycle_repr.cycle) *
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t)) :=
      Tezos_raw_protocol_alpha.Storage_description.Pair left_args right_args.
  End Snapshoted_owner_index.
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
  
  Definition clear
    : Indexed_context.context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t := Indexed_context.clear.
End Roll.

Module Vote.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Vote.

Module Seed.
  Record unrevealed_nonce := {
    nonce_hash : Tezos_raw_protocol_alpha.Nonce_hash.t;
    delegate :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t;
    rewards : Tezos_raw_protocol_alpha.Tez_repr.t;
    fees : Tezos_raw_protocol_alpha.Tez_repr.t }.
  
  Inductive nonce_status : Type :=
  | Unrevealed : unrevealed_nonce -> nonce_status
  | Revealed : Tezos_raw_protocol_alpha.Seed_repr.nonce -> nonce_status.
  
  Module Nonce.
    Import Level_repr.
    
    Definition context := Tezos_raw_protocol_alpha.Raw_context.t.
    
    Definition mem
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
      Cycle.Nonce.mem (ctxt, (cycle l)) (level l).
    
    Definition get
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Cycle.Nonce.value) := Cycle.Nonce.get (ctxt, (cycle l)) (level l).
    
    Definition get_option
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option Cycle.Nonce.value)) :=
      Cycle.Nonce.get_option (ctxt, (cycle l)) (level l).
    
    Definition set
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      Cycle.Nonce.set (ctxt, (cycle l)) (level l) v.
    
    Definition init
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      Cycle.Nonce.init (ctxt, (cycle l)) (level l) v.
    
    Definition init_set
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
      Cycle.Nonce.init_set (ctxt, (cycle l)) (level l) v.
    
    Definition set_option
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t) (v : option Cycle.Nonce.value)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
      Cycle.Nonce.set_option (ctxt, (cycle l)) (level l) v.
    
    Definition delete
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
      Cycle.Nonce.delete (ctxt, (cycle l)) (level l).
    
    Definition remove
      (ctxt : Cycle.Indexed_context.t)
      (l : Tezos_raw_protocol_alpha.Level_repr.t)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t :=
      Cycle.Nonce.remove (ctxt, (cycle l)) (level l).
  End Nonce.
  
  (* ❌ This kind of module is not handled. *)
  unhandled_module
End Seed.

(* ❌ Applications of functors are not handled. *)
functor_application

Module Ramp_up.
  (* ❌ Applications of functors are not handled. *)
  functor_application
  
  (* ❌ Applications of functors are not handled. *)
  functor_application
End Ramp_up.

src/proto_alpha/lib_protocol/storage_description.ml 27 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module StringMap = Map.Make (String)

type 'key t = 'key description ref

and 'key description =
  | Empty : 'key description
  | Value : {
      get : 'key -> 'a option tzresult Lwt.t;
      encoding : 'a Data_encoding.t;
    }
      -> 'key description
  | NamedDir : 'key t StringMap.t -> 'key description
  | IndexedDir : {
      arg : 'a RPC_arg.t;
      arg_encoding : 'a Data_encoding.t;
      list : 'key -> 'a list tzresult Lwt.t;
      subdir : ('key * 'a) t;
    }
      -> 'key description

let rec register_named_subcontext : type r. r t -> string list -> r t =
 fun dir names ->
  match (!dir, names) with
  | (_, []) ->
      dir
  | (Value _, _) ->
      invalid_arg ""
  | (IndexedDir _, _) ->
      invalid_arg ""
  | (Empty, name :: names) ->
      let subdir = ref Empty in
      dir := NamedDir (StringMap.singleton name subdir) ;
      register_named_subcontext subdir names
  | (NamedDir map, name :: names) ->
      let subdir =
        match StringMap.find_opt name map with
        | Some subdir ->
            subdir
        | None ->
            let subdir = ref Empty in
            dir := NamedDir (StringMap.add name subdir map) ;
            subdir
      in
      register_named_subcontext subdir names

type (_, _, _) args =
  | One : {
      rpc_arg : 'a RPC_arg.t;
      encoding : 'a Data_encoding.t;
      compare : 'a -> 'a -> int;
    }
      -> ('key, 'a, 'key * 'a) args
  | Pair :
      ('key, 'a, 'inter_key) args * ('inter_key, 'b, 'sub_key) args
      -> ('key, 'a * 'b, 'sub_key) args

let rec unpack : type a b c. (a, b, c) args -> c -> a * b = function
  | One _ ->
      fun x -> x
  | Pair (l, r) ->
      let unpack_l = unpack l in
      let unpack_r = unpack r in
      fun x ->
        let (c, d) = unpack_r x in
        let (b, a) = unpack_l c in
        (b, (a, d))

let rec pack : type a b c. (a, b, c) args -> a -> b -> c = function
  | One _ ->
      fun b a -> (b, a)
  | Pair (l, r) ->
      let pack_l = pack l in
      let pack_r = pack r in
      fun b (a, d) ->
        let c = pack_l b a in
        pack_r c d

let rec compare : type a b c. (a, b, c) args -> b -> b -> int = function
  | One {compare; _} ->
      compare
  | Pair (l, r) -> (
      let compare_l = compare l in
      let compare_r = compare r in
      fun (a1, b1) (a2, b2) ->
        match compare_l a1 a2 with 0 -> compare_r b1 b2 | x -> x )

let destutter equal l =
  match l with
  | [] ->
      []
  | (i, _) :: l ->
      let rec loop acc i = function
        | [] ->
            acc
        | (j, _) :: l ->
            if equal i j then loop acc i l else loop (j :: acc) j l
      in
      loop [i] i l

let rec register_indexed_subcontext :
    type r a b.
    r t -> list:(r -> a list tzresult Lwt.t) -> (r, a, b) args -> b t =
 fun dir ~list path ->
  match path with
  | Pair (left, right) ->
      let compare_left = compare left in
      let equal_left x y = Compare.Int.(compare_left x y = 0) in
      let list_left r = list r >>=? fun l -> return (destutter equal_left l) in
      let list_right r =
        let (a, k) = unpack left r in
        list a
        >>=? fun l ->
        return (List.map snd (List.filter (fun (x, _) -> equal_left x k) l))
      in
      register_indexed_subcontext
        (register_indexed_subcontext dir ~list:list_left left)
        ~list:list_right
        right
  | One {rpc_arg = arg; encoding = arg_encoding; _} -> (
    match !dir with
    | Value _ ->
        invalid_arg ""
    | NamedDir _ ->
        invalid_arg ""
    | Empty ->
        let subdir = ref Empty in
        dir := IndexedDir {arg; arg_encoding; list; subdir} ;
        subdir
    | IndexedDir {arg = inner_arg; subdir; _} -> (
      match RPC_arg.eq arg inner_arg with
      | None ->
          invalid_arg ""
      | Some RPC_arg.Eq ->
          subdir ) )

let register_value :
    type a b.
    a t -> get:(a -> b option tzresult Lwt.t) -> b Data_encoding.t -> unit =
 fun dir ~get encoding ->
  match !dir with Empty -> dir := Value {get; encoding} | _ -> invalid_arg ""

let create () = ref Empty

let rec pp : type a. Format.formatter -> a t -> unit =
 fun ppf dir ->
  match !dir with
  | Empty ->
      Format.fprintf ppf "EMPTY"
  | Value _e ->
      Format.fprintf ppf "Value"
  | NamedDir map ->
      Format.fprintf
        ppf
        "@[<v>%a@]"
        (Format.pp_print_list pp_item)
        (StringMap.bindings map)
  | IndexedDir {arg; subdir; _} ->
      let name = Format.asprintf "<%s>" (RPC_arg.descr arg).name in
      pp_item ppf (name, subdir)

and pp_item : type a. Format.formatter -> string * a t -> unit =
 fun ppf (name, dir) -> Format.fprintf ppf "@[<v 2>%s@ %a@]" name pp dir

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  val rpc_arg : t RPC_arg.t

  val encoding : t Data_encoding.t

  val compare : t -> t -> int
end

type _ handler =
  | Handler : {
      encoding : 'a Data_encoding.t;
      get : 'key -> int -> 'a tzresult Lwt.t;
    }
      -> 'key handler

type _ opt_handler =
  | Opt_handler : {
      encoding : 'a Data_encoding.t;
      get : 'key -> int -> 'a option tzresult Lwt.t;
    }
      -> 'key opt_handler

let rec combine_object = function
  | [] ->
      Handler {encoding = Data_encoding.unit; get = (fun _ _ -> return_unit)}
  | (name, Opt_handler handler) :: fields ->
      let (Handler handlers) = combine_object fields in
      Handler
        {
          encoding =
            Data_encoding.merge_objs
              Data_encoding.(obj1 (opt name (dynamic_size handler.encoding)))
              handlers.encoding;
          get =
            (fun k i ->
              handler.get k i
              >>=? fun v1 -> handlers.get k i >>=? fun v2 -> return (v1, v2));
        }

type query = {depth : int}

let depth_query =
  let open RPC_query in
  query (fun depth -> {depth})
  |+ field "depth" RPC_arg.int 0 (fun t -> t.depth)
  |> seal

let build_directory : type key. key t -> key RPC_directory.t =
 fun dir ->
  let rpc_dir = ref (RPC_directory.empty : key RPC_directory.t) in
  let register : type ikey. (key, ikey) RPC_path.t -> ikey opt_handler -> unit
      =
   fun path (Opt_handler {encoding; get}) ->
    let service =
      RPC_service.get_service ~query:depth_query ~output:encoding path
    in
    rpc_dir :=
      RPC_directory.register !rpc_dir service (fun k q () ->
          get k (q.depth + 1)
          >>=? function None -> raise Not_found | Some x -> return x)
  in
  let rec build_handler :
      type ikey. ikey t -> (key, ikey) RPC_path.t -> ikey opt_handler =
   fun dir path ->
    match !dir with
    | Empty ->
        Opt_handler
          {encoding = Data_encoding.unit; get = (fun _ _ -> return_none)}
    | Value {get; encoding} ->
        let handler =
          Opt_handler
            {
              encoding;
              get =
                (fun k i -> if Compare.Int.(i < 0) then return_none else get k);
            }
        in
        register path handler ; handler
    | NamedDir map ->
        let fields = StringMap.bindings map in
        let fields =
          List.map
            (fun (name, dir) ->
              (name, build_handler dir RPC_path.(path / name)))
            fields
        in
        let (Handler handler) = combine_object fields in
        let handler =
          Opt_handler
            {
              encoding = handler.encoding;
              get =
                (fun k i ->
                  if Compare.Int.(i < 0) then return_none
                  else handler.get k (i - 1) >>=? fun v -> return_some v);
            }
        in
        register path handler ; handler
    | IndexedDir {arg; arg_encoding; list; subdir} ->
        let (Opt_handler handler) =
          build_handler subdir RPC_path.(path /: arg)
        in
        let encoding =
          let open Data_encoding in
          union
            [ case
                (Tag 0)
                ~title:"Leaf"
                (dynamic_size arg_encoding)
                (function (key, None) -> Some key | _ -> None)
                (fun key -> (key, None));
              case
                (Tag 1)
                ~title:"Dir"
                (tup2
                   (dynamic_size arg_encoding)
                   (dynamic_size handler.encoding))
                (function (key, Some value) -> Some (key, value) | _ -> None)
                (fun (key, value) -> (key, Some value)) ]
        in
        let get k i =
          if Compare.Int.(i < 0) then return_none
          else if Compare.Int.(i = 0) then return_some []
          else
            list k
            >>=? fun keys ->
            map_s
              (fun key ->
                if Compare.Int.(i = 1) then return (key, None)
                else
                  handler.get (k, key) (i - 1)
                  >>=? fun value -> return (key, value))
              keys
            >>=? fun values -> return_some values
        in
        let handler =
          Opt_handler
            {encoding = Data_encoding.(list (dynamic_size encoding)); get}
        in
        register path handler ; handler
  in
  ignore (build_handler dir RPC_path.open_root : key opt_handler) ;
  !rpc_dir
src/proto_alpha/lib_protocol/storage_description.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

Reserved Notation "'t".

Inductive description (key : Type) : Type :=
| Empty : description key
| Value : forall {a : Type},
  (key ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (option a))) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  description key
| NamedDir :
  (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.t) ('t key))
  -> description key
| IndexedDir : forall {a : Type},
  (Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (key ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list a))) -> ('t (key * a)) -> description key

where "'t" := (fun (key : Type) =>
  Tezos_protocol_environment_alpha__Environment.Pervasives.ref (description key)).

Definition t := 't.

Arguments Empty {_}.
Arguments Value {_}.
Arguments NamedDir {_}.
Arguments IndexedDir {_}.

Fixpoint register_named_subcontext {r : Type} (dir : t r) (names : list string)
  : t r :=
  match ((op_exclamation dir), names) with
  | (_, []) => dir
  | (Value _, _) => invalid_arg "" % string
  | (IndexedDir _, _) => invalid_arg "" % string
  | (Empty, cons name names) =>
    let subdir := ref Empty in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ :=
      op_coloneq dir
        (NamedDir
          (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.singleton)
            name subdir)) in
    register_named_subcontext subdir names
  | (NamedDir map, cons name names) =>
    let subdir :=
      match
        StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.find_opt)
          name map with
      | Some subdir => subdir
      | None =>
        let subdir := ref Empty in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ :=
          op_coloneq dir
            (NamedDir
              (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.add)
                name subdir map)) in
        subdir
      end in
    register_named_subcontext subdir names
  end.

Inductive args : forall (_ _ _ : Type), Type :=
| One : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.RPC_arg.t a) ->
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (a -> a -> Z) -> args key a (key * a)
| Pair : forall {a b inter_key key sub_key : Type}, (args key a inter_key) ->
  (args inter_key b sub_key) -> args key (a * b) sub_key.

Fixpoint unpack {a b c : Type} (function_parameter : args a b c) : c -> a * b :=
  match function_parameter with
  | One _ => fun x => x
  | Pair l r =>
    let unpack_l := unpack l in
    let unpack_r := unpack r in
    fun x =>
      let '(c, d) := unpack_r x in
      let '(b, a) := unpack_l c in
      (b, (a, d))
  end.

Fixpoint pack {a b c : Type} (function_parameter : args a b c) : a -> b -> c :=
  match function_parameter with
  | One _ => fun b => fun a => (b, a)
  | Pair l r =>
    let pack_l := pack l in
    let pack_r := pack r in
    fun b =>
      fun function_parameter =>
        let '(a, d) := function_parameter in
        let c := pack_l b a in
        pack_r c d
  end.

Fixpoint compare {a b c : Type} (function_parameter : args a b c)
  : b -> b -> Z :=
  match function_parameter with
  | One {| compare := compare |} => compare
  | Pair l r =>
    let compare_l := compare l in
    let compare_r := compare r in
    fun function_parameter =>
      let '(a1, b1) := function_parameter in
      fun function_parameter =>
        let '(a2, b2) := function_parameter in
        match compare_l a1 a2 with
        | 0 => compare_r b1 b2
        | x => x
        end
  end.

Definition destutter {A B : Type} (equal : A -> A -> bool) (l : list (A * B))
  : list A :=
  match l with
  | [] => []
  | cons (i, _) l =>
    let fix loop {C : Type}
      (acc : list A) (i : A) (function_parameter : list (A * C)) : list A :=
      match function_parameter with
      | [] => acc
      | cons (j, _) l =>
        if equal i j then
          loop acc i l
        else
          loop (cons j acc) j l
      end in
    loop (cons i []) i l
  end.

Fixpoint register_indexed_subcontext {a b r : Type}
  (dir : t r)
  (list :
    r ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list a))) (path : args r a b) : t b :=
  match path with
  | Pair left right =>
    let compare_left := compare left in
    let equal_left (x : op_dollar0) (y : op_dollar0) : bool :=
      Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
        (compare_left x y) 0 in
    let list_left (r : r)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list op_dollar0)) :=
      op_gtgteqquestion (list r) (fun l => _return (destutter equal_left l)) in
    let list_right (r : op_dollarPair_'inter_key)
      : Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (list op_dollar1)) :=
      let '(a, k) := unpack left r in
      op_gtgteqquestion (list a)
        (fun l =>
          _return
            (List.map snd
              (List.filter
                (fun function_parameter =>
                  let '(x, _) := function_parameter in
                  equal_left x k) l))) in
    register_indexed_subcontext (register_indexed_subcontext dir list_left left)
      list_right right
  | One {| rpc_arg := arg; encoding := arg_encoding |} =>
    match op_exclamation dir with
    | Value _ => invalid_arg "" % string
    | NamedDir _ => invalid_arg "" % string
    | Empty =>
      let subdir := ref Empty in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        op_coloneq dir
          (IndexedDir
            {| arg := arg; arg_encoding := arg_encoding; list := list;
              subdir := subdir |}) in
      subdir
    | IndexedDir {| arg := inner_arg; subdir := subdir |} =>
      match RPC_arg.eq arg inner_arg with
      | None => invalid_arg "" % string
      | Some Tezos_protocol_environment_alpha__Environment.RPC_arg.Eq => subdir
      end
    end
  end.

Definition register_value {a b : Type}
  (dir : t a)
  (get :
    a ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option b)))
  (encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t b)
  : unit :=
  match op_exclamation dir with
  | Empty => op_coloneq dir (Value {| get := get; encoding := encoding |})
  | _ => invalid_arg "" % string
  end.

Definition create {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Pervasives.ref (description A) :=
  let 'tt := function_parameter in
  ref Empty.

Fixpoint pp {a : Type}
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (dir : t a) : unit :=
  match op_exclamation dir with
  | Empty =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "EMPTY" % string
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
        "EMPTY" % string)
  | Value _e =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
          "Value" % string
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
        "Value" % string)
  | NamedDir map =>
    Format.fprintf ppf
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                "<v>" % string
                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
              "<v>" % string))
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
        "@[<v>%a@]" % string) (Format.pp_print_list None pp_item)
      (StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
        map)
  | IndexedDir {| arg := arg; subdir := subdir |} =>
    let name :=
      Format.asprintf
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
            "<" % char
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Char_literal
                ">" % char
                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))
          "<%s>" % string) (name (RPC_arg.descr arg)) in
    pp_item ppf (name, subdir)
  end

with pp_item {a : Type}
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (function_parameter : string * (t a)) : unit :=
  let '(name, dir) := function_parameter in
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "<v 2>" % string
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
            "<v 2>" % string))
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Break
              "@ " % string 1 0)
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))
      "@[<v 2>%s@ %a@]" % string) name pp dir.

Module INDEX.
  Record signature {t : Type} := {
    t := t;
    path_length : Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
    rpc_arg : Tezos_protocol_environment_alpha__Environment.RPC_arg.t t;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
    compare : t -> t -> Z;
  }.
  Arguments signature : clear implicits.
End INDEX.

Inductive handler : forall (_ : Type), Type :=
| Handler : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (key ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult a))
  -> handler key.

Inductive opt_handler : forall (_ : Type), Type :=
| Opt_handler : forall {a key : Type},
  (Tezos_protocol_environment_alpha__Environment.Data_encoding.t a) ->
  (key ->
    Z ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option a))) -> opt_handler key.

Fixpoint combine_object {A : Type}
  (function_parameter : list (string * (opt_handler A))) : handler A :=
  match function_parameter with
  | [] =>
    Handler
      {| encoding := Data_encoding.unit;
        get :=
          fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '_ := function_parameter in
              return_unit |}
  | cons (name, Opt_handler handler) fields =>
    let 'Handler handlers := combine_object fields in
    Handler
      {|
        encoding :=
          Data_encoding.merge_objs
            (obj1 (opt None None name (dynamic_size None (encoding handler))))
            (encoding handlers);
        get :=
          fun k =>
            fun i =>
              op_gtgteqquestion ((get handler) k i)
                (fun v1 =>
                  op_gtgteqquestion ((get handlers) k i)
                    (fun v2 => _return (v1, v2))) |}
  end.

Record query := {
  depth : Z }.

Definition depth_query
  : Tezos_protocol_environment_alpha__Environment.RPC_query.t query :=
  op_pipegt
    (op_pipeplus (query (fun depth => {| depth := depth |}))
      (field None "depth" % string RPC_arg.int 0 (fun t => depth t))) seal.

Definition build_directory {key : Type} (dir : t key)
  : Tezos_protocol_environment_alpha__Environment.RPC_directory.t key :=
  let rpc_dir := ref RPC_directory.empty in
  let register {ikey : Type}
    (path : Tezos_protocol_environment_alpha__Environment.RPC_path.t key ikey)
    (function_parameter : opt_handler ikey) : unit :=
    let 'Opt_handler {| encoding := encoding; get := get |} :=
      function_parameter in
    let service := RPC_service.get_service None depth_query encoding path in
    op_coloneq rpc_dir
      (RPC_directory.register (op_exclamation rpc_dir) service
        (fun k =>
          fun q =>
            fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion (get k (op_plus (depth q) 1))
                (fun function_parameter =>
                  match function_parameter with
                  | None => raise OCaml.Not_found
                  | Some x => _return x
                  end))) in
  let fix build_handler {ikey : Type}
    (dir : t ikey) (path :
    Tezos_protocol_environment_alpha__Environment.RPC_path.t key ikey)
    : opt_handler ikey :=
    match op_exclamation dir with
    | Empty =>
      Opt_handler
        {| encoding := Data_encoding.unit;
          get :=
            fun function_parameter =>
              let '_ := function_parameter in
              fun function_parameter =>
                let '_ := function_parameter in
                return_none |}
    | Value {| get := get; encoding := encoding |} =>
      let handler :=
        Opt_handler
          {| encoding := encoding;
            get :=
              fun k =>
                fun i =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                      i 0 then
                    return_none
                  else
                    get k |} in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := register path handler in
      handler
    | NamedDir map =>
      let fields :=
        StringMap.(Tezos_protocol_environment_alpha__Environment.MAP.S.bindings)
          map in
      let fields :=
        List.map
          (fun function_parameter =>
            let '(name, dir) := function_parameter in
            (name, (build_handler dir (op_div path name)))) fields in
      let 'Handler handler := combine_object fields in
      let handler :=
        Opt_handler
          {| encoding := encoding handler;
            get :=
              fun k =>
                fun i =>
                  if
                    Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
                      i 0 then
                    return_none
                  else
                    op_gtgteqquestion ((get handler) k (op_minus i 1))
                      (fun v => return_some v) |} in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := register path handler in
      handler
    |
      IndexedDir {|
        arg := arg;
          arg_encoding := arg_encoding;
          list := list;
          subdir := subdir
          |} =>
      let 'Opt_handler handler := build_handler subdir (op_divcolon path arg) in
      let encoding :=
        union None
          (cons
            (case "Leaf" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
              (dynamic_size None arg_encoding)
              (fun function_parameter =>
                match function_parameter with
                | (key, None) => Some key
                | _ => None
                end) (fun key => (key, None)))
            (cons
              (case "Dir" % string None
                (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag
                  1)
                (tup2 (dynamic_size None arg_encoding)
                  (dynamic_size None (encoding handler)))
                (fun function_parameter =>
                  match function_parameter with
                  | (key, Some value) => Some (key, value)
                  | _ => None
                  end)
                (fun function_parameter =>
                  let '(key, value) := function_parameter in
                  (key, (Some value)))) [])) in
      let get
        (k : ikey) (i :
        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
        : Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (option
              (list (op_dollarIndexedDir_'a * (option op_dollarOpt_handler_'a1))))) :=
        if
          Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_lt)
            i 0 then
          return_none
        else
          if
            Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
              i 0 then
            return_some []
          else
            op_gtgteqquestion (list k)
              (fun keys =>
                op_gtgteqquestion
                  (map_s
                    (fun key =>
                      if
                        Tezos_protocol_environment_alpha__Environment.Compare.Int.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_eq)
                          i 1 then
                        _return (key, None)
                      else
                        op_gtgteqquestion
                          ((get handler) (k, key) (op_minus i 1))
                          (fun value => _return (key, value))) keys)
                  (fun values => return_some values)) in
      let handler :=
        Opt_handler
          {| encoding := list None (dynamic_size None encoding); get := get |}
        in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := register path handler in
      handler
    end in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := ignore (build_handler dir RPC_path.open_root) in
  op_exclamation rpc_dir.

src/proto_alpha/lib_protocol/storage_functors.ml 18 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Storage_sigs

module Registered = struct
  let ghost = false
end

module Ghost = struct
  let ghost = true
end

module Make_encoder (V : VALUE) = struct
  let of_bytes ~key b =
    match Data_encoding.Binary.of_bytes V.encoding b with
    | None ->
        error (Raw_context.Storage_error (Corrupted_data key))
    | Some v ->
        Ok v

  let to_bytes v =
    match Data_encoding.Binary.to_bytes V.encoding v with
    | Some b ->
        b
    | None ->
        MBytes.create 0
end

let len_name = "len"

let data_name = "data"

let encode_len_value bytes =
  let length = MBytes.length bytes in
  Data_encoding.(Binary.to_bytes_exn int31) length

let decode_len_value key len =
  match Data_encoding.(Binary.of_bytes int31) len with
  | None ->
      fail (Raw_context.Storage_error (Corrupted_data key))
  | Some len ->
      return len

let map_key f = function `Key k -> `Key (f k) | `Dir k -> `Dir (f k)

module Make_subcontext (R : REGISTER) (C : Raw_context.T) (N : NAME) :
  Raw_context.T with type t = C.t = struct
  type t = C.t

  type context = t

  let name_length = List.length N.name

  let to_key k = N.name @ k

  let of_key k = Misc.remove_elem_from_list name_length k

  let mem t k = C.mem t (to_key k)

  let dir_mem t k = C.dir_mem t (to_key k)

  let get t k = C.get t (to_key k)

  let get_option t k = C.get_option t (to_key k)

  let init t k v = C.init t (to_key k) v

  let set t k v = C.set t (to_key k) v

  let init_set t k v = C.init_set t (to_key k) v

  let set_option t k v = C.set_option t (to_key k) v

  let delete t k = C.delete t (to_key k)

  let remove t k = C.remove t (to_key k)

  let remove_rec t k = C.remove_rec t (to_key k)

  let copy t ~from ~to_ = C.copy t ~from:(to_key from) ~to_:(to_key to_)

  let fold t k ~init ~f =
    C.fold t (to_key k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

  let keys t k = C.keys t (to_key k) >|= fun keys -> List.map of_key keys

  let fold_keys t k ~init ~f =
    C.fold_keys t (to_key k) ~init ~f:(fun k acc -> f (of_key k) acc)

  let project = C.project

  let absolute_key c k = C.absolute_key c (to_key k)

  let consume_gas = C.consume_gas

  let check_enough_gas = C.check_enough_gas

  let description =
    let description =
      if R.ghost then Storage_description.create () else C.description
    in
    Storage_description.register_named_subcontext description N.name
end

module Make_single_data_storage
    (R : REGISTER)
    (C : Raw_context.T)
    (N : NAME)
    (V : VALUE) : Single_data_storage with type t = C.t and type value = V.t =
struct
  type t = C.t

  type context = t

  type value = V.t

  let mem t = C.mem t N.name

  include Make_encoder (V)

  let get t =
    C.get t N.name
    >>=? fun b ->
    let key = C.absolute_key t N.name in
    Lwt.return (of_bytes ~key b)

  let get_option t =
    C.get_option t N.name
    >>= function
    | None ->
        return_none
    | Some b -> (
        let key = C.absolute_key t N.name in
        match of_bytes ~key b with
        | Ok v ->
            return_some v
        | Error _ as err ->
            Lwt.return err )

  let init t v =
    C.init t N.name (to_bytes v) >>=? fun t -> return (C.project t)

  let set t v = C.set t N.name (to_bytes v) >>=? fun t -> return (C.project t)

  let init_set t v =
    C.init_set t N.name (to_bytes v) >>= fun t -> Lwt.return (C.project t)

  let set_option t v =
    C.set_option t N.name (Option.map ~f:to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let remove t = C.remove t N.name >>= fun t -> Lwt.return (C.project t)

  let delete t = C.delete t N.name >>=? fun t -> return (C.project t)

  let () =
    let open Storage_description in
    let description =
      if R.ghost then Storage_description.create () else C.description
    in
    register_value
      ~get:get_option
      (register_named_subcontext description N.name)
      V.encoding
end

module type INDEX = sig
  type t

  val path_length : int

  val to_path : t -> string list -> string list

  val of_path : string list -> t option

  type 'a ipath

  val args : ('a, t, 'a ipath) Storage_description.args
end

module Pair (I1 : INDEX) (I2 : INDEX) : INDEX with type t = I1.t * I2.t =
struct
  type t = I1.t * I2.t

  let path_length = I1.path_length + I2.path_length

  let to_path (x, y) l = I1.to_path x (I2.to_path y l)

  let of_path l =
    match Misc.take I1.path_length l with
    | None ->
        None
    | Some (l1, l2) -> (
      match (I1.of_path l1, I2.of_path l2) with
      | (Some x, Some y) ->
          Some (x, y)
      | _ ->
          None )

  type 'a ipath = 'a I1.ipath I2.ipath

  let args = Storage_description.Pair (I1.args, I2.args)
end

module Make_data_set_storage (C : Raw_context.T) (I : INDEX) :
  Data_set_storage with type t = C.t and type elt = I.t = struct
  type t = C.t

  type context = t

  type elt = I.t

  let inited = MBytes.of_string "inited"

  let mem s i = C.mem s (I.to_path i [])

  let add s i =
    C.init_set s (I.to_path i []) inited >>= fun t -> Lwt.return (C.project t)

  let del s i =
    C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)

  let set s i = function true -> add s i | false -> del s i

  let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)

  let fold s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 1) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some p ->
                  f p acc ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value (* TODO fixme 'elements...' *)
      ~get:(fun c ->
        let (c, k) = unpack c in
        mem c k >>= function true -> return_some true | false -> return_none)
      (register_indexed_subcontext
         ~list:(fun c -> elements c >>= return)
         C.description
         I.args)
      Data_encoding.bool
end

module Make_indexed_data_storage (C : Raw_context.T) (I : INDEX) (V : VALUE) :
  Indexed_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t = struct
  type t = C.t

  type context = t

  type key = I.t

  type value = V.t

  include Make_encoder (V)

  let mem s i = C.mem s (I.to_path i [])

  let get s i =
    C.get s (I.to_path i [])
    >>=? fun b ->
    let key = C.absolute_key s (I.to_path i []) in
    Lwt.return (of_bytes ~key b)

  let get_option s i =
    C.get_option s (I.to_path i [])
    >>= function
    | None ->
        return_none
    | Some b -> (
        let key = C.absolute_key s (I.to_path i []) in
        match of_bytes ~key b with
        | Ok v ->
            return_some v
        | Error _ as err ->
            Lwt.return err )

  let set s i v =
    C.set s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)

  let init s i v =
    C.init s (I.to_path i []) (to_bytes v) >>=? fun t -> return (C.project t)

  let init_set s i v =
    C.init_set s (I.to_path i []) (to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let set_option s i v =
    C.set_option s (I.to_path i []) (Option.map ~f:to_bytes v)
    >>= fun t -> Lwt.return (C.project t)

  let remove s i =
    C.remove s (I.to_path i []) >>= fun t -> Lwt.return (C.project t)

  let delete s i =
    C.delete s (I.to_path i []) >>=? fun t -> return (C.project t)

  let clear s = C.remove_rec s [] >>= fun t -> Lwt.return (C.project t)

  let fold_keys s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 1) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match I.of_path file with
              | None ->
                  assert false
              | Some path ->
                  f path acc ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let fold s ~init ~f =
    let f path acc =
      get s path
      >>= function
      | Error _ ->
          (* FIXME: silently ignore unparsable data *)
          Lwt.return acc
      | Ok v ->
          f path v acc
    in
    fold_keys s ~init ~f

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value
      ~get:(fun c ->
        let (c, k) = unpack c in
        get_option c k)
      (register_indexed_subcontext
         ~list:(fun c -> keys c >>= return)
         C.description
         I.args)
      V.encoding
end

module Make_indexed_carbonated_data_storage
    (C : Raw_context.T)
    (I : INDEX)
    (V : VALUE) :
  Non_iterable_indexed_carbonated_data_storage
    with type t = C.t
     and type key = I.t
     and type value = V.t = struct
  type t = C.t

  type context = t

  type key = I.t

  type value = V.t

  include Make_encoder (V)

  let data_key i = I.to_path i [data_name]

  let len_key i = I.to_path i [len_name]

  let consume_mem_gas c =
    Lwt.return (C.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))

  let existing_size c i =
    C.get_option c (len_key i)
    >>= function
    | None ->
        return (0, false)
    | Some len ->
        decode_len_value (len_key i) len >>=? fun len -> return (len, true)

  let consume_read_gas get c i =
    get c (len_key i)
    >>=? fun len ->
    decode_len_value (len_key i) len
    >>=? fun len ->
    Lwt.return
      (C.consume_gas c (Gas_limit_repr.read_bytes_cost (Z.of_int len)))

  let consume_serialize_write_gas set c i v =
    let bytes = to_bytes v in
    let len = MBytes.length bytes in
    Lwt.return (C.consume_gas c (Gas_limit_repr.alloc_mbytes_cost len))
    >>=? fun c ->
    Lwt.return
      (C.consume_gas c (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
    >>=? fun c ->
    set c (len_key i) (encode_len_value bytes) >>=? fun c -> return (c, bytes)

  let consume_remove_gas del c i =
    Lwt.return (C.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
    >>=? fun c -> del c (len_key i)

  let mem s i =
    consume_mem_gas s
    >>=? fun s ->
    C.mem s (data_key i) >>= fun exists -> return (C.project s, exists)

  let get s i =
    consume_read_gas C.get s i
    >>=? fun s ->
    C.get s (data_key i)
    >>=? fun b ->
    let key = C.absolute_key s (data_key i) in
    Lwt.return (of_bytes ~key b) >>=? fun v -> return (C.project s, v)

  let get_option s i =
    consume_mem_gas s
    >>=? fun s ->
    C.mem s (data_key i)
    >>= fun exists ->
    if exists then get s i >>=? fun (s, v) -> return (s, Some v)
    else return (C.project s, None)

  let set s i v =
    existing_size s i
    >>=? fun (prev_size, _) ->
    consume_serialize_write_gas C.set s i v
    >>=? fun (s, bytes) ->
    C.set s (data_key i) bytes
    >>=? fun t ->
    let size_diff = MBytes.length bytes - prev_size in
    return (C.project t, size_diff)

  let init s i v =
    consume_serialize_write_gas C.init s i v
    >>=? fun (s, bytes) ->
    C.init s (data_key i) bytes
    >>=? fun t ->
    let size = MBytes.length bytes in
    return (C.project t, size)

  let init_set s i v =
    let init_set s i v = C.init_set s i v >>= return in
    existing_size s i
    >>=? fun (prev_size, existed) ->
    consume_serialize_write_gas init_set s i v
    >>=? fun (s, bytes) ->
    init_set s (data_key i) bytes
    >>=? fun t ->
    let size_diff = MBytes.length bytes - prev_size in
    return (C.project t, size_diff, existed)

  let remove s i =
    let remove s i = C.remove s i >>= return in
    existing_size s i
    >>=? fun (prev_size, existed) ->
    consume_remove_gas remove s i
    >>=? fun s ->
    remove s (data_key i) >>=? fun t -> return (C.project t, prev_size, existed)

  let delete s i =
    existing_size s i
    >>=? fun (prev_size, _) ->
    consume_remove_gas C.delete s i
    >>=? fun s ->
    C.delete s (data_key i) >>=? fun t -> return (C.project t, prev_size)

  let set_option s i v =
    match v with None -> remove s i | Some v -> init_set s i v

  let fold_keys_unaccounted s ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 0) then
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir _ ->
                Lwt.return acc
            | `Key file -> (
              match List.rev file with
              | last :: _ when Compare.String.(last = len_name) ->
                  Lwt.return acc
              | last :: rest when Compare.String.(last = data_name) -> (
                  let file = List.rev rest in
                  match I.of_path file with
                  | None ->
                      assert false
                  | Some path ->
                      f path acc )
              | _ ->
                  assert false ))
      else
        C.fold s path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let keys_unaccounted s =
    fold_keys_unaccounted s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

  let () =
    let open Storage_description in
    let unpack = unpack I.args in
    register_value (* TODO export consumed gas ?? *)
      ~get:(fun c ->
        let (c, k) = unpack c in
        get_option c k >>=? fun (_, v) -> return v)
      (register_indexed_subcontext
         ~list:(fun c -> keys_unaccounted c >>= return)
         C.description
         I.args)
      V.encoding
end

module Make_indexed_data_snapshotable_storage
    (C : Raw_context.T)
    (Snapshot_index : INDEX)
    (I : INDEX)
    (V : VALUE) :
  Indexed_data_snapshotable_storage
    with type t = C.t
     and type snapshot = Snapshot_index.t
     and type key = I.t
     and type value = V.t = struct
  type snapshot = Snapshot_index.t

  let data_name = ["current"]

  let snapshot_name = ["snapshot"]

  module C_data =
    Make_subcontext (Registered) (C)
      (struct
        let name = data_name
      end)

  module C_snapshot =
    Make_subcontext (Registered) (C)
      (struct
        let name = snapshot_name
      end)

  include Make_indexed_data_storage (C_data) (I) (V)
  module Snapshot =
    Make_indexed_data_storage (C_snapshot) (Pair (Snapshot_index) (I)) (V)

  let snapshot_path id = snapshot_name @ Snapshot_index.to_path id []

  let snapshot_exists s id = C.dir_mem s (snapshot_path id)

  let snapshot s id =
    C.copy s ~from:data_name ~to_:(snapshot_path id)
    >>=? fun t -> return (C.project t)

  let delete_snapshot s id =
    C.remove_rec s (snapshot_path id) >>= fun t -> Lwt.return (C.project t)
end

module Make_indexed_subcontext (C : Raw_context.T) (I : INDEX) :
  Indexed_raw_context
    with type t = C.t
     and type key = I.t
     and type 'a ipath = 'a I.ipath = struct
  type t = C.t

  type context = t

  type key = I.t

  type 'a ipath = 'a I.ipath

  let clear t = C.remove_rec t [] >>= fun t -> Lwt.return (C.project t)

  let fold_keys t ~init ~f =
    let rec dig i path acc =
      if Compare.Int.(i <= 0) then
        match I.of_path path with
        | None ->
            assert false
        | Some path ->
            f path acc
      else
        C.fold t path ~init:acc ~f:(fun k acc ->
            match k with
            | `Dir k ->
                dig (i - 1) k acc
            | `Key _ ->
                Lwt.return acc)
    in
    dig I.path_length [] init

  let keys t = fold_keys t ~init:[] ~f:(fun i acc -> Lwt.return (i :: acc))

  let list t k = C.fold t k ~init:[] ~f:(fun k acc -> Lwt.return (k :: acc))

  let remove_rec t k = C.remove_rec t (I.to_path k [])

  let copy t ~from ~to_ =
    C.copy t ~from:(I.to_path from []) ~to_:(I.to_path to_ [])

  let description =
    Storage_description.register_indexed_subcontext
      ~list:(fun c -> keys c >>= return)
      C.description
      I.args

  let unpack = Storage_description.unpack I.args

  let pack = Storage_description.pack I.args

  module Raw_context = struct
    type t = C.t I.ipath

    type context = t

    let to_key i k = I.to_path i k

    let of_key k = Misc.remove_elem_from_list I.path_length k

    let mem c k =
      let (t, i) = unpack c in
      C.mem t (to_key i k)

    let dir_mem c k =
      let (t, i) = unpack c in
      C.dir_mem t (to_key i k)

    let get c k =
      let (t, i) = unpack c in
      C.get t (to_key i k)

    let get_option c k =
      let (t, i) = unpack c in
      C.get_option t (to_key i k)

    let init c k v =
      let (t, i) = unpack c in
      C.init t (to_key i k) v >>=? fun t -> return (pack t i)

    let set c k v =
      let (t, i) = unpack c in
      C.set t (to_key i k) v >>=? fun t -> return (pack t i)

    let init_set c k v =
      let (t, i) = unpack c in
      C.init_set t (to_key i k) v >>= fun t -> Lwt.return (pack t i)

    let set_option c k v =
      let (t, i) = unpack c in
      C.set_option t (to_key i k) v >>= fun t -> Lwt.return (pack t i)

    let delete c k =
      let (t, i) = unpack c in
      C.delete t (to_key i k) >>=? fun t -> return (pack t i)

    let remove c k =
      let (t, i) = unpack c in
      C.remove t (to_key i k) >>= fun t -> Lwt.return (pack t i)

    let remove_rec c k =
      let (t, i) = unpack c in
      C.remove_rec t (to_key i k) >>= fun t -> Lwt.return (pack t i)

    let copy c ~from ~to_ =
      let (t, i) = unpack c in
      C.copy t ~from:(to_key i from) ~to_:(to_key i to_)
      >>=? fun t -> return (pack t i)

    let fold c k ~init ~f =
      let (t, i) = unpack c in
      C.fold t (to_key i k) ~init ~f:(fun k acc -> f (map_key of_key k) acc)

    let keys c k =
      let (t, i) = unpack c in
      C.keys t (to_key i k) >|= fun keys -> List.map of_key keys

    let fold_keys c k ~init ~f =
      let (t, i) = unpack c in
      C.fold_keys t (to_key i k) ~init ~f:(fun k acc -> f (of_key k) acc)

    let project c =
      let (t, _) = unpack c in
      C.project t

    let absolute_key c k =
      let (t, i) = unpack c in
      C.absolute_key t (to_key i k)

    let consume_gas c g =
      let (t, i) = unpack c in
      C.consume_gas t g >>? fun t -> ok (pack t i)

    let check_enough_gas c g =
      let (t, _i) = unpack c in
      C.check_enough_gas t g

    let description = description
  end

  let resolve t prefix =
    let rec loop i prefix = function
      | [] when Compare.Int.(i = I.path_length) -> (
        match I.of_path prefix with
        | None ->
            assert false
        | Some path ->
            Lwt.return [path] )
      | [] ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix [])
            prefixes
          >|= List.flatten
      | [d] when Compare.Int.(i = I.path_length - 1) ->
          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function
              | `Key prefix | `Dir prefix -> (
                match
                  Misc.remove_prefix ~prefix:d (List.hd (List.rev prefix))
                with
                | None ->
                    Lwt.return_nil
                | Some _ ->
                    loop (i + 1) prefix [] ))
            prefixes
          >|= List.flatten
      | "" :: ds ->
          list t prefix
          >>= fun prefixes ->
          Lwt_list.map_s
            (function `Key prefix | `Dir prefix -> loop (i + 1) prefix ds)
            prefixes
          >|= List.flatten
      | d :: ds -> (
          if Compare.Int.(i >= I.path_length) then invalid_arg "IO.resolve" ;
          C.dir_mem t (prefix @ [d])
          >>= function
          | true -> loop (i + 1) (prefix @ [d]) ds | false -> Lwt.return_nil )
    in
    loop 0 [] prefix

  module Make_set (R : REGISTER) (N : NAME) = struct
    type t = C.t

    type context = t

    type elt = I.t

    let inited = MBytes.of_string "inited"

    let mem s i = Raw_context.mem (pack s i) N.name

    let add s i =
      Raw_context.init_set (pack s i) N.name inited
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let del s i =
      Raw_context.remove (pack s i) N.name
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let set s i = function true -> add s i | false -> del s i

    let clear s =
      fold_keys s ~init:s ~f:(fun i s ->
          Raw_context.remove (pack s i) N.name
          >>= fun c ->
          let (s, _) = unpack c in
          Lwt.return s)
      >>= fun t -> Lwt.return (C.project t)

    let fold s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          mem s i >>= function true -> f i acc | false -> Lwt.return acc)

    let elements s = fold s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      let description =
        if R.ghost then Storage_description.create ()
        else Raw_context.description
      in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          mem c k
          >>= function true -> return_some true | false -> return_none)
        (register_named_subcontext description N.name)
        Data_encoding.bool
  end

  module Make_map (N : NAME) (V : VALUE) = struct
    type t = C.t

    type context = t

    type key = I.t

    type value = V.t

    include Make_encoder (V)

    let mem s i = Raw_context.mem (pack s i) N.name

    let get s i =
      Raw_context.get (pack s i) N.name
      >>=? fun b ->
      let key = Raw_context.absolute_key (pack s i) N.name in
      Lwt.return (of_bytes ~key b)

    let get_option s i =
      Raw_context.get_option (pack s i) N.name
      >>= function
      | None ->
          return_none
      | Some b -> (
          let key = Raw_context.absolute_key (pack s i) N.name in
          match of_bytes ~key b with
          | Ok v ->
              return_some v
          | Error _ as err ->
              Lwt.return err )

    let set s i v =
      Raw_context.set (pack s i) N.name (to_bytes v)
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let init s i v =
      Raw_context.init (pack s i) N.name (to_bytes v)
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let init_set s i v =
      Raw_context.init_set (pack s i) N.name (to_bytes v)
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let set_option s i v =
      Raw_context.set_option (pack s i) N.name (Option.map ~f:to_bytes v)
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let remove s i =
      Raw_context.remove (pack s i) N.name
      >>= fun c ->
      let (s, _) = unpack c in
      Lwt.return (C.project s)

    let delete s i =
      Raw_context.delete (pack s i) N.name
      >>=? fun c ->
      let (s, _) = unpack c in
      return (C.project s)

    let clear s =
      fold_keys s ~init:s ~f:(fun i s ->
          Raw_context.remove (pack s i) N.name
          >>= fun c ->
          let (s, _) = unpack c in
          Lwt.return s)
      >>= fun t -> Lwt.return (C.project t)

    let fold s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          get s i >>= function Error _ -> Lwt.return acc | Ok v -> f i v acc)

    let bindings s =
      fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

    let fold_keys s ~init ~f =
      fold_keys s ~init ~f:(fun i acc ->
          mem s i >>= function false -> Lwt.return acc | true -> f i acc)

    let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          get_option c k)
        (register_named_subcontext Raw_context.description N.name)
        V.encoding
  end

  module Make_carbonated_map (N : NAME) (V : VALUE) = struct
    type t = C.t

    type context = t

    type key = I.t

    type value = V.t

    include Make_encoder (V)

    let len_name = len_name :: N.name

    let data_name = data_name :: N.name

    let consume_mem_gas c =
      Lwt.return
        (Raw_context.consume_gas c (Gas_limit_repr.read_bytes_cost Z.zero))

    let existing_size c =
      Raw_context.get_option c len_name
      >>= function
      | None ->
          return (0, false)
      | Some len ->
          decode_len_value len_name len >>=? fun len -> return (len, true)

    let consume_read_gas get c =
      get c len_name
      >>=? fun len ->
      decode_len_value len_name len
      >>=? fun len ->
      Lwt.return
        (Raw_context.consume_gas
           c
           (Gas_limit_repr.read_bytes_cost (Z.of_int len)))

    let consume_write_gas set c v =
      let bytes = to_bytes v in
      let len = MBytes.length bytes in
      Lwt.return
        (Raw_context.consume_gas
           c
           (Gas_limit_repr.write_bytes_cost (Z.of_int len)))
      >>=? fun c ->
      set c len_name (encode_len_value bytes) >>=? fun c -> return (c, bytes)

    let consume_remove_gas del c =
      Lwt.return
        (Raw_context.consume_gas c (Gas_limit_repr.write_bytes_cost Z.zero))
      >>=? fun c -> del c len_name

    let mem s i =
      consume_mem_gas (pack s i)
      >>=? fun c ->
      Raw_context.mem c data_name
      >>= fun res -> return (Raw_context.project c, res)

    let get s i =
      consume_read_gas Raw_context.get (pack s i)
      >>=? fun c ->
      Raw_context.get c data_name
      >>=? fun b ->
      let key = Raw_context.absolute_key c data_name in
      Lwt.return (of_bytes ~key b)
      >>=? fun v -> return (Raw_context.project c, v)

    let get_option s i =
      consume_mem_gas (pack s i)
      >>=? fun c ->
      let (s, _) = unpack c in
      Raw_context.mem (pack s i) data_name
      >>= fun exists ->
      if exists then get s i >>=? fun (s, v) -> return (s, Some v)
      else return (C.project s, None)

    let set s i v =
      existing_size (pack s i)
      >>=? fun (prev_size, _) ->
      consume_write_gas Raw_context.set (pack s i) v
      >>=? fun (c, bytes) ->
      Raw_context.set c data_name bytes
      >>=? fun c ->
      let size_diff = MBytes.length bytes - prev_size in
      return (Raw_context.project c, size_diff)

    let init s i v =
      consume_write_gas Raw_context.init (pack s i) v
      >>=? fun (c, bytes) ->
      Raw_context.init c data_name bytes
      >>=? fun c ->
      let size = MBytes.length bytes in
      return (Raw_context.project c, size)

    let init_set s i v =
      let init_set c k v = Raw_context.init_set c k v >>= return in
      existing_size (pack s i)
      >>=? fun (prev_size, existed) ->
      consume_write_gas init_set (pack s i) v
      >>=? fun (c, bytes) ->
      init_set c data_name bytes
      >>=? fun c ->
      let size_diff = MBytes.length bytes - prev_size in
      return (Raw_context.project c, size_diff, existed)

    let remove s i =
      let remove c k = Raw_context.remove c k >>= return in
      existing_size (pack s i)
      >>=? fun (prev_size, existed) ->
      consume_remove_gas remove (pack s i)
      >>=? fun c ->
      remove c data_name
      >>=? fun c -> return (Raw_context.project c, prev_size, existed)

    let delete s i =
      existing_size (pack s i)
      >>=? fun (prev_size, _) ->
      consume_remove_gas Raw_context.delete (pack s i)
      >>=? fun c ->
      Raw_context.delete c data_name
      >>=? fun c -> return (Raw_context.project c, prev_size)

    let set_option s i v =
      match v with None -> remove s i | Some v -> init_set s i v

    let () =
      let open Storage_description in
      let unpack = unpack I.args in
      register_value
        ~get:(fun c ->
          let (c, k) = unpack c in
          get_option c k >>=? fun (_, v) -> return v)
        (register_named_subcontext Raw_context.description N.name)
        V.encoding
  end
end

module Wrap_indexed_data_storage
    (C : Indexed_data_storage) (K : sig
      type t

      val wrap : t -> C.key

      val unwrap : C.key -> t option
    end) =
struct
  type t = C.t

  type context = C.t

  type key = K.t

  type value = C.value

  let mem ctxt k = C.mem ctxt (K.wrap k)

  let get ctxt k = C.get ctxt (K.wrap k)

  let get_option ctxt k = C.get_option ctxt (K.wrap k)

  let set ctxt k v = C.set ctxt (K.wrap k) v

  let init ctxt k v = C.init ctxt (K.wrap k) v

  let init_set ctxt k v = C.init_set ctxt (K.wrap k) v

  let set_option ctxt k v = C.set_option ctxt (K.wrap k) v

  let delete ctxt k = C.delete ctxt (K.wrap k)

  let remove ctxt k = C.remove ctxt (K.wrap k)

  let clear ctxt = C.clear ctxt

  let fold ctxt ~init ~f =
    C.fold ctxt ~init ~f:(fun k v acc ->
        match K.unwrap k with None -> Lwt.return acc | Some k -> f k v acc)

  let bindings s =
    fold s ~init:[] ~f:(fun p v acc -> Lwt.return ((p, v) :: acc))

  let fold_keys s ~init ~f =
    C.fold_keys s ~init ~f:(fun k acc ->
        match K.unwrap k with None -> Lwt.return acc | Some k -> f k acc)

  let keys s = fold_keys s ~init:[] ~f:(fun p acc -> Lwt.return (p :: acc))
end
src/proto_alpha/lib_protocol/storage_functors.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Storage_sigs.

Module Registered.
  Definition ghost : bool := false.
End Registered.

Module Ghost.
  Definition ghost : bool := true.
End Ghost.

(* ❌ Functors are not handled. *)
functor

Definition len_name : string := "len" % string.

Definition data_name : string := "data" % string.

Definition encode_len_value
  (bytes : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.MBytes.t :=
  let length := MBytes.length string in
  (Binary.to_bytes_exn int31) length.

Definition decode_len_value
  (key : list string)
  (len : Tezos_protocol_environment_alpha__Environment.MBytes.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  match (Binary.of_bytes int31) len with
  | None =>
    fail
      (Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_error
        (Tezos_raw_protocol_alpha.Raw_context.Corrupted_data key))
  | Some len => _return len
  end.

Definition map_key {A B : Type} (f : A -> B) (function_parameter : variant)
  : variant :=
  match function_parameter with
  | Key k =>
    (* ❌ Variants not supported *)
    variant
  | Dir k =>
    (* ❌ Variants not supported *)
    variant
  end.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

Module INDEX.
  Record signature {t ipath : Type} := {
    t := t;
    path_length : Z;
    to_path : t -> (list string) -> list string;
    of_path : (list string) -> option t;
    polymorphic_abstract_type;
    args : forall {a : Type}, Tezos_raw_protocol_alpha.Storage_description.args
      a t (ipath a);
  }.
  Arguments signature : clear implicits.
End INDEX.

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

(* ❌ Functors are not handled. *)
functor

src/proto_alpha/lib_protocol/storage_sigs.ml 10 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** {1 Entity Accessor Signatures} *)

(** The generic signature of a single data accessor (a single value
    bound to a specific key in the hierarchical (key x value)
    database). *)
module type Single_data_storage = sig
  type t

  type context = t

  (** The type of the value *)
  type value

  (** Tells if the data is already defined *)
  val mem : context -> bool Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error} if the key is not set or if the deserialisation
      fails *)
  val get : context -> value tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized, or {!Storage_helpers.Storage_error}
      if the deserialisation fails *)
  val get_option : context -> value option tzresult Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Existing_key} if the bucket exists *)
  val init : context -> value -> Raw_context.t tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_Error
      Missing_key} if the value does not exists *)
  val set : context -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists *)
  val init_set : context -> value -> Raw_context.t Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> value option -> Raw_context.t Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists *)
  val delete : context -> Raw_context.t tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if
      the bucket does not exists *)
  val remove : context -> Raw_context.t Lwt.t
end

(** Variant of {!Single_data_storage} with gas accounting. *)
module type Single_carbonated_data_storage = sig
  type t

  type context = t

  (** The type of the value *)
  type value

  (** Tells if the data is already defined.
      Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
  val mem : context -> (Raw_context.t * bool) tzresult Lwt.t

  (** Retrieve the value from the storage bucket ; returns a
      {!Storage_error} if the key is not set or if the deserialisation
      fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
  val get : context -> (Raw_context.t * value) tzresult Lwt.t

  (** Retrieves the value from the storage bucket ; returns [None] if
      the data is not initialized, or {!Storage_helpers.Storage_error}
      if the deserialisation fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
      or [Gas_repr.read_bytes_cost Z.zero]. *)
  val get_option : context -> (Raw_context.t * value option) tzresult Lwt.t

  (** Allocates the storage bucket and initializes it ; returns a
      {!Storage_error Missing_key} if the bucket exists.
      Consumes [Gas_repr.write_bytes_cost <size of the value>].
      Returns the size. *)
  val init : context -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Updates the content of the bucket ; returns a {!Storage_Error
      Existing_key} if the value does not exists.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old to the new size. *)
  val set : context -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates the data and initializes it with a value ; just
      updates it if the bucket exists.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val init_set :
    context -> value -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists.
      Consumes the same gas cost as either {!remove} or {!init_set}.
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val set_option :
    context -> value option -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** Delete the storage bucket ; returns a {!Storage_error
      Missing_key} if the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size. *)
  val delete : context -> (Raw_context.t * int) tzresult Lwt.t

  (** Removes the storage bucket and its contents ; does nothing if
      the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size, and a boolean
      indicating if a value was already associated to this key. *)
  val remove : context -> (Raw_context.t * int * bool) tzresult Lwt.t
end

(** Restricted version of {!Indexed_data_storage} w/o iterators. *)
module type Non_iterable_indexed_data_storage = sig
  type t

  type context = t

  (** An abstract type for keys *)
  type key

  (** The type of values *)
  type value

  (** Tells if a given key is already bound to a storage bucket *)
  val mem : context -> key -> bool Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns {!Storage_error Missing_key} if the key is not set ;
      returns {!Storage_error Corrupted_data} if the deserialisation
      fails. *)
  val get : context -> key -> value tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns [None] if the value is not set ; returns {!Storage_error
      Corrupted_data} if the deserialisation fails. *)
  val get_option : context -> key -> value option tzresult Lwt.t

  (** Updates the content of a bucket ; returns A {!Storage_Error
      Missing_key} if the value does not exists. *)
  val set : context -> key -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it ;
      returns a {!Storage_error Existing_key} if the bucket exists. *)
  val init : context -> key -> value -> Raw_context.t tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it
      with a value ; just updates it if the bucket exists. *)
  val init_set : context -> key -> value -> Raw_context.t Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists. *)
  val set_option : context -> key -> value option -> Raw_context.t Lwt.t

  (** Delete a storage bucket and its contents ; returns a
      {!Storage_error Missing_key} if the bucket does not exists. *)
  val delete : context -> key -> Raw_context.t tzresult Lwt.t

  (** Removes a storage bucket and its contents ; does nothing if the
      bucket does not exists. *)
  val remove : context -> key -> Raw_context.t Lwt.t
end

(** Variant of {!Non_iterable_indexed_data_storage} with gas accounting. *)
module type Non_iterable_indexed_carbonated_data_storage = sig
  type t

  type context = t

  (** An abstract type for keys *)
  type key

  (** The type of values *)
  type value

  (** Tells if a given key is already bound to a storage bucket.
      Consumes [Gas_repr.read_bytes_cost Z.zero]. *)
  val mem : context -> key -> (Raw_context.t * bool) tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns {!Storage_error Missing_key} if the key is not set ;
      returns {!Storage_error Corrupted_data} if the deserialisation
      fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>]. *)
  val get : context -> key -> (Raw_context.t * value) tzresult Lwt.t

  (** Retrieve a value from the storage bucket at a given key ;
      returns [None] if the value is not set ; returns {!Storage_error
      Corrupted_data} if the deserialisation fails.
      Consumes [Gas_repr.read_bytes_cost <size of the value>] if present
      or [Gas_repr.read_bytes_cost Z.zero]. *)
  val get_option :
    context -> key -> (Raw_context.t * value option) tzresult Lwt.t

  (** Updates the content of a bucket ; returns A {!Storage_Error
      Missing_key} if the value does not exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old to the new size. *)
  val set : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it ;
      returns a {!Storage_error Existing_key} if the bucket exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the value>].
      Returns the size. *)
  val init : context -> key -> value -> (Raw_context.t * int) tzresult Lwt.t

  (** Allocates a storage bucket at the given key and initializes it
      with a value ; just updates it if the bucket exists.
      Consumes serialization cost.
      Consumes [Gas_repr.write_bytes_cost <size of the new value>].
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val init_set :
    context -> key -> value -> (Raw_context.t * int * bool) tzresult Lwt.t

  (** When the value is [Some v], allocates the data and initializes
      it with [v] ; just updates it if the bucket exists. When the
      valus is [None], delete the storage bucket when the value ; does
      nothing if the bucket does not exists.
      Consumes serialization cost.
      Consumes the same gas cost as either {!remove} or {!init_set}.
      Returns the difference from the old (maybe 0) to the new size, and a boolean
      indicating if a value was already associated to this key. *)
  val set_option :
    context ->
    key ->
    value option ->
    (Raw_context.t * int * bool) tzresult Lwt.t

  (** Delete a storage bucket and its contents ; returns a
      {!Storage_error Missing_key} if the bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size. *)
  val delete : context -> key -> (Raw_context.t * int) tzresult Lwt.t

  (** Removes a storage bucket and its contents ; does nothing if the
      bucket does not exists.
      Consumes [Gas_repr.write_bytes_cost Z.zero].
      Returns the freed size, and a boolean
      indicating if a value was already associated to this key. *)
  val remove : context -> key -> (Raw_context.t * int * bool) tzresult Lwt.t
end

(** The generic signature of indexed data accessors (a set of values
    of the same type indexed by keys of the same form in the
    hierarchical (key x value) database). *)
module type Indexed_data_storage = sig
  include Non_iterable_indexed_data_storage

  (** Empties all the keys and associated data. *)
  val clear : context -> Raw_context.t Lwt.t

  (** Lists all the keys. *)
  val keys : context -> key list Lwt.t

  (** Lists all the keys and associated data. *)
  val bindings : context -> (key * value) list Lwt.t

  (** Iterates over all the keys and associated data. *)
  val fold :
    context -> init:'a -> f:(key -> value -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Iterate over all the keys. *)
  val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t
end

module type Indexed_data_snapshotable_storage = sig
  type snapshot

  type key

  include Indexed_data_storage with type key := key

  module Snapshot :
    Indexed_data_storage
      with type key = snapshot * key
       and type value = value
       and type t = t

  val snapshot_exists : context -> snapshot -> bool Lwt.t

  val snapshot : context -> snapshot -> Raw_context.t tzresult Lwt.t

  val delete_snapshot : context -> snapshot -> Raw_context.t Lwt.t
end

(** The generic signature of a data set accessor (a set of values
    bound to a specific key prefix in the hierarchical (key x value)
    database). *)
module type Data_set_storage = sig
  type t

  type context = t

  (** The type of elements. *)
  type elt

  (** Tells if a elt is a member of the set *)
  val mem : context -> elt -> bool Lwt.t

  (** Adds a elt is a member of the set *)
  val add : context -> elt -> Raw_context.t Lwt.t

  (** Removes a elt of the set ; does nothing if not a member *)
  val del : context -> elt -> Raw_context.t Lwt.t

  (** Adds/Removes a elt of the set *)
  val set : context -> elt -> bool -> Raw_context.t Lwt.t

  (** Returns the elements of the set, deserialized in a list in no
      particular order. *)
  val elements : context -> elt list Lwt.t

  (** Iterates over the elements of the set. *)
  val fold : context -> init:'a -> f:(elt -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  (** Removes all elements in the set *)
  val clear : context -> Raw_context.t Lwt.t
end

module type NAME = sig
  val name : Raw_context.key
end

module type VALUE = sig
  type t

  val encoding : t Data_encoding.t
end

module type REGISTER = sig
  val ghost : bool
end

module type Indexed_raw_context = sig
  type t

  type context = t

  type key

  type 'a ipath

  val clear : context -> Raw_context.t Lwt.t

  val fold_keys : context -> init:'a -> f:(key -> 'a -> 'a Lwt.t) -> 'a Lwt.t

  val keys : context -> key list Lwt.t

  val resolve : context -> string list -> key list Lwt.t

  val remove_rec : context -> key -> context Lwt.t

  val copy : context -> from:key -> to_:key -> context tzresult Lwt.t

  module Make_set (R : REGISTER) (N : NAME) :
    Data_set_storage with type t = t and type elt = key

  module Make_map (N : NAME) (V : VALUE) :
    Indexed_data_storage
      with type t = t
       and type key = key
       and type value = V.t

  module Make_carbonated_map (N : NAME) (V : VALUE) :
    Non_iterable_indexed_carbonated_data_storage
      with type t = t
       and type key = key
       and type value = V.t

  module Raw_context : Raw_context.T with type t = t ipath
end
src/proto_alpha/lib_protocol/storage_sigs.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Single_data_storage.
  Record signature {t value : Type} := {
    t := t;
    context := t;
    value := value;
    mem : context -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    get : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          value);
    get_option : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (option value));
    init : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    init_set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    set_option : context ->
      (option value) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    delete : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t);
    remove : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Single_data_storage.

Module Single_carbonated_data_storage.
  Record signature {t value : Type} := {
    t := t;
    context := t;
    value := value;
    mem : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * bool));
    get : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * value));
    get_option : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * (option value)));
    init : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    init_set : context ->
      value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    set_option : context ->
      (option value) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    delete : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    remove : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
  }.
  Arguments signature : clear implicits.
End Single_carbonated_data_storage.

Module Non_iterable_indexed_data_storage.
  Record signature {t key value : Type} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    get : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            value);
    get_option : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (option value));
    set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Tezos_raw_protocol_alpha.Raw_context.t);
    init : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              Tezos_raw_protocol_alpha.Raw_context.t);
    init_set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            Tezos_raw_protocol_alpha.Raw_context.t;
    set_option : context ->
      key ->
        (option value) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            Tezos_raw_protocol_alpha.Raw_context.t;
    delete : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    remove : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Non_iterable_indexed_data_storage.

Module Non_iterable_indexed_carbonated_data_storage.
  Record signature {t key value : Type} := {
    t := t;
    context := t;
    key := key;
    value := value;
    mem : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * bool));
    get : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * value));
    get_option : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * (option value)));
    set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    init : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    init_set : context ->
      key ->
        value ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    set_option : context ->
      key ->
        (option value) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
    delete : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z));
    remove : context ->
      key ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            (Tezos_raw_protocol_alpha.Raw_context.t * Z * bool));
  }.
  Arguments signature : clear implicits.
End Non_iterable_indexed_carbonated_data_storage.

Module Indexed_data_storage.
  Record signature {t key value : Type} := {
    include;
    clear : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
    keys : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    bindings : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list (key * value));
    fold : forall {a : Type}, context ->
      a ->
        (key ->
          value -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a)
          -> Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    fold_keys : forall {a : Type}, context ->
      a ->
        (key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t a;
  }.
  Arguments signature : clear implicits.
End Indexed_data_storage.

Module Indexed_data_snapshotable_storage.
  Record signature {snapshot key t value : Type} := {
    snapshot := snapshot;
    key := key;
    include;
    Snapshot : Indexed_data_storage.signature t (snapshot * key) value;
    snapshot_exists : context ->
      snapshot -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    snapshot : context ->
      snapshot ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t);
    delete_snapshot : context ->
      snapshot ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Indexed_data_snapshotable_storage.

Module Data_set_storage.
  Record signature {t elt : Type} := {
    t := t;
    context := t;
    elt := elt;
    mem : context ->
      elt -> Tezos_protocol_environment_alpha__Environment.Lwt.t bool;
    add : context ->
      elt ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    del : context ->
      elt ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          Tezos_raw_protocol_alpha.Raw_context.t;
    set : context ->
      elt ->
        bool ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            Tezos_raw_protocol_alpha.Raw_context.t;
    elements : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list elt);
    fold : forall {a : Type}, context ->
      a ->
        (elt -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    clear : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
  }.
  Arguments signature : clear implicits.
End Data_set_storage.

Module NAME.
  Record signature := {
    name : Tezos_raw_protocol_alpha.Raw_context.key;
  }.
End NAME.

Module VALUE.
  Record signature {t : Type} := {
    t := t;
    encoding : Tezos_protocol_environment_alpha__Environment.Data_encoding.t t;
  }.
  Arguments signature : clear implicits.
End VALUE.

Module REGISTER.
  Record signature := {
    ghost : bool;
  }.
End REGISTER.

Module Indexed_raw_context.
  Record signature {t key ipath : Type} := {
    t := t;
    context := t;
    key := key;
    polymorphic_abstract_type;
    clear : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        Tezos_raw_protocol_alpha.Raw_context.t;
    fold_keys : forall {a : Type}, context ->
      a ->
        (key -> a -> Tezos_protocol_environment_alpha__Environment.Lwt.t a) ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t a;
    keys : context ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    resolve : context ->
      (list string) ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t (list key);
    remove_rec : context ->
      key -> Tezos_protocol_environment_alpha__Environment.Lwt.t context;
    copy : context ->
      key ->
        key ->
          Tezos_protocol_environment_alpha__Environment.Lwt.t
            (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
              context);
    Make_set : functor;
    Make_map : functor;
    Make_carbonated_map : functor;
    Raw_context : Raw_context.T.signature (ipath t);
  }.
  Arguments signature : clear implicits.
End Indexed_raw_context.

src/proto_alpha/lib_protocol/test/activation.ml 132 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** The activation operation creates an implicit contract from a
    registered commitment present in the context. It is parametrized by
    a public key hash (pkh) and a secret.

    The commitments are composed of :
    - a blinded pkh that can be revealed by the secret ;
    - an amount.

    The commitments and the secrets are generated from
    /scripts/create_genesis/create_genenis.py and should be coherent.
*)

open Protocol
open Alpha_context
open Test_utils
open Test_tez

(* Generated commitments and secrets  *)

(* Commitments are hard-coded in {Tezos_proto_alpha_parameters.Default_parameters} *)

(* let commitments =
 *   List.map (fun (bpkh, a) ->
 *       Commitment_repr.{
 *         blinded_public_key_hash=Blinded_public_key_hash.of_b58check_exn bpkh ;
 *         amount = Tez_repr.of_mutez_exn (Int64.of_string a)}
 *     )
 *     [ ( "btz1bRL4X5BWo2Fj4EsBdUwexXqgTf75uf1qa", "23932454669343" ) ;
 *       ( "btz1SxjV1syBgftgKy721czKi3arVkVwYUFSv", "72954577464032" ) ;
 *       ( "btz1LtoNCjiW23txBTenALaf5H6NKF1L3c1gw", "217487035428349" ) ;
 *       ( "btz1SUd3mMhEBcWudrn8u361MVAec4WYCcFoy", "4092742372031" ) ;
 *       ( "btz1MvBXf4orko1tsGmzkjLbpYSgnwUjEe81r", "17590039016550" ) ;
 *       ( "btz1LoDZ3zsjgG3k3cqTpUMc9bsXbchu9qMXT", "26322312350555" ) ;
 *       ( "btz1RMfq456hFV5AeDiZcQuZhoMv2dMpb9hpP", "244951387881443" ) ;
 *       ( "btz1Y9roTh4A7PsMBkp8AgdVFrqUDNaBE59y1", "80065050465525" ) ;
 *       ( "btz1Q1N2ePwhVw5ED3aaRVek6EBzYs1GDkSVD", "3569618927693" ) ;
 *       ( "btz1VFFVsVMYHd5WfaDTAt92BeQYGK8Ri4eLy", "9034781424478" ) ;
 *     ] *)

type secret_account = {
  account : public_key_hash;
  activation_code : Blinded_public_key_hash.activation_code;
  amount : Tez.t;
}

let secrets () =
  (* Exported from proto_alpha client - TODO : remove when relocated to lib_crypto *)
  let read_key mnemonic email password =
    match Bip39.of_words mnemonic with
    | None ->
        assert false
    | Some t ->
        (* TODO: unicode normalization (NFKD)... *)
        let passphrase =
          Bigstring.(concat "" [of_string email; of_string password])
        in
        let sk = Bip39.to_seed ~passphrase t in
        let sk = Bigstring.sub_bytes sk 0 32 in
        let sk : Signature.Secret_key.t =
          Ed25519
            (Data_encoding.Binary.of_bytes_exn Ed25519.Secret_key.encoding sk)
        in
        let pk = Signature.Secret_key.to_public_key sk in
        let pkh = Signature.Public_key.hash pk in
        (pkh, pk, sk)
  in
  List.map
    (fun (mnemonic, secret, amount, pkh, password, email) ->
      let (pkh', pk, sk) = read_key mnemonic email password in
      let pkh = Signature.Public_key_hash.of_b58check_exn pkh in
      assert (Signature.Public_key_hash.equal pkh pkh') ;
      let account = Account.{pkh; pk; sk} in
      Account.add_account account ;
      {
        account = account.pkh;
        activation_code = Blinded_public_key_hash.activation_code_of_hex secret;
        amount =
          Option.unopt_exn
            (Invalid_argument "tez conversion")
            (Tez.of_mutez (Int64.of_string amount));
      })
    [ ( [ "envelope";
          "hospital";
          "mind";
          "sunset";
          "cancel";
          "muscle";
          "leisure";
          "thumb";
          "wine";
          "market";
          "exit";
          "lucky";
          "style";
          "picnic";
          "success" ],
        "0f39ed0b656509c2ecec4771712d9cddefe2afac",
        "23932454669343",
        "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF",
        "z0eZHQQGKt",
        "cjgfoqmk.wpxnvnup@tezos.example.org" );
      ( [ "flag";
          "quote";
          "will";
          "valley";
          "mouse";
          "chat";
          "hold";
          "prosper";
          "silk";
          "tent";
          "cruel";
          "cause";
          "demise";
          "bottom";
          "practice" ],
        "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4",
        "72954577464032",
        "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX",
        "MHErskWPE6",
        "oklmcktr.ztljnpzc@tezos.example.org" );
      ( [ "library";
          "away";
          "inside";
          "paper";
          "wise";
          "focus";
          "sweet";
          "expose";
          "require";
          "change";
          "stove";
          "planet";
          "zone";
          "reflect";
          "finger" ],
        "411dfef031eeecc506de71c9df9f8e44297cf5ba",
        "217487035428348",
        "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc",
        "0AO6BzQNfN",
        "ctgnkvqm.kvtiybky@tezos.example.org" );
      ( [ "cruel";
          "fluid";
          "damage";
          "demand";
          "mimic";
          "above";
          "village";
          "alpha";
          "vendor";
          "staff";
          "absent";
          "uniform";
          "fire";
          "asthma";
          "milk" ],
        "08d7d355bc3391d12d140780b39717d9f46fcf87",
        "4092742372031",
        "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS",
        "9kbZ7fR6im",
        "bnyxxzqr.tdszcvqb@tezos.example.org" );
      ( [ "opera";
          "divorce";
          "easy";
          "myself";
          "idea";
          "aim";
          "dash";
          "scout";
          "case";
          "resource";
          "vote";
          "humor";
          "ticket";
          "client";
          "edge" ],
        "9b7cad042fba557618bdc4b62837c5f125b50e56",
        "17590039016550",
        "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM",
        "suxT5H09yY",
        "iilkhohu.otnyuvna@tezos.example.org" );
      ( [ "token";
          "similar";
          "ginger";
          "tongue";
          "gun";
          "sort";
          "piano";
          "month";
          "hotel";
          "vote";
          "undo";
          "success";
          "hobby";
          "shell";
          "cart" ],
        "124c0ca217f11ffc6c7b76a743d867c8932e5afd",
        "26322312350555",
        "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU",
        "4odVdLykaa",
        "kwhlglvr.slriitzy@tezos.example.org" );
      ( [ "shield";
          "warrior";
          "gorilla";
          "birth";
          "steak";
          "neither";
          "feel";
          "only";
          "liberty";
          "float";
          "oven";
          "extend";
          "pulse";
          "suffer";
          "vapor" ],
        "ac7a2125beea68caf5266a647f24dce9fea018a7",
        "244951387881443",
        "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur",
        "A6yeMqBFG8",
        "lvrmlbyj.yczltcxn@tezos.example.org" );
      ( [ "waste";
          "open";
          "scan";
          "tip";
          "subway";
          "dance";
          "rent";
          "copper";
          "garlic";
          "laundry";
          "defense";
          "clerk";
          "another";
          "staff";
          "liar" ],
        "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2",
        "80065050465525",
        "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs",
        "oVZqpq60sk",
        "rfodmrha.zzdndvyk@tezos.example.org" );
      ( [ "fiber";
          "next";
          "property";
          "cradle";
          "silk";
          "obey";
          "gossip";
          "push";
          "key";
          "second";
          "across";
          "minimum";
          "nice";
          "boil";
          "age" ],
        "dac31640199f2babc157aadc0021cd71128ca9ea",
        "3569618927693",
        "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX",
        "FfytQTTVbu",
        "owecikdy.gxnyttya@tezos.example.org" );
      ( [ "print";
          "labor";
          "budget";
          "speak";
          "poem";
          "diet";
          "chunk";
          "eternal";
          "book";
          "saddle";
          "pioneer";
          "ankle";
          "happy";
          "only";
          "exclude" ],
        "bb841227f250a066eb8429e56937ad504d7b34dd",
        "9034781424478",
        "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u",
        "zknAl3lrX2",
        "ettilrvh.zsrqrbud@tezos.example.org" ) ]

let activation_init () =
  Context.init ~with_commitments:true 1
  >>=? fun (b, cs) -> secrets () |> fun ss -> return (b, cs, ss)

let simple_init_with_commitments () =
  activation_init ()
  >>=? fun (blk, _contracts, _secrets) ->
  Block.bake blk >>=? fun _ -> return_unit

(** A single activation *)
let single_activation () =
  activation_init ()
  >>=? fun (blk, _contracts, secrets) ->
  let ({account; activation_code; amount = expected_amount; _} as _first_one) =
    List.hd secrets
  in
  (* Contract does not exist *)
  Assert.balance_is
    ~loc:__LOC__
    (B blk)
    (Contract.implicit_contract account)
    Tez.zero
  >>=? fun () ->
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>=? fun blk ->
  (* Contract does exist *)
  Assert.balance_is
    ~loc:__LOC__
    (B blk)
    (Contract.implicit_contract account)
    expected_amount

(** 10 activations, one per bake *)
let multi_activation_1 () =
  activation_init ()
  >>=? fun (blk, _contracts, secrets) ->
  Error_monad.fold_left_s
    (fun blk {account; activation_code; amount = expected_amount; _} ->
      Op.activation (B blk) account activation_code
      >>=? fun operation ->
      Block.bake ~operation blk
      >>=? fun blk ->
      Assert.balance_is
        ~loc:__LOC__
        (B blk)
        (Contract.implicit_contract account)
        expected_amount
      >>=? fun () -> return blk)
    blk
    secrets
  >>=? fun _ -> return_unit

(** All in one bake *)
let multi_activation_2 () =
  activation_init ()
  >>=? fun (blk, _contracts, secrets) ->
  Error_monad.fold_left_s
    (fun ops {account; activation_code; _} ->
      Op.activation (B blk) account activation_code
      >>=? fun op -> return (op :: ops))
    []
    secrets
  >>=? fun ops ->
  Block.bake ~operations:ops blk
  >>=? fun blk ->
  Error_monad.iter_s
    (fun {account; amount = expected_amount; _} ->
      (* Contract does exist *)
      Assert.balance_is
        ~loc:__LOC__
        (B blk)
        (Contract.implicit_contract account)
        expected_amount)
    secrets

(** Transfer with activated account *)
let activation_and_transfer () =
  activation_init ()
  >>=? fun (blk, contracts, secrets) ->
  let ({account; activation_code; _} as _first_one) = List.hd secrets in
  let bootstrap_contract = List.hd contracts in
  let first_contract = Contract.implicit_contract account in
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>=? fun blk ->
  Context.Contract.balance (B blk) bootstrap_contract
  >>=? fun amount ->
  Tez.( /? ) amount 2L
  >>?= fun half_amount ->
  Context.Contract.balance (B blk) first_contract
  >>=? fun activated_amount_before ->
  Op.transaction (B blk) bootstrap_contract first_contract half_amount
  >>=? fun operation ->
  Block.bake ~operation blk
  >>=? fun blk ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B blk)
    (Contract.implicit_contract account)
    activated_amount_before
    half_amount

(** Transfer to an unactivated account and then activating it *)
let transfer_to_unactivated_then_activate () =
  activation_init ()
  >>=? fun (blk, contracts, secrets) ->
  let ({account; activation_code; amount} as _first_one) = List.hd secrets in
  let bootstrap_contract = List.hd contracts in
  let unactivated_commitment_contract = Contract.implicit_contract account in
  Context.Contract.balance (B blk) bootstrap_contract
  >>=? fun b_amount ->
  Tez.( /? ) b_amount 2L
  >>?= fun b_half_amount ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Op.transaction
    (I inc)
    bootstrap_contract
    unactivated_commitment_contract
    b_half_amount
  >>=? fun op ->
  Incremental.add_operation inc op
  >>=? fun inc ->
  Op.activation (I inc) account activation_code
  >>=? fun op' ->
  Incremental.add_operation inc op'
  >>=? fun inc ->
  Incremental.finalize_block inc
  >>=? fun blk2 ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B blk2)
    (Contract.implicit_contract account)
    amount
    b_half_amount

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Invalid pkh activation : expected to fail as the context does not
    contain any commitment *)
let invalid_activation_with_no_commitments () =
  Context.init 1
  >>=? fun (blk, _) ->
  let secrets = secrets () in
  let ({account; activation_code; _} as _first_one) = List.hd secrets in
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Wrong activation : wrong secret given in the operation *)
let invalid_activation_wrong_secret () =
  activation_init ()
  >>=? fun (blk, _, secrets) ->
  let ({account; _} as _first_one) = List.nth secrets 0 in
  let ({activation_code; _} as _second_one) = List.nth secrets 1 in
  Op.activation (B blk) account activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Invalid pkh activation : expected to fail as the context does not
    contain an associated commitment *)
let invalid_activation_inexistent_pkh () =
  activation_init ()
  >>=? fun (blk, _, secrets) ->
  let ({activation_code; _} as _first_one) = List.hd secrets in
  let inexistent_pkh =
    Signature.Public_key_hash.of_b58check_exn
      "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o"
  in
  Op.activation (B blk) inexistent_pkh activation_code
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Invalid pkh activation : expected to fail as the commitment has
    already been claimed *)
let invalid_double_activation () =
  activation_init ()
  >>=? fun (blk, _, secrets) ->
  let ({account; activation_code; _} as _first_one) = List.hd secrets in
  Incremental.begin_construction blk
  >>=? fun inc ->
  Op.activation (I inc) account activation_code
  >>=? fun op ->
  Incremental.add_operation inc op
  >>=? fun inc ->
  Op.activation (I inc) account activation_code
  >>=? fun op' ->
  Incremental.add_operation inc op'
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_activation _ ->
          true
      | _ ->
          false)

(** Transfer from an unactivated commitment account *)
let invalid_transfer_from_unactived_account () =
  activation_init ()
  >>=? fun (blk, contracts, secrets) ->
  let ({account; _} as _first_one) = List.hd secrets in
  let bootstrap_contract = List.hd contracts in
  let unactivated_commitment_contract = Contract.implicit_contract account in
  (* No activation *)
  Op.transaction
    (B blk)
    unactivated_commitment_contract
    bootstrap_contract
    Tez.one
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Empty_implicit_contract pkh ->
          if pkh = account then true else false
      | _ ->
          false)

let tests =
  [ Test.tztest "init with commitments" `Quick simple_init_with_commitments;
    Test.tztest "single activation" `Quick single_activation;
    Test.tztest "multi-activation one-by-one" `Quick multi_activation_1;
    Test.tztest "multi-activation all at a time" `Quick multi_activation_2;
    Test.tztest "activation and transfer" `Quick activation_and_transfer;
    Test.tztest
      "transfer to unactivated account then activate"
      `Quick
      transfer_to_unactivated_then_activate;
    Test.tztest
      "invalid activation with no commitments"
      `Quick
      invalid_activation_with_no_commitments;
    Test.tztest
      "invalid activation with commitments"
      `Quick
      invalid_activation_inexistent_pkh;
    Test.tztest "invalid double activation" `Quick invalid_double_activation;
    Test.tztest "wrong activation code" `Quick invalid_activation_wrong_secret;
    Test.tztest
      "invalid transfer from unactivated account"
      `Quick
      invalid_transfer_from_unactived_account ]
src/proto_alpha/lib_protocol/test/activation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Record secret_account := {
  account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
  activation_code :
    Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code;
  amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t }.

Definition secrets (function_parameter : unit) : list secret_account :=
  let 'tt := function_parameter in
  let read_key {A : Type}
    (mnemonic : list string) (email : string) (password : string)
    : Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
      * A * Stdlib.Bytes.t :=
    match op_startypeminuserrorstar mnemonic with
    | None =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Some t =>
      let passphrase :=
        concat "" % string
          (cons (of_string email) (cons (of_string password) [])) in
      let sk := op_startypeminuserrorstar passphrase t in
      let sk := Bigstring.sub_bytes sk 0 32 in
      let '_ := op_startypeminuserrorstar in
      let pk := op_startypeminuserrorstar sk in
      let pkh := Signature.Public_key.hash pk in
      (pkh, pk, sk)
    end in
  List.map
    (fun function_parameter =>
      let '(mnemonic, secret, amount, pkh, password, email) :=
        function_parameter in
      let '(pkh', pk, sk) := read_key mnemonic email password in
      let pkh := Signature.Public_key_hash.of_b58check_exn pkh in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ :=
        (* ❌ Assert instruction is not handled. *)
        assert (Signature.Public_key_hash.equal pkh pkh') in
      let account := op_startypeminuserrorstar in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := op_startypeminuserrorstar account in
      {| account := pkh account;
        activation_code := Blinded_public_key_hash.activation_code_of_hex secret;
        amount :=
          op_startypeminuserrorstar
            (OCaml.Invalid_argument "tez conversion" % string)
            (Tez.of_mutez (Int64.of_string amount)) |})
    (cons
      ((cons "envelope" % string
        (cons "hospital" % string
          (cons "mind" % string
            (cons "sunset" % string
              (cons "cancel" % string
                (cons "muscle" % string
                  (cons "leisure" % string
                    (cons "thumb" % string
                      (cons "wine" % string
                        (cons "market" % string
                          (cons "exit" % string
                            (cons "lucky" % string
                              (cons "style" % string
                                (cons "picnic" % string
                                  (cons "success" % string []))))))))))))))),
        "0f39ed0b656509c2ecec4771712d9cddefe2afac" % string,
        "23932454669343" % string,
        "tz1MawerETND6bqJqx8GV3YHUrvMBCDasRBF" % string, "z0eZHQQGKt" % string,
        "cjgfoqmk.wpxnvnup@tezos.example.org" % string)
      (cons
        ((cons "flag" % string
          (cons "quote" % string
            (cons "will" % string
              (cons "valley" % string
                (cons "mouse" % string
                  (cons "chat" % string
                    (cons "hold" % string
                      (cons "prosper" % string
                        (cons "silk" % string
                          (cons "tent" % string
                            (cons "cruel" % string
                              (cons "cause" % string
                                (cons "demise" % string
                                  (cons "bottom" % string
                                    (cons "practice" % string []))))))))))))))),
          "41f98b15efc63fa893d61d7d6eee4a2ce9427ac4" % string,
          "72954577464032" % string,
          "tz1X4maqF9tC1Yn4jULjHRAyzjAtc25Z68TX" % string,
          "MHErskWPE6" % string, "oklmcktr.ztljnpzc@tezos.example.org" % string)
        (cons
          ((cons "library" % string
            (cons "away" % string
              (cons "inside" % string
                (cons "paper" % string
                  (cons "wise" % string
                    (cons "focus" % string
                      (cons "sweet" % string
                        (cons "expose" % string
                          (cons "require" % string
                            (cons "change" % string
                              (cons "stove" % string
                                (cons "planet" % string
                                  (cons "zone" % string
                                    (cons "reflect" % string
                                      (cons "finger" % string []))))))))))))))),
            "411dfef031eeecc506de71c9df9f8e44297cf5ba" % string,
            "217487035428348" % string,
            "tz1SWBY7rWMutEuWS54Pt33MkzAS6eWkUuTc" % string,
            "0AO6BzQNfN" % string,
            "ctgnkvqm.kvtiybky@tezos.example.org" % string)
          (cons
            ((cons "cruel" % string
              (cons "fluid" % string
                (cons "damage" % string
                  (cons "demand" % string
                    (cons "mimic" % string
                      (cons "above" % string
                        (cons "village" % string
                          (cons "alpha" % string
                            (cons "vendor" % string
                              (cons "staff" % string
                                (cons "absent" % string
                                  (cons "uniform" % string
                                    (cons "fire" % string
                                      (cons "asthma" % string
                                        (cons "milk" % string []))))))))))))))),
              "08d7d355bc3391d12d140780b39717d9f46fcf87" % string,
              "4092742372031" % string,
              "tz1amUjiZaevaxQy5wKn4SSRvVoERCip3nZS" % string,
              "9kbZ7fR6im" % string,
              "bnyxxzqr.tdszcvqb@tezos.example.org" % string)
            (cons
              ((cons "opera" % string
                (cons "divorce" % string
                  (cons "easy" % string
                    (cons "myself" % string
                      (cons "idea" % string
                        (cons "aim" % string
                          (cons "dash" % string
                            (cons "scout" % string
                              (cons "case" % string
                                (cons "resource" % string
                                  (cons "vote" % string
                                    (cons "humor" % string
                                      (cons "ticket" % string
                                        (cons "client" % string
                                          (cons "edge" % string []))))))))))))))),
                "9b7cad042fba557618bdc4b62837c5f125b50e56" % string,
                "17590039016550" % string,
                "tz1Zaee3QBtD4ErY1SzqUvyYTrENrExu6yQM" % string,
                "suxT5H09yY" % string,
                "iilkhohu.otnyuvna@tezos.example.org" % string)
              (cons
                ((cons "token" % string
                  (cons "similar" % string
                    (cons "ginger" % string
                      (cons "tongue" % string
                        (cons "gun" % string
                          (cons "sort" % string
                            (cons "piano" % string
                              (cons "month" % string
                                (cons "hotel" % string
                                  (cons "vote" % string
                                    (cons "undo" % string
                                      (cons "success" % string
                                        (cons "hobby" % string
                                          (cons "shell" % string
                                            (cons "cart" % string []))))))))))))))),
                  "124c0ca217f11ffc6c7b76a743d867c8932e5afd" % string,
                  "26322312350555" % string,
                  "tz1geDUUhfXK1EMj7VQdRjug1MoFe6gHWnCU" % string,
                  "4odVdLykaa" % string,
                  "kwhlglvr.slriitzy@tezos.example.org" % string)
                (cons
                  ((cons "shield" % string
                    (cons "warrior" % string
                      (cons "gorilla" % string
                        (cons "birth" % string
                          (cons "steak" % string
                            (cons "neither" % string
                              (cons "feel" % string
                                (cons "only" % string
                                  (cons "liberty" % string
                                    (cons "float" % string
                                      (cons "oven" % string
                                        (cons "extend" % string
                                          (cons "pulse" % string
                                            (cons "suffer" % string
                                              (cons "vapor" % string []))))))))))))))),
                    "ac7a2125beea68caf5266a647f24dce9fea018a7" % string,
                    "244951387881443" % string,
                    "tz1h3nY7jcZciJgAwRhWcrEwqfVp7VQoffur" % string,
                    "A6yeMqBFG8" % string,
                    "lvrmlbyj.yczltcxn@tezos.example.org" % string)
                  (cons
                    ((cons "waste" % string
                      (cons "open" % string
                        (cons "scan" % string
                          (cons "tip" % string
                            (cons "subway" % string
                              (cons "dance" % string
                                (cons "rent" % string
                                  (cons "copper" % string
                                    (cons "garlic" % string
                                      (cons "laundry" % string
                                        (cons "defense" % string
                                          (cons "clerk" % string
                                            (cons "another" % string
                                              (cons "staff" % string
                                                (cons "liar" % string []))))))))))))))),
                      "2b3e94be133a960fa0ef87f6c0922c19f9d87ca2" % string,
                      "80065050465525" % string,
                      "tz1VzL4Xrb3fL3ckvqCWy6bdGMzU2w9eoRqs" % string,
                      "oVZqpq60sk" % string,
                      "rfodmrha.zzdndvyk@tezos.example.org" % string)
                    (cons
                      ((cons "fiber" % string
                        (cons "next" % string
                          (cons "property" % string
                            (cons "cradle" % string
                              (cons "silk" % string
                                (cons "obey" % string
                                  (cons "gossip" % string
                                    (cons "push" % string
                                      (cons "key" % string
                                        (cons "second" % string
                                          (cons "across" % string
                                            (cons "minimum" % string
                                              (cons "nice" % string
                                                (cons "boil" % string
                                                  (cons "age" % string []))))))))))))))),
                        "dac31640199f2babc157aadc0021cd71128ca9ea" % string,
                        "3569618927693" % string,
                        "tz1RUHg536oRKhPLFfttcB5gSWAhh4E9TWjX" % string,
                        "FfytQTTVbu" % string,
                        "owecikdy.gxnyttya@tezos.example.org" % string)
                      (cons
                        ((cons "print" % string
                          (cons "labor" % string
                            (cons "budget" % string
                              (cons "speak" % string
                                (cons "poem" % string
                                  (cons "diet" % string
                                    (cons "chunk" % string
                                      (cons "eternal" % string
                                        (cons "book" % string
                                          (cons "saddle" % string
                                            (cons "pioneer" % string
                                              (cons "ankle" % string
                                                (cons "happy" % string
                                                  (cons "only" % string
                                                    (cons "exclude" % string []))))))))))))))),
                          "bb841227f250a066eb8429e56937ad504d7b34dd" % string,
                          "9034781424478" % string,
                          "tz1M1LFbgctcPWxstrao9aLr2ECW1fV4pH5u" % string,
                          "zknAl3lrX2" % string,
                          "ettilrvh.zsrqrbud@tezos.example.org" % string) [])))))))))).

Definition activation_init {A B : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A * B * (list secret_account))) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar true 1)
    (fun function_parameter =>
      let '(b, cs) := function_parameter in
      op_pipegt (secrets tt) (fun ss => _return (b, cs, ss))).

Definition simple_init_with_commitments (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _contracts, _secrets) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar blk)
        (fun function_parameter =>
          let '_ := function_parameter in
          return_unit)).

Definition single_activation {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _contracts, secrets) := function_parameter in
      let
        '{|
          account := account;
            activation_code := activation_code;
            amount := expected_amount
            |} as _first_one := List.hd secrets in
      op_gtgteqquestion
        (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
          (Contract.implicit_contract account) Tez.zero)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar account
              activation_code)
            (fun operation =>
              op_gtgteqquestion (op_startypeminuserrorstar operation blk)
                (fun blk =>
                  op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                    (Contract.implicit_contract account) expected_amount)))).

Definition multi_activation_1 (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _contracts, secrets) := function_parameter in
      op_gtgteqquestion
        (Error_monad.fold_left_s
          (fun blk =>
            fun function_parameter =>
              let '{|
                account := account;
                  activation_code := activation_code;
                  amount := expected_amount
                  |} := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar account
                  activation_code)
                (fun operation =>
                  op_gtgteqquestion (op_startypeminuserrorstar operation blk)
                    (fun blk =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar __LOC__
                          op_startypeminuserrorstar
                          (Contract.implicit_contract account) expected_amount)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          _return blk)))) blk secrets)
        (fun function_parameter =>
          let '_ := function_parameter in
          return_unit)).

Definition multi_activation_2 (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _contracts, secrets) := function_parameter in
      op_gtgteqquestion
        (Error_monad.fold_left_s
          (fun ops =>
            fun function_parameter =>
              let '{|
                account := account; activation_code := activation_code |} :=
                function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar account
                  activation_code) (fun op => _return (cons op ops))) [] secrets)
        (fun ops =>
          op_gtgteqquestion (op_startypeminuserrorstar ops blk)
            (fun blk =>
              Error_monad.iter_s
                (fun function_parameter =>
                  let '{| account := account; amount := expected_amount |} :=
                    function_parameter in
                  op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                    (Contract.implicit_contract account) expected_amount)
                secrets))).

Definition activation_and_transfer {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, contracts, secrets) := function_parameter in
      let
        '{| account := account; activation_code := activation_code |} as
          _first_one := List.hd secrets in
      let bootstrap_contract := List.hd contracts in
      let first_contract := Contract.implicit_contract account in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar account
          activation_code)
        (fun operation =>
          op_gtgteqquestion (op_startypeminuserrorstar operation blk)
            (fun blk =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  bootstrap_contract)
                (fun amount =>
                  op_startypeminuserrorstar
                    (Tez.op_divquestion amount
                      (* ❌ Constant of type int64 is converted to int *)
                      2)
                    (fun half_amount =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          first_contract)
                        (fun activated_amount_before =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              bootstrap_contract first_contract half_amount)
                            (fun operation =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar operation blk)
                                (fun blk =>
                                  op_startypeminuserrorstar __LOC__
                                    op_startypeminuserrorstar
                                    (Contract.implicit_contract account)
                                    activated_amount_before half_amount)))))))).

Definition transfer_to_unactivated_then_activate {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, contracts, secrets) := function_parameter in
      let
        '{|
          account := account;
            activation_code := activation_code;
            amount := amount
            |} as _first_one := List.hd secrets in
      let bootstrap_contract := List.hd contracts in
      let unactivated_commitment_contract := Contract.implicit_contract account
        in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap_contract)
        (fun b_amount =>
          op_startypeminuserrorstar
            (Tez.op_divquestion b_amount
              (* ❌ Constant of type int64 is converted to int *)
              2)
            (fun b_half_amount =>
              op_gtgteqquestion (op_startypeminuserrorstar blk)
                (fun inc =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      bootstrap_contract unactivated_commitment_contract
                      b_half_amount)
                    (fun op =>
                      op_gtgteqquestion (op_startypeminuserrorstar inc op)
                        (fun inc =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              account activation_code)
                            (fun op' =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar inc op')
                                (fun inc =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar inc)
                                    (fun blk2 =>
                                      op_startypeminuserrorstar __LOC__
                                        op_startypeminuserrorstar
                                        (Contract.implicit_contract account)
                                        amount b_half_amount))))))))).

Definition invalid_activation_with_no_commitments {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(blk, _) := function_parameter in
      let secrets := secrets tt in
      let
        '{| account := account; activation_code := activation_code |} as
          _first_one := List.hd secrets in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar account
          activation_code)
        (fun operation =>
          op_gtgteq (op_startypeminuserrorstar operation blk)
            (fun res =>
              op_startypeminuserrorstar __LOC__ res
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
                      _ => true
                  | _ => false
                  end)))).

Definition invalid_activation_wrong_secret {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _, secrets) := function_parameter in
      let '{| account := account |} as _first_one :=
        op_startypeminuserrorstar secrets 0 in
      let '{| activation_code := activation_code |} as _second_one :=
        op_startypeminuserrorstar secrets 1 in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar account
          activation_code)
        (fun operation =>
          op_gtgteq (op_startypeminuserrorstar operation blk)
            (fun res =>
              op_startypeminuserrorstar __LOC__ res
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
                      _ => true
                  | _ => false
                  end)))).

Definition invalid_activation_inexistent_pkh {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _, secrets) := function_parameter in
      let '{| activation_code := activation_code |} as _first_one :=
        List.hd secrets in
      let inexistent_pkh :=
        Signature.Public_key_hash.of_b58check_exn
          "tz1PeQHGKPWSpNoozvxgqLN9TFsj6rDqNV3o" % string in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar inexistent_pkh
          activation_code)
        (fun operation =>
          op_gtgteq (op_startypeminuserrorstar operation blk)
            (fun res =>
              op_startypeminuserrorstar __LOC__ res
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
                      _ => true
                  | _ => false
                  end)))).

Definition invalid_double_activation {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, _, secrets) := function_parameter in
      let
        '{| account := account; activation_code := activation_code |} as
          _first_one := List.hd secrets in
      op_gtgteqquestion (op_startypeminuserrorstar blk)
        (fun inc =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar account
              activation_code)
            (fun op =>
              op_gtgteqquestion (op_startypeminuserrorstar inc op)
                (fun inc =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar account
                      activation_code)
                    (fun op' =>
                      op_gtgteq (op_startypeminuserrorstar inc op')
                        (fun res =>
                          op_startypeminuserrorstar __LOC__ res
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_activation
                                  _ => true
                              | _ => false
                              end))))))).

Definition invalid_transfer_from_unactived_account {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (activation_init tt)
    (fun function_parameter =>
      let '(blk, contracts, secrets) := function_parameter in
      let '{| account := account |} as _first_one := List.hd secrets in
      let bootstrap_contract := List.hd contracts in
      let unactivated_commitment_contract := Contract.implicit_contract account
        in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar
          unactivated_commitment_contract bootstrap_contract Tez.one)
        (fun operation =>
          op_gtgteq (op_startypeminuserrorstar operation blk)
            (fun res =>
              op_startypeminuserrorstar __LOC__ res
                (fun function_parameter =>
                  match function_parameter with
                  |
                    Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
                      pkh =>
                    if op_startypeminuserrorstar pkh account then
                      true
                    else
                      false
                  | _ => false
                  end)))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "init with commitments" % string
      (* ❌ Variants not supported *)
      variant simple_init_with_commitments)
    (cons
      (op_startypeminuserrorstar "single activation" % string
        (* ❌ Variants not supported *)
        variant single_activation)
      (cons
        (op_startypeminuserrorstar "multi-activation one-by-one" % string
          (* ❌ Variants not supported *)
          variant multi_activation_1)
        (cons
          (op_startypeminuserrorstar "multi-activation all at a time" % string
            (* ❌ Variants not supported *)
            variant multi_activation_2)
          (cons
            (op_startypeminuserrorstar "activation and transfer" % string
              (* ❌ Variants not supported *)
              variant activation_and_transfer)
            (cons
              (op_startypeminuserrorstar
                "transfer to unactivated account then activate" % string
                (* ❌ Variants not supported *)
                variant transfer_to_unactivated_then_activate)
              (cons
                (op_startypeminuserrorstar
                  "invalid activation with no commitments" % string
                  (* ❌ Variants not supported *)
                  variant invalid_activation_with_no_commitments)
                (cons
                  (op_startypeminuserrorstar
                    "invalid activation with commitments" % string
                    (* ❌ Variants not supported *)
                    variant invalid_activation_inexistent_pkh)
                  (cons
                    (op_startypeminuserrorstar
                      "invalid double activation" % string
                      (* ❌ Variants not supported *)
                      variant invalid_double_activation)
                    (cons
                      (op_startypeminuserrorstar
                        "wrong activation code" % string
                        (* ❌ Variants not supported *)
                        variant invalid_activation_wrong_secret)
                      (cons
                        (op_startypeminuserrorstar
                          "invalid transfer from unactivated account" % string
                          (* ❌ Variants not supported *)
                          variant invalid_transfer_from_unactived_account) [])))))))))).

src/proto_alpha/lib_protocol/test/baking.ml 54 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_utils

(** Tests for [bake_n] and [bake_until_end_cycle]. *)
let test_cycle () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun csts ->
  let blocks_per_cycle = csts.parametric.blocks_per_cycle in
  let pp fmt x = Format.fprintf fmt "%ld" x in
  (* Tests that [bake_until_cycle_end] returns a block at
     level [blocks_per_cycle]. *)
  Block.bake b
  >>=? fun b ->
  Block.bake_until_cycle_end b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun curr_level ->
  Assert.equal
    ~loc:__LOC__
    Int32.equal
    "not the right level"
    pp
    (Alpha_context.Raw_level.to_int32 curr_level)
    blocks_per_cycle
  >>=? fun () ->
  (* Tests that [bake_n n] bakes [n] blocks. *)
  Context.get_level (B b)
  >>=? fun l ->
  Block.bake_n 10 b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun curr_level ->
  Assert.equal
    ~loc:__LOC__
    Int32.equal
    "not the right level"
    pp
    (Alpha_context.Raw_level.to_int32 curr_level)
    (Int32.add (Alpha_context.Raw_level.to_int32 l) 10l)

(** Tests the formula introduced in Emmy+ for block reward:
    (16/(p+1)) * (0.8 + 0.2 * e / 32)
    where p is the block priority and
    e is the number of included endorsements *)
let test_block_reward priority () =
  ( match priority with
  | 0 ->
      Test_tez.Tez.(of_int 128 /? Int64.of_int 10)
      >>?= fun min -> return (Test_tez.Tez.of_int 16, min)
  | 1 ->
      Test_tez.Tez.(of_int 64 /? Int64.of_int 10)
      >>?= fun min -> return (Test_tez.Tez.of_int 8, min)
  | 3 ->
      Test_tez.Tez.(of_int 32 /? Int64.of_int 10)
      >>?= fun min -> return (Test_tez.Tez.of_int 4, min)
  | _ ->
      fail (invalid_arg "prio should be 0, 1, or 3") )
  >>=? fun (expected_reward_max_endo, expected_reward_min_endo) ->
  let endorsers_per_block = 32 in
  Context.init ~endorsers_per_block 32
  >>=? fun (b, _) ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  fold_left_s
    (fun ops (endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
      let delegate = endorser.delegate in
      Op.endorsement ~delegate (B b) ()
      >>=? fun op -> return (Operation.pack op :: ops))
    []
    endorsers
  >>=? fun ops ->
  Block.bake ~policy:(By_priority 0) ~operations:ops b
  >>=? fun b ->
  (* bake a block at priority 0 and 32 endorsements;
     the reward is 16 tez *)
  Context.get_baking_reward (B b) ~priority ~endorsing_power:32
  >>=? fun baking_reward ->
  Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_max_endo
  >>=? fun () ->
  (* bake a block at priority 0 and 0 endorsements;
     the reward is 12.8 tez *)
  Context.get_baking_reward (B b) ~priority ~endorsing_power:0
  >>=? fun baking_reward ->
  Assert.equal_tez ~loc:__LOC__ baking_reward expected_reward_min_endo

let tests =
  [ Test.tztest "cycle" `Quick test_cycle;
    Test.tztest "block_reward for priority 0" `Quick (test_block_reward 0);
    Test.tztest "block_reward for priority 1" `Quick (test_block_reward 1);
    Test.tztest "block_reward for priority 3" `Quick (test_block_reward 3) ]
src/proto_alpha/lib_protocol/test/baking.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition test_cycle {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun csts =>
          let blocks_per_cycle := blocks_per_cycle (parametric csts) in
          let pp
            (fmt :
            Tezos_protocol_environment_alpha__Environment.Format.formatter) (x :
            int32) : unit :=
            Format.fprintf fmt
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
                "%ld" % string) x in
          op_gtgteqquestion (op_startypeminuserrorstar b)
            (fun b =>
              op_gtgteqquestion (op_startypeminuserrorstar b)
                (fun b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar)
                    (fun curr_level =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar __LOC__ Int32.equal
                          "not the right level" % string pp
                          (Alpha_context.Raw_level.to_int32 curr_level)
                          blocks_per_cycle)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar)
                            (fun l =>
                              op_gtgteqquestion (op_startypeminuserrorstar 10 b)
                                (fun b =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar)
                                    (fun curr_level =>
                                      op_startypeminuserrorstar __LOC__
                                        Int32.equal
                                        "not the right level" % string pp
                                        (Alpha_context.Raw_level.to_int32
                                          curr_level)
                                        (Int32.add
                                          (Alpha_context.Raw_level.to_int32 l)
                                          (* ❌ Constant of type int32 is converted to int *)
                                          10)))))))))).

Definition test_block_reward {A : Type}
  (priority : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    match priority with
    | 0 =>
      op_startypeminuserrorstar op_startypeminuserrorstar
        (fun min => _return ((op_startypeminuserrorstar 16), min))
    | 1 =>
      op_startypeminuserrorstar op_startypeminuserrorstar
        (fun min => _return ((op_startypeminuserrorstar 8), min))
    | 3 =>
      op_startypeminuserrorstar op_startypeminuserrorstar
        (fun min => _return ((op_startypeminuserrorstar 4), min))
    | _ => fail (invalid_arg "prio should be 0, 1, or 3" % string)
    end
    (fun function_parameter =>
      let '(expected_reward_max_endo, expected_reward_min_endo) :=
        function_parameter in
      let endorsers_per_block := 32 in
      op_gtgteqquestion (op_startypeminuserrorstar endorsers_per_block 32)
        (fun function_parameter =>
          let '(b, _) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun endorsers =>
              op_gtgteqquestion
                (fold_left_s
                  (fun ops =>
                    fun endorser =>
                      let delegate := delegate endorser in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar delegate
                          op_startypeminuserrorstar tt)
                        (fun op => _return (cons (Operation.pack op) ops))) []
                  endorsers)
                (fun ops =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar ops b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          priority 32)
                        (fun baking_reward =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar __LOC__ baking_reward
                              expected_reward_max_endo)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar priority 0)
                                (fun baking_reward =>
                                  op_startypeminuserrorstar __LOC__
                                    baking_reward expected_reward_min_endo)))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "cycle" % string
      (* ❌ Variants not supported *)
      variant test_cycle)
    (cons
      (op_startypeminuserrorstar "block_reward for priority 0" % string
        (* ❌ Variants not supported *)
        variant (test_block_reward 0))
      (cons
        (op_startypeminuserrorstar "block_reward for priority 1" % string
          (* ❌ Variants not supported *)
          variant (test_block_reward 1))
        (cons
          (op_startypeminuserrorstar "block_reward for priority 3" % string
            (* ❌ Variants not supported *)
            variant (test_block_reward 3)) []))).

src/proto_alpha/lib_protocol/test/combined_operations.ml 137 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Multiple operations can be grouped in one ensuring their
    derministic application.

    If an invalid operation is present in this group of operation, the
    previous applied operations are backtracked leaving the context
    unchanged and the following operations are skipped. Fees attributed
    to the operations are collected by the baker nonetheless.

    Only manager operations are allowed in multiple transactions.
    They must all belong to the same manager as there is only one signature. *)

open Protocol
open Test_tez
open Test_utils

let ten_tez = Tez.of_int 10

(** Groups ten transactions between the same parties. *)
let multiple_transfers () =
  Context.init 3
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  let c3 = List.nth contracts 2 in
  map_s (fun _ -> Op.transaction (B blk) c1 c2 Tez.one) (1 -- 10)
  >>=? fun ops ->
  Op.combine_operations ~source:c1 (B blk) ops
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Context.Contract.balance (B blk) c2
  >>=? fun c2_old_balance ->
  Context.Contract.pkh c3
  >>=? fun baker_pkh ->
  Block.bake ~policy:(By_account baker_pkh) ~operation blk
  >>=? fun blk ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B blk)
    c1
    c1_old_balance
    (Tez.of_int 10)
  >>=? fun () ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B blk)
    c2
    c2_old_balance
    (Tez.of_int 10)
  >>=? fun () -> return_unit

(** Groups ten delegated originations. *)
let multiple_origination_and_delegation () =
  Context.init 2
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  let n = 10 in
  Context.get_constants (B blk)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Context.Contract.pkh c2
  >>=? fun delegate_pkh ->
  (* Deploy n smart contracts with dummy scripts from c1 *)
  map_s
    (fun i ->
      Op.origination
        ~delegate:delegate_pkh
        ~counter:(Z.of_int i)
        ~fee:Tez.zero
        ~script:Op.dummy_script
        ~credit:(Tez.of_int 10)
        (B blk)
        c1)
    (1 -- n)
  >>=? fun originations ->
  (* These computed originated contracts are not the ones really created *)
  (* We will extract them from the tickets *)
  let (originations_operations, _) = List.split originations in
  Op.combine_operations ~source:c1 (B blk) originations_operations
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Incremental.add_operation inc operation
  >>=? fun inc ->
  (* To retrieve the originated contracts, it is easier to extract them
     from the tickets. Else, we could (could we ?) hash each combined
     operation individually. *)
  let tickets = Incremental.rev_tickets inc in
  let open Apply_results in
  let tickets =
    List.fold_left
      (fun acc -> function No_operation_metadata -> assert false
        | Operation_metadata {contents} ->
            to_list (Contents_result_list contents) @ acc)
      []
      tickets
    |> List.rev
  in
  let new_contracts =
    List.map
      (function
        | Contents_result
            (Manager_operation_result
              { operation_result =
                  Applied (Origination_result {originated_contracts = [h]; _});
                _ }) ->
            h
        | _ ->
            assert false)
      tickets
  in
  (* Previous balance - (Credit (n * 10tz) + Origination cost (n tz)) *)
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Tez.(origination_burn *? Int64.of_int n)
  >>?= fun origination_total_cost ->
  Lwt.return
    ( Tez.( *? ) Op.dummy_script_cost 10L
    >>? Tez.( +? ) (Tez.of_int (10 * n))
    >>? Tez.( +? ) origination_total_cost )
  >>=? fun total_cost ->
  Assert.balance_was_debited ~loc:__LOC__ (I inc) c1 c1_old_balance total_cost
  >>=? fun () ->
  iter_s
    (fun c -> Assert.balance_is ~loc:__LOC__ (I inc) c (Tez.of_int 10))
    new_contracts
  >>=? fun () -> return_unit

let expect_balance_too_low = function
  | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
      return_unit
  | _ ->
      failwith
        "Contract should not have a sufficient balance : operation expected \
         to fail."

(** Groups three operations, the midlle one failing.
    Checks that the receipt is consistent.
    Variant without fees. *)
let failing_operation_in_the_middle () =
  Context.init 2
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one
  >>=? fun op1 ->
  Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.max_tez
  >>=? fun op2 ->
  Op.transaction ~fee:Tez.zero (B blk) c1 c2 Tez.one
  >>=? fun op3 ->
  let operations = [op1; op2; op3] in
  Op.combine_operations ~source:c1 (B blk) operations
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Context.Contract.balance (B blk) c2
  >>=? fun c2_old_balance ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Incremental.add_operation
    ~expect_failure:expect_balance_too_low
    inc
    operation
  >>=? fun inc ->
  let tickets = Incremental.rev_tickets inc in
  let open Apply_results in
  let tickets =
    List.fold_left
      (fun acc -> function No_operation_metadata -> assert false
        | Operation_metadata {contents} ->
            to_list (Contents_result_list contents) @ acc)
      []
      tickets
  in
  ( match tickets with
  | Contents_result
      (Manager_operation_result {operation_result = Backtracked _; _})
    :: Contents_result
         (Manager_operation_result
           { operation_result = Failed (_, [Contract_storage.Balance_too_low _]);
             _ })
       :: Contents_result
            (Manager_operation_result {operation_result = Skipped _; _})
          :: _ ->
      ()
  | _ ->
      assert false ) ;
  Assert.balance_is ~loc:__LOC__ (I inc) c1 c1_old_balance
  >>=? fun () ->
  Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance
  >>=? fun () -> return_unit

(** Groups three operations, the midlle one failing.
    Checks that the receipt is consistent.
    Variant with fees, that should be spent even in case of failure. *)
let failing_operation_in_the_middle_with_fees () =
  Context.init 2
  >>=? fun (blk, contracts) ->
  let c1 = List.nth contracts 0 in
  let c2 = List.nth contracts 1 in
  Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one
  >>=? fun op1 ->
  Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.max_tez
  >>=? fun op2 ->
  Op.transaction ~fee:Tez.one (B blk) c1 c2 Tez.one
  >>=? fun op3 ->
  let operations = [op1; op2; op3] in
  Op.combine_operations ~source:c1 (B blk) operations
  >>=? fun operation ->
  Context.Contract.balance (B blk) c1
  >>=? fun c1_old_balance ->
  Context.Contract.balance (B blk) c2
  >>=? fun c2_old_balance ->
  Incremental.begin_construction blk
  >>=? fun inc ->
  Incremental.add_operation
    ~expect_failure:expect_balance_too_low
    inc
    operation
  >>=? fun inc ->
  let tickets = Incremental.rev_tickets inc in
  let open Apply_results in
  let tickets =
    List.fold_left
      (fun acc -> function No_operation_metadata -> assert false
        | Operation_metadata {contents} ->
            to_list (Contents_result_list contents) @ acc)
      []
      tickets
  in
  ( match tickets with
  | Contents_result
      (Manager_operation_result {operation_result = Backtracked _; _})
    :: Contents_result
         (Manager_operation_result
           { operation_result = Failed (_, [Contract_storage.Balance_too_low _]);
             _ })
       :: Contents_result
            (Manager_operation_result {operation_result = Skipped _; _})
          :: _ ->
      ()
  | _ ->
      assert false ) ;
  (* In the presence of a failure, all the fees are collected. Even for skipped operations. *)
  Assert.balance_was_debited
    ~loc:__LOC__
    (I inc)
    c1
    c1_old_balance
    (Tez.of_int 3)
  >>=? fun () ->
  Assert.balance_is ~loc:__LOC__ (I inc) c2 c2_old_balance
  >>=? fun () -> return_unit

let tests =
  [ Test.tztest "multiple transfers" `Quick multiple_transfers;
    Test.tztest
      "multiple originations and delegations"
      `Quick
      multiple_origination_and_delegation;
    Test.tztest
      "Failing operation in the middle"
      `Quick
      failing_operation_in_the_middle;
    Test.tztest
      "Failing operation in the middle (with fees)"
      `Quick
      failing_operation_in_the_middle_with_fees ]
src/proto_alpha/lib_protocol/test/combined_operations.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition ten_tez {A : Type} : A := op_startypeminuserrorstar 10.

Definition multiple_transfers (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 3)
    (fun function_parameter =>
      let '(blk, contracts) := function_parameter in
      let c1 := op_startypeminuserrorstar contracts 0 in
      let c2 := op_startypeminuserrorstar contracts 1 in
      let c3 := op_startypeminuserrorstar contracts 2 in
      op_gtgteqquestion
        (map_s
          (fun function_parameter =>
            let '_ := function_parameter in
            op_startypeminuserrorstar op_startypeminuserrorstar c1 c2
              op_startypeminuserrorstar) (op_startypeminuserrorstar 1 10))
        (fun ops =>
          op_gtgteqquestion
            (op_startypeminuserrorstar c1 op_startypeminuserrorstar ops)
            (fun operation =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar c1)
                (fun c1_old_balance =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar c2)
                    (fun c2_old_balance =>
                      op_gtgteqquestion (op_startypeminuserrorstar c3)
                        (fun baker_pkh =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              operation blk)
                            (fun blk =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar c1 c1_old_balance
                                  (op_startypeminuserrorstar 10))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      op_startypeminuserrorstar c2
                                      c2_old_balance
                                      (op_startypeminuserrorstar 10))
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      return_unit))))))))).

Definition multiple_origination_and_delegation {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(blk, contracts) := function_parameter in
      let c1 := op_startypeminuserrorstar contracts 0 in
      let c2 := op_startypeminuserrorstar contracts 1 in
      let n := 10 in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteqquestion (op_startypeminuserrorstar c2)
            (fun delegate_pkh =>
              op_gtgteqquestion
                (map_s
                  (fun i =>
                    op_startypeminuserrorstar delegate_pkh (Z.of_int i)
                      op_startypeminuserrorstar op_startypeminuserrorstar
                      (op_startypeminuserrorstar 10) op_startypeminuserrorstar
                      c1) (op_startypeminuserrorstar 1 n))
                (fun originations =>
                  let '(originations_operations, _) := List.split originations
                    in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar c1 op_startypeminuserrorstar
                      originations_operations)
                    (fun operation =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar c1)
                        (fun c1_old_balance =>
                          op_gtgteqquestion (op_startypeminuserrorstar blk)
                            (fun inc =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar inc operation)
                                (fun inc =>
                                  let tickets := op_startypeminuserrorstar inc
                                    in
                                  let tickets :=
                                    op_pipegt
                                      (List.fold_left
                                        (fun acc =>
                                          fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
                                              =>
                                              (* ❌ Assert instruction is not handled. *)
                                              assert false
                                            |
                                              Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                                                {| contents := contents |} =>
                                              op_at
                                                (to_list
                                                  (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result_list
                                                    contents)) acc
                                            end) [] tickets) List.rev in
                                  let new_contracts :=
                                    List.map
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                            (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                              {|
                                              operation_result :=
                                                Tezos_protocol_alpha.Protocol.Apply_results.Applied
                                                  (Tezos_protocol_alpha.Protocol.Apply_results.Origination_result
                                                    {|
                                                    originated_contracts := cons h []
                                                      |})
                                                |}) => h
                                        | _ =>
                                          (* ❌ Assert instruction is not handled. *)
                                          assert false
                                        end) tickets in
                                  op_startypeminuserrorstar
                                    op_startypeminuserrorstar
                                    (fun origination_burn =>
                                      op_startypeminuserrorstar
                                        op_startypeminuserrorstar
                                        (fun origination_total_cost =>
                                          op_gtgteqquestion
                                            (Lwt._return
                                              (op_gtgtquestion
                                                (op_gtgtquestion
                                                  (op_startypeminuserrorstar
                                                    op_startypeminuserrorstar
                                                    (* ❌ Constant of type int64 is converted to int *)
                                                    10)
                                                  (op_startypeminuserrorstar
                                                    (op_startypeminuserrorstar
                                                      (op_star 10 n))))
                                                (op_startypeminuserrorstar
                                                  origination_total_cost)))
                                            (fun total_cost =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  __LOC__
                                                  op_startypeminuserrorstar c1
                                                  c1_old_balance total_cost)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteqquestion
                                                    (iter_s
                                                      (fun c =>
                                                        op_startypeminuserrorstar
                                                          __LOC__
                                                          op_startypeminuserrorstar
                                                          c
                                                          (op_startypeminuserrorstar
                                                            10)) new_contracts)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      return_unit))))))))))))).

Definition expect_balance_too_low
  (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  |
    cons
      (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
          _ _ _)) _ => return_unit
  | _ =>
    failwith
      "Contract should not have a sufficient balance : operation expected to fail."
        % string
  end.

Definition failing_operation_in_the_middle (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(blk, contracts) := function_parameter in
      let c1 := op_startypeminuserrorstar contracts 0 in
      let c2 := op_startypeminuserrorstar contracts 1 in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar
          op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
        (fun op1 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar
              op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
            (fun op2 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
                (fun op3 =>
                  let operations := cons op1 (cons op2 (cons op3 [])) in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar c1 op_startypeminuserrorstar
                      operations)
                    (fun operation =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar c1)
                        (fun c1_old_balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              c2)
                            (fun c2_old_balance =>
                              op_gtgteqquestion (op_startypeminuserrorstar blk)
                                (fun inc =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      expect_balance_too_low inc operation)
                                    (fun inc =>
                                      let tickets :=
                                        op_startypeminuserrorstar inc in
                                      let tickets :=
                                        List.fold_left
                                          (fun acc =>
                                            fun function_parameter =>
                                              match function_parameter with
                                              |
                                                Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
                                                =>
                                                (* ❌ Assert instruction is not handled. *)
                                                assert false
                                              |
                                                Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                                                  {| contents := contents |} =>
                                                op_at
                                                  (to_list
                                                    (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result_list
                                                      contents)) acc
                                              end) [] tickets in
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        match tickets with
                                        |
                                          cons
                                            (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                              (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                                {|
                                                operation_result :=
                                                  Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
                                                    _
                                                    _
                                                  |}))
                                            (cons
                                              (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                                (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                                  {|
                                                  operation_result :=
                                                    Tezos_protocol_alpha.Protocol.Apply_results.Failed
                                                      _
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                          _
                                                          _
                                                          _)
                                                        [])
                                                    |}))
                                              (cons
                                                (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                                  (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                                    {|
                                                    operation_result := Tezos_protocol_alpha.Protocol.Apply_results.Skipped _
                                                      |})) _)) => tt
                                        | _ =>
                                          (* ❌ Assert instruction is not handled. *)
                                          assert false
                                        end in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar c1
                                          c1_old_balance)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              op_startypeminuserrorstar c2
                                              c2_old_balance)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              return_unit))))))))))).

Definition failing_operation_in_the_middle_with_fees (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(blk, contracts) := function_parameter in
      let c1 := op_startypeminuserrorstar contracts 0 in
      let c2 := op_startypeminuserrorstar contracts 1 in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar
          op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
        (fun op1 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar
              op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
            (fun op2 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  op_startypeminuserrorstar c1 c2 op_startypeminuserrorstar)
                (fun op3 =>
                  let operations := cons op1 (cons op2 (cons op3 [])) in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar c1 op_startypeminuserrorstar
                      operations)
                    (fun operation =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar c1)
                        (fun c1_old_balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              c2)
                            (fun c2_old_balance =>
                              op_gtgteqquestion (op_startypeminuserrorstar blk)
                                (fun inc =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      expect_balance_too_low inc operation)
                                    (fun inc =>
                                      let tickets :=
                                        op_startypeminuserrorstar inc in
                                      let tickets :=
                                        List.fold_left
                                          (fun acc =>
                                            fun function_parameter =>
                                              match function_parameter with
                                              |
                                                Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
                                                =>
                                                (* ❌ Assert instruction is not handled. *)
                                                assert false
                                              |
                                                Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                                                  {| contents := contents |} =>
                                                op_at
                                                  (to_list
                                                    (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result_list
                                                      contents)) acc
                                              end) [] tickets in
                                      (* ❌ Sequences of instructions are not handled (operator ";") *)
                                      let _ :=
                                        match tickets with
                                        |
                                          cons
                                            (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                              (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                                {|
                                                operation_result :=
                                                  Tezos_protocol_alpha.Protocol.Apply_results.Backtracked
                                                    _
                                                    _
                                                  |}))
                                            (cons
                                              (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                                (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                                  {|
                                                  operation_result :=
                                                    Tezos_protocol_alpha.Protocol.Apply_results.Failed
                                                      _
                                                      (cons
                                                        (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                          _
                                                          _
                                                          _)
                                                        [])
                                                    |}))
                                              (cons
                                                (Tezos_protocol_alpha.Protocol.Apply_results.Contents_result
                                                  (Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
                                                    {|
                                                    operation_result := Tezos_protocol_alpha.Protocol.Apply_results.Skipped _
                                                      |})) _)) => tt
                                        | _ =>
                                          (* ❌ Assert instruction is not handled. *)
                                          assert false
                                        end in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar c1
                                          c1_old_balance
                                          (op_startypeminuserrorstar 3))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              op_startypeminuserrorstar c2
                                              c2_old_balance)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              return_unit))))))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "multiple transfers" % string
      (* ❌ Variants not supported *)
      variant multiple_transfers)
    (cons
      (op_startypeminuserrorstar
        "multiple originations and delegations" % string
        (* ❌ Variants not supported *)
        variant multiple_origination_and_delegation)
      (cons
        (op_startypeminuserrorstar "Failing operation in the middle" % string
          (* ❌ Variants not supported *)
          variant failing_operation_in_the_middle)
        (cons
          (op_startypeminuserrorstar
            "Failing operation in the middle (with fees)" % string
            (* ❌ Variants not supported *)
            variant failing_operation_in_the_middle_with_fees) []))).

src/proto_alpha/lib_protocol/test/delegation.ml 1063 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_tez
open Test_utils

(**************************************************************************)
(* bootstrap contracts *)
(**************************************************************************)
(* Bootstrap contracts are heavily used in other tests. It is helpful
   to test some properties of these contracts, so we can correctly
   interpret the other tests that use them. *)

let expect_error err = function
  | err0 :: _ when err = err0 ->
      return_unit
  | _ ->
      failwith "Unexpected successful result"

let expect_alpha_error err = expect_error (Environment.Ecoproto_error err)

let expect_no_change_registered_delegate_pkh pkh = function
  | Environment.Ecoproto_error (Delegate_storage.No_deletion pkh0) :: _
    when pkh0 = pkh ->
      return_unit
  | _ ->
      failwith "Delegate can not be deleted and operation should fail."

(** bootstrap contracts delegate to themselves *)
let bootstrap_manager_is_bootstrap_delegate () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap0 = List.hd bootstrap_contracts in
  Context.Contract.delegate (B b) bootstrap0
  >>=? fun delegate0 ->
  Context.Contract.manager (B b) bootstrap0
  >>=? fun manager0 -> Assert.equal_pkh ~loc:__LOC__ delegate0 manager0.pkh

(** bootstrap contracts cannot change their delegate *)
let bootstrap_delegate_cannot_change ~fee () =
  Context.init 2
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap0 = List.nth bootstrap_contracts 0 in
  let bootstrap1 = List.nth bootstrap_contracts 1 in
  Context.Contract.pkh bootstrap0
  >>=? fun pkh1 ->
  Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap1
  >>=? fun manager1 ->
  Context.Contract.balance (I i) bootstrap0
  >>=? fun balance0 ->
  Context.Contract.delegate (I i) bootstrap0
  >>=? fun delegate0 ->
  (* change delegation to bootstrap1 *)
  Op.delegation ~fee (I i) bootstrap0 (Some manager1.pkh)
  >>=? fun set_delegate ->
  if fee > balance0 then
    Incremental.add_operation i set_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation
      ~expect_failure:(expect_no_change_registered_delegate_pkh delegate0)
      i
      set_delegate
    >>=? fun i ->
    Incremental.finalize_block i
    >>=? fun b ->
    (* bootstrap0 still has same delegate *)
    Context.Contract.delegate (B b) bootstrap0
    >>=? fun delegate0_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate0_after delegate0
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (B b) bootstrap0 balance0 fee

(** bootstrap contracts cannot delete their delegation *)
let bootstrap_delegate_cannot_be_removed ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap = List.hd bootstrap_contracts in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  (* remove delegation *)
  Op.delegation ~fee (I i) bootstrap None
  >>=? fun set_delegate ->
  if fee > balance then
    Incremental.add_operation i set_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation
      ~expect_failure:(expect_no_change_registered_delegate_pkh manager.pkh)
      i
      set_delegate
    >>=? fun i ->
    (* delegate has not changed *)
    Context.Contract.delegate (I i) bootstrap
    >>=? fun delegate_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate delegate_after
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee

(** contracts not registered as delegate can change their delegation *)
let delegate_can_be_changed_from_unregistered_contract ~fee () =
  Context.init 2
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap0 = List.hd bootstrap_contracts in
  let bootstrap1 = List.nth bootstrap_contracts 1 in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let unregistered = Contract.implicit_contract unregistered_pkh in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap0
  >>=? fun manager0 ->
  Context.Contract.manager (I i) bootstrap1
  >>=? fun manager1 ->
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap0 unregistered credit
  >>=? fun credit_contract ->
  Context.Contract.balance (I i) bootstrap0
  >>=? fun balance ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* delegate to bootstrap0 *)
  Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager0.pkh)
  >>=? fun set_delegate ->
  Incremental.add_operation i set_delegate
  >>=? fun i ->
  Context.Contract.delegate (I i) unregistered
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate manager0.pkh
  >>=? fun () ->
  (* change delegation to bootstrap1 *)
  Op.delegation ~fee (I i) unregistered (Some manager1.pkh)
  >>=? fun change_delegate ->
  if fee > balance then
    Incremental.add_operation i change_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation i change_delegate
    >>=? fun i ->
    (* delegate has changed *)
    Context.Contract.delegate (I i) unregistered
    >>=? fun delegate_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate_after manager1.pkh
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee

(** contracts not registered as delegate can delete their delegation *)
let delegate_can_be_removed_from_unregistered_contract ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let unregistered = Contract.implicit_contract unregistered_pkh in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap unregistered credit
  >>=? fun credit_contract ->
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* delegate to bootstrap *)
  Op.delegation ~fee:Tez.zero (I i) unregistered (Some manager.pkh)
  >>=? fun set_delegate ->
  Incremental.add_operation i set_delegate
  >>=? fun i ->
  Context.Contract.delegate (I i) unregistered
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh
  >>=? fun () ->
  (* remove delegation *)
  Op.delegation ~fee (I i) unregistered None
  >>=? fun delete_delegate ->
  if fee > balance then
    Incremental.add_operation i delete_delegate
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation i delete_delegate
    >>=? fun i ->
    (* the delegate has been removed *)
    Context.Contract.delegate_opt (I i) unregistered
    >>=? (function
           | None ->
               return_unit
           | Some _ ->
               failwith "Expected delegate to be removed")
    >>=? fun () ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) unregistered credit fee

(** bootstrap keys are already registered as delegate keys *)
let bootstrap_manager_already_registered_delegate ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  let pkh = manager.pkh in
  let impl_contract = Contract.implicit_contract pkh in
  Context.Contract.balance (I i) impl_contract
  >>=? fun balance ->
  Op.delegation ~fee (I i) impl_contract (Some pkh)
  >>=? fun sec_reg ->
  if fee > balance then
    Incremental.add_operation i sec_reg
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    Incremental.add_operation
      ~expect_failure:(function
        | Environment.Ecoproto_error Delegate_storage.Active_delegate :: _ ->
            return_unit
        | _ ->
            failwith "Delegate is already active and operation should fail.")
      i
      sec_reg
    >>=? fun i ->
    (* fee has been debited *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee

(** bootstrap manager can be set as delegate of an originated contract
    (through origination operation) *)
let delegate_to_bootstrap_by_origination ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  Context.Contract.manager (I i) bootstrap
  >>=? fun manager ->
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  (* originate a contract with bootstrap's manager as delegate *)
  Op.origination
    ~fee
    ~credit:Tez.zero
    ~delegate:manager.pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  Context.get_constants (I i)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  (* 0.257tz *)
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return
    (Tez.( +? ) fee origination_burn >>? Tez.( +? ) Op.dummy_script_cost)
  >>=? fun total_fee ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else if total_fee > balance && balance >= fee then
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      i
      ~expect_failure:(function
        | Environment.Ecoproto_error (Contract.Balance_too_low _) :: _ ->
            return_unit
        | _ ->
            failwith
              "Not enough balance for origination burn: operation should fail.")
      op
    >>=? fun i ->
    (* fee was taken *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    (* originated contract has not been created *)
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)
  else
    (* bootstrap is delegate, fee + origination burn have been debited *)
    Incremental.add_operation i op
    >>=? fun i ->
    Context.Contract.delegate (I i) orig_contract
    >>=? fun delegate ->
    Assert.equal_pkh ~loc:__LOC__ delegate manager.pkh
    >>=? fun () ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance total_fee

let tests_bootstrap_contracts =
  [ Test.tztest
      "bootstrap contracts delegate to themselves"
      `Quick
      bootstrap_manager_is_bootstrap_delegate;
    Test.tztest
      "bootstrap contracts can change their delegate (small fee)"
      `Quick
      (bootstrap_delegate_cannot_change ~fee:Tez.one_mutez);
    Test.tztest
      "bootstrap contracts can change their delegate (max fee)"
      `Quick
      (bootstrap_delegate_cannot_change ~fee:Tez.max_tez);
    Test.tztest
      "bootstrap contracts cannot remove their delegation (small fee)"
      `Quick
      (bootstrap_delegate_cannot_be_removed ~fee:Tez.one_mutez);
    Test.tztest
      "bootstrap contracts cannot remove their delegation (max fee)"
      `Quick
      (bootstrap_delegate_cannot_be_removed ~fee:Tez.max_tez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation \
       (small fee)"
      `Quick
      (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.one_mutez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation (max \
       fee)"
      `Quick
      (delegate_can_be_changed_from_unregistered_contract ~fee:Tez.max_tez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation \
       (small fee)"
      `Quick
      (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.one_mutez);
    Test.tztest
      "contracts not registered as delegate can remove their delegation (max \
       fee)"
      `Quick
      (delegate_can_be_removed_from_unregistered_contract ~fee:Tez.max_tez);
    Test.tztest
      "bootstrap keys are already registered as delegate keys (small fee)"
      `Quick
      (bootstrap_manager_already_registered_delegate ~fee:Tez.one_mutez);
    Test.tztest
      "bootstrap keys are already registered as delegate keys (max fee)"
      `Quick
      (bootstrap_manager_already_registered_delegate ~fee:Tez.max_tez);
    Test.tztest
      "bootstrap manager can be delegate (init origination, small fee)"
      `Quick
      (delegate_to_bootstrap_by_origination ~fee:Tez.one_mutez);
    (* balance enough for fee but not for fee + origination burn + dummy script storage cost *)
    Test.tztest
      "bootstrap manager can be delegate (init origination, edge case)"
      `Quick
      (delegate_to_bootstrap_by_origination
         ~fee:(Tez.of_mutez_exn 3_999_999_705_000L));
    (* fee bigger than bootstrap's initial balance*)
    Test.tztest
      "bootstrap manager can be delegate (init origination, large fee)"
      `Quick
      (delegate_to_bootstrap_by_origination ~fee:(Tez.of_int 10_000_000)) ]

(**************************************************************************)
(* delegate registration *)
(**************************************************************************)
(* A delegate is a pkh. Delegates must be registered. Registration is
   done via the self-delegation of the implicit contract corresponding
   to the pkh. The implicit contract must be credited when the
   self-delegation is done. Furthermore, trying to register an already
   registered key raises an error.

   In this series of tests, we verify that
   1- unregistered delegate keys cannot be delegated to,
   2- registered keys can be delegated to,
   3- registering an already registered key raises an error.


   We consider three scenarios for setting a delegate:
   - through origination,
   - through delegation when the implicit contract has no delegate yet,
   - through delegation when the implicit contract already has a delegate.

   We also test that emptying the implicit contract linked to a
   registered delegate key does not unregister the delegate key.
*)

(*
   Valid registration

   Unregistered key:
   - contract not credited and no self-delegation
   - contract credited but no self-delegation
   - contract not credited and self-delegation

Not credited:
- no credit operation
- credit operation of 1μꜩ and then debit operation of 1μꜩ

*)

(** A- unregistered delegate keys cannot be used for delegation *)

(* Two main series of tests: without self-delegation, and with a failed attempt at self-delegation
   1- no self-delegation
     a- no credit
   - no token transfer
   - credit of 1μꜩ and then debit of 1μꜩ
     b- with credit of 1μꜩ.
     For every scenario, we try three different ways of delegating:
   - through origination (init origination)
   - through delegation when no delegate was assigned (init delegation)
   - through delegation when a delegate was assigned (switch delegation).

   2- Self-delegation fails if the contract has no credit. We try the
   two possibilities of 1a for non-credited contracts.
*)

let expect_unregistered_key pkh = function
  | Environment.Ecoproto_error (Roll_storage.Unregistered_delegate pkh0) :: _
    when pkh = pkh0 ->
      return_unit
  | _ ->
      failwith "Delegate key is not registered: operation should fail."

(* A1: no self-delegation *)
(* no token transfer, no self-delegation *)
let unregistered_delegate_key_init_origination ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  (* origination with delegate argument *)
  Op.origination
    ~fee
    ~delegate:unregistered_pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  Context.get_constants (I i)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return (Tez.( +? ) fee origination_burn)
  >>=? fun _total_fee ->
  (* FIXME unused variable *)
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    (* originated contract has not been created *)
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_init_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been debited; no delegate *)
    Incremental.add_operation
      i
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    (* implicit contract has no delegate *)
    Context.Contract.delegate (I i) impl_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_switch_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let bootstrap_pkh =
    Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
  in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun init_credit ->
  Incremental.add_operation i init_credit
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* set and check the initial delegate *)
  Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
  >>=? fun delegate_op ->
  Incremental.add_operation i delegate_op
  >>=? fun i ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate_pkh ->
  Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
  >>=? fun () ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been debited; no delegate *)
    Incremental.add_operation
      i
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    (* implicit contract delegate has not changed *)
    Context.Contract.delegate (I i) bootstrap
    >>=? fun delegate_pkh_after ->
    Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate_pkh_after

(* credit of some amount, no self-delegation *)
let unregistered_delegate_key_init_origination_credit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* origination with delegate argument *)
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Op.origination
    ~fee
    ~delegate:unregistered_pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination not done, fee taken *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_init_delegation_credit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Lwt.return Tez.(credit +? amount)
  >>=? fun balance ->
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun init_credit ->
  Incremental.add_operation i init_credit
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance
  >>=? fun _ ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, no delegate for contract *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_switch_delegation_credit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let bootstrap_pkh =
    Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
  in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Lwt.return Tez.(credit +? amount)
  >>=? fun balance ->
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun init_credit ->
  Incremental.add_operation i init_credit
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract balance
  >>=? fun _ ->
  (* set and check the initial delegate *)
  Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
  >>=? fun delegate_op ->
  Incremental.add_operation i delegate_op
  >>=? fun i ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate_pkh ->
  Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
  >>=? fun () ->
  (* switch delegate through delegation *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, delegate for contract has not changed *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract balance fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>=? fun delegate ->
    Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh
    >>=? fun () -> Assert.equal_pkh ~loc:__LOC__ delegate bootstrap_pkh

(* a credit of some amount followed by a debit of the same amount, no self-delegation *)
let unregistered_delegate_key_init_origination_credit_debit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (* credit + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* debit + check balance *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun debit_contract ->
  Incremental.add_operation i debit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* origination with delegate argument *)
  Context.Contract.balance (I i) bootstrap
  >>=? fun balance ->
  Op.origination
    ~fee
    ~delegate:unregistered_pkh
    (I i)
    bootstrap
    ~script:Op.dummy_script
  >>=? fun (op, orig_contract) ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee taken, origination not processed *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) bootstrap balance fee
    >>=? fun () ->
    Context.Contract.balance (I i) orig_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_init_delegation_credit_debit ~amount ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* debit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) impl_contract bootstrap amount
  >>=? fun debit_contract ->
  Incremental.add_operation i debit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* try to delegate *)
  Op.delegation ~fee (I i) impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, no delegate for contract *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>= fun err ->
    Assert.error ~loc:__LOC__ err (function
        | RPC_context.Not_found _ ->
            true
        | _ ->
            false)

let unregistered_delegate_key_switch_delegation_credit_debit ~fee ~amount () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let bootstrap_pkh =
    Contract.is_implicit bootstrap |> Option.unopt_assert ~loc:__POS__
  in
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  let unregistered_delegate_account = Account.new_account () in
  let unregistered_delegate_pkh =
    Account.(unregistered_delegate_account.pkh)
  in
  (* credit + check balance *)
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* debit + check balance *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun debit_contract ->
  Incremental.add_operation i debit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* delegation - initial credit for the delegated contract *)
  let credit = Tez.of_int 10 in
  Op.transaction ~fee:Tez.zero (I i) bootstrap impl_contract credit
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract credit
  >>=? fun _ ->
  (* set and check the initial delegate *)
  Op.delegation ~fee:Tez.zero (I i) impl_contract (Some bootstrap_pkh)
  >>=? fun delegate_op ->
  Incremental.add_operation i delegate_op
  >>=? fun i ->
  Context.Contract.delegate (I i) bootstrap
  >>=? fun delegate_pkh ->
  Assert.equal_pkh ~loc:__LOC__ bootstrap_pkh delegate_pkh
  >>=? fun () ->
  (* switch delegate through delegation *)
  Op.delegation (I i) ~fee impl_contract (Some unregistered_delegate_pkh)
  >>=? fun delegate_op ->
  if fee > credit then
    Incremental.add_operation i delegate_op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* fee has been taken, delegate for contract has not changed *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key unregistered_delegate_pkh)
      i
      delegate_op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) impl_contract credit fee
    >>=? fun () ->
    Context.Contract.delegate (I i) impl_contract
    >>=? fun delegate ->
    Assert.not_equal_pkh ~loc:__LOC__ delegate unregistered_delegate_pkh

(* A2- self-delegation to an empty contract fails *)
let failed_self_delegation_no_transaction () =
  Context.init 1
  >>=? fun (b, _) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let account = Account.new_account () in
  let unregistered_pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (* check balance *)
  Context.Contract.balance (I i) impl_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ Tez.zero balance
  >>=? fun _ ->
  (* self delegation fails *)
  Op.delegation (I i) impl_contract (Some unregistered_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Contract_storage.Empty_implicit_contract pkh ->
          if pkh = unregistered_pkh then true else false
      | _ ->
          false)

let failed_self_delegation_emptied_implicit_contract amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let unregistered_pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract unregistered_pkh in
  (*  credit implicit contract and check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* empty implicit contract and check balance *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* self delegation fails *)
  Op.delegation (I i) impl_contract (Some unregistered_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Contract_storage.Empty_implicit_contract pkh ->
          if pkh = unregistered_pkh then true else false
      | _ ->
          false)

(** B- valid registration:
    - credit implicit contract with some ꜩ + verification of balance
    - self delegation + verification
    - empty contract + verification of balance + verification of not being erased / self-delegation
    - create delegator implicit contract w first implicit contract as delegate + verification of delegation *)
let valid_delegate_registration_init_delegation_credit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
  >>=? fun _ ->
  (* create an implicit contract with no delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* check no delegate for delegator contract *)
  Context.Contract.delegate (I i) delegator
  >>= fun err ->
  Assert.error ~loc:__LOC__ err (function
      | RPC_context.Not_found _ ->
          true
      | _ ->
          false)
  >>=? fun _ ->
  (* delegation to the newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* check delegation *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

let valid_delegate_registration_switch_delegation_credit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
  >>=? fun _ ->
  (* create an implicit contract with bootstrap's account as delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun bootstrap_manager ->
  Op.delegation (I i) delegator (Some bootstrap_manager.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* test delegate of new contract is bootstrap *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh
  >>=? fun _ ->
  (* delegation with newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

let valid_delegate_registration_init_delegation_credit_debit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
  >>=? fun _ ->
  (* empty implicit contracts are usually deleted but they are kept if
     they were registered as delegates. we empty the contract in
     order to verify this. *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  (* impl_contract is empty *)
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* verify self-delegation after contract is emptied *)
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
  >>=? fun _ ->
  (* create an implicit contract with no delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  (* check no delegate for delegator contract *)
  Context.Contract.delegate (I i) delegator
  >>= fun err ->
  Assert.error ~loc:__LOC__ err (function
      | RPC_context.Not_found _ ->
          true
      | _ ->
          false)
  >>=? fun _ ->
  (* delegation to the newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* check delegation *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

let valid_delegate_registration_switch_delegation_credit_debit amount () =
  (* create an implicit contract *)
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let delegate_account = Account.new_account () in
  let delegate_pkh = Account.(delegate_account.pkh) in
  let impl_contract = Contract.implicit_contract delegate_pkh in
  (* credit > 0ꜩ + check balance *)
  Op.transaction (I i) bootstrap impl_contract amount
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract amount
  >>=? fun _ ->
  (* self delegation + verification *)
  Op.delegation (I i) impl_contract (Some delegate_pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) impl_contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate_pkh delegate
  >>=? fun _ ->
  (* empty implicit contracts are usually deleted but they are kept if
     they were registered as delegates. we empty the contract in
     order to verify this. *)
  Op.transaction (I i) impl_contract bootstrap amount
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  (* impl_contract is empty *)
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* create an implicit contract with bootstrap's account as delegate *)
  let unregistered_account = Account.new_account () in
  let unregistered_pkh = Account.(unregistered_account.pkh) in
  let delegator = Contract.implicit_contract unregistered_pkh in
  Op.transaction ~fee:Tez.zero (I i) bootstrap delegator Tez.one
  >>=? fun credit_contract ->
  Incremental.add_operation i credit_contract
  >>=? fun i ->
  Context.Contract.manager (I i) bootstrap
  >>=? fun bootstrap_manager ->
  Op.delegation (I i) delegator (Some bootstrap_manager.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  (* test delegate of new contract is bootstrap *)
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate bootstrap_manager.pkh
  >>=? fun _ ->
  (* delegation with newly registered key *)
  Op.delegation (I i) delegator (Some delegate_account.pkh)
  >>=? fun delegation ->
  Incremental.add_operation i delegation
  >>=? fun i ->
  Context.Contract.delegate (I i) delegator
  >>=? fun delegator_delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegator_delegate delegate_pkh

(* with implicit contract with some credit *)

(** C- a second self-delegation should raise an `Active_delegate` error *)
let double_registration () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract pkh in
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  (* second self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun second_registration ->
  Incremental.add_operation i second_registration
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Delegate_storage.Active_delegate ->
          true
      | _ ->
          false)

(* with implicit contract emptied after first self-delegation  *)
let double_registration_when_empty () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract pkh in
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* self delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  (* empty the delegate account *)
  Op.transaction (I i) impl_contract bootstrap Tez.one_mutez
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* second self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun second_registration ->
  Incremental.add_operation i second_registration
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Delegate_storage.Active_delegate ->
          true
      | _ ->
          false)

(* with implicit contract emptied then recredited after first self-delegation  *)
let double_registration_when_recredited () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let account = Account.new_account () in
  let pkh = Account.(account.pkh) in
  let impl_contract = Contract.implicit_contract pkh in
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* self delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun self_delegation ->
  Incremental.add_operation i self_delegation
  >>=? fun i ->
  (* empty the delegate account *)
  Op.transaction (I i) impl_contract bootstrap Tez.one_mutez
  >>=? fun empty_contract ->
  Incremental.add_operation i empty_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.zero
  >>=? fun _ ->
  (* credit 1μꜩ+ check balance *)
  Op.transaction (I i) bootstrap impl_contract Tez.one_mutez
  >>=? fun create_contract ->
  Incremental.add_operation i create_contract
  >>=? fun i ->
  Assert.balance_is ~loc:__LOC__ (I i) impl_contract Tez.one_mutez
  >>=? fun _ ->
  (* second self-delegation *)
  Op.delegation (I i) impl_contract (Some pkh)
  >>=? fun second_registration ->
  Incremental.add_operation i second_registration
  >>= fun err ->
  Assert.proto_error ~loc:__LOC__ err (function
      | Delegate_storage.Active_delegate ->
          true
      | _ ->
          false)

(* self-delegation on unrevealed contract *)
let unregistered_and_unrevealed_self_delegate_key_init_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let {Account.pkh; _} = Account.new_account () in
  let {Account.pkh = delegate_pkh; _} = Account.new_account () in
  let contract = Alpha_context.Contract.implicit_contract pkh in
  Op.transaction (I i) bootstrap contract (Tez.of_int 10)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation ~fee (I i) contract (Some delegate_pkh)
  >>=? fun op ->
  Context.Contract.balance (I i) contract
  >>=? fun balance ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key delegate_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee

(* self-delegation on revelead but not registered contract *)
let unregistered_and_revealed_self_delegate_key_init_delegation ~fee () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let {Account.pkh; pk; _} = Account.new_account () in
  let {Account.pkh = delegate_pkh; _} = Account.new_account () in
  let contract = Alpha_context.Contract.implicit_contract pkh in
  Op.transaction (I i) bootstrap contract (Tez.of_int 10)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.revelation (I i) pk
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation ~fee (I i) contract (Some delegate_pkh)
  >>=? fun op ->
  Context.Contract.balance (I i) contract
  >>=? fun balance ->
  if fee > balance then
    Incremental.add_operation i op
    >>= fun err ->
    Assert.proto_error ~loc:__LOC__ err (function
        | Contract_storage.Balance_too_low _ ->
            true
        | _ ->
            false)
  else
    (* origination did not proceed; fee has been debited *)
    Incremental.add_operation
      ~expect_failure:(expect_unregistered_key delegate_pkh)
      i
      op
    >>=? fun i ->
    Assert.balance_was_debited ~loc:__LOC__ (I i) contract balance fee

(* self-delegation on revealed and registered contract *)
let registered_self_delegate_key_init_delegation () =
  Context.init 1
  >>=? fun (b, bootstrap_contracts) ->
  Incremental.begin_construction b
  >>=? fun i ->
  let bootstrap = List.hd bootstrap_contracts in
  let {Account.pkh; _} = Account.new_account () in
  let {Account.pkh = delegate_pkh; pk = delegate_pk; _} =
    Account.new_account ()
  in
  let contract = Alpha_context.Contract.implicit_contract pkh in
  let delegate_contract =
    Alpha_context.Contract.implicit_contract delegate_pkh
  in
  Op.transaction (I i) bootstrap contract (Tez.of_int 10)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.transaction (I i) bootstrap delegate_contract (Tez.of_int 1)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.revelation (I i) delegate_pk
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation (I i) delegate_contract (Some delegate_pkh)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Op.delegation (I i) contract (Some delegate_pkh)
  >>=? fun op ->
  Incremental.add_operation i op
  >>=? fun i ->
  Context.Contract.delegate (I i) contract
  >>=? fun delegate ->
  Assert.equal_pkh ~loc:__LOC__ delegate delegate_pkh
  >>=? fun () -> return_unit

let tests_delegate_registration =
  [ (*** unregistered delegate key: no self-delegation ***)
    (* no token transfer, no self-delegation *)
    Test.tztest
      "unregistered delegate key (origination, small fee)"
      `Quick
      (unregistered_delegate_key_init_origination ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key (origination, edge case fee)"
      `Quick
      (unregistered_delegate_key_init_origination ~fee:(Tez.of_int 3_999_488));
    Test.tztest
      "unregistered delegate key (origination, large fee)"
      `Quick
      (unregistered_delegate_key_init_origination ~fee:(Tez.of_int 10_000_000));
    Test.tztest
      "unregistered delegate key (init with delegation, small fee)"
      `Quick
      (unregistered_delegate_key_init_delegation ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key (init with delegation, max fee)"
      `Quick
      (unregistered_delegate_key_init_delegation ~fee:Tez.max_tez);
    Test.tztest
      "unregistered delegate key (switch with delegation, small fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key (switch with delegation, max fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation ~fee:Tez.max_tez);
    (* credit/debit 1μꜩ, no self-delegation *)
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (origination, small fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit_debit
         ~fee:Tez.one_mutez
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (origination, large fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit_debit
         ~fee:Tez.max_tez
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (init with delegation, \
       small fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (init with delegation, \
       large fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (switch with \
       delegation, small fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit/debit 1μꜩ (switch with \
       delegation, large fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit_debit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    (* credit 1μꜩ, no self-delegation *)
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (origination, small fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit
         ~fee:Tez.one_mutez
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (origination, edge case fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit
         ~fee:(Tez.of_int 3_999_488)
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (origination, large fee)"
      `Quick
      (unregistered_delegate_key_init_origination_credit
         ~fee:(Tez.of_int 10_000_000)
         ~amount:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (init with delegation, small \
       fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (init with delegation, large \
       fee)"
      `Quick
      (unregistered_delegate_key_init_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (switch with delegation, \
       small fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered delegate key - credit 1μꜩ (switch with delegation, \
       large fee)"
      `Quick
      (unregistered_delegate_key_switch_delegation_credit
         ~amount:Tez.one_mutez
         ~fee:Tez.max_tez);
    (* self delegation on unrevealed and unregistered contract *)
    Test.tztest
      "unregistered and unrevealed self-delegation (small fee)"
      `Quick
      (unregistered_and_unrevealed_self_delegate_key_init_delegation
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered and unrevealed self-delegation (large fee)"
      `Quick
      (unregistered_and_unrevealed_self_delegate_key_init_delegation
         ~fee:Tez.max_tez);
    (* self delegation on unregistered contract *)
    Test.tztest
      "unregistered and revealed self-delegation (small fee)"
      `Quick
      (unregistered_and_revealed_self_delegate_key_init_delegation
         ~fee:Tez.one_mutez);
    Test.tztest
      "unregistered and revealed self-delegation  large fee)"
      `Quick
      (unregistered_and_revealed_self_delegate_key_init_delegation
         ~fee:Tez.max_tez);
    (* self delegation on registered contract *)
    Test.tztest
      "registered and revelead self-delegation"
      `Quick
      registered_self_delegate_key_init_delegation;
    (*** unregistered delegate key: failed self-delegation ***)
    (* no token transfer, self-delegation *)
    Test.tztest
      "failed self-delegation: no transaction"
      `Quick
      failed_self_delegation_no_transaction;
    (* credit 1μtz, debit 1μtz, self-delegation *)
    Test.tztest
      "failed self-delegation: credit & debit 1μꜩ"
      `Quick
      (failed_self_delegation_emptied_implicit_contract Tez.one_mutez);
    (*** valid registration ***)
    (* valid registration: credit 1 μꜩ, self delegation *)
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation (init with \
       delegation)"
      `Quick
      (valid_delegate_registration_init_delegation_credit Tez.one_mutez);
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation (switch \
       with delegation)"
      `Quick
      (valid_delegate_registration_switch_delegation_credit Tez.one_mutez);
    (* valid registration: credit 1 μꜩ, self delegation, debit 1μꜩ *)
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation, debit \
       1μꜩ (init with delegation)"
      `Quick
      (valid_delegate_registration_init_delegation_credit_debit Tez.one_mutez);
    Test.tztest
      "valid delegate registration: credit 1μꜩ, self delegation, debit \
       1μꜩ (switch with delegation)"
      `Quick
      (valid_delegate_registration_switch_delegation_credit_debit Tez.one_mutez);
    (*** double registration ***)
    Test.tztest "double registration" `Quick double_registration;
    Test.tztest
      "double registration when delegate account is emptied"
      `Quick
      double_registration_when_empty;
    Test.tztest
      "double registration when delegate account is emptied and then recredited"
      `Quick
      double_registration_when_recredited ]

(******************************************************************************)
(* Main                                                                       *)
(******************************************************************************)

let tests = tests_bootstrap_contracts @ tests_delegate_registration
src/proto_alpha/lib_protocol/test/delegation.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition expect_error {A B : Type} (err : A) (function_parameter : list B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  | cons err0 _ => return_unit
  | _ => failwith "Unexpected successful result" % string
  end.

Definition expect_alpha_error {A : Type}
  (err : Tezos_protocol_alpha.Protocol.Environment.Error_monad.error)
  : (list A) ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  expect_error (Tezos_base__TzPervasives.Error_monad.Ecoproto_error err).

Definition expect_no_change_registered_delegate_pkh {A : Type}
  (pkh : A)
  (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  |
    cons
      (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.No_deletion
          pkh0)) _ => return_unit
  | _ =>
    failwith "Delegate can not be deleted and operation should fail." % string
  end.

Definition bootstrap_manager_is_bootstrap_delegate {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      let bootstrap0 := List.hd bootstrap_contracts in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap0)
        (fun delegate0 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap0)
            (fun manager0 =>
              op_startypeminuserrorstar __LOC__ delegate0 (pkh manager0)))).

Definition bootstrap_delegate_cannot_change {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      let bootstrap0 := op_startypeminuserrorstar bootstrap_contracts 0 in
      let bootstrap1 := op_startypeminuserrorstar bootstrap_contracts 1 in
      op_gtgteqquestion (op_startypeminuserrorstar bootstrap0)
        (fun pkh1 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar b op_startypeminuserrorstar)
            (fun i =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap1)
                (fun manager1 =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      bootstrap0)
                    (fun balance0 =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          bootstrap0)
                        (fun delegate0 =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar fee
                              op_startypeminuserrorstar bootstrap0
                              (Some (pkh manager1)))
                            (fun set_delegate =>
                              if op_startypeminuserrorstar fee balance0 then
                                op_gtgteq
                                  (op_startypeminuserrorstar i set_delegate)
                                  (fun err =>
                                    op_startypeminuserrorstar __LOC__ err
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                            _ _ _ => true
                                        | _ => false
                                        end))
                              else
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    (expect_no_change_registered_delegate_pkh
                                      delegate0) i set_delegate)
                                  (fun i =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar i)
                                      (fun b =>
                                        op_gtgteqquestion
                                          (op_startypeminuserrorstar
                                            op_startypeminuserrorstar bootstrap0)
                                          (fun delegate0_after =>
                                            op_gtgteqquestion
                                              (op_startypeminuserrorstar __LOC__
                                                delegate0_after delegate0)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                op_startypeminuserrorstar
                                                  __LOC__
                                                  op_startypeminuserrorstar
                                                  bootstrap0 balance0 fee))))))))))).

Definition bootstrap_delegate_cannot_be_removed {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      let bootstrap := List.hd bootstrap_contracts in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
            (fun balance =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
                (fun delegate =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      bootstrap)
                    (fun manager =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar fee op_startypeminuserrorstar
                          bootstrap None)
                        (fun set_delegate =>
                          if op_startypeminuserrorstar fee balance then
                            op_gtgteq (op_startypeminuserrorstar i set_delegate)
                              (fun err =>
                                op_startypeminuserrorstar __LOC__ err
                                  (fun function_parameter =>
                                    match function_parameter with
                                    |
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                        _ _ _ => true
                                    | _ => false
                                    end))
                          else
                            op_gtgteqquestion
                              (op_startypeminuserrorstar
                                (expect_no_change_registered_delegate_pkh
                                  (pkh manager)) i set_delegate)
                              (fun i =>
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar bootstrap)
                                  (fun delegate_after =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar __LOC__
                                        delegate delegate_after)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar bootstrap
                                          balance fee))))))))).

Definition delegate_can_be_changed_from_unregistered_contract {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      let bootstrap0 := List.hd bootstrap_contracts in
      let bootstrap1 := op_startypeminuserrorstar bootstrap_contracts 1 in
      let unregistered_account := op_startypeminuserrorstar tt in
      let unregistered_pkh := op_startypeminuserrorstar in
      let unregistered := Contract.implicit_contract unregistered_pkh in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap0)
            (fun manager0 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap1)
                (fun manager1 =>
                  let credit := op_startypeminuserrorstar 10 in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar Tez.zero
                      op_startypeminuserrorstar bootstrap0 unregistered credit)
                    (fun credit_contract =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          bootstrap0)
                        (fun balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i credit_contract)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar Tez.zero
                                  op_startypeminuserrorstar unregistered
                                  (Some (pkh manager0)))
                                (fun set_delegate =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar i set_delegate)
                                    (fun i =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar unregistered)
                                        (fun delegate =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              delegate (pkh manager0))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar fee
                                                  op_startypeminuserrorstar
                                                  unregistered
                                                  (Some (pkh manager1)))
                                                (fun change_delegate =>
                                                  if
                                                    op_startypeminuserrorstar
                                                      fee balance then
                                                    op_gtgteq
                                                      (op_startypeminuserrorstar
                                                        i change_delegate)
                                                      (fun err =>
                                                        op_startypeminuserrorstar
                                                          __LOC__ err
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                                _ _ _ => true
                                                            | _ => false
                                                            end))
                                                  else
                                                    op_gtgteqquestion
                                                      (op_startypeminuserrorstar
                                                        i change_delegate)
                                                      (fun i =>
                                                        op_gtgteqquestion
                                                          (op_startypeminuserrorstar
                                                            op_startypeminuserrorstar
                                                            unregistered)
                                                          (fun delegate_after =>
                                                            op_gtgteqquestion
                                                              (op_startypeminuserrorstar
                                                                __LOC__
                                                                delegate_after
                                                                (pkh manager1))
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                let 'tt :=
                                                                  function_parameter
                                                                  in
                                                                op_startypeminuserrorstar
                                                                  __LOC__
                                                                  op_startypeminuserrorstar
                                                                  unregistered
                                                                  credit fee))))))))))))))).

Definition delegate_can_be_removed_from_unregistered_contract {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      let bootstrap := List.hd bootstrap_contracts in
      let unregistered_account := op_startypeminuserrorstar tt in
      let unregistered_pkh := op_startypeminuserrorstar in
      let unregistered := Contract.implicit_contract unregistered_pkh in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
            (fun manager =>
              let credit := op_startypeminuserrorstar 10 in
              op_gtgteqquestion
                (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
                  bootstrap unregistered credit)
                (fun credit_contract =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      bootstrap)
                    (fun balance =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar i credit_contract)
                        (fun i =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar Tez.zero
                              op_startypeminuserrorstar unregistered
                              (Some (pkh manager)))
                            (fun set_delegate =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar i set_delegate)
                                (fun i =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar unregistered)
                                    (fun delegate =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          delegate (pkh manager))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar fee
                                              op_startypeminuserrorstar
                                              unregistered None)
                                            (fun delete_delegate =>
                                              if
                                                op_startypeminuserrorstar fee
                                                  balance then
                                                op_gtgteq
                                                  (op_startypeminuserrorstar i
                                                    delete_delegate)
                                                  (fun err =>
                                                    op_startypeminuserrorstar
                                                      __LOC__ err
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        |
                                                          Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                            _ _ _ => true
                                                        | _ => false
                                                        end))
                                              else
                                                op_gtgteqquestion
                                                  (op_startypeminuserrorstar i
                                                    delete_delegate)
                                                  (fun i =>
                                                    op_gtgteqquestion
                                                      (op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          op_startypeminuserrorstar
                                                          unregistered)
                                                        (fun function_parameter
                                                          =>
                                                          match
                                                            function_parameter
                                                            with
                                                          | None => return_unit
                                                          | Some _ =>
                                                            failwith
                                                              "Expected delegate to be removed"
                                                                % string
                                                          end))
                                                      (fun function_parameter =>
                                                        let 'tt :=
                                                          function_parameter in
                                                        op_startypeminuserrorstar
                                                          __LOC__
                                                          op_startypeminuserrorstar
                                                          unregistered credit
                                                          fee))))))))))))).

Definition bootstrap_manager_already_registered_delegate {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
            (fun manager =>
              let pkh := pkh manager in
              let impl_contract := Contract.implicit_contract pkh in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  impl_contract)
                (fun balance =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar fee op_startypeminuserrorstar
                      impl_contract (Some pkh))
                    (fun sec_reg =>
                      if op_startypeminuserrorstar fee balance then
                        op_gtgteq (op_startypeminuserrorstar i sec_reg)
                          (fun err =>
                            op_startypeminuserrorstar __LOC__ err
                              (fun function_parameter =>
                                match function_parameter with
                                |
                                  Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                    _ _ _ => true
                                | _ => false
                                end))
                      else
                        op_gtgteqquestion
                          (op_startypeminuserrorstar
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                cons
                                  (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate)
                                  _ => return_unit
                              | _ =>
                                failwith
                                  "Delegate is already active and operation should fail."
                                    % string
                              end) i sec_reg)
                          (fun i =>
                            op_startypeminuserrorstar __LOC__
                              op_startypeminuserrorstar impl_contract balance
                              fee)))))).

Definition delegate_to_bootstrap_by_origination {A : Type}
  (fee : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
            (fun manager =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap)
                (fun balance =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar fee Tez.zero (pkh manager)
                      op_startypeminuserrorstar bootstrap
                      op_startypeminuserrorstar)
                    (fun function_parameter =>
                      let '(op, orig_contract) := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          op_startypeminuserrorstar
                            (op_starquestion op_startypeminuserrorstar
                              (Int64.of_int op_startypeminuserrorstar))
                            (fun origination_burn =>
                              op_gtgteqquestion
                                (Lwt._return
                                  (op_gtgtquestion
                                    (Tez.op_plusquestion fee origination_burn)
                                    (Tez.op_plusquestion
                                      op_startypeminuserrorstar)))
                                (fun total_fee =>
                                  if op_startypeminuserrorstar fee balance then
                                    op_gtgteq (op_startypeminuserrorstar i op)
                                      (fun err =>
                                        op_startypeminuserrorstar __LOC__ err
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                _ _ _ => true
                                            | _ => false
                                            end))
                                  else
                                    if
                                      op_andand
                                        (op_startypeminuserrorstar total_fee
                                          balance)
                                        (op_startypeminuserrorstar balance fee)
                                      then
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar i
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              cons
                                                (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
                                                  (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                    _ _ _)) _ => return_unit
                                            | _ =>
                                              failwith
                                                "Not enough balance for origination burn: operation should fail."
                                                  % string
                                            end) op)
                                        (fun i =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              op_startypeminuserrorstar
                                              bootstrap balance fee)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteq
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar
                                                  orig_contract)
                                                (fun err =>
                                                  op_startypeminuserrorstar
                                                    __LOC__ err
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      | _ => true
                                                      | _ => false
                                                      end))))
                                    else
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar i op)
                                        (fun i =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar
                                              orig_contract)
                                            (fun delegate =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  __LOC__ delegate (pkh manager))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_startypeminuserrorstar
                                                    __LOC__
                                                    op_startypeminuserrorstar
                                                    bootstrap balance total_fee))))))))))).

Definition tests_bootstrap_contracts {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar
      "bootstrap contracts delegate to themselves" % string
      (* ❌ Variants not supported *)
      variant bootstrap_manager_is_bootstrap_delegate)
    (cons
      (op_startypeminuserrorstar
        "bootstrap contracts can change their delegate (small fee)" % string
        (* ❌ Variants not supported *)
        variant (bootstrap_delegate_cannot_change Tez.one_mutez))
      (cons
        (op_startypeminuserrorstar
          "bootstrap contracts can change their delegate (max fee)" % string
          (* ❌ Variants not supported *)
          variant (bootstrap_delegate_cannot_change op_startypeminuserrorstar))
        (cons
          (op_startypeminuserrorstar
            "bootstrap contracts cannot remove their delegation (small fee)" %
              string
            (* ❌ Variants not supported *)
            variant (bootstrap_delegate_cannot_be_removed Tez.one_mutez))
          (cons
            (op_startypeminuserrorstar
              "bootstrap contracts cannot remove their delegation (max fee)" %
                string
              (* ❌ Variants not supported *)
              variant
              (bootstrap_delegate_cannot_be_removed op_startypeminuserrorstar))
            (cons
              (op_startypeminuserrorstar
                "contracts not registered as delegate can remove their delegation (small fee)"
                  % string
                (* ❌ Variants not supported *)
                variant
                (delegate_can_be_changed_from_unregistered_contract
                  Tez.one_mutez))
              (cons
                (op_startypeminuserrorstar
                  "contracts not registered as delegate can remove their delegation (max fee)"
                    % string
                  (* ❌ Variants not supported *)
                  variant
                  (delegate_can_be_changed_from_unregistered_contract
                    op_startypeminuserrorstar))
                (cons
                  (op_startypeminuserrorstar
                    "contracts not registered as delegate can remove their delegation (small fee)"
                      % string
                    (* ❌ Variants not supported *)
                    variant
                    (delegate_can_be_removed_from_unregistered_contract
                      Tez.one_mutez))
                  (cons
                    (op_startypeminuserrorstar
                      "contracts not registered as delegate can remove their delegation (max fee)"
                        % string
                      (* ❌ Variants not supported *)
                      variant
                      (delegate_can_be_removed_from_unregistered_contract
                        op_startypeminuserrorstar))
                    (cons
                      (op_startypeminuserrorstar
                        "bootstrap keys are already registered as delegate keys (small fee)"
                          % string
                        (* ❌ Variants not supported *)
                        variant
                        (bootstrap_manager_already_registered_delegate
                          Tez.one_mutez))
                      (cons
                        (op_startypeminuserrorstar
                          "bootstrap keys are already registered as delegate keys (max fee)"
                            % string
                          (* ❌ Variants not supported *)
                          variant
                          (bootstrap_manager_already_registered_delegate
                            op_startypeminuserrorstar))
                        (cons
                          (op_startypeminuserrorstar
                            "bootstrap manager can be delegate (init origination, small fee)"
                              % string
                            (* ❌ Variants not supported *)
                            variant
                            (delegate_to_bootstrap_by_origination Tez.one_mutez))
                          (cons
                            (op_startypeminuserrorstar
                              "bootstrap manager can be delegate (init origination, edge case)"
                                % string
                              (* ❌ Variants not supported *)
                              variant
                              (delegate_to_bootstrap_by_origination
                                (op_startypeminuserrorstar
                                  (* ❌ Constant of type int64 is converted to int *)
                                  3999999705000)))
                            (cons
                              (op_startypeminuserrorstar
                                "bootstrap manager can be delegate (init origination, large fee)"
                                  % string
                                (* ❌ Variants not supported *)
                                variant
                                (delegate_to_bootstrap_by_origination
                                  (op_startypeminuserrorstar 10000000))) []))))))))))))).

Definition expect_unregistered_key {A : Type}
  (pkh : A)
  (function_parameter : list Tezos_base__TzPervasives.Error_monad.error)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  match function_parameter with
  |
    cons
      (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
        (Tezos_protocol_environment_alpha__Environment.Error_monad.Unregistered_delegate
          pkh0)) _ => return_unit
  | _ =>
    failwith "Delegate key is not registered: operation should fail." % string
  end.

Definition unregistered_delegate_key_init_origination {A : Type}
  (fee : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          op_gtgteqquestion
            (op_startypeminuserrorstar fee unregistered_pkh
              op_startypeminuserrorstar bootstrap op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(op, orig_contract) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_startypeminuserrorstar
                    (op_starquestion op_startypeminuserrorstar
                      (Int64.of_int op_startypeminuserrorstar))
                    (fun origination_burn =>
                      op_gtgteqquestion
                        (Lwt._return (Tez.op_plusquestion fee origination_burn))
                        (fun _total_fee =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              bootstrap)
                            (fun balance =>
                              if op_startypeminuserrorstar fee balance then
                                op_gtgteq (op_startypeminuserrorstar i op)
                                  (fun err =>
                                    op_startypeminuserrorstar __LOC__ err
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                            _ _ _ => true
                                        | _ => false
                                        end))
                              else
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    (expect_unregistered_key unregistered_pkh) i
                                    op)
                                  (fun i =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar __LOC__
                                        op_startypeminuserrorstar bootstrap
                                        balance fee)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq
                                          (op_startypeminuserrorstar
                                            op_startypeminuserrorstar
                                            orig_contract)
                                          (fun err =>
                                            op_startypeminuserrorstar __LOC__
                                              err
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ => true
                                                | _ => false
                                                end))))))))))).

Definition unregistered_delegate_key_init_delegation {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          let unregistered_delegate_account := op_startypeminuserrorstar tt in
          let unregistered_delegate_pkh := op_startypeminuserrorstar in
          let credit := op_startypeminuserrorstar 10 in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract credit)
            (fun credit_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i credit_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract credit)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar fee op_startypeminuserrorstar
                          impl_contract (Some unregistered_delegate_pkh))
                        (fun delegate_op =>
                          if op_startypeminuserrorstar fee credit then
                            op_gtgteq (op_startypeminuserrorstar i delegate_op)
                              (fun err =>
                                op_startypeminuserrorstar __LOC__ err
                                  (fun function_parameter =>
                                    match function_parameter with
                                    |
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                        _ _ _ => true
                                    | _ => false
                                    end))
                          else
                            op_gtgteqquestion
                              (op_startypeminuserrorstar i
                                (expect_unregistered_key
                                  unregistered_delegate_pkh) delegate_op)
                              (fun i =>
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar __LOC__
                                    op_startypeminuserrorstar impl_contract
                                    credit fee)
                                  (fun function_parameter =>
                                    let 'tt := function_parameter in
                                    op_gtgteq
                                      (op_startypeminuserrorstar
                                        op_startypeminuserrorstar impl_contract)
                                      (fun err =>
                                        op_startypeminuserrorstar __LOC__ err
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ => true
                                            | _ => false
                                            end)))))))))).

Definition unregistered_delegate_key_switch_delegation {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let bootstrap_pkh :=
            op_pipegt (Contract.is_implicit bootstrap)
              (op_startypeminuserrorstar __POS__) in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          let unregistered_delegate_account := op_startypeminuserrorstar tt in
          let unregistered_delegate_pkh := op_startypeminuserrorstar in
          let credit := op_startypeminuserrorstar 10 in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract credit)
            (fun init_credit =>
              op_gtgteqquestion (op_startypeminuserrorstar i init_credit)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract credit)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar Tez.zero
                          op_startypeminuserrorstar impl_contract
                          (Some bootstrap_pkh))
                        (fun delegate_op =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i delegate_op)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar bootstrap)
                                (fun delegate_pkh =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      bootstrap_pkh delegate_pkh)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar fee
                                          op_startypeminuserrorstar
                                          impl_contract
                                          (Some unregistered_delegate_pkh))
                                        (fun delegate_op =>
                                          if
                                            op_startypeminuserrorstar fee credit
                                            then
                                            op_gtgteq
                                              (op_startypeminuserrorstar i
                                                delegate_op)
                                              (fun err =>
                                                op_startypeminuserrorstar
                                                  __LOC__ err
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                        _ _ _ => true
                                                    | _ => false
                                                    end))
                                          else
                                            op_gtgteqquestion
                                              (op_startypeminuserrorstar i
                                                (expect_unregistered_key
                                                  unregistered_delegate_pkh)
                                                delegate_op)
                                              (fun i =>
                                                op_gtgteqquestion
                                                  (op_startypeminuserrorstar
                                                    __LOC__
                                                    op_startypeminuserrorstar
                                                    impl_contract credit fee)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteqquestion
                                                      (op_startypeminuserrorstar
                                                        op_startypeminuserrorstar
                                                        bootstrap)
                                                      (fun delegate_pkh_after =>
                                                        op_startypeminuserrorstar
                                                          __LOC__ delegate_pkh
                                                          delegate_pkh_after))))))))))))).

Definition unregistered_delegate_key_init_origination_credit {A B C : Type}
  (fee : A) (amount : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          bootstrap)
                        (fun balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar fee unregistered_pkh
                              op_startypeminuserrorstar bootstrap
                              op_startypeminuserrorstar)
                            (fun function_parameter =>
                              let '(op, orig_contract) := function_parameter in
                              if op_startypeminuserrorstar fee balance then
                                op_gtgteq (op_startypeminuserrorstar i op)
                                  (fun err =>
                                    op_startypeminuserrorstar __LOC__ err
                                      (fun function_parameter =>
                                        match function_parameter with
                                        |
                                          Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                            _ _ _ => true
                                        | _ => false
                                        end))
                              else
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    (expect_unregistered_key unregistered_pkh) i
                                    op)
                                  (fun i =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar __LOC__
                                        op_startypeminuserrorstar bootstrap
                                        balance fee)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        op_gtgteq
                                          (op_startypeminuserrorstar
                                            op_startypeminuserrorstar
                                            orig_contract)
                                          (fun err =>
                                            op_startypeminuserrorstar __LOC__
                                              err
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | _ => true
                                                | _ => false
                                                end))))))))))).

Definition unregistered_delegate_key_init_delegation_credit {A B : Type}
  (fee : A) (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          let unregistered_delegate_account := op_startypeminuserrorstar tt in
          let unregistered_delegate_pkh := op_startypeminuserrorstar in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      let credit := op_startypeminuserrorstar 10 in
                      op_gtgteqquestion
                        (Lwt._return (op_plusquestion credit amount))
                        (fun balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar Tez.zero
                              op_startypeminuserrorstar bootstrap impl_contract
                              credit)
                            (fun init_credit =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar i init_credit)
                                (fun i =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      op_startypeminuserrorstar impl_contract
                                      balance)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar fee
                                          op_startypeminuserrorstar
                                          impl_contract
                                          (Some unregistered_delegate_pkh))
                                        (fun delegate_op =>
                                          if
                                            op_startypeminuserrorstar fee credit
                                            then
                                            op_gtgteq
                                              (op_startypeminuserrorstar i
                                                delegate_op)
                                              (fun err =>
                                                op_startypeminuserrorstar
                                                  __LOC__ err
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                        _ _ _ => true
                                                    | _ => false
                                                    end))
                                          else
                                            op_gtgteqquestion
                                              (op_startypeminuserrorstar
                                                (expect_unregistered_key
                                                  unregistered_delegate_pkh) i
                                                delegate_op)
                                              (fun i =>
                                                op_gtgteqquestion
                                                  (op_startypeminuserrorstar
                                                    __LOC__
                                                    op_startypeminuserrorstar
                                                    impl_contract balance fee)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteq
                                                      (op_startypeminuserrorstar
                                                        op_startypeminuserrorstar
                                                        impl_contract)
                                                      (fun err =>
                                                        op_startypeminuserrorstar
                                                          __LOC__ err
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ => true
                                                            | _ => false
                                                            end)))))))))))))).

Definition unregistered_delegate_key_switch_delegation_credit {A B : Type}
  (fee : A) (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let bootstrap_pkh :=
            op_pipegt (Contract.is_implicit bootstrap)
              (op_startypeminuserrorstar __POS__) in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          let unregistered_delegate_account := op_startypeminuserrorstar tt in
          let unregistered_delegate_pkh := op_startypeminuserrorstar in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      let credit := op_startypeminuserrorstar 10 in
                      op_gtgteqquestion
                        (Lwt._return (op_plusquestion credit amount))
                        (fun balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar Tez.zero
                              op_startypeminuserrorstar bootstrap impl_contract
                              credit)
                            (fun init_credit =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar i init_credit)
                                (fun i =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      op_startypeminuserrorstar impl_contract
                                      balance)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar Tez.zero
                                          op_startypeminuserrorstar
                                          impl_contract (Some bootstrap_pkh))
                                        (fun delegate_op =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar i
                                              delegate_op)
                                            (fun i =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar
                                                  bootstrap)
                                                (fun delegate_pkh =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      __LOC__ bootstrap_pkh
                                                      delegate_pkh)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          fee
                                                          op_startypeminuserrorstar
                                                          impl_contract
                                                          (Some
                                                            unregistered_delegate_pkh))
                                                        (fun delegate_op =>
                                                          if
                                                            op_startypeminuserrorstar
                                                              fee credit then
                                                            op_gtgteq
                                                              (op_startypeminuserrorstar
                                                                i delegate_op)
                                                              (fun err =>
                                                                op_startypeminuserrorstar
                                                                  __LOC__ err
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    |
                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                                        _ _ _ =>
                                                                      true
                                                                    | _ => false
                                                                    end))
                                                          else
                                                            op_gtgteqquestion
                                                              (op_startypeminuserrorstar
                                                                (expect_unregistered_key
                                                                  unregistered_delegate_pkh)
                                                                i delegate_op)
                                                              (fun i =>
                                                                op_gtgteqquestion
                                                                  (op_startypeminuserrorstar
                                                                    __LOC__
                                                                    op_startypeminuserrorstar
                                                                    impl_contract
                                                                    balance fee)
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    let 'tt :=
                                                                      function_parameter
                                                                      in
                                                                    op_gtgteqquestion
                                                                      (op_startypeminuserrorstar
                                                                        op_startypeminuserrorstar
                                                                        impl_contract)
                                                                      (fun
                                                                        delegate
                                                                        =>
                                                                        op_gtgteqquestion
                                                                          (op_startypeminuserrorstar
                                                                            __LOC__
                                                                            delegate
                                                                            unregistered_delegate_pkh)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              'tt :=
                                                                              function_parameter
                                                                              in
                                                                            op_startypeminuserrorstar
                                                                              __LOC__
                                                                              delegate
                                                                              bootstrap_pkh)))))))))))))))))).

Definition unregistered_delegate_key_init_origination_credit_debit
  {A B C : Type} (fee : A) (amount : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract bootstrap amount)
                        (fun debit_contract =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i debit_contract)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar impl_contract
                                  Tez.zero)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar bootstrap)
                                    (fun balance =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar fee
                                          unregistered_pkh
                                          op_startypeminuserrorstar bootstrap
                                          op_startypeminuserrorstar)
                                        (fun function_parameter =>
                                          let '(op, orig_contract) :=
                                            function_parameter in
                                          if
                                            op_startypeminuserrorstar fee
                                              balance then
                                            op_gtgteq
                                              (op_startypeminuserrorstar i op)
                                              (fun err =>
                                                op_startypeminuserrorstar
                                                  __LOC__ err
                                                  (fun function_parameter =>
                                                    match function_parameter
                                                      with
                                                    |
                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                        _ _ _ => true
                                                    | _ => false
                                                    end))
                                          else
                                            op_gtgteqquestion
                                              (op_startypeminuserrorstar
                                                (expect_unregistered_key
                                                  unregistered_pkh) i op)
                                              (fun i =>
                                                op_gtgteqquestion
                                                  (op_startypeminuserrorstar
                                                    __LOC__
                                                    op_startypeminuserrorstar
                                                    bootstrap balance fee)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    op_gtgteq
                                                      (op_startypeminuserrorstar
                                                        op_startypeminuserrorstar
                                                        orig_contract)
                                                      (fun err =>
                                                        op_startypeminuserrorstar
                                                          __LOC__ err
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            | _ => true
                                                            | _ => false
                                                            end)))))))))))))).

Definition unregistered_delegate_key_init_delegation_credit_debit {A B C : Type}
  (amount : A) (fee : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          let unregistered_delegate_account := op_startypeminuserrorstar tt in
          let unregistered_delegate_pkh := op_startypeminuserrorstar in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar Tez.zero
                          op_startypeminuserrorstar impl_contract bootstrap
                          amount)
                        (fun debit_contract =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i debit_contract)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar impl_contract
                                  Tez.zero)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  let credit := op_startypeminuserrorstar 10 in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar Tez.zero
                                      op_startypeminuserrorstar bootstrap
                                      impl_contract credit)
                                    (fun credit_contract =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar i
                                          credit_contract)
                                        (fun i =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              op_startypeminuserrorstar
                                              impl_contract credit)
                                            (fun function_parameter =>
                                              let '_ := function_parameter in
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar fee
                                                  op_startypeminuserrorstar
                                                  impl_contract
                                                  (Some
                                                    unregistered_delegate_pkh))
                                                (fun delegate_op =>
                                                  if
                                                    op_startypeminuserrorstar
                                                      fee credit then
                                                    op_gtgteq
                                                      (op_startypeminuserrorstar
                                                        i delegate_op)
                                                      (fun err =>
                                                        op_startypeminuserrorstar
                                                          __LOC__ err
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            match
                                                              function_parameter
                                                              with
                                                            |
                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                                _ _ _ => true
                                                            | _ => false
                                                            end))
                                                  else
                                                    op_gtgteqquestion
                                                      (op_startypeminuserrorstar
                                                        (expect_unregistered_key
                                                          unregistered_delegate_pkh)
                                                        i delegate_op)
                                                      (fun i =>
                                                        op_gtgteqquestion
                                                          (op_startypeminuserrorstar
                                                            __LOC__
                                                            op_startypeminuserrorstar
                                                            impl_contract credit
                                                            fee)
                                                          (fun
                                                            function_parameter
                                                            =>
                                                            let 'tt :=
                                                              function_parameter
                                                              in
                                                            op_gtgteq
                                                              (op_startypeminuserrorstar
                                                                op_startypeminuserrorstar
                                                                impl_contract)
                                                              (fun err =>
                                                                op_startypeminuserrorstar
                                                                  __LOC__ err
                                                                  (fun
                                                                    function_parameter
                                                                    =>
                                                                    match
                                                                      function_parameter
                                                                      with
                                                                    | _ => true
                                                                    | _ => false
                                                                    end)))))))))))))))).

Definition unregistered_delegate_key_switch_delegation_credit_debit
  {A B C : Type} (fee : A) (amount : B) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let bootstrap_pkh :=
            op_pipegt (Contract.is_implicit bootstrap)
              (op_startypeminuserrorstar __POS__) in
          let unregistered_account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          let unregistered_delegate_account := op_startypeminuserrorstar tt in
          let unregistered_delegate_pkh := op_startypeminuserrorstar in
          op_gtgteqquestion
            (op_startypeminuserrorstar Tez.zero op_startypeminuserrorstar
              bootstrap impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract bootstrap amount)
                        (fun debit_contract =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i debit_contract)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar impl_contract
                                  Tez.zero)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  let credit := op_startypeminuserrorstar 10 in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar Tez.zero
                                      op_startypeminuserrorstar bootstrap
                                      impl_contract credit)
                                    (fun credit_contract =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar i
                                          credit_contract)
                                        (fun i =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              op_startypeminuserrorstar
                                              impl_contract credit)
                                            (fun function_parameter =>
                                              let '_ := function_parameter in
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  Tez.zero
                                                  op_startypeminuserrorstar
                                                  impl_contract
                                                  (Some bootstrap_pkh))
                                                (fun delegate_op =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar i
                                                      delegate_op)
                                                    (fun i =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          op_startypeminuserrorstar
                                                          bootstrap)
                                                        (fun delegate_pkh =>
                                                          op_gtgteqquestion
                                                            (op_startypeminuserrorstar
                                                              __LOC__
                                                              bootstrap_pkh
                                                              delegate_pkh)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  op_startypeminuserrorstar
                                                                  fee
                                                                  impl_contract
                                                                  (Some
                                                                    unregistered_delegate_pkh))
                                                                (fun delegate_op
                                                                  =>
                                                                  if
                                                                    op_startypeminuserrorstar
                                                                      fee credit
                                                                    then
                                                                    op_gtgteq
                                                                      (op_startypeminuserrorstar
                                                                        i
                                                                        delegate_op)
                                                                      (fun err
                                                                        =>
                                                                        op_startypeminuserrorstar
                                                                          __LOC__
                                                                          err
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            |
                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                                                _
                                                                                _
                                                                                _
                                                                              =>
                                                                              true
                                                                            | _
                                                                              =>
                                                                              false
                                                                            end))
                                                                  else
                                                                    op_gtgteqquestion
                                                                      (op_startypeminuserrorstar
                                                                        (expect_unregistered_key
                                                                          unregistered_delegate_pkh)
                                                                        i
                                                                        delegate_op)
                                                                      (fun i =>
                                                                        op_gtgteqquestion
                                                                          (op_startypeminuserrorstar
                                                                            __LOC__
                                                                            op_startypeminuserrorstar
                                                                            impl_contract
                                                                            credit
                                                                            fee)
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            let
                                                                              'tt :=
                                                                              function_parameter
                                                                              in
                                                                            op_gtgteqquestion
                                                                              (op_startypeminuserrorstar
                                                                                op_startypeminuserrorstar
                                                                                impl_contract)
                                                                              (fun
                                                                                delegate
                                                                                =>
                                                                                op_startypeminuserrorstar
                                                                                  __LOC__
                                                                                  delegate
                                                                                  unregistered_delegate_pkh))))))))))))))))))).

Definition failed_self_delegation_no_transaction {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar impl_contract)
            (fun balance =>
              op_gtgteqquestion
                (op_startypeminuserrorstar __LOC__ Tez.zero balance)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      impl_contract (Some unregistered_pkh))
                    (fun self_delegation =>
                      op_gtgteq (op_startypeminuserrorstar i self_delegation)
                        (fun err =>
                          op_startypeminuserrorstar __LOC__ err
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
                                  pkh =>
                                if
                                  op_startypeminuserrorstar pkh unregistered_pkh
                                  then
                                  true
                                else
                                  false
                              | _ => false
                              end))))))).

Definition failed_self_delegation_emptied_implicit_contract {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let account := op_startypeminuserrorstar tt in
          let unregistered_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract unregistered_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract bootstrap amount)
                        (fun create_contract =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i create_contract)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar impl_contract
                                  Tez.zero)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar impl_contract
                                      (Some unregistered_pkh))
                                    (fun self_delegation =>
                                      op_gtgteq
                                        (op_startypeminuserrorstar i
                                          self_delegation)
                                        (fun err =>
                                          op_startypeminuserrorstar __LOC__ err
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
                                                  pkh =>
                                                if
                                                  op_startypeminuserrorstar pkh
                                                    unregistered_pkh then
                                                  true
                                                else
                                                  false
                                              | _ => false
                                              end))))))))))).

Definition valid_delegate_registration_init_delegation_credit {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let delegate_account := op_startypeminuserrorstar tt in
          let delegate_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract delegate_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some delegate_pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract)
                                (fun delegate =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__ delegate
                                      delegate_pkh)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      let unregistered_account :=
                                        op_startypeminuserrorstar tt in
                                      let unregistered_pkh :=
                                        op_startypeminuserrorstar in
                                      let delegator :=
                                        Contract.implicit_contract
                                          unregistered_pkh in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar Tez.zero
                                          op_startypeminuserrorstar bootstrap
                                          delegator Tez.one)
                                        (fun credit_contract =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar i
                                              credit_contract)
                                            (fun i =>
                                              op_gtgteq
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar
                                                  delegator)
                                                (fun err =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      __LOC__ err
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | _ => true
                                                        | _ => false
                                                        end))
                                                    (fun function_parameter =>
                                                      let '_ :=
                                                        function_parameter in
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          op_startypeminuserrorstar
                                                          delegator
                                                          (Some
                                                            (pkh
                                                              delegate_account)))
                                                        (fun delegation =>
                                                          op_gtgteqquestion
                                                            (op_startypeminuserrorstar
                                                              i delegation)
                                                            (fun i =>
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  op_startypeminuserrorstar
                                                                  delegator)
                                                                (fun
                                                                  delegator_delegate
                                                                  =>
                                                                  op_startypeminuserrorstar
                                                                    __LOC__
                                                                    delegator_delegate
                                                                    delegate_pkh)))))))))))))))).

Definition valid_delegate_registration_switch_delegation_credit {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let delegate_account := op_startypeminuserrorstar tt in
          let delegate_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract delegate_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some delegate_pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract)
                                (fun delegate =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__ delegate
                                      delegate_pkh)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      let unregistered_account :=
                                        op_startypeminuserrorstar tt in
                                      let unregistered_pkh :=
                                        op_startypeminuserrorstar in
                                      let delegator :=
                                        Contract.implicit_contract
                                          unregistered_pkh in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar Tez.zero
                                          op_startypeminuserrorstar bootstrap
                                          delegator Tez.one)
                                        (fun credit_contract =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar i
                                              credit_contract)
                                            (fun i =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar
                                                  bootstrap)
                                                (fun bootstrap_manager =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      op_startypeminuserrorstar
                                                      delegator
                                                      (Some
                                                        (pkh bootstrap_manager)))
                                                    (fun delegation =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          i delegation)
                                                        (fun i =>
                                                          op_gtgteqquestion
                                                            (op_startypeminuserrorstar
                                                              op_startypeminuserrorstar
                                                              delegator)
                                                            (fun
                                                              delegator_delegate
                                                              =>
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  __LOC__
                                                                  delegator_delegate
                                                                  (pkh
                                                                    bootstrap_manager))
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let '_ :=
                                                                    function_parameter
                                                                    in
                                                                  op_gtgteqquestion
                                                                    (op_startypeminuserrorstar
                                                                      op_startypeminuserrorstar
                                                                      delegator
                                                                      (Some
                                                                        (pkh
                                                                          delegate_account)))
                                                                    (fun
                                                                      delegation
                                                                      =>
                                                                      op_gtgteqquestion
                                                                        (op_startypeminuserrorstar
                                                                          i
                                                                          delegation)
                                                                        (fun i
                                                                          =>
                                                                          op_gtgteqquestion
                                                                            (op_startypeminuserrorstar
                                                                              op_startypeminuserrorstar
                                                                              delegator)
                                                                            (fun
                                                                              delegator_delegate
                                                                              =>
                                                                              op_startypeminuserrorstar
                                                                                __LOC__
                                                                                delegator_delegate
                                                                                delegate_pkh))))))))))))))))))).

Definition valid_delegate_registration_init_delegation_credit_debit {A B : Type}
  (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let delegate_account := op_startypeminuserrorstar tt in
          let delegate_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract delegate_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some delegate_pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract)
                                (fun delegate =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      delegate_pkh delegate)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar
                                          impl_contract bootstrap amount)
                                        (fun empty_contract =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar i
                                              empty_contract)
                                            (fun i =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  __LOC__
                                                  op_startypeminuserrorstar
                                                  impl_contract Tez.zero)
                                                (fun function_parameter =>
                                                  let '_ := function_parameter
                                                    in
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      op_startypeminuserrorstar
                                                      impl_contract)
                                                    (fun delegate =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          __LOC__ delegate_pkh
                                                          delegate)
                                                        (fun function_parameter
                                                          =>
                                                          let '_ :=
                                                            function_parameter
                                                            in
                                                          let
                                                            unregistered_account :=
                                                            op_startypeminuserrorstar
                                                              tt in
                                                          let
                                                            unregistered_pkh :=
                                                            op_startypeminuserrorstar
                                                            in
                                                          let delegator :=
                                                            Contract.implicit_contract
                                                              unregistered_pkh
                                                            in
                                                          op_gtgteqquestion
                                                            (op_startypeminuserrorstar
                                                              Tez.zero
                                                              op_startypeminuserrorstar
                                                              bootstrap
                                                              delegator Tez.one)
                                                            (fun credit_contract
                                                              =>
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  i
                                                                  credit_contract)
                                                                (fun i =>
                                                                  op_gtgteq
                                                                    (op_startypeminuserrorstar
                                                                      op_startypeminuserrorstar
                                                                      delegator)
                                                                    (fun err =>
                                                                      op_gtgteqquestion
                                                                        (op_startypeminuserrorstar
                                                                          __LOC__
                                                                          err
                                                                          (fun
                                                                            function_parameter
                                                                            =>
                                                                            match
                                                                              function_parameter
                                                                              with
                                                                            | _
                                                                              =>
                                                                              true
                                                                            | _
                                                                              =>
                                                                              false
                                                                            end))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            '_ :=
                                                                            function_parameter
                                                                            in
                                                                          op_gtgteqquestion
                                                                            (op_startypeminuserrorstar
                                                                              op_startypeminuserrorstar
                                                                              delegator
                                                                              (Some
                                                                                (pkh
                                                                                  delegate_account)))
                                                                            (fun
                                                                              delegation
                                                                              =>
                                                                              op_gtgteqquestion
                                                                                (op_startypeminuserrorstar
                                                                                  i
                                                                                  delegation)
                                                                                (fun
                                                                                  i
                                                                                  =>
                                                                                  op_gtgteqquestion
                                                                                    (op_startypeminuserrorstar
                                                                                      op_startypeminuserrorstar
                                                                                      delegator)
                                                                                    (fun
                                                                                      delegator_delegate
                                                                                      =>
                                                                                      op_startypeminuserrorstar
                                                                                        __LOC__
                                                                                        delegator_delegate
                                                                                        delegate_pkh))))))))))))))))))))).

Definition valid_delegate_registration_switch_delegation_credit_debit
  {A B : Type} (amount : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let delegate_account := op_startypeminuserrorstar tt in
          let delegate_pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract delegate_pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract amount)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract amount)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some delegate_pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract)
                                (fun delegate =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      delegate_pkh delegate)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar
                                          impl_contract bootstrap amount)
                                        (fun empty_contract =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar i
                                              empty_contract)
                                            (fun i =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  __LOC__
                                                  op_startypeminuserrorstar
                                                  impl_contract Tez.zero)
                                                (fun function_parameter =>
                                                  let '_ := function_parameter
                                                    in
                                                  let unregistered_account :=
                                                    op_startypeminuserrorstar tt
                                                    in
                                                  let unregistered_pkh :=
                                                    op_startypeminuserrorstar in
                                                  let delegator :=
                                                    Contract.implicit_contract
                                                      unregistered_pkh in
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      Tez.zero
                                                      op_startypeminuserrorstar
                                                      bootstrap delegator
                                                      Tez.one)
                                                    (fun credit_contract =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          i credit_contract)
                                                        (fun i =>
                                                          op_gtgteqquestion
                                                            (op_startypeminuserrorstar
                                                              op_startypeminuserrorstar
                                                              bootstrap)
                                                            (fun
                                                              bootstrap_manager
                                                              =>
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  op_startypeminuserrorstar
                                                                  delegator
                                                                  (Some
                                                                    (pkh
                                                                      bootstrap_manager)))
                                                                (fun delegation
                                                                  =>
                                                                  op_gtgteqquestion
                                                                    (op_startypeminuserrorstar
                                                                      i
                                                                      delegation)
                                                                    (fun i =>
                                                                      op_gtgteqquestion
                                                                        (op_startypeminuserrorstar
                                                                          op_startypeminuserrorstar
                                                                          delegator)
                                                                        (fun
                                                                          delegator_delegate
                                                                          =>
                                                                          op_gtgteqquestion
                                                                            (op_startypeminuserrorstar
                                                                              __LOC__
                                                                              delegator_delegate
                                                                              (pkh
                                                                                bootstrap_manager))
                                                                            (fun
                                                                              function_parameter
                                                                              =>
                                                                              let
                                                                                '_ :=
                                                                                function_parameter
                                                                                in
                                                                              op_gtgteqquestion
                                                                                (op_startypeminuserrorstar
                                                                                  op_startypeminuserrorstar
                                                                                  delegator
                                                                                  (Some
                                                                                    (pkh
                                                                                      delegate_account)))
                                                                                (fun
                                                                                  delegation
                                                                                  =>
                                                                                  op_gtgteqquestion
                                                                                    (op_startypeminuserrorstar
                                                                                      i
                                                                                      delegation)
                                                                                    (fun
                                                                                      i
                                                                                      =>
                                                                                      op_gtgteqquestion
                                                                                        (op_startypeminuserrorstar
                                                                                          op_startypeminuserrorstar
                                                                                          delegator)
                                                                                        (fun
                                                                                          delegator_delegate
                                                                                          =>
                                                                                          op_startypeminuserrorstar
                                                                                            __LOC__
                                                                                            delegator_delegate
                                                                                            delegate_pkh)))))))))))))))))))))).

Definition double_registration {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let account := op_startypeminuserrorstar tt in
          let pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract Tez.one_mutez)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract Tez.one_mutez)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract
                                  (Some pkh))
                                (fun second_registration =>
                                  op_gtgteq
                                    (op_startypeminuserrorstar i
                                      second_registration)
                                    (fun err =>
                                      op_startypeminuserrorstar __LOC__ err
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
                                            => true
                                          | _ => false
                                          end)))))))))).

Definition double_registration_when_empty {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let account := op_startypeminuserrorstar tt in
          let pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract Tez.one_mutez)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract Tez.one_mutez)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract
                                  bootstrap Tez.one_mutez)
                                (fun empty_contract =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar i empty_contract)
                                    (fun i =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar
                                          impl_contract Tez.zero)
                                        (fun function_parameter =>
                                          let '_ := function_parameter in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar
                                              impl_contract (Some pkh))
                                            (fun second_registration =>
                                              op_gtgteq
                                                (op_startypeminuserrorstar i
                                                  second_registration)
                                                (fun err =>
                                                  op_startypeminuserrorstar
                                                    __LOC__ err
                                                    (fun function_parameter =>
                                                      match function_parameter
                                                        with
                                                      |
                                                        Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
                                                        => true
                                                      | _ => false
                                                      end))))))))))))).

Definition double_registration_when_recredited {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let account := op_startypeminuserrorstar tt in
          let pkh := op_startypeminuserrorstar in
          let impl_contract := Contract.implicit_contract pkh in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              impl_contract Tez.one_mutez)
            (fun create_contract =>
              op_gtgteqquestion (op_startypeminuserrorstar i create_contract)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ op_startypeminuserrorstar
                      impl_contract Tez.one_mutez)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          impl_contract (Some pkh))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar i self_delegation)
                            (fun i =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar impl_contract
                                  bootstrap Tez.one_mutez)
                                (fun empty_contract =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar i empty_contract)
                                    (fun i =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar
                                          impl_contract Tez.zero)
                                        (fun function_parameter =>
                                          let '_ := function_parameter in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar
                                              bootstrap impl_contract
                                              Tez.one_mutez)
                                            (fun create_contract =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar i
                                                  create_contract)
                                                (fun i =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      __LOC__
                                                      op_startypeminuserrorstar
                                                      impl_contract
                                                      Tez.one_mutez)
                                                    (fun function_parameter =>
                                                      let '_ :=
                                                        function_parameter in
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          op_startypeminuserrorstar
                                                          impl_contract
                                                          (Some pkh))
                                                        (fun second_registration
                                                          =>
                                                          op_gtgteq
                                                            (op_startypeminuserrorstar
                                                              i
                                                              second_registration)
                                                            (fun err =>
                                                              op_startypeminuserrorstar
                                                                __LOC__ err
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  match
                                                                    function_parameter
                                                                    with
                                                                  |
                                                                    Tezos_protocol_environment_alpha__Environment.Error_monad.Active_delegate
                                                                    => true
                                                                  | _ => false
                                                                  end)))))))))))))))).

Definition unregistered_and_unrevealed_self_delegate_key_init_delegation
  {A B : Type} (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let '_ := op_startypeminuserrorstar tt in
          let '_ := op_startypeminuserrorstar tt in
          let contract :=
            Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
            in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              contract (op_startypeminuserrorstar 10))
            (fun op =>
              op_gtgteqquestion (op_startypeminuserrorstar i op)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar fee op_startypeminuserrorstar
                      contract (Some op_startypeminuserrorstar))
                    (fun op =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          contract)
                        (fun balance =>
                          if op_startypeminuserrorstar fee balance then
                            op_gtgteq (op_startypeminuserrorstar i op)
                              (fun err =>
                                op_startypeminuserrorstar __LOC__ err
                                  (fun function_parameter =>
                                    match function_parameter with
                                    |
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                        _ _ _ => true
                                    | _ => false
                                    end))
                          else
                            op_gtgteqquestion
                              (op_startypeminuserrorstar
                                (expect_unregistered_key
                                  op_startypeminuserrorstar) i op)
                              (fun i =>
                                op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar contract balance fee))))))).

Definition unregistered_and_revealed_self_delegate_key_init_delegation
  {A B : Type} (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let '_ := op_startypeminuserrorstar tt in
          let '_ := op_startypeminuserrorstar tt in
          let contract :=
            Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
            in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              contract (op_startypeminuserrorstar 10))
            (fun op =>
              op_gtgteqquestion (op_startypeminuserrorstar i op)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      op_startypeminuserrorstar)
                    (fun op =>
                      op_gtgteqquestion (op_startypeminuserrorstar i op)
                        (fun i =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar fee
                              op_startypeminuserrorstar contract
                              (Some op_startypeminuserrorstar))
                            (fun op =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar contract)
                                (fun balance =>
                                  if op_startypeminuserrorstar fee balance then
                                    op_gtgteq (op_startypeminuserrorstar i op)
                                      (fun err =>
                                        op_startypeminuserrorstar __LOC__ err
                                          (fun function_parameter =>
                                            match function_parameter with
                                            |
                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                _ _ _ => true
                                            | _ => false
                                            end))
                                  else
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar
                                        (expect_unregistered_key
                                          op_startypeminuserrorstar) i op)
                                      (fun i =>
                                        op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar contract
                                          balance fee))))))))).

Definition registered_self_delegate_key_init_delegation
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, bootstrap_contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let bootstrap := List.hd bootstrap_contracts in
          let '_ := op_startypeminuserrorstar tt in
          let '_ := op_startypeminuserrorstar tt in
          let contract :=
            Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
            in
          let delegate_contract :=
            Alpha_context.Contract.implicit_contract op_startypeminuserrorstar
            in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar bootstrap
              contract (op_startypeminuserrorstar 10))
            (fun op =>
              op_gtgteqquestion (op_startypeminuserrorstar i op)
                (fun i =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      bootstrap delegate_contract (op_startypeminuserrorstar 1))
                    (fun op =>
                      op_gtgteqquestion (op_startypeminuserrorstar i op)
                        (fun i =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              op_startypeminuserrorstar)
                            (fun op =>
                              op_gtgteqquestion (op_startypeminuserrorstar i op)
                                (fun i =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar
                                      delegate_contract
                                      (Some op_startypeminuserrorstar))
                                    (fun op =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar i op)
                                        (fun i =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar contract
                                              (Some op_startypeminuserrorstar))
                                            (fun op =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar i op)
                                                (fun i =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      op_startypeminuserrorstar
                                                      contract)
                                                    (fun delegate =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          __LOC__ delegate
                                                          op_startypeminuserrorstar)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          return_unit)))))))))))))).

Definition tests_delegate_registration {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar
      "unregistered delegate key (origination, small fee)" % string
      (* ❌ Variants not supported *)
      variant (unregistered_delegate_key_init_origination Tez.one_mutez))
    (cons
      (op_startypeminuserrorstar
        "unregistered delegate key (origination, edge case fee)" % string
        (* ❌ Variants not supported *)
        variant
        (unregistered_delegate_key_init_origination
          (op_startypeminuserrorstar 3999488)))
      (cons
        (op_startypeminuserrorstar
          "unregistered delegate key (origination, large fee)" % string
          (* ❌ Variants not supported *)
          variant
          (unregistered_delegate_key_init_origination
            (op_startypeminuserrorstar 10000000)))
        (cons
          (op_startypeminuserrorstar
            "unregistered delegate key (init with delegation, small fee)" %
              string
            (* ❌ Variants not supported *)
            variant (unregistered_delegate_key_init_delegation Tez.one_mutez))
          (cons
            (op_startypeminuserrorstar
              "unregistered delegate key (init with delegation, max fee)" %
                string
              (* ❌ Variants not supported *)
              variant
              (unregistered_delegate_key_init_delegation
                op_startypeminuserrorstar))
            (cons
              (op_startypeminuserrorstar
                "unregistered delegate key (switch with delegation, small fee)"
                  % string
                (* ❌ Variants not supported *)
                variant
                (unregistered_delegate_key_switch_delegation Tez.one_mutez))
              (cons
                (op_startypeminuserrorstar
                  "unregistered delegate key (switch with delegation, max fee)"
                    % string
                  (* ❌ Variants not supported *)
                  variant
                  (unregistered_delegate_key_switch_delegation
                    op_startypeminuserrorstar))
                (cons
                  (op_startypeminuserrorstar
                    "unregistered delegate key - credit/debit 1μꜩ (origination, small fee)"
                      % string
                    (* ❌ Variants not supported *)
                    variant
                    (unregistered_delegate_key_init_origination_credit_debit
                      Tez.one_mutez Tez.one_mutez))
                  (cons
                    (op_startypeminuserrorstar
                      "unregistered delegate key - credit/debit 1μꜩ (origination, large fee)"
                        % string
                      (* ❌ Variants not supported *)
                      variant
                      (unregistered_delegate_key_init_origination_credit_debit
                        op_startypeminuserrorstar Tez.one_mutez))
                    (cons
                      (op_startypeminuserrorstar
                        "unregistered delegate key - credit/debit 1μꜩ (init with delegation, small fee)"
                          % string
                        (* ❌ Variants not supported *)
                        variant
                        (unregistered_delegate_key_init_delegation_credit_debit
                          Tez.one_mutez Tez.one_mutez))
                      (cons
                        (op_startypeminuserrorstar
                          "unregistered delegate key - credit/debit 1μꜩ (init with delegation, large fee)"
                            % string
                          (* ❌ Variants not supported *)
                          variant
                          (unregistered_delegate_key_init_delegation_credit_debit
                            Tez.one_mutez op_startypeminuserrorstar))
                        (cons
                          (op_startypeminuserrorstar
                            "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, small fee)"
                              % string
                            (* ❌ Variants not supported *)
                            variant
                            (unregistered_delegate_key_switch_delegation_credit_debit
                              Tez.one_mutez Tez.one_mutez))
                          (cons
                            (op_startypeminuserrorstar
                              "unregistered delegate key - credit/debit 1μꜩ (switch with delegation, large fee)"
                                % string
                              (* ❌ Variants not supported *)
                              variant
                              (unregistered_delegate_key_switch_delegation_credit_debit
                                op_startypeminuserrorstar Tez.one_mutez))
                            (cons
                              (op_startypeminuserrorstar
                                "unregistered delegate key - credit 1μꜩ (origination, small fee)"
                                  % string
                                (* ❌ Variants not supported *)
                                variant
                                (unregistered_delegate_key_init_origination_credit
                                  Tez.one_mutez Tez.one_mutez))
                              (cons
                                (op_startypeminuserrorstar
                                  "unregistered delegate key - credit 1μꜩ (origination, edge case fee)"
                                    % string
                                  (* ❌ Variants not supported *)
                                  variant
                                  (unregistered_delegate_key_init_origination_credit
                                    (op_startypeminuserrorstar 3999488)
                                    Tez.one_mutez))
                                (cons
                                  (op_startypeminuserrorstar
                                    "unregistered delegate key - credit 1μꜩ (origination, large fee)"
                                      % string
                                    (* ❌ Variants not supported *)
                                    variant
                                    (unregistered_delegate_key_init_origination_credit
                                      (op_startypeminuserrorstar 10000000)
                                      Tez.one_mutez))
                                  (cons
                                    (op_startypeminuserrorstar
                                      "unregistered delegate key - credit 1μꜩ (init with delegation, small fee)"
                                        % string
                                      (* ❌ Variants not supported *)
                                      variant
                                      (unregistered_delegate_key_init_delegation_credit
                                        Tez.one_mutez Tez.one_mutez))
                                    (cons
                                      (op_startypeminuserrorstar
                                        "unregistered delegate key - credit 1μꜩ (init with delegation, large fee)"
                                          % string
                                        (* ❌ Variants not supported *)
                                        variant
                                        (unregistered_delegate_key_init_delegation_credit
                                          op_startypeminuserrorstar
                                          Tez.one_mutez))
                                      (cons
                                        (op_startypeminuserrorstar
                                          "unregistered delegate key - credit 1μꜩ (switch with delegation, small fee)"
                                            % string
                                          (* ❌ Variants not supported *)
                                          variant
                                          (unregistered_delegate_key_switch_delegation_credit
                                            Tez.one_mutez Tez.one_mutez))
                                        (cons
                                          (op_startypeminuserrorstar
                                            "unregistered delegate key - credit 1μꜩ (switch with delegation, large fee)"
                                              % string
                                            (* ❌ Variants not supported *)
                                            variant
                                            (unregistered_delegate_key_switch_delegation_credit
                                              op_startypeminuserrorstar
                                              Tez.one_mutez))
                                          (cons
                                            (op_startypeminuserrorstar
                                              "unregistered and unrevealed self-delegation (small fee)"
                                                % string
                                              (* ❌ Variants not supported *)
                                              variant
                                              (unregistered_and_unrevealed_self_delegate_key_init_delegation
                                                Tez.one_mutez))
                                            (cons
                                              (op_startypeminuserrorstar
                                                "unregistered and unrevealed self-delegation (large fee)"
                                                  % string
                                                (* ❌ Variants not supported *)
                                                variant
                                                (unregistered_and_unrevealed_self_delegate_key_init_delegation
                                                  op_startypeminuserrorstar))
                                              (cons
                                                (op_startypeminuserrorstar
                                                  "unregistered and revealed self-delegation (small fee)"
                                                    % string
                                                  (* ❌ Variants not supported *)
                                                  variant
                                                  (unregistered_and_revealed_self_delegate_key_init_delegation
                                                    Tez.one_mutez))
                                                (cons
                                                  (op_startypeminuserrorstar
                                                    "unregistered and revealed self-delegation  large fee)"
                                                      % string
                                                    (* ❌ Variants not supported *)
                                                    variant
                                                    (unregistered_and_revealed_self_delegate_key_init_delegation
                                                      op_startypeminuserrorstar))
                                                  (cons
                                                    (op_startypeminuserrorstar
                                                      "registered and revelead self-delegation"
                                                        % string
                                                      (* ❌ Variants not supported *)
                                                      variant
                                                      registered_self_delegate_key_init_delegation)
                                                    (cons
                                                      (op_startypeminuserrorstar
                                                        "failed self-delegation: no transaction"
                                                          % string
                                                        (* ❌ Variants not supported *)
                                                        variant
                                                        failed_self_delegation_no_transaction)
                                                      (cons
                                                        (op_startypeminuserrorstar
                                                          "failed self-delegation: credit & debit 1μꜩ"
                                                            % string
                                                          (* ❌ Variants not supported *)
                                                          variant
                                                          (failed_self_delegation_emptied_implicit_contract
                                                            Tez.one_mutez))
                                                        (cons
                                                          (op_startypeminuserrorstar
                                                            "valid delegate registration: credit 1μꜩ, self delegation (init with delegation)"
                                                              % string
                                                            (* ❌ Variants not supported *)
                                                            variant
                                                            (valid_delegate_registration_init_delegation_credit
                                                              Tez.one_mutez))
                                                          (cons
                                                            (op_startypeminuserrorstar
                                                              "valid delegate registration: credit 1μꜩ, self delegation (switch with delegation)"
                                                                % string
                                                              (* ❌ Variants not supported *)
                                                              variant
                                                              (valid_delegate_registration_switch_delegation_credit
                                                                Tez.one_mutez))
                                                            (cons
                                                              (op_startypeminuserrorstar
                                                                "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (init with delegation)"
                                                                  % string
                                                                (* ❌ Variants not supported *)
                                                                variant
                                                                (valid_delegate_registration_init_delegation_credit_debit
                                                                  Tez.one_mutez))
                                                              (cons
                                                                (op_startypeminuserrorstar
                                                                  "valid delegate registration: credit 1μꜩ, self delegation, debit 1μꜩ (switch with delegation)"
                                                                    % string
                                                                  (* ❌ Variants not supported *)
                                                                  variant
                                                                  (valid_delegate_registration_switch_delegation_credit_debit
                                                                    Tez.one_mutez))
                                                                (cons
                                                                  (op_startypeminuserrorstar
                                                                    "double registration"
                                                                      % string
                                                                    (* ❌ Variants not supported *)
                                                                    variant
                                                                    double_registration)
                                                                  (cons
                                                                    (op_startypeminuserrorstar
                                                                      "double registration when delegate account is emptied"
                                                                        % string
                                                                      (* ❌ Variants not supported *)
                                                                      variant
                                                                      double_registration_when_empty)
                                                                    (cons
                                                                      (op_startypeminuserrorstar
                                                                        "double registration when delegate account is emptied and then recredited"
                                                                          %
                                                                          string
                                                                        (* ❌ Variants not supported *)
                                                                        variant
                                                                        double_registration_when_recredited)
                                                                      []))))))))))))))))))))))))))))))))).

Definition tests {A : Type} : list A :=
  op_at tests_bootstrap_contracts tests_delegate_registration.

src/proto_alpha/lib_protocol/test/double_baking.ml 108 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Double baking evidence operation may happen when a baker
    baked two different blocks on the same level. *)

open Protocol
open Alpha_context

(****************************************************************)
(*                  Utility functions                           *)
(****************************************************************)

let get_first_different_baker baker bakers =
  return
  @@ List.find
       (fun baker' -> Signature.Public_key_hash.( <> ) baker baker')
       bakers

let get_first_different_bakers ctxt =
  Context.get_bakers ctxt
  >>=? fun bakers ->
  let baker_1 = List.hd bakers in
  get_first_different_baker baker_1 (List.tl bakers)
  >>=? fun baker_2 -> return (baker_1, baker_2)

let get_first_different_endorsers ctxt =
  Context.get_endorsers ctxt
  >>=? fun endorsers ->
  let endorser_1 = (List.hd endorsers).delegate in
  let endorser_2 = (List.hd (List.tl endorsers)).delegate in
  return (endorser_1, endorser_2)

(** Bake two block at the same level using the same policy (i.e. same
    baker) *)
let block_fork ?policy contracts b =
  let (contract_a, contract_b) =
    (List.hd contracts, List.hd (List.tl contracts))
  in
  Op.transaction (B b) contract_a contract_b Alpha_context.Tez.one_cent
  >>=? fun operation ->
  Block.bake ?policy ~operation b
  >>=? fun blk_a -> Block.bake ?policy b >>=? fun blk_b -> return (blk_a, blk_b)

(****************************************************************)
(*                        Tests                                 *)
(****************************************************************)

(** Simple scenario where two blocks are baked by a same baker and
    exposed by a double baking evidence operation *)
let valid_double_baking_evidence () =
  Context.init 2
  >>=? fun (b, contracts) ->
  Context.get_bakers (B b)
  >>=? fun bakers ->
  let priority_0_baker = List.hd bakers in
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  Op.double_baking (B blk_a) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~policy:(Excluding [priority_0_baker]) ~operation blk_a
  >>=? fun blk ->
  (* Check that the frozen deposit, the fees and rewards are removed *)
  iter_s
    (fun kind ->
      let contract =
        Alpha_context.Contract.implicit_contract priority_0_baker
      in
      Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
    [Deposit; Fees; Rewards]

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Check that a double baking operation fails if it exposes the same two blocks *)
let same_blocks () =
  Context.init 2
  >>=? fun (b, _contracts) ->
  Block.bake b
  >>=? fun ba ->
  Op.double_baking (B ba) ba.header ba.header
  >>=? fun operation ->
  Block.bake ~operation ba
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_double_baking_evidence _ ->
          true
      | _ ->
          false)
  >>=? fun () -> return_unit

(** Check that a double baking operation exposing two blocks with
    different levels fails *)
let different_levels () =
  Context.init 2
  >>=? fun (b, contracts) ->
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  Block.bake blk_b
  >>=? fun blk_b_2 ->
  Op.double_baking (B blk_a) blk_a.header blk_b_2.header
  >>=? fun operation ->
  Block.bake ~operation blk_a
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_double_baking_evidence _ ->
          true
      | _ ->
          false)

(** Check that a double baking operation exposing two yet to be baked
    blocks fails *)
let too_early_double_baking_evidence () =
  Context.init 2
  >>=? fun (b, contracts) ->
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  Op.double_baking (B b) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Too_early_double_baking_evidence _ ->
          true
      | _ ->
          false)

(** Check that after [preserved_cycles + 1], it is not possible to
    create a double baking operation anymore *)
let too_late_double_baking_evidence () =
  Context.init 2
  >>=? fun (b, contracts) ->
  Context.get_constants (B b)
  >>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
  block_fork ~policy:(By_priority 0) contracts b
  >>=? fun (blk_a, blk_b) ->
  fold_left_s
    (fun blk _ -> Block.bake_until_cycle_end blk)
    blk_a
    (1 -- (preserved_cycles + 1))
  >>=? fun blk ->
  Op.double_baking (B blk) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Outdated_double_baking_evidence _ ->
          true
      | _ ->
          false)

(** Check that an invalid double baking evidence that exposes two block
    baking with same level made by different bakers fails *)
let different_delegates () =
  Context.init 2
  >>=? fun (b, _) ->
  get_first_different_bakers (B b)
  >>=? fun (baker_1, baker_2) ->
  Block.bake ~policy:(By_account baker_1) b
  >>=? fun blk_a ->
  Block.bake ~policy:(By_account baker_2) b
  >>=? fun blk_b ->
  Op.double_baking (B blk_a) blk_a.header blk_b.header
  >>=? fun operation ->
  Block.bake ~operation blk_a
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Apply.Inconsistent_double_baking_evidence _ ->
          true
      | _ ->
          false)

let wrong_signer () =
  (* Baker_2 bakes a block but baker signs it. *)
  let header_custom_signer baker baker_2 b =
    Block.Forge.forge_header ~policy:(By_account baker_2) b
    >>=? fun header ->
    Block.Forge.set_baker baker header |> Block.Forge.sign_header
  in
  Context.init 2
  >>=? fun (b, _) ->
  get_first_different_bakers (B b)
  >>=? fun (baker_1, baker_2) ->
  Block.bake ~policy:(By_account baker_1) b
  >>=? fun blk_a ->
  header_custom_signer baker_1 baker_2 b
  >>=? fun header_b ->
  Op.double_baking (B blk_a) blk_a.header header_b
  >>=? fun operation ->
  Block.bake ~operation blk_a
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Baking.Invalid_block_signature _ ->
          true
      | _ ->
          false)

let tests =
  [ Test.tztest
      "valid double baking evidence"
      `Quick
      valid_double_baking_evidence;
    (* Should fail*)
    Test.tztest "same blocks" `Quick same_blocks;
    Test.tztest "different levels" `Quick different_levels;
    Test.tztest
      "too early double baking evidence"
      `Quick
      too_early_double_baking_evidence;
    Test.tztest
      "too late double baking evidence"
      `Quick
      too_late_double_baking_evidence;
    Test.tztest "different delegates" `Quick different_delegates;
    Test.tztest "wrong delegate" `Quick wrong_signer ]
src/proto_alpha/lib_protocol/test/double_baking.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition get_first_different_baker {A B : Type}
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (bakers : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  op_atat _return
    (op_startypeminuserrorstar
      (fun baker' => Signature.Public_key_hash.op_ltgt baker baker') bakers).

Definition get_first_different_bakers {A B : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * B)) :=
  op_gtgteqquestion (op_startypeminuserrorstar ctxt)
    (fun bakers =>
      let baker_1 := List.hd bakers in
      op_gtgteqquestion (get_first_different_baker baker_1 (List.tl bakers))
        (fun baker_2 => _return (baker_1, baker_2))).

Definition get_first_different_endorsers {A B C : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * C)) :=
  op_gtgteqquestion (op_startypeminuserrorstar ctxt)
    (fun endorsers =>
      let endorser_1 := delegate (List.hd endorsers) in
      let endorser_2 := delegate (List.hd (List.tl endorsers)) in
      _return (endorser_1, endorser_2)).

Definition block_fork {A B C D E : Type}
  (policy : option A) (contracts : list B) (b : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (D * E)) :=
  let '(contract_a, contract_b) :=
    ((List.hd contracts), (List.hd (List.tl contracts))) in
  op_gtgteqquestion
    (op_startypeminuserrorstar op_startypeminuserrorstar contract_a contract_b
      Alpha_context.Tez.one_cent)
    (fun operation =>
      op_gtgteqquestion (op_startypeminuserrorstar policy operation b)
        (fun blk_a =>
          op_gtgteqquestion (op_startypeminuserrorstar policy b)
            (fun blk_b => _return (blk_a, blk_b)))).

Definition valid_double_baking_evidence (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun bakers =>
          let priority_0_baker := List.hd bakers in
          op_gtgteqquestion
            (block_fork (Some op_startypeminuserrorstar) contracts b)
            (fun function_parameter =>
              let '(blk_a, blk_b) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (header blk_a) (header blk_b))
                (fun operation =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      operation blk_a)
                    (fun blk =>
                      iter_s
                        (fun kind =>
                          let contract :=
                            Alpha_context.Contract.implicit_contract
                              priority_0_baker in
                          op_startypeminuserrorstar __LOC__
                            op_startypeminuserrorstar contract kind Tez.zero)
                        (cons op_startypeminuserrorstar
                          (cons op_startypeminuserrorstar
                            (cons op_startypeminuserrorstar [])))))))).

Definition same_blocks (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun ba =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar (header ba)
              (header ba))
            (fun operation =>
              op_gtgteq (op_startypeminuserrorstar operation ba)
                (fun res =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ res
                      (fun function_parameter =>
                        match function_parameter with
                        |
                          Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_baking_evidence
                            _ => true
                        | _ => false
                        end))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      return_unit))))).

Definition different_levels {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      op_gtgteqquestion
        (block_fork (Some op_startypeminuserrorstar) contracts b)
        (fun function_parameter =>
          let '(blk_a, blk_b) := function_parameter in
          op_gtgteqquestion (op_startypeminuserrorstar blk_b)
            (fun blk_b_2 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (header blk_a) (header blk_b_2))
                (fun operation =>
                  op_gtgteq (op_startypeminuserrorstar operation blk_a)
                    (fun res =>
                      op_startypeminuserrorstar __LOC__ res
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_baking_evidence
                              _ => true
                          | _ => false
                          end)))))).

Definition too_early_double_baking_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      op_gtgteqquestion
        (block_fork (Some op_startypeminuserrorstar) contracts b)
        (fun function_parameter =>
          let '(blk_a, blk_b) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar (header blk_a)
              (header blk_b))
            (fun operation =>
              op_gtgteq (op_startypeminuserrorstar operation b)
                (fun res =>
                  op_startypeminuserrorstar __LOC__ res
                    (fun function_parameter =>
                      match function_parameter with
                      |
                        Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_baking_evidence
                          _ => true
                      | _ => false
                      end))))).

Definition too_late_double_baking_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '{| parametric := {| preserved_cycles := preserved_cycles |} |} :=
            function_parameter in
          op_gtgteqquestion
            (block_fork (Some op_startypeminuserrorstar) contracts b)
            (fun function_parameter =>
              let '(blk_a, blk_b) := function_parameter in
              op_gtgteqquestion
                (fold_left_s
                  (fun blk =>
                    fun function_parameter =>
                      let '_ := function_parameter in
                      op_startypeminuserrorstar blk) blk_a
                  (op_startypeminuserrorstar 1 (op_plus preserved_cycles 1)))
                (fun blk =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (header blk_a) (header blk_b))
                    (fun operation =>
                      op_gtgteq (op_startypeminuserrorstar operation blk)
                        (fun res =>
                          op_startypeminuserrorstar __LOC__ res
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_baking_evidence
                                  _ => true
                              | _ => false
                              end))))))).

Definition different_delegates {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (get_first_different_bakers op_startypeminuserrorstar)
        (fun function_parameter =>
          let '(baker_1, baker_2) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar b)
            (fun blk_a =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar b)
                (fun blk_b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (header blk_a) (header blk_b))
                    (fun operation =>
                      op_gtgteq (op_startypeminuserrorstar operation blk_a)
                        (fun e =>
                          op_startypeminuserrorstar __LOC__ e
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_baking_evidence
                                  _ => true
                              | _ => false
                              end))))))).

Definition wrong_signer {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  let header_custom_signer {B C D E : Type} (baker : B) (baker_2 : C) (b : D)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult E) :=
    op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar b)
      (fun header =>
        op_pipegt (op_startypeminuserrorstar baker header)
          op_startypeminuserrorstar) in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (get_first_different_bakers op_startypeminuserrorstar)
        (fun function_parameter =>
          let '(baker_1, baker_2) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar b)
            (fun blk_a =>
              op_gtgteqquestion (header_custom_signer baker_1 baker_2 b)
                (fun header_b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (header blk_a) header_b)
                    (fun operation =>
                      op_gtgteq (op_startypeminuserrorstar operation blk_a)
                        (fun e =>
                          op_startypeminuserrorstar __LOC__ e
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_block_signature
                                  _ _ => true
                              | _ => false
                              end))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "valid double baking evidence" % string
      (* ❌ Variants not supported *)
      variant valid_double_baking_evidence)
    (cons
      (op_startypeminuserrorstar "same blocks" % string
        (* ❌ Variants not supported *)
        variant same_blocks)
      (cons
        (op_startypeminuserrorstar "different levels" % string
          (* ❌ Variants not supported *)
          variant different_levels)
        (cons
          (op_startypeminuserrorstar "too early double baking evidence" % string
            (* ❌ Variants not supported *)
            variant too_early_double_baking_evidence)
          (cons
            (op_startypeminuserrorstar
              "too late double baking evidence" % string
              (* ❌ Variants not supported *)
              variant too_late_double_baking_evidence)
            (cons
              (op_startypeminuserrorstar "different delegates" % string
                (* ❌ Variants not supported *)
                variant different_delegates)
              (cons
                (op_startypeminuserrorstar "wrong delegate" % string
                  (* ❌ Variants not supported *)
                  variant wrong_signer) [])))))).

src/proto_alpha/lib_protocol/test/double_endorsement.ml 126 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Double endorsement evidence operation may happen when an endorser
    endorsed two different blocks on the same level. *)

open Protocol
open Alpha_context

(****************************************************************)
(*                  Utility functions                           *)
(****************************************************************)

let get_first_different_baker baker bakers =
  return
  @@ List.find
       (fun baker' -> Signature.Public_key_hash.( <> ) baker baker')
       bakers

let get_first_different_bakers ctxt =
  Context.get_bakers ctxt
  >>=? fun bakers ->
  let baker_1 = List.hd bakers in
  get_first_different_baker baker_1 (List.tl bakers)
  >>=? fun baker_2 -> return (baker_1, baker_2)

let get_first_different_endorsers ctxt =
  Context.get_endorsers ctxt
  >>=? fun endorsers ->
  let endorser_1 = List.hd endorsers in
  let endorser_2 = List.hd (List.tl endorsers) in
  return (endorser_1, endorser_2)

let block_fork b =
  get_first_different_bakers (B b)
  >>=? fun (baker_1, baker_2) ->
  Block.bake ~policy:(By_account baker_1) b
  >>=? fun blk_a ->
  Block.bake ~policy:(By_account baker_2) b
  >>=? fun blk_b -> return (blk_a, blk_b)

(****************************************************************)
(*                        Tests                                 *)
(****************************************************************)

(** Simple scenario where two endorsements are made from the same
    delegate and exposed by a double_endorsement operation. Also verify
    that punishment is operated. *)
let valid_double_endorsement_evidence () =
  Context.init 2
  >>=? fun (b, _) ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B blk_a) ()
  >>=? fun endorsement_a ->
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  Block.bake ~operations:[Operation.pack endorsement_a] blk_a
  >>=? fun blk_a ->
  (* Block.bake ~operations:[endorsement_b] blk_b >>=? fun _ -> *)
  Op.double_endorsement (B blk_a) endorsement_a endorsement_b
  >>=? fun operation ->
  (* Bake with someone different than the bad endorser *)
  Context.get_bakers (B blk_a)
  >>=? fun bakers ->
  get_first_different_baker delegate bakers
  >>=? fun baker ->
  Block.bake ~policy:(By_account baker) ~operation blk_a
  >>=? fun blk ->
  (* Check that the frozen deposit, the fees and rewards are removed *)
  iter_s
    (fun kind ->
      let contract = Alpha_context.Contract.implicit_contract delegate in
      Assert.balance_is ~loc:__LOC__ (B blk) contract ~kind Tez.zero)
    [Deposit; Fees; Rewards]

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Check that an invalid double endorsement operation that exposes a valid
    endorsement fails. *)
let invalid_double_endorsement () =
  Context.init 10
  >>=? fun (b, _) ->
  Block.bake b
  >>=? fun b ->
  Op.endorsement (B b) ()
  >>=? fun endorsement ->
  Block.bake ~operation:(Operation.pack endorsement) b
  >>=? fun b ->
  Op.double_endorsement (B b) endorsement endorsement
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_double_endorsement_evidence ->
          true
      | _ ->
          false)

(** Check that a double endorsement added at the same time as a double
    endorsement operation fails. *)
let too_early_double_endorsement_evidence () =
  Context.init 2
  >>=? fun (b, _) ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B blk_a) ()
  >>=? fun endorsement_a ->
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  Op.double_endorsement (B b) endorsement_a endorsement_b
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Too_early_double_endorsement_evidence _ ->
          true
      | _ ->
          false)

(** Check that after [preserved_cycles + 1], it is not possible
    to create a double_endorsement anymore. *)
let too_late_double_endorsement_evidence () =
  Context.init 2
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B blk_a) ()
  >>=? fun endorsement_a ->
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  fold_left_s
    (fun blk _ -> Block.bake_until_cycle_end blk)
    blk_a
    (1 -- (preserved_cycles + 1))
  >>=? fun blk ->
  Op.double_endorsement (B blk) endorsement_a endorsement_b
  >>=? fun operation ->
  Block.bake ~operation blk
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Outdated_double_endorsement_evidence _ ->
          true
      | _ ->
          false)

(** Check that an invalid double endorsement evidence that expose two
    endorsements made by two different endorsers fails. *)
let different_delegates () =
  Context.init 2
  >>=? fun (b, _) ->
  Block.bake b
  >>=? fun b ->
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (endorser_a, _a_slots) ->
  get_first_different_endorsers (B blk_b)
  >>=? fun (endorser_b1c, endorser_b2c) ->
  let endorser_b =
    if Signature.Public_key_hash.( = ) endorser_a endorser_b1c.delegate then
      endorser_b2c.delegate
    else endorser_b1c.delegate
  in
  Op.endorsement ~delegate:endorser_a (B blk_a) ()
  >>=? fun e_a ->
  Op.endorsement ~delegate:endorser_b (B blk_b) ()
  >>=? fun e_b ->
  Block.bake ~operation:(Operation.pack e_b) blk_b
  >>=? fun _ ->
  Op.double_endorsement (B blk_b) e_a e_b
  >>=? fun operation ->
  Block.bake ~operation blk_b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Inconsistent_double_endorsement_evidence _ ->
          true
      | _ ->
          false)

(** Check that a double endorsement evidence that exposes a ill-formed
    endorsement fails. *)
let wrong_delegate () =
  Context.init ~endorsers_per_block:1 2
  >>=? fun (b, contracts) ->
  Error_monad.map_s (Context.Contract.manager (B b)) contracts
  >>=? fun accounts ->
  let pkh1 = (List.nth accounts 0).Account.pkh in
  let pkh2 = (List.nth accounts 1).Account.pkh in
  block_fork b
  >>=? fun (blk_a, blk_b) ->
  Context.get_endorser (B blk_a)
  >>=? fun (endorser_a, _a_slots) ->
  Op.endorsement ~delegate:endorser_a (B blk_a) ()
  >>=? fun endorsement_a ->
  Context.get_endorser (B blk_b)
  >>=? fun (endorser_b, _b_slots) ->
  let delegate =
    if Signature.Public_key_hash.equal pkh1 endorser_b then pkh2 else pkh1
  in
  Op.endorsement ~delegate (B blk_b) ()
  >>=? fun endorsement_b ->
  Op.double_endorsement (B blk_b) endorsement_a endorsement_b
  >>=? fun operation ->
  Block.bake ~operation blk_b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Baking.Unexpected_endorsement ->
          true
      | _ ->
          false)

let tests =
  [ Test.tztest
      "valid double endorsement evidence"
      `Quick
      valid_double_endorsement_evidence;
    Test.tztest
      "invalid double endorsement evidence"
      `Quick
      invalid_double_endorsement;
    Test.tztest
      "too early double endorsement evidence"
      `Quick
      too_early_double_endorsement_evidence;
    Test.tztest
      "too late double endorsement evidence"
      `Quick
      too_late_double_endorsement_evidence;
    Test.tztest "different delegates" `Quick different_delegates;
    Test.tztest "wrong delegate" `Quick wrong_delegate ]
src/proto_alpha/lib_protocol/test/double_endorsement.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition get_first_different_baker {A B : Type}
  (baker :
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (bakers : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  op_atat _return
    (op_startypeminuserrorstar
      (fun baker' => Signature.Public_key_hash.op_ltgt baker baker') bakers).

Definition get_first_different_bakers {A B : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * B)) :=
  op_gtgteqquestion (op_startypeminuserrorstar ctxt)
    (fun bakers =>
      let baker_1 := List.hd bakers in
      op_gtgteqquestion (get_first_different_baker baker_1 (List.tl bakers))
        (fun baker_2 => _return (baker_1, baker_2))).

Definition get_first_different_endorsers {A B : Type} (ctxt : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * B)) :=
  op_gtgteqquestion (op_startypeminuserrorstar ctxt)
    (fun endorsers =>
      let endorser_1 := List.hd endorsers in
      let endorser_2 := List.hd (List.tl endorsers) in
      _return (endorser_1, endorser_2)).

Definition block_fork {A B C : Type} (b : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (B * C)) :=
  op_gtgteqquestion (get_first_different_bakers op_startypeminuserrorstar)
    (fun function_parameter =>
      let '(baker_1, baker_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar b)
        (fun blk_a =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar b)
            (fun blk_b => _return (blk_a, blk_b)))).

Definition valid_double_endorsement_evidence (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (block_fork b)
        (fun function_parameter =>
          let '(blk_a, blk_b) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(delegate, _slots) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
                (fun endorsement_a =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar delegate
                      op_startypeminuserrorstar tt)
                    (fun endorsement_b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar
                          (cons (Operation.pack endorsement_a) []) blk_a)
                        (fun blk_a =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              endorsement_a endorsement_b)
                            (fun operation =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar)
                                (fun bakers =>
                                  op_gtgteqquestion
                                    (get_first_different_baker delegate bakers)
                                    (fun baker =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar operation
                                          blk_a)
                                        (fun blk =>
                                          iter_s
                                            (fun kind =>
                                              let contract :=
                                                Alpha_context.Contract.implicit_contract
                                                  delegate in
                                              op_startypeminuserrorstar __LOC__
                                                op_startypeminuserrorstar
                                                contract kind Tez.zero)
                                            (cons op_startypeminuserrorstar
                                              (cons op_startypeminuserrorstar
                                                (cons op_startypeminuserrorstar
                                                  []))))))))))))).

Definition invalid_double_endorsement {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 10)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar tt)
            (fun endorsement =>
              op_gtgteqquestion
                (op_startypeminuserrorstar (Operation.pack endorsement) b)
                (fun b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      endorsement endorsement)
                    (fun operation =>
                      op_gtgteq (op_startypeminuserrorstar operation b)
                        (fun res =>
                          op_startypeminuserrorstar __LOC__ res
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_double_endorsement_evidence
                                => true
                              | _ => false
                              end))))))).

Definition too_early_double_endorsement_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (block_fork b)
        (fun function_parameter =>
          let '(blk_a, blk_b) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(delegate, _slots) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
                (fun endorsement_a =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar delegate
                      op_startypeminuserrorstar tt)
                    (fun endorsement_b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          endorsement_a endorsement_b)
                        (fun operation =>
                          op_gtgteq (op_startypeminuserrorstar operation b)
                            (fun res =>
                              op_startypeminuserrorstar __LOC__ res
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.Too_early_double_endorsement_evidence
                                      _ => true
                                  | _ => false
                                  end)))))))).

Definition too_late_double_endorsement_evidence {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '{| parametric := {| preserved_cycles := preserved_cycles |} |} :=
            function_parameter in
          op_gtgteqquestion (block_fork b)
            (fun function_parameter =>
              let '(blk_a, blk_b) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(delegate, _slots) := function_parameter in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar delegate
                      op_startypeminuserrorstar tt)
                    (fun endorsement_a =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar delegate
                          op_startypeminuserrorstar tt)
                        (fun endorsement_b =>
                          op_gtgteqquestion
                            (fold_left_s
                              (fun blk =>
                                fun function_parameter =>
                                  let '_ := function_parameter in
                                  op_startypeminuserrorstar blk) blk_a
                              (op_startypeminuserrorstar 1
                                (op_plus preserved_cycles 1)))
                            (fun blk =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar endorsement_a
                                  endorsement_b)
                                (fun operation =>
                                  op_gtgteq
                                    (op_startypeminuserrorstar operation blk)
                                    (fun res =>
                                      op_startypeminuserrorstar __LOC__ res
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Outdated_double_endorsement_evidence
                                              _ => true
                                          | _ => false
                                          end)))))))))).

Definition different_delegates {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion (block_fork b)
            (fun function_parameter =>
              let '(blk_a, blk_b) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(endorser_a, _a_slots) := function_parameter in
                  op_gtgteqquestion
                    (get_first_different_endorsers op_startypeminuserrorstar)
                    (fun function_parameter =>
                      let '(endorser_b1c, endorser_b2c) := function_parameter in
                      let endorser_b :=
                        if
                          Signature.Public_key_hash.op_eq endorser_a
                            (delegate endorser_b1c) then
                          delegate endorser_b2c
                        else
                          delegate endorser_b1c in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar endorser_a
                          op_startypeminuserrorstar tt)
                        (fun e_a =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar endorser_b
                              op_startypeminuserrorstar tt)
                            (fun e_b =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar (Operation.pack e_b)
                                  blk_b)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar e_a e_b)
                                    (fun operation =>
                                      op_gtgteq
                                        (op_startypeminuserrorstar operation
                                          blk_b)
                                        (fun res =>
                                          op_startypeminuserrorstar __LOC__ res
                                            (fun function_parameter =>
                                              match function_parameter with
                                              |
                                                Tezos_protocol_environment_alpha__Environment.Error_monad.Inconsistent_double_endorsement_evidence
                                                  _ => true
                                              | _ => false
                                              end))))))))))).

Definition wrong_delegate {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      op_gtgteqquestion
        (Error_monad.map_s (op_startypeminuserrorstar op_startypeminuserrorstar)
          contracts)
        (fun accounts =>
          let pkh1 := Account.pkh (op_startypeminuserrorstar accounts 0) in
          let pkh2 := Account.pkh (op_startypeminuserrorstar accounts 1) in
          op_gtgteqquestion (block_fork b)
            (fun function_parameter =>
              let '(blk_a, blk_b) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(endorser_a, _a_slots) := function_parameter in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar endorser_a
                      op_startypeminuserrorstar tt)
                    (fun endorsement_a =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar)
                        (fun function_parameter =>
                          let '(endorser_b, _b_slots) := function_parameter in
                          let delegate :=
                            if Signature.Public_key_hash.equal pkh1 endorser_b
                              then
                              pkh2
                            else
                              pkh1 in
                          op_gtgteqquestion
                            (op_startypeminuserrorstar delegate
                              op_startypeminuserrorstar tt)
                            (fun endorsement_b =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar endorsement_a
                                  endorsement_b)
                                (fun operation =>
                                  op_gtgteq
                                    (op_startypeminuserrorstar operation blk_b)
                                    (fun e =>
                                      op_startypeminuserrorstar __LOC__ e
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Unexpected_endorsement
                                            => true
                                          | _ => false
                                          end)))))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "valid double endorsement evidence" % string
      (* ❌ Variants not supported *)
      variant valid_double_endorsement_evidence)
    (cons
      (op_startypeminuserrorstar "invalid double endorsement evidence" % string
        (* ❌ Variants not supported *)
        variant invalid_double_endorsement)
      (cons
        (op_startypeminuserrorstar
          "too early double endorsement evidence" % string
          (* ❌ Variants not supported *)
          variant too_early_double_endorsement_evidence)
        (cons
          (op_startypeminuserrorstar
            "too late double endorsement evidence" % string
            (* ❌ Variants not supported *)
            variant too_late_double_endorsement_evidence)
          (cons
            (op_startypeminuserrorstar "different delegates" % string
              (* ❌ Variants not supported *)
              variant different_delegates)
            (cons
              (op_startypeminuserrorstar "wrong delegate" % string
                (* ❌ Variants not supported *)
                variant wrong_delegate) []))))).

src/proto_alpha/lib_protocol/test/endorsement.ml 302 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Endorsing a block adds an extra layer of confidence to the Tezos's
    PoS algorithm. The block endorsing operation must be included in
    the following block. Each endorser possess a number of slots
    corresponding to their priority. After [preserved_cycles], a reward
    is given to the endorser. This reward depends on the priority of
    the block that contains the endorsements. *)

open Protocol
open Alpha_context
open Test_utils
open Test_tez

(****************************************************************)
(*                    Utility functions                         *)
(****************************************************************)

let get_expected_reward ctxt ~priority ~baker ~endorsing_power =
  ( if baker then Context.get_baking_reward ctxt ~priority ~endorsing_power
  else return (Test_tez.Tez.of_int 0) )
  >>=? fun baking_reward ->
  Context.get_endorsing_reward ctxt ~priority ~endorsing_power
  >>=? fun endorsing_reward ->
  Test_tez.Tez.(endorsing_reward +? baking_reward)
  >>?= fun reward -> return reward

let get_expected_deposit ctxt ~baker ~endorsing_power =
  Context.get_constants ctxt
  >>=? fun Constants.
             { parametric =
                 {endorsement_security_deposit; block_security_deposit; _};
               _ } ->
  let open Environment in
  let open Tez in
  let baking_deposit = if baker then block_security_deposit else of_int 0 in
  endorsement_security_deposit *? Int64.of_int endorsing_power
  >>?= fun endorsement_deposit ->
  endorsement_deposit +? baking_deposit >>?= fun deposit -> return deposit

(* [baker] is true if the [pkh] has also baked the current block, in
   which case correspoding deposit and reward should be ajusted *)
let assert_endorser_balance_consistency ~loc ?(priority = 0) ?(baker = false)
    ~endorsing_power ctxt pkh initial_balance =
  let contract = Contract.implicit_contract pkh in
  get_expected_reward ctxt ~priority ~baker ~endorsing_power
  >>=? fun reward ->
  get_expected_deposit ctxt ~baker ~endorsing_power
  >>=? fun deposit ->
  Assert.balance_was_debited ~loc ctxt contract initial_balance deposit
  >>=? fun () ->
  Context.Contract.balance ~kind:Rewards ctxt contract
  >>=? fun reward_balance ->
  Assert.equal_tez ~loc reward_balance reward
  >>=? fun () ->
  Context.Contract.balance ~kind:Deposit ctxt contract
  >>=? fun deposit_balance -> Assert.equal_tez ~loc deposit_balance deposit

let delegates_with_slots endorsers =
  List.map
    (fun (endorser : Delegate_services.Endorsing_rights.t) ->
      endorser.delegate)
    endorsers

let endorsing_power endorsers =
  List.fold_left
    (fun sum (endorser : Delegate_services.Endorsing_rights.t) ->
      sum + List.length endorser.slots)
    0
    endorsers

(****************************************************************)
(*                      Tests                                   *)
(****************************************************************)

(** Apply a single endorsement from the slot 0 endorser *)
let simple_endorsement () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_endorser (B b)
  >>=? fun (delegate, slots) ->
  Op.endorsement ~delegate (B b) ()
  >>=? fun op ->
  Context.Contract.balance (B b) (Contract.implicit_contract delegate)
  >>=? fun initial_balance ->
  let policy = Block.Excluding [delegate] in
  Block.get_next_baker ~policy b
  >>=? fun (_, priority, _) ->
  Block.bake ~policy ~operations:[Operation.pack op] b
  >>=? fun b2 ->
  assert_endorser_balance_consistency
    ~loc:__LOC__
    (B b2)
    ~priority
    ~endorsing_power:(List.length slots)
    delegate
    initial_balance

(** Apply a maximum number of endorsements. An endorser can be
    selected twice. *)
let max_endorsement () =
  let endorsers_per_block = 16 in
  Context.init ~endorsers_per_block 32
  >>=? fun (b, _) ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  Assert.equal_int
    ~loc:__LOC__
    (List.length
       (List.concat
          (List.map
             (fun {Alpha_services.Delegate.Endorsing_rights.slots; _} -> slots)
             endorsers)))
    endorsers_per_block
  >>=? fun () ->
  fold_left_s
    (fun (delegates, ops, balances)
         (endorser : Alpha_services.Delegate.Endorsing_rights.t) ->
      let delegate = endorser.delegate in
      Context.Contract.balance (B b) (Contract.implicit_contract delegate)
      >>=? fun balance ->
      Op.endorsement ~delegate (B b) ()
      >>=? fun op ->
      return
        ( delegate :: delegates,
          Operation.pack op :: ops,
          (List.length endorser.slots, balance) :: balances ))
    ([], [], [])
    endorsers
  >>=? fun (delegates, ops, previous_balances) ->
  Block.bake ~policy:(Excluding delegates) ~operations:(List.rev ops) b
  >>=? fun b ->
  (* One account can endorse more than one time per level, we must
     check that the bonds are summed up *)
  iter_s
    (fun (endorser_account, (endorsing_power, previous_balance)) ->
      assert_endorser_balance_consistency
        ~loc:__LOC__
        (B b)
        ~endorsing_power
        endorser_account
        previous_balance)
    (List.combine delegates previous_balances)

(** Check every that endorsers' balances are consistent with different priorities *)
let consistent_priorities () =
  let priorities = 0 -- 64 in
  Context.init 64
  >>=? fun (b, _) ->
  fold_left_s
    (fun (b, used_pkhes) priority ->
      (* Choose an endorser that has not baked nor endorsed before *)
      Context.get_endorsers (B b)
      >>=? fun endorsers ->
      let endorser =
        List.find_opt
          (fun (e : Delegate_services.Endorsing_rights.t) ->
            not (Signature.Public_key_hash.Set.mem e.delegate used_pkhes))
          endorsers
      in
      match endorser with
      | None ->
          return (b, used_pkhes) (* not enough fresh endorsers; we "stop" *)
      | Some endorser ->
          Context.Contract.balance
            (B b)
            (Contract.implicit_contract endorser.delegate)
          >>=? fun balance ->
          Op.endorsement ~delegate:endorser.delegate (B b) ()
          >>=? fun operation ->
          let operation = Operation.pack operation in
          Block.get_next_baker ~policy:(By_priority priority) b
          >>=? fun (baker, _, _) ->
          let used_pkhes =
            Signature.Public_key_hash.Set.add baker used_pkhes
          in
          let used_pkhes =
            Signature.Public_key_hash.Set.add endorser.delegate used_pkhes
          in
          (* Bake with a specific priority *)
          Block.bake ~policy:(By_priority priority) ~operation b
          >>=? fun b ->
          let is_baker =
            Signature.Public_key_hash.(baker = endorser.delegate)
          in
          assert_endorser_balance_consistency
            ~loc:__LOC__
            ~priority
            ~baker:is_baker
            (B b)
            ~endorsing_power:(List.length endorser.slots)
            endorser.delegate
            balance
          >>=? fun () -> return (b, used_pkhes))
    (b, Signature.Public_key_hash.Set.empty)
    priorities
  >>=? fun _b -> return_unit

(** Check that after [preserved_cycles] cycles the endorser gets his reward *)
let reward_retrieval () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun Constants.{parametric = {preserved_cycles; _}; _} ->
  Context.get_endorser (B b)
  >>=? fun (endorser, slots) ->
  Context.Contract.balance (B b) (Contract.implicit_contract endorser)
  >>=? fun balance ->
  Op.endorsement ~delegate:endorser (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  let policy = Block.Excluding [endorser] in
  Block.get_next_baker ~policy b
  >>=? fun (_, priority, _) ->
  Block.bake ~policy ~operation b
  >>=? fun b ->
  (* Bake (preserved_cycles + 1) cycles *)
  fold_left_s
    (fun b _ -> Block.bake_until_cycle_end ~policy:(Excluding [endorser]) b)
    b
    (0 -- preserved_cycles)
  >>=? fun b ->
  get_expected_reward
    (B b)
    ~priority
    ~baker:false
    ~endorsing_power:(List.length slots)
  >>=? fun reward ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser)
    balance
    reward

(** Check that after [preserved_cycles] cycles endorsers get their
    reward. Two endorsers are used and they endorse in different
    cycles. *)
let reward_retrieval_two_endorsers () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun Constants.
             { parametric =
                 { preserved_cycles;
                   endorsement_reward;
                   endorsement_security_deposit;
                   _ };
               _ } ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  let endorser1 = List.hd endorsers in
  let endorser2 = List.hd (List.tl endorsers) in
  Context.Contract.balance
    (B b)
    (Contract.implicit_contract endorser1.delegate)
  >>=? fun balance1 ->
  Context.Contract.balance
    (B b)
    (Contract.implicit_contract endorser2.delegate)
  >>=? fun balance2 ->
  Lwt.return
    Tez.(
      endorsement_security_deposit
      *? Int64.of_int (List.length endorser1.slots))
  >>=? fun security_deposit1 ->
  (* endorser1 endorses the genesis block in cycle 0 *)
  Op.endorsement ~delegate:endorser1.delegate (B b) ()
  >>=? fun operation1 ->
  let policy = Block.Excluding [endorser1.delegate; endorser2.delegate] in
  Block.get_next_baker ~policy b
  >>=? fun (_, priority, _) ->
  Tez.(endorsement_reward /? Int64.(succ (of_int priority)))
  >>?= fun reward_per_slot ->
  Lwt.return
    Tez.(reward_per_slot *? Int64.of_int (List.length endorser1.slots))
  >>=? fun reward1 ->
  (* bake next block, include endorsement of endorser1 *)
  Block.bake ~policy ~operation:(Operation.pack operation1) b
  >>=? fun b ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    security_deposit1
  >>=? fun () ->
  Assert.balance_is
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
  >>=? fun () ->
  (* complete cycle 0 *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    security_deposit1
  >>=? fun () ->
  Assert.balance_is
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
  >>=? fun () ->
  (* get the slots of endorser2 for the current block *)
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  let same_endorser2 endorser =
    Signature.Public_key_hash.(
      endorser.Delegate_services.Endorsing_rights.delegate = endorser2.delegate)
  in
  let endorser2 = List.find same_endorser2 endorsers in
  (* No exception raised: in sandboxed mode endorsers do not change between blocks *)
  Lwt.return
    Tez.(
      endorsement_security_deposit
      *? Int64.of_int (List.length endorser2.slots))
  >>=? fun security_deposit2 ->
  (* endorser2 endorses the last block in cycle 0 *)
  Op.endorsement ~delegate:endorser2.delegate (B b) ()
  >>=? fun operation2 ->
  (* bake first block in cycle 1, include endorsement of endorser2 *)
  Block.bake ~policy ~operation:(Operation.pack operation2) b
  >>=? fun b ->
  let priority = b.header.protocol_data.contents.priority in
  Tez.(endorsement_reward /? Int64.(succ (of_int priority)))
  >>?= fun reward_per_slot ->
  Lwt.return
    Tez.(reward_per_slot *? Int64.of_int (List.length endorser2.slots))
  >>=? fun reward2 ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    security_deposit1
  >>=? fun () ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
    security_deposit2
  >>=? fun () ->
  (* bake [preserved_cycles] cycles *)
  fold_left_s
    (fun b _ ->
      Assert.balance_was_debited
        ~loc:__LOC__
        (B b)
        (Contract.implicit_contract endorser1.delegate)
        balance1
        security_deposit1
      >>=? fun () ->
      Assert.balance_was_debited
        ~loc:__LOC__
        (B b)
        (Contract.implicit_contract endorser2.delegate)
        balance2
        security_deposit2
      >>=? fun () -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- preserved_cycles)
  >>=? fun b ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    reward1
  >>=? fun () ->
  Assert.balance_was_debited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
    security_deposit2
  >>=? fun () ->
  (* bake cycle [preserved_cycle + 1] *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser1.delegate)
    balance1
    reward1
  >>=? fun () ->
  Assert.balance_was_credited
    ~loc:__LOC__
    (B b)
    (Contract.implicit_contract endorser2.delegate)
    balance2
    reward2

(****************************************************************)
(*  The following test scenarios are supposed to raise errors.  *)
(****************************************************************)

(** Wrong endorsement predecessor : apply an endorsement with an
    incorrect block predecessor *)
let wrong_endorsement_predecessor () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_endorser (B b)
  >>=? fun (genesis_endorser, _slots) ->
  Block.bake b
  >>=? fun b' ->
  Op.endorsement ~delegate:genesis_endorser ~signing_context:(B b) (B b') ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Block.bake ~operation b'
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Wrong_endorsement_predecessor _ ->
          true
      | _ ->
          false)

(** Invalid_endorsement_level : apply an endorsement with an incorrect
    level (i.e. the predecessor level) *)
let invalid_endorsement_level () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_level (B b)
  >>=? fun genesis_level ->
  Block.bake b
  >>=? fun b ->
  Op.endorsement ~level:genesis_level (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Block.bake ~operation b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Invalid_endorsement_level ->
          true
      | _ ->
          false)

(** Duplicate endorsement : apply an endorsement that has already been done *)
let duplicate_endorsement () =
  Context.init 5
  >>=? fun (b, _) ->
  Incremental.begin_construction b
  >>=? fun inc ->
  Op.endorsement (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Incremental.add_operation inc operation
  >>=? fun inc ->
  Op.endorsement (B b) ()
  >>=? fun operation ->
  let operation = Operation.pack operation in
  Incremental.add_operation inc operation
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Apply.Duplicate_endorsement _ ->
          true
      | _ ->
          false)

(** Apply a single endorsement from the slot 0 endorser *)
let not_enough_for_deposit () =
  Context.init 5 ~endorsers_per_block:1
  >>=? fun (b_init, contracts) ->
  Error_monad.map_s
    (fun c ->
      Context.Contract.manager (B b_init) c >>=? fun m -> return (m, c))
    contracts
  >>=? fun managers ->
  Block.bake b_init
  >>=? fun b ->
  (* retrieve the level 2's endorser *)
  Context.get_endorser (B b)
  >>=? fun (endorser, _slots) ->
  let (_, contract_other_than_endorser) =
    List.find
      (fun (c, _) ->
        not (Signature.Public_key_hash.equal c.Account.pkh endorser))
      managers
  in
  let (_, contract_of_endorser) =
    List.find
      (fun (c, _) -> Signature.Public_key_hash.equal c.Account.pkh endorser)
      managers
  in
  Context.Contract.balance (B b) (Contract.implicit_contract endorser)
  >>=? fun initial_balance ->
  (* Empty the future endorser account *)
  Op.transaction
    (B b_init)
    contract_of_endorser
    contract_other_than_endorser
    initial_balance
  >>=? fun op_trans ->
  Block.bake ~operation:op_trans b_init
  >>=? fun b ->
  (* Endorse with a zero balance *)
  Op.endorsement ~delegate:endorser (B b) ()
  >>=? fun op_endo ->
  Block.bake
    ~policy:(Excluding [endorser])
    ~operation:(Operation.pack op_endo)
    b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Delegate_storage.Balance_too_low_for_deposit _ ->
          true
      | _ ->
          false)

(* check that a block with not enough endorsement cannot be baked *)
let endorsement_threshold () =
  let initial_endorsers = 28 in
  let num_accounts = 100 in
  Context.init ~initial_endorsers num_accounts
  >>=? fun (b, _) ->
  Context.get_endorsers (B b)
  >>=? fun endorsers ->
  let num_endorsers = List.length endorsers in
  (* we try to bake with more and more endorsers, but at each
     iteration with a timestamp smaller than required *)
  iter_s
    (fun i ->
      (* the priority is chosen rather arbitrarily *)
      let priority = num_endorsers - i in
      let crt_endorsers = List.take_n i endorsers in
      let endorsing_power = endorsing_power crt_endorsers in
      let delegates = delegates_with_slots crt_endorsers in
      map_s (fun x -> Op.endorsement ~delegate:x (B b) ()) delegates
      >>=? fun ops ->
      Context.get_minimal_valid_time (B b) ~priority ~endorsing_power
      >>=? fun timestamp ->
      (* decrease the timestamp by one second *)
      let seconds =
        Int64.(sub (of_string (Timestamp.to_seconds_string timestamp)) 1L)
      in
      match Timestamp.of_seconds (Int64.to_string seconds) with
      | None ->
          failwith "timestamp to/from string manipulation failed"
      | Some timestamp ->
          Block.bake
            ~timestamp
            ~policy:(By_priority priority)
            ~operations:(List.map Operation.pack ops)
            b
          >>= fun b2 ->
          Assert.proto_error ~loc:__LOC__ b2 (function
              | Baking.Timestamp_too_early _
              | Apply.Not_enough_endorsements_for_priority _ ->
                  true
              | _ ->
                  false))
    (0 -- (num_endorsers - 1))
  >>=? fun () ->
  (* we bake with all endorsers endorsing, at the right time *)
  let priority = 0 in
  let endorsing_power = endorsing_power endorsers in
  let delegates = delegates_with_slots endorsers in
  map_s (fun delegate -> Op.endorsement ~delegate (B b) ()) delegates
  >>=? fun ops ->
  Context.get_minimal_valid_time (B b) ~priority ~endorsing_power
  >>=? fun timestamp ->
  Block.bake
    ~policy:(By_priority priority)
    ~timestamp
    ~operations:(List.map Operation.pack ops)
    b
  >>= fun _ -> return_unit

let test_fitness_gap () =
  let num_accounts = 5 in
  Context.init num_accounts
  >>=? fun (b, _) ->
  ( match Fitness_repr.to_int64 b.header.shell.fitness with
  | Ok fitness ->
      return (Int64.to_int fitness)
  | Error _ ->
      assert false )
  >>=? fun fitness ->
  Context.get_endorser (B b)
  >>=? fun (delegate, _slots) ->
  Op.endorsement ~delegate (B b) ()
  >>=? fun op ->
  (* bake at priority 0 succeed thanks to enough endorsements *)
  Block.bake ~policy:(By_priority 0) ~operations:[Operation.pack op] b
  >>=? fun b ->
  ( match Fitness_repr.to_int64 b.header.shell.fitness with
  | Ok new_fitness ->
      return (Int64.to_int new_fitness - fitness)
  | Error _ ->
      assert false )
  >>=? fun res ->
  (* in Emmy+, the fitness increases by 1, so the difference between
     the fitness at level 1 and at level 0 is 1, independently if the
     number fo endorements (here 1) *)
  Assert.equal_int ~loc:__LOC__ res 1 >>=? fun () -> return_unit

let tests =
  [ Test.tztest "Simple endorsement" `Quick simple_endorsement;
    Test.tztest "Maximum endorsement" `Quick max_endorsement;
    Test.tztest "Consistent priorities" `Quick consistent_priorities;
    Test.tztest "Reward retrieval" `Quick reward_retrieval;
    Test.tztest
      "Reward retrieval two endorsers"
      `Quick
      reward_retrieval_two_endorsers;
    Test.tztest "Endorsement threshold" `Quick endorsement_threshold;
    Test.tztest "Fitness gap" `Quick test_fitness_gap;
    (* Fail scenarios *)
    Test.tztest
      "Wrong endorsement predecessor"
      `Quick
      wrong_endorsement_predecessor;
    Test.tztest "Invalid endorsement level" `Quick invalid_endorsement_level;
    Test.tztest "Duplicate endorsement" `Quick duplicate_endorsement;
    Test.tztest "Not enough for deposit" `Quick not_enough_for_deposit ]
src/proto_alpha/lib_protocol/test/endorsement.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition get_expected_reward {A B C D : Type}
  (ctxt : A) (priority : B) (baker : bool) (endorsing_power : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
  op_gtgteqquestion
    (if baker then
      op_startypeminuserrorstar ctxt priority endorsing_power
    else
      _return (op_startypeminuserrorstar 0))
    (fun baking_reward =>
      op_gtgteqquestion
        (op_startypeminuserrorstar ctxt priority endorsing_power)
        (fun endorsing_reward =>
          op_startypeminuserrorstar op_startypeminuserrorstar
            (fun reward => _return reward))).

Definition get_expected_deposit {A B : Type}
  (ctxt : A) (baker : bool) (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  op_gtgteqquestion (op_startypeminuserrorstar ctxt)
    (fun function_parameter =>
      let '{|
        parametric := {|
          block_security_deposit := block_security_deposit;
            endorsement_security_deposit := endorsement_security_deposit
            |}
          |} := function_parameter in
      let baking_deposit :=
        if baker then
          block_security_deposit
        else
          op_startypeminuserrorstar 0 in
      op_startypeminuserrorstar
        (op_starquestion endorsement_security_deposit
          (Int64.of_int endorsing_power))
        (fun endorsement_deposit =>
          op_startypeminuserrorstar
            (op_plusquestion endorsement_deposit baking_deposit)
            (fun deposit => _return deposit))).

Definition assert_endorser_balance_consistency {A B C D : Type}
  (loc : A) (op_staroptstar : option Z)
  : (option bool) ->
    Z ->
      B ->
        Tezos_raw_protocol_alpha__Alpha_context.public_key_hash ->
          C ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                D) :=
  let priority :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun op_staroptstar =>
    let baker :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => false
      end in
    fun endorsing_power =>
      fun ctxt =>
        fun pkh =>
          fun initial_balance =>
            let contract := Contract.implicit_contract pkh in
            op_gtgteqquestion
              (get_expected_reward ctxt priority baker endorsing_power)
              (fun reward =>
                op_gtgteqquestion
                  (get_expected_deposit ctxt baker endorsing_power)
                  (fun deposit =>
                    op_gtgteqquestion
                      (op_startypeminuserrorstar loc ctxt contract
                        initial_balance deposit)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        op_gtgteqquestion
                          (op_startypeminuserrorstar op_startypeminuserrorstar
                            ctxt contract)
                          (fun reward_balance =>
                            op_gtgteqquestion
                              (op_startypeminuserrorstar loc reward_balance
                                reward)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar ctxt contract)
                                  (fun deposit_balance =>
                                    op_startypeminuserrorstar loc
                                      deposit_balance deposit)))))).

Definition delegates_with_slots
  (endorsers :
    list Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
  : list
    Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t :=
  List.map (fun endorser => delegate endorser) endorsers.

Definition endorsing_power
  (endorsers :
    list Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
  : Z :=
  List.fold_left
    (fun sum => fun endorser => op_plus sum (List.length (slots endorser))) 0
    endorsers.

Definition simple_endorsement {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '(delegate, slots) := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
            (fun op =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (Contract.implicit_contract delegate))
                (fun initial_balance =>
                  let policy := op_startypeminuserrorstar in
                  op_gtgteqquestion (op_startypeminuserrorstar policy b)
                    (fun function_parameter =>
                      let '(_, priority, _) := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar policy
                          (cons (Operation.pack op) []) b)
                        (fun b2 =>
                          assert_endorser_balance_consistency __LOC__
                            (Some priority) None (List.length slots)
                            op_startypeminuserrorstar delegate initial_balance)))))).

Definition max_endorsement (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let endorsers_per_block := 16 in
  op_gtgteqquestion (op_startypeminuserrorstar endorsers_per_block 32)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun endorsers =>
          op_gtgteqquestion
            (op_startypeminuserrorstar __LOC__
              (List.length
                (List.concat
                  (List.map
                    (fun function_parameter =>
                      let '{|
                        Alpha_services.Delegate.Endorsing_rights.slots := slots
                          |} := function_parameter in
                      slots) endorsers))) endorsers_per_block)
            (fun function_parameter =>
              let 'tt := function_parameter in
              op_gtgteqquestion
                (fold_left_s
                  (fun function_parameter =>
                    let '(delegates, ops, balances) := function_parameter in
                    fun endorser =>
                      let delegate := delegate endorser in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          (Contract.implicit_contract delegate))
                        (fun balance =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar delegate
                              op_startypeminuserrorstar tt)
                            (fun op =>
                              _return
                                ((cons delegate delegates),
                                  (cons (Operation.pack op) ops),
                                  (cons
                                    ((List.length (slots endorser)), balance)
                                    balances))))) ([], [], []) endorsers)
                (fun function_parameter =>
                  let '(delegates, ops, previous_balances) := function_parameter
                    in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (List.rev ops) b)
                    (fun b =>
                      iter_s
                        (fun function_parameter =>
                          let
                            '(endorser_account,
                              (endorsing_power, previous_balance)) :=
                            function_parameter in
                          assert_endorser_balance_consistency __LOC__ None None
                            endorsing_power op_startypeminuserrorstar
                            endorser_account previous_balance)
                        (List.combine delegates previous_balances)))))).

Definition consistent_priorities (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let priorities := op_startypeminuserrorstar 0 64 in
  op_gtgteqquestion (op_startypeminuserrorstar 64)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion
        (fold_left_s
          (fun function_parameter =>
            let '(b, used_pkhes) := function_parameter in
            fun priority =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar)
                (fun endorsers =>
                  let endorser :=
                    List.find_opt
                      (fun e =>
                        not
                          (Signature.Public_key_hash.Set.mem (delegate e)
                            used_pkhes)) endorsers in
                  match endorser with
                  | None => _return (b, used_pkhes)
                  | Some endorser =>
                    op_gtgteqquestion
                      (op_startypeminuserrorstar op_startypeminuserrorstar
                        (Contract.implicit_contract (delegate endorser)))
                      (fun balance =>
                        op_gtgteqquestion
                          (op_startypeminuserrorstar (delegate endorser)
                            op_startypeminuserrorstar tt)
                          (fun operation =>
                            let operation := Operation.pack operation in
                            op_gtgteqquestion
                              (op_startypeminuserrorstar
                                op_startypeminuserrorstar b)
                              (fun function_parameter =>
                                let '(baker, _, _) := function_parameter in
                                let used_pkhes :=
                                  Signature.Public_key_hash.Set.add baker
                                    used_pkhes in
                                let used_pkhes :=
                                  Signature.Public_key_hash.Set.add
                                    (delegate endorser) used_pkhes in
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar operation b)
                                  (fun b =>
                                    let is_baker :=
                                      op_eq baker (delegate endorser) in
                                    op_gtgteqquestion
                                      (assert_endorser_balance_consistency
                                        __LOC__ (Some priority) (Some is_baker)
                                        (List.length (slots endorser))
                                        op_startypeminuserrorstar
                                        (delegate endorser) balance)
                                      (fun function_parameter =>
                                        let 'tt := function_parameter in
                                        _return (b, used_pkhes))))))
                  end)) (b, Signature.Public_key_hash.Set.empty) priorities)
        (fun _b => return_unit)).

Definition reward_retrieval {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '{| parametric := {| preserved_cycles := preserved_cycles |} |} :=
            function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(endorser, slots) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (Contract.implicit_contract endorser))
                (fun balance =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar endorser
                      op_startypeminuserrorstar tt)
                    (fun operation =>
                      let operation := Operation.pack operation in
                      let policy := op_startypeminuserrorstar in
                      op_gtgteqquestion (op_startypeminuserrorstar policy b)
                        (fun function_parameter =>
                          let '(_, priority, _) := function_parameter in
                          op_gtgteqquestion
                            (op_startypeminuserrorstar policy operation b)
                            (fun b =>
                              op_gtgteqquestion
                                (fold_left_s
                                  (fun b =>
                                    fun function_parameter =>
                                      let '_ := function_parameter in
                                      op_startypeminuserrorstar
                                        op_startypeminuserrorstar b) b
                                  (op_startypeminuserrorstar 0 preserved_cycles))
                                (fun b =>
                                  op_gtgteqquestion
                                    (get_expected_reward
                                      op_startypeminuserrorstar priority false
                                      (List.length slots))
                                    (fun reward =>
                                      op_startypeminuserrorstar __LOC__
                                        op_startypeminuserrorstar
                                        (Contract.implicit_contract endorser)
                                        balance reward))))))))).

Definition reward_retrieval_two_endorsers {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '{|
            parametric := {|
              preserved_cycles := preserved_cycles;
                endorsement_security_deposit :=
                  endorsement_security_deposit;
                endorsement_reward := endorsement_reward
                |}
              |} := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun endorsers =>
              let endorser1 := List.hd endorsers in
              let endorser2 := List.hd (List.tl endorsers) in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (Contract.implicit_contract (delegate endorser1)))
                (fun balance1 =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (Contract.implicit_contract (delegate endorser2)))
                    (fun balance2 =>
                      op_gtgteqquestion
                        (Lwt._return
                          (op_starquestion endorsement_security_deposit
                            (Int64.of_int (List.length (slots endorser1)))))
                        (fun security_deposit1 =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar (delegate endorser1)
                              op_startypeminuserrorstar tt)
                            (fun operation1 =>
                              let policy := op_startypeminuserrorstar in
                              op_gtgteqquestion
                                (op_startypeminuserrorstar policy b)
                                (fun function_parameter =>
                                  let '(_, priority, _) := function_parameter in
                                  op_startypeminuserrorstar
                                    (op_divquestion endorsement_reward
                                      (succ (of_int priority)))
                                    (fun reward_per_slot =>
                                      op_gtgteqquestion
                                        (Lwt._return
                                          (op_starquestion reward_per_slot
                                            (Int64.of_int
                                              (List.length (slots endorser1)))))
                                        (fun reward1 =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar policy
                                              (Operation.pack operation1) b)
                                            (fun b =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  __LOC__
                                                  op_startypeminuserrorstar
                                                  (Contract.implicit_contract
                                                    (delegate endorser1))
                                                  balance1 security_deposit1)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      __LOC__
                                                      op_startypeminuserrorstar
                                                      (Contract.implicit_contract
                                                        (delegate endorser2))
                                                      balance2)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          policy b)
                                                        (fun b =>
                                                          op_gtgteqquestion
                                                            (op_startypeminuserrorstar
                                                              __LOC__
                                                              op_startypeminuserrorstar
                                                              (Contract.implicit_contract
                                                                (delegate
                                                                  endorser1))
                                                              balance1
                                                              security_deposit1)
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  __LOC__
                                                                  op_startypeminuserrorstar
                                                                  (Contract.implicit_contract
                                                                    (delegate
                                                                      endorser2))
                                                                  balance2)
                                                                (fun
                                                                  function_parameter
                                                                  =>
                                                                  let 'tt :=
                                                                    function_parameter
                                                                    in
                                                                  op_gtgteqquestion
                                                                    (op_startypeminuserrorstar
                                                                      op_startypeminuserrorstar)
                                                                    (fun
                                                                      endorsers
                                                                      =>
                                                                      let
                                                                        same_endorser2
                                                                        (endorser
                                                                        :
                                                                        Tezos_protocol_alpha.Protocol.Delegate_services.Endorsing_rights.t)
                                                                        : bool :=
                                                                        op_eq
                                                                          (Delegate_services.Endorsing_rights.delegate
                                                                            endorser)
                                                                          (delegate
                                                                            endorser2)
                                                                        in
                                                                      let
                                                                        endorser2 :=
                                                                        op_startypeminuserrorstar
                                                                          same_endorser2
                                                                          endorsers
                                                                        in
                                                                      op_gtgteqquestion
                                                                        (Lwt._return
                                                                          (op_starquestion
                                                                            endorsement_security_deposit
                                                                            (Int64.of_int
                                                                              (List.length
                                                                                (slots
                                                                                  endorser2)))))
                                                                        (fun
                                                                          security_deposit2
                                                                          =>
                                                                          op_gtgteqquestion
                                                                            (op_startypeminuserrorstar
                                                                              (delegate
                                                                                endorser2)
                                                                              op_startypeminuserrorstar
                                                                              tt)
                                                                            (fun
                                                                              operation2
                                                                              =>
                                                                              op_gtgteqquestion
                                                                                (op_startypeminuserrorstar
                                                                                  policy
                                                                                  (Operation.pack
                                                                                    operation2)
                                                                                  b)
                                                                                (fun
                                                                                  b
                                                                                  =>
                                                                                  let
                                                                                    priority :=
                                                                                    priority
                                                                                      op_startypeminuserrorstar
                                                                                    in
                                                                                  op_startypeminuserrorstar
                                                                                    (op_divquestion
                                                                                      endorsement_reward
                                                                                      (succ
                                                                                        (of_int
                                                                                          priority)))
                                                                                    (fun
                                                                                      reward_per_slot
                                                                                      =>
                                                                                      op_gtgteqquestion
                                                                                        (Lwt._return
                                                                                          (op_starquestion
                                                                                            reward_per_slot
                                                                                            (Int64.of_int
                                                                                              (List.length
                                                                                                (slots
                                                                                                  endorser2)))))
                                                                                        (fun
                                                                                          reward2
                                                                                          =>
                                                                                          op_gtgteqquestion
                                                                                            (op_startypeminuserrorstar
                                                                                              __LOC__
                                                                                              op_startypeminuserrorstar
                                                                                              (Contract.implicit_contract
                                                                                                (delegate
                                                                                                  endorser1))
                                                                                              balance1
                                                                                              security_deposit1)
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                'tt :=
                                                                                                function_parameter
                                                                                                in
                                                                                              op_gtgteqquestion
                                                                                                (op_startypeminuserrorstar
                                                                                                  __LOC__
                                                                                                  op_startypeminuserrorstar
                                                                                                  (Contract.implicit_contract
                                                                                                    (delegate
                                                                                                      endorser2))
                                                                                                  balance2
                                                                                                  security_deposit2)
                                                                                                (fun
                                                                                                  function_parameter
                                                                                                  =>
                                                                                                  let
                                                                                                    'tt :=
                                                                                                    function_parameter
                                                                                                    in
                                                                                                  op_gtgteqquestion
                                                                                                    (fold_left_s
                                                                                                      (fun
                                                                                                        b
                                                                                                        =>
                                                                                                        fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            '_ :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_gtgteqquestion
                                                                                                            (op_startypeminuserrorstar
                                                                                                              __LOC__
                                                                                                              op_startypeminuserrorstar
                                                                                                              (Contract.implicit_contract
                                                                                                                (delegate
                                                                                                                  endorser1))
                                                                                                              balance1
                                                                                                              security_deposit1)
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                'tt :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_gtgteqquestion
                                                                                                                (op_startypeminuserrorstar
                                                                                                                  __LOC__
                                                                                                                  op_startypeminuserrorstar
                                                                                                                  (Contract.implicit_contract
                                                                                                                    (delegate
                                                                                                                      endorser2))
                                                                                                                  balance2
                                                                                                                  security_deposit2)
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_startypeminuserrorstar
                                                                                                                    policy
                                                                                                                    b)))
                                                                                                      b
                                                                                                      (op_startypeminuserrorstar
                                                                                                        1
                                                                                                        preserved_cycles))
                                                                                                    (fun
                                                                                                      b
                                                                                                      =>
                                                                                                      op_gtgteqquestion
                                                                                                        (op_startypeminuserrorstar
                                                                                                          __LOC__
                                                                                                          op_startypeminuserrorstar
                                                                                                          (Contract.implicit_contract
                                                                                                            (delegate
                                                                                                              endorser1))
                                                                                                          balance1
                                                                                                          reward1)
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_gtgteqquestion
                                                                                                            (op_startypeminuserrorstar
                                                                                                              __LOC__
                                                                                                              op_startypeminuserrorstar
                                                                                                              (Contract.implicit_contract
                                                                                                                (delegate
                                                                                                                  endorser2))
                                                                                                              balance2
                                                                                                              security_deposit2)
                                                                                                            (fun
                                                                                                              function_parameter
                                                                                                              =>
                                                                                                              let
                                                                                                                'tt :=
                                                                                                                function_parameter
                                                                                                                in
                                                                                                              op_gtgteqquestion
                                                                                                                (op_startypeminuserrorstar
                                                                                                                  policy
                                                                                                                  b)
                                                                                                                (fun
                                                                                                                  b
                                                                                                                  =>
                                                                                                                  op_gtgteqquestion
                                                                                                                    (op_startypeminuserrorstar
                                                                                                                      __LOC__
                                                                                                                      op_startypeminuserrorstar
                                                                                                                      (Contract.implicit_contract
                                                                                                                        (delegate
                                                                                                                          endorser1))
                                                                                                                      balance1
                                                                                                                      reward1)
                                                                                                                    (fun
                                                                                                                      function_parameter
                                                                                                                      =>
                                                                                                                      let
                                                                                                                        'tt :=
                                                                                                                        function_parameter
                                                                                                                        in
                                                                                                                      op_startypeminuserrorstar
                                                                                                                        __LOC__
                                                                                                                        op_startypeminuserrorstar
                                                                                                                        (Contract.implicit_contract
                                                                                                                          (delegate
                                                                                                                            endorser2))
                                                                                                                        balance2
                                                                                                                        reward2))))))))))))))))))))))))))))).

Definition wrong_endorsement_predecessor {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '(genesis_endorser, _slots) := function_parameter in
          op_gtgteqquestion (op_startypeminuserrorstar b)
            (fun b' =>
              op_gtgteqquestion
                (op_startypeminuserrorstar genesis_endorser
                  op_startypeminuserrorstar op_startypeminuserrorstar tt)
                (fun operation =>
                  let operation := Operation.pack operation in
                  op_gtgteq (op_startypeminuserrorstar operation b')
                    (fun res =>
                      op_startypeminuserrorstar __LOC__ res
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Wrong_endorsement_predecessor
                              _ _ => true
                          | _ => false
                          end)))))).

Definition invalid_endorsement_level {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun genesis_level =>
          op_gtgteqquestion (op_startypeminuserrorstar b)
            (fun b =>
              op_gtgteqquestion
                (op_startypeminuserrorstar genesis_level
                  op_startypeminuserrorstar tt)
                (fun operation =>
                  let operation := Operation.pack operation in
                  op_gtgteq (op_startypeminuserrorstar operation b)
                    (fun res =>
                      op_startypeminuserrorstar __LOC__ res
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_endorsement_level
                            => true
                          | _ => false
                          end)))))).

Definition duplicate_endorsement {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun inc =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar tt)
            (fun operation =>
              let operation := Operation.pack operation in
              op_gtgteqquestion (op_startypeminuserrorstar inc operation)
                (fun inc =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar tt)
                    (fun operation =>
                      let operation := Operation.pack operation in
                      op_gtgteq (op_startypeminuserrorstar inc operation)
                        (fun res =>
                          op_startypeminuserrorstar __LOC__ res
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Duplicate_endorsement
                                  _ => true
                              | _ => false
                              end))))))).

Definition not_enough_for_deposit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5 1)
    (fun function_parameter =>
      let '(b_init, contracts) := function_parameter in
      op_gtgteqquestion
        (Error_monad.map_s
          (fun c =>
            op_gtgteqquestion
              (op_startypeminuserrorstar op_startypeminuserrorstar c)
              (fun m => _return (m, c))) contracts)
        (fun managers =>
          op_gtgteqquestion (op_startypeminuserrorstar b_init)
            (fun b =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(endorser, _slots) := function_parameter in
                  let '(_, contract_other_than_endorser) :=
                    op_startypeminuserrorstar
                      (fun function_parameter =>
                        let '(c, _) := function_parameter in
                        not
                          (Signature.Public_key_hash.equal (Account.pkh c)
                            endorser)) managers in
                  let '(_, contract_of_endorser) :=
                    op_startypeminuserrorstar
                      (fun function_parameter =>
                        let '(c, _) := function_parameter in
                        Signature.Public_key_hash.equal (Account.pkh c) endorser)
                      managers in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (Contract.implicit_contract endorser))
                    (fun initial_balance =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          contract_of_endorser contract_other_than_endorser
                          initial_balance)
                        (fun op_trans =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_trans b_init)
                            (fun b =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar endorser
                                  op_startypeminuserrorstar tt)
                                (fun op_endo =>
                                  op_gtgteq
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar
                                      (Operation.pack op_endo) b)
                                    (fun res =>
                                      op_startypeminuserrorstar __LOC__ res
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low_for_deposit
                                              _ => true
                                          | _ => false
                                          end)))))))))).

Definition endorsement_threshold (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let initial_endorsers := 28 in
  let num_accounts := 100 in
  op_gtgteqquestion (op_startypeminuserrorstar initial_endorsers num_accounts)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun endorsers =>
          let num_endorsers := List.length endorsers in
          op_gtgteqquestion
            (iter_s
              (fun i =>
                let priority := op_minus num_endorsers i in
                let crt_endorsers := op_startypeminuserrorstar i endorsers in
                let endorsing_power := endorsing_power crt_endorsers in
                let delegates := delegates_with_slots crt_endorsers in
                op_gtgteqquestion
                  (map_s
                    (fun x =>
                      op_startypeminuserrorstar x op_startypeminuserrorstar tt)
                    delegates)
                  (fun ops =>
                    op_gtgteqquestion
                      (op_startypeminuserrorstar op_startypeminuserrorstar
                        priority endorsing_power)
                      (fun timestamp =>
                        let seconds :=
                          sub
                            (of_string (Timestamp.to_seconds_string timestamp))
                            (* ❌ Constant of type int64 is converted to int *)
                            1 in
                        match Timestamp.of_seconds (Int64.to_string seconds)
                          with
                        | None =>
                          failwith
                            "timestamp to/from string manipulation failed" %
                              string
                        | Some timestamp =>
                          op_gtgteq
                            (op_startypeminuserrorstar timestamp
                              op_startypeminuserrorstar
                              (List.map Operation.pack ops) b)
                            (fun b2 =>
                              op_startypeminuserrorstar __LOC__ b2
                                (fun function_parameter =>
                                  match function_parameter with
                                  |
                                    Tezos_protocol_environment_alpha__Environment.Error_monad.Timestamp_too_early
                                      _ _ |
                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Not_enough_endorsements_for_priority
                                        _ => true
                                  | _ => false
                                  end))
                        end)))
              (op_startypeminuserrorstar 0 (op_minus num_endorsers 1)))
            (fun function_parameter =>
              let 'tt := function_parameter in
              let priority := 0 in
              let endorsing_power := endorsing_power endorsers in
              let delegates := delegates_with_slots endorsers in
              op_gtgteqquestion
                (map_s
                  (fun delegate =>
                    op_startypeminuserrorstar delegate op_startypeminuserrorstar
                      tt) delegates)
                (fun ops =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      priority endorsing_power)
                    (fun timestamp =>
                      op_gtgteq
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          timestamp (List.map Operation.pack ops) b)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          return_unit)))))).

Definition test_fitness_gap (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let num_accounts := 5 in
  op_gtgteqquestion (op_startypeminuserrorstar num_accounts)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion
        match Fitness_repr.to_int64 (fitness (shell (header b))) with
        | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok fitness =>
          _return (Int64.to_int fitness)
        | Tezos_protocol_environment_alpha__Environment.Pervasives.Error _ =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        end
        (fun fitness =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(delegate, _slots) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar delegate op_startypeminuserrorstar tt)
                (fun op =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (cons (Operation.pack op) []) b)
                    (fun b =>
                      op_gtgteqquestion
                        match Fitness_repr.to_int64 (fitness (shell (header b)))
                          with
                        |
                          Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                            new_fitness =>
                          _return (op_minus (Int64.to_int new_fitness) fitness)
                        |
                          Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                            _ =>
                          (* ❌ Assert instruction is not handled. *)
                          assert false
                        end
                        (fun res =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar __LOC__ res 1)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "Simple endorsement" % string
      (* ❌ Variants not supported *)
      variant simple_endorsement)
    (cons
      (op_startypeminuserrorstar "Maximum endorsement" % string
        (* ❌ Variants not supported *)
        variant max_endorsement)
      (cons
        (op_startypeminuserrorstar "Consistent priorities" % string
          (* ❌ Variants not supported *)
          variant consistent_priorities)
        (cons
          (op_startypeminuserrorstar "Reward retrieval" % string
            (* ❌ Variants not supported *)
            variant reward_retrieval)
          (cons
            (op_startypeminuserrorstar "Reward retrieval two endorsers" % string
              (* ❌ Variants not supported *)
              variant reward_retrieval_two_endorsers)
            (cons
              (op_startypeminuserrorstar "Endorsement threshold" % string
                (* ❌ Variants not supported *)
                variant endorsement_threshold)
              (cons
                (op_startypeminuserrorstar "Fitness gap" % string
                  (* ❌ Variants not supported *)
                  variant test_fitness_gap)
                (cons
                  (op_startypeminuserrorstar
                    "Wrong endorsement predecessor" % string
                    (* ❌ Variants not supported *)
                    variant wrong_endorsement_predecessor)
                  (cons
                    (op_startypeminuserrorstar
                      "Invalid endorsement level" % string
                      (* ❌ Variants not supported *)
                      variant invalid_endorsement_level)
                    (cons
                      (op_startypeminuserrorstar
                        "Duplicate endorsement" % string
                        (* ❌ Variants not supported *)
                        variant duplicate_endorsement)
                      (cons
                        (op_startypeminuserrorstar
                          "Not enough for deposit" % string
                          (* ❌ Variants not supported *)
                          variant not_enough_for_deposit) [])))))))))).

src/proto_alpha/lib_protocol/test/helpers/account.ml 26 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

type t = {
  pkh : Signature.Public_key_hash.t;
  pk : Signature.Public_key.t;
  sk : Signature.Secret_key.t;
}

type account = t

let known_accounts = Signature.Public_key_hash.Table.create 17

let new_account ?seed () =
  let seed = Option.map ~f:Bigstring.of_bytes seed in
  let (pkh, pk, sk) = Signature.generate_key ?seed () in
  let account = {pkh; pk; sk} in
  Signature.Public_key_hash.Table.add known_accounts pkh account ;
  account

let add_account ({pkh; _} as account) =
  Signature.Public_key_hash.Table.add known_accounts pkh account

let activator_account = new_account ()

let find pkh =
  try return (Signature.Public_key_hash.Table.find known_accounts pkh)
  with Not_found ->
    failwith "Missing account: %a" Signature.Public_key_hash.pp pkh

let find_alternate pkh =
  let exception Found of t in
  try
    Signature.Public_key_hash.Table.iter
      (fun pkh' account ->
        if not (Signature.Public_key_hash.equal pkh pkh') then
          raise (Found account))
      known_accounts ;
    raise Not_found
  with Found account -> account

let dummy_account = new_account ()

let generate_accounts ?(initial_balances = []) n : (t * Tez_repr.t) list =
  Signature.Public_key_hash.Table.clear known_accounts ;
  let default_amount = Tez_repr.of_mutez_exn 4_000_000_000_000L in
  let amount i =
    match List.nth_opt initial_balances i with
    | None ->
        default_amount
    | Some a ->
        Tez_repr.of_mutez_exn a
  in
  List.map
    (fun i ->
      let (pkh, pk, sk) = Signature.generate_key () in
      let account = {pkh; pk; sk} in
      Signature.Public_key_hash.Table.add known_accounts pkh account ;
      (account, amount i))
    (0 -- (n - 1))

let commitment_secret =
  Blinded_public_key_hash.activation_code_of_hex
    "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb"

let new_commitment ?seed () =
  let seed = Option.map ~f:Bigstring.of_bytes seed in
  let (pkh, pk, sk) = Signature.generate_key ?seed ~algo:Ed25519 () in
  let unactivated_account = {pkh; pk; sk} in
  let open Commitment_repr in
  let pkh = match pkh with Ed25519 pkh -> pkh | _ -> assert false in
  let bpkh = Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in
  (Lwt.return @@ Environment.wrap_error @@ Tez_repr.(one *? 4_000L))
  >>=? fun amount ->
  return @@ (unactivated_account, {blinded_public_key_hash = bpkh; amount})
src/proto_alpha/lib_protocol/test/helpers/account.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Record t := {
  pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t;
  pk : Tezos_base__TzPervasives.Signature.Public_key.t;
  sk : Tezos_base__TzPervasives.Signature.Secret_key.t }.

Definition account := t.

Definition known_accounts
  : Tezos_base__TzPervasives.Signature.Public_key_hash.Table.t t :=
  Signature.Public_key_hash.Table.create 17.

Definition new_account
  (seed : option Stdlib.Bytes.t) (function_parameter : unit) : t :=
  let 'tt := function_parameter in
  let seed := Option.map Bigstring.of_bytes seed in
  let '(pkh, pk, sk) := Signature.generate_key None seed tt in
  let account := {| pkh := pkh; pk := pk; sk := sk |} in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := Signature.Public_key_hash.Table.add known_accounts pkh account in
  account.

Definition add_account (function_parameter : t) : unit :=
  let '{| pkh := pkh |} as account := function_parameter in
  Signature.Public_key_hash.Table.add known_accounts pkh account.

Definition activator_account : t := new_account None tt.

Definition find
  (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.Table.key)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  (* ❌ Try-with are not handled *)
  try (_return (Signature.Public_key_hash.Table.find known_accounts pkh)).

Definition find_alternate
  (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t) : t :=
  (* ❌ Let of exception is not handled *)
  let_exception.

Definition dummy_account : t := new_account None tt.

Definition generate_accounts (op_staroptstar : option (list int64))
  : Z -> list (t * Tezos_protocol_alpha.Protocol.Tez_repr.t) :=
  let initial_balances :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun n =>
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Signature.Public_key_hash.Table.clear known_accounts in
    let default_amount :=
      Tez_repr.of_mutez_exn
        (* ❌ Constant of type int64 is converted to int *)
        4000000000000 in
    let amount (i : Z) : Tezos_protocol_alpha.Protocol.Tez_repr.t :=
      match List.nth_opt initial_balances i with
      | None => default_amount
      | Some a => Tez_repr.of_mutez_exn a
      end in
    List.map
      (fun i =>
        let '(pkh, pk, sk) := Signature.generate_key None None tt in
        let account := {| pkh := pkh; pk := pk; sk := sk |} in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := Signature.Public_key_hash.Table.add known_accounts pkh account
          in
        (account, (amount i))) (op_minusminus 0 (Z.sub n 1)).

Definition commitment_secret
  : Tezos_protocol_alpha.Protocol.Blinded_public_key_hash.activation_code :=
  Blinded_public_key_hash.activation_code_of_hex
    "aaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb" % string.

Definition new_commitment
  (seed : option Stdlib.Bytes.t) (function_parameter : unit)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (t * Tezos_protocol_alpha.Protocol.Commitment_repr.t)) :=
  let 'tt := function_parameter in
  let seed := Option.map Bigstring.of_bytes seed in
  let '(pkh, pk, sk) :=
    Signature.generate_key (Some Tezos_base__TzPervasives.Signature.Ed25519)
      seed tt in
  let unactivated_account := {| pkh := pkh; pk := pk; sk := sk |} in
  let pkh :=
    match pkh with
    | Tezos_base__TzPervasives.Signature.Ed25519 pkh => pkh
    | _ =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    end in
  let bpkh := Blinded_public_key_hash.of_ed25519_pkh commitment_secret pkh in
  op_gtgteqquestion
    (apply Lwt._return
      (apply Environment.wrap_error
        (op_starquestion one
          (* ❌ Constant of type int64 is converted to int *)
          4000)))
    (fun amount =>
      apply _return
        (unactivated_account,
          {| blinded_public_key_hash := bpkh; amount := amount |})).

src/proto_alpha/lib_protocol/test/helpers/assert.ml 41 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let error ~loc v f =
  match v with
  | Error err when List.exists f err ->
      return_unit
  | Ok _ ->
      failwith "Unexpected successful result (%s)" loc
  | Error err ->
      failwith "@[Unexpected error (%s): %a@]" loc pp_print_error err

let proto_error ~loc v f =
  error ~loc v (function
      | Environment.Ecoproto_error err ->
          f err
      | _ ->
          false)

let equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
  if not (cmp a b) then
    failwith "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" loc msg pp a pp b
  else return_unit

let not_equal ~loc (cmp : 'a -> 'a -> bool) msg pp a b =
  if cmp a b then
    failwith "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" loc msg pp a pp b
  else return_unit

(* tez *)
let equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) =
  let open Alpha_context in
  equal ~loc Tez.( = ) "Tez aren't equal" Tez.pp a b

let not_equal_tez ~loc (a : Alpha_context.Tez.t) (b : Alpha_context.Tez.t) =
  let open Alpha_context in
  not_equal ~loc Tez.( = ) "Tez are equal" Tez.pp a b

(* int *)
let equal_int ~loc (a : int) (b : int) =
  equal ~loc ( = ) "Integers aren't equal" Format.pp_print_int a b

let not_equal_int ~loc (a : int) (b : int) =
  not_equal ~loc ( = ) "Integers are equal" Format.pp_print_int a b

(* bool *)
let equal_bool ~loc (a : bool) (b : bool) =
  equal ~loc ( = ) "Booleans aren't equal" Format.pp_print_bool a b

let not_equal_bool ~loc (a : bool) (b : bool) =
  not_equal ~loc ( = ) "Booleans are equal" Format.pp_print_bool a b

(* pkh *)
let equal_pkh ~loc (a : Signature.Public_key_hash.t)
    (b : Signature.Public_key_hash.t) =
  let module PKH = Signature.Public_key_hash in
  equal ~loc PKH.equal "Public key hashes  aren't equal" PKH.pp a b

let not_equal_pkh ~loc (a : Signature.Public_key_hash.t)
    (b : Signature.Public_key_hash.t) =
  let module PKH = Signature.Public_key_hash in
  not_equal ~loc PKH.equal "Public key hashes are equal" PKH.pp a b

open Context

(* Some asserts for account operations *)

(** [balance_is b c amount] checks that the current balance of contract [c] is
    [amount].
    Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
    [Rewards] for the others. *)
let balance_is ~loc b contract ?(kind = Contract.Main) expected =
  Contract.balance b contract ~kind
  >>=? fun balance -> equal_tez ~loc balance expected

(** [balance_was_operated ~operand b c old_balance amount] checks that the
    current balance of contract [c] is [operand old_balance amount] and
    returns the current balance.
    Default balance type is [Main], pass [~kind] with [Deposit], [Fees] or
    [Rewards] for the others. *)
let balance_was_operated ~operand ~loc b contract ?(kind = Contract.Main)
    old_balance amount =
  operand old_balance amount |> Environment.wrap_error |> Lwt.return
  >>=? fun expected -> balance_is ~loc b contract ~kind expected

let balance_was_credited =
  balance_was_operated ~operand:Alpha_context.Tez.( +? )

let balance_was_debited =
  balance_was_operated ~operand:Alpha_context.Tez.( -? )

(* debug *)

let print_balances ctxt id =
  Contract.balance ~kind:Main ctxt id
  >>=? fun main ->
  Contract.balance ~kind:Deposit ctxt id
  >>=? fun deposit ->
  Contract.balance ~kind:Fees ctxt id
  >>=? fun fees ->
  Contract.balance ~kind:Rewards ctxt id
  >>|? fun rewards ->
  Format.printf
    "\nMain: %s\nDeposit: %s\nFees: %s\nRewards: %s\n"
    (Alpha_context.Tez.to_string main)
    (Alpha_context.Tez.to_string deposit)
    (Alpha_context.Tez.to_string fees)
    (Alpha_context.Tez.to_string rewards)
src/proto_alpha/lib_protocol/test/helpers/assert.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition error {A : Type}
  (loc : string) (v : sum A Tezos_base__TzPervasives.trace)
  (f : Tezos_base__TzPervasives.error -> bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  match v with
  | Stdlib.Error err => return_unit
  | Stdlib.Ok _ =>
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal
          "Unexpected successful result (" % string
          (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
            (CamlinternalFormatBasics.Char_literal ")" % char
              CamlinternalFormatBasics.End_of_format)))
        "Unexpected successful result (%s)" % string) loc
  | Stdlib.Error err =>
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.String_literal "Unexpected error (" % string
            (CamlinternalFormatBasics.String CamlinternalFormatBasics.No_padding
              (CamlinternalFormatBasics.String_literal "): " % string
                (CamlinternalFormatBasics.Alpha
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    CamlinternalFormatBasics.End_of_format))))))
        "@[Unexpected error (%s): %a@]" % string) loc pp_print_error err
  end.

Definition proto_error {A : Type}
  (loc : string) (v : sum A Tezos_base__TzPervasives.trace)
  (f : Tezos_protocol_alpha.Protocol.Environment.Error_monad.error -> bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  error loc v
    (fun function_parameter =>
      match function_parameter with
      | Tezos_base__TzPervasives.Error_monad.Ecoproto_error err => f err
      | _ => false
      end).

Definition equal {a : Type}
  (loc : string) (cmp : a -> a -> bool) (msg : string)
  (pp : Stdlib.Format.formatter -> a -> unit) (a : a) (b : a)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if negb (cmp a b) then
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "]" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    (CamlinternalFormatBasics.String_literal " - " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            " : " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " is not equal to " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[@[[%s]@] - @[%s : %a is not equal to %a@]@]" % string) loc msg pp a
      pp b
  else
    return_unit.

Definition not_equal {a : Type}
  (loc : string) (cmp : a -> a -> bool) (msg : string)
  (pp : Stdlib.Format.formatter -> a -> unit) (a : a) (b : a)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  if cmp a b then
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.Formatting_gen
          (CamlinternalFormatBasics.Open_box
            (CamlinternalFormatBasics.Format
              CamlinternalFormatBasics.End_of_format "" % string))
          (CamlinternalFormatBasics.Formatting_gen
            (CamlinternalFormatBasics.Open_box
              (CamlinternalFormatBasics.Format
                CamlinternalFormatBasics.End_of_format "" % string))
            (CamlinternalFormatBasics.Char_literal "[" % char
              (CamlinternalFormatBasics.String
                CamlinternalFormatBasics.No_padding
                (CamlinternalFormatBasics.Char_literal "]" % char
                  (CamlinternalFormatBasics.Formatting_lit
                    CamlinternalFormatBasics.Close_box
                    (CamlinternalFormatBasics.String_literal " - " % string
                      (CamlinternalFormatBasics.Formatting_gen
                        (CamlinternalFormatBasics.Open_box
                          (CamlinternalFormatBasics.Format
                            CamlinternalFormatBasics.End_of_format "" % string))
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            " : " % string
                            (CamlinternalFormatBasics.Alpha
                              (CamlinternalFormatBasics.String_literal
                                " is equal to " % string
                                (CamlinternalFormatBasics.Alpha
                                  (CamlinternalFormatBasics.Formatting_lit
                                    CamlinternalFormatBasics.Close_box
                                    (CamlinternalFormatBasics.Formatting_lit
                                      CamlinternalFormatBasics.Close_box
                                      CamlinternalFormatBasics.End_of_format)))))))))))))))
        "@[@[[%s]@] - @[%s : %a is equal to %a@]@]" % string) loc msg pp a pp b
  else
    return_unit.

Definition equal_tez
  (loc : string) (a : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (b : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  equal loc Tez.op_eq "Tez aren't equal" % string Tez.pp a b.

Definition not_equal_tez
  (loc : string) (a : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  (b : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  not_equal loc Tez.op_eq "Tez are equal" % string Tez.pp a b.

Definition equal_int (loc : string) (a : Z) (b : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  equal loc equiv_decb "Integers aren't equal" % string Format.pp_print_int a b.

Definition not_equal_int (loc : string) (a : Z) (b : Z)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  not_equal loc equiv_decb "Integers are equal" % string Format.pp_print_int a b.

Definition equal_bool (loc : string) (a : bool) (b : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  equal loc equiv_decb "Booleans aren't equal" % string Format.pp_print_bool a b.

Definition not_equal_bool (loc : string) (a : bool) (b : bool)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  not_equal loc equiv_decb "Booleans are equal" % string Format.pp_print_bool a
    b.

Definition equal_pkh
  (loc : string) (a : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (b : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let PKH := Signature.Public_key_hash in
  equal loc PKH.equal "Public key hashes  aren't equal" % string PKH.pp a b.

Definition not_equal_pkh
  (loc : string) (a : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (b : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let PKH := Signature.Public_key_hash in
  not_equal loc PKH.equal "Public key hashes are equal" % string PKH.pp a b.

Import Context.

Definition balance_is
  (loc : string) (b : Tezos_alpha_test_helpers__Context.t)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (op_staroptstar :
    option Tezos_alpha_test_helpers.Context.Contract.balance_kind)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
    Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let kind :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tezos_alpha_test_helpers.Context.Contract.Main
    end in
  fun expected =>
    op_gtgteqquestion (Contract.balance (Some kind) b contract)
      (fun balance => equal_tez loc balance expected).

Definition balance_was_operated {A B : Type}
  (operand :
    A ->
      B ->
        Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t) (loc : string)
  (b : Tezos_alpha_test_helpers__Context.t)
  (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (op_staroptstar :
    option Tezos_alpha_test_helpers.Context.Contract.balance_kind)
  : A -> B -> Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let kind :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tezos_alpha_test_helpers.Context.Contract.Main
    end in
  fun old_balance =>
    fun amount =>
      op_gtgteqquestion
        (OCaml.Stdlib.reverse_apply
          (OCaml.Stdlib.reverse_apply (operand old_balance amount)
            Environment.wrap_error) Lwt._return)
        (fun expected => balance_is loc b contract (Some kind) expected).

Definition balance_was_credited
  : string ->
    Tezos_alpha_test_helpers__Context.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        (option Tezos_alpha_test_helpers.Context.Contract.balance_kind) ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  balance_was_operated Alpha_context.Tez.op_plusquestion.

Definition balance_was_debited
  : string ->
    Tezos_alpha_test_helpers__Context.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        (option Tezos_alpha_test_helpers.Context.Contract.balance_kind) ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
            Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez ->
              Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  balance_was_operated Alpha_context.Tez.op_minusquestion.

Definition print_balances
  (ctxt : Tezos_alpha_test_helpers__Context.t)
  (id : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  op_gtgteqquestion
    (Contract.balance (Some Tezos_alpha_test_helpers.Context.Contract.Main) ctxt
      id)
    (fun main =>
      op_gtgteqquestion
        (Contract.balance
          (Some Tezos_alpha_test_helpers.Context.Contract.Deposit) ctxt id)
        (fun deposit =>
          op_gtgteqquestion
            (Contract.balance
              (Some Tezos_alpha_test_helpers.Context.Contract.Fees) ctxt id)
            (fun fees =>
              op_gtgtpipequestion
                (Contract.balance
                  (Some Tezos_alpha_test_helpers.Context.Contract.Rewards) ctxt
                  id)
                (fun rewards =>
                  Format.printf
                    (CamlinternalFormatBasics.Format
                      (CamlinternalFormatBasics.String_literal
                        "
Main: " % string
                        (CamlinternalFormatBasics.String
                          CamlinternalFormatBasics.No_padding
                          (CamlinternalFormatBasics.String_literal
                            "
Deposit: " % string
                            (CamlinternalFormatBasics.String
                              CamlinternalFormatBasics.No_padding
                              (CamlinternalFormatBasics.String_literal
                                "
Fees: " % string
                                (CamlinternalFormatBasics.String
                                  CamlinternalFormatBasics.No_padding
                                  (CamlinternalFormatBasics.String_literal
                                    "
Rewards: " % string
                                    (CamlinternalFormatBasics.String
                                      CamlinternalFormatBasics.No_padding
                                      (CamlinternalFormatBasics.Char_literal
                                        "010" % char
                                        CamlinternalFormatBasics.End_of_format)))))))))
                      "
Main: %s
Deposit: %s
Fees: %s
Rewards: %s
" % string)
                    (Alpha_context.Tez.to_string main)
                    (Alpha_context.Tez.to_string deposit)
                    (Alpha_context.Tez.to_string fees)
                    (Alpha_context.Tez.to_string rewards))))).

src/proto_alpha/lib_protocol/test/helpers/block.ml 49 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
module Proto_Nonce = Nonce (* Renamed otherwise is masked by Alpha_context *)

open Alpha_context

(* This type collects a block and the context that results from its application *)
type t = {
  hash : Block_hash.t;
  header : Block_header.t;
  operations : Operation.packed list;
  context : Tezos_protocol_environment.Context.t;
}

type block = t

let rpc_context block =
  {
    Environment.Updater.block_hash = block.hash;
    block_header = block.header.shell;
    context = block.context;
  }

let rpc_ctxt =
  new Environment.proto_rpc_context_of_directory rpc_context rpc_services

(******** Policies ***********)

(* Policies are functions that take a block and return a tuple
   [(account, level, timestamp)] for the [forge_header] function. *)

(* This type is used only to provide a simpler interface to the exterior. *)
type baker_policy =
  | By_priority of int
  | By_account of public_key_hash
  | Excluding of public_key_hash list

let get_next_baker_by_priority priority block =
  Alpha_services.Delegate.Baking_rights.get
    rpc_ctxt
    ~all:true
    ~max_priority:(priority + 1)
    block
  >>=? fun bakers ->
  let {Alpha_services.Delegate.Baking_rights.delegate = pkh; timestamp; _} =
    List.find
      (fun {Alpha_services.Delegate.Baking_rights.priority = p; _} ->
        p = priority)
      bakers
  in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let get_next_baker_by_account pkh block =
  Alpha_services.Delegate.Baking_rights.get
    rpc_ctxt
    ~delegates:[pkh]
    ~max_priority:256
    block
  >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh;
        timestamp;
        priority;
        _ } =
    List.hd bakers
  in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let get_next_baker_excluding excludes block =
  Alpha_services.Delegate.Baking_rights.get rpc_ctxt ~max_priority:256 block
  >>=? fun bakers ->
  let { Alpha_services.Delegate.Baking_rights.delegate = pkh;
        timestamp;
        priority;
        _ } =
    List.find
      (fun {Alpha_services.Delegate.Baking_rights.delegate; _} ->
        not (List.mem delegate excludes))
      bakers
  in
  return (pkh, priority, Option.unopt_exn (Failure "") timestamp)

let dispatch_policy = function
  | By_priority p ->
      get_next_baker_by_priority p
  | By_account a ->
      get_next_baker_by_account a
  | Excluding al ->
      get_next_baker_excluding al

let get_next_baker ?(policy = By_priority 0) = dispatch_policy policy

let get_endorsing_power b =
  fold_left_s
    (fun acc (op : Operation.packed) ->
      let (Operation_data data) = op.protocol_data in
      match data.contents with
      | Single (Endorsement _) ->
          Alpha_services.Delegate.Endorsing_power.get
            rpc_ctxt
            b
            op
            Chain_id.zero
          >>=? fun endorsement_power -> return (acc + endorsement_power)
      | _ ->
          return acc)
    0
    b.operations

module Forge = struct
  type header = {
    baker : public_key_hash;
    (* the signer of the block *)
    shell : Block_header.shell_header;
    contents : Block_header.contents;
  }

  let default_proof_of_work_nonce =
    MBytes.create Constants.proof_of_work_nonce_size

  let make_contents ?(proof_of_work_nonce = default_proof_of_work_nonce)
      ~priority ~seed_nonce_hash () =
    Block_header.{priority; proof_of_work_nonce; seed_nonce_hash}

  let make_shell ~level ~predecessor ~timestamp ~fitness ~operations_hash =
    Tezos_base.Block_header.
      {
        level;
        predecessor;
        timestamp;
        fitness;
        operations_hash;
        (* We don't care of the following values, only the shell validates them. *)
        proto_level = 0;
        validation_passes = 0;
        context = Context_hash.zero;
      }

  let set_seed_nonce_hash seed_nonce_hash {baker; shell; contents} =
    {baker; shell; contents = {contents with seed_nonce_hash}}

  let set_baker baker header = {header with baker}

  let sign_header {baker; shell; contents} =
    Account.find baker
    >>=? fun delegate ->
    let unsigned_bytes =
      Data_encoding.Binary.to_bytes_exn
        Block_header.unsigned_encoding
        (shell, contents)
    in
    let signature =
      Signature.sign
        ~watermark:Signature.(Block_header Chain_id.zero)
        delegate.sk
        unsigned_bytes
    in
    Block_header.{shell; protocol_data = {contents; signature}} |> return

  let forge_header ?(policy = By_priority 0) ?timestamp ?(operations = []) pred
      =
    dispatch_policy policy pred
    >>=? fun (pkh, priority, _timestamp) ->
    Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt pred priority 0
    >>=? fun expected_timestamp ->
    let timestamp = Option.unopt ~default:expected_timestamp timestamp in
    let level = Int32.succ pred.header.shell.level in
    ( match Fitness_repr.to_int64 pred.header.shell.fitness with
    | Ok old_fitness ->
        return
          (Fitness_repr.from_int64 (Int64.add (Int64.of_int 1) old_fitness))
    | Error _ ->
        assert false )
    >>=? fun fitness ->
    Alpha_services.Helpers.current_level ~offset:1l rpc_ctxt pred
    >>|? (function
           | {expected_commitment = true; _} ->
               Some (fst (Proto_Nonce.generate ()))
           | {expected_commitment = false; _} ->
               None)
    >>=? fun seed_nonce_hash ->
    let hashes = List.map Operation.hash_packed operations in
    let operations_hash =
      Operation_list_list_hash.compute [Operation_list_hash.compute hashes]
    in
    let shell =
      make_shell
        ~level
        ~predecessor:pred.hash
        ~timestamp
        ~fitness
        ~operations_hash
    in
    let contents = make_contents ~priority ~seed_nonce_hash () in
    return {baker = pkh; shell; contents}

  (* compatibility only, needed by incremental *)
  let contents ?(proof_of_work_nonce = default_proof_of_work_nonce)
      ?(priority = 0) ?seed_nonce_hash () =
    {Block_header.priority; proof_of_work_nonce; seed_nonce_hash}
end

(********* Genesis creation *************)

(* Hard-coded context key *)
let protocol_param_key = ["protocol_parameters"]

let check_constants_consistency constants =
  let open Constants_repr in
  let {blocks_per_cycle; blocks_per_commitment; blocks_per_roll_snapshot; _} =
    constants
  in
  Error_monad.unless (blocks_per_commitment <= blocks_per_cycle) (fun () ->
      failwith
        "Inconsistent constants : blocks per commitment must be less than \
         blocks per cycle")
  >>=? fun () ->
  Error_monad.unless (blocks_per_cycle >= blocks_per_roll_snapshot) (fun () ->
      failwith
        "Inconsistent constants : blocks per cycle must be superior than \
         blocks per roll snapshot")
  >>=? return

let initial_context ?(with_commitments = false) constants header
    initial_accounts =
  let open Tezos_protocol_alpha_parameters in
  let bootstrap_accounts =
    List.map
      (fun (Account.{pk; pkh; _}, amount) ->
        Default_parameters.make_bootstrap_account (pkh, pk, amount))
      initial_accounts
  in
  let parameters =
    Default_parameters.parameters_of_constants
      ~bootstrap_accounts
      ~with_commitments
      constants
  in
  let json = Default_parameters.json_of_parameters parameters in
  let proto_params =
    Data_encoding.Binary.to_bytes_exn Data_encoding.json json
  in
  Tezos_protocol_environment.Context.(
    let empty = Memory_context.empty in
    set empty ["version"] (MBytes.of_string "genesis")
    >>= fun ctxt -> set ctxt protocol_param_key proto_params)
  >>= fun ctxt ->
  Main.init ctxt header >|= Environment.wrap_error
  >>=? fun {context; _} -> return context

let genesis_with_parameters parameters =
  let hash =
    Block_hash.of_b58check_exn
      "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
  in
  let shell =
    Forge.make_shell
      ~level:0l
      ~predecessor:hash
      ~timestamp:Time.Protocol.epoch
      ~fitness:(Fitness_repr.from_int64 0L)
      ~operations_hash:Operation_list_list_hash.zero
  in
  let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in
  let open Tezos_protocol_alpha_parameters in
  let json = Default_parameters.json_of_parameters parameters in
  let proto_params =
    Data_encoding.Binary.to_bytes_exn Data_encoding.json json
  in
  Tezos_protocol_environment.Context.(
    let empty = Memory_context.empty in
    set empty ["version"] (MBytes.of_string "genesis")
    >>= fun ctxt -> set ctxt protocol_param_key proto_params)
  >>= fun ctxt ->
  Main.init ctxt shell >|= Environment.wrap_error
  >>=? fun {context; _} ->
  let block =
    {
      hash;
      header = {shell; protocol_data = {contents; signature = Signature.zero}};
      operations = [];
      context;
    }
  in
  return block

(* if no parameter file is passed we check in the current directory
   where the test is run *)
let genesis ?with_commitments ?endorsers_per_block ?initial_endorsers
    ?min_proposal_quorum (initial_accounts : (Account.t * Tez_repr.t) list) =
  if initial_accounts = [] then
    Pervasives.failwith "Must have one account with a roll to bake" ;
  let open Tezos_protocol_alpha_parameters in
  let constants = Default_parameters.constants_test in
  let endorsers_per_block =
    Option.unopt ~default:constants.endorsers_per_block endorsers_per_block
  in
  let initial_endorsers =
    Option.unopt ~default:constants.initial_endorsers initial_endorsers
  in
  let min_proposal_quorum =
    Option.unopt ~default:constants.min_proposal_quorum min_proposal_quorum
  in
  let constants =
    {
      constants with
      endorsers_per_block;
      initial_endorsers;
      min_proposal_quorum;
    }
  in
  (* Check there is at least one roll *)
  ( try
      let open Test_utils in
      fold_left_s
        (fun acc (_, amount) ->
          Environment.wrap_error @@ Tez_repr.( +? ) acc amount
          >>?= fun acc ->
          if acc >= constants.tokens_per_roll then raise Exit else return acc)
        Tez_repr.zero
        initial_accounts
      >>=? fun _ ->
      failwith "Insufficient tokens in initial accounts to create one roll"
    with Exit -> return_unit )
  >>=? fun () ->
  check_constants_consistency constants
  >>=? fun () ->
  let hash =
    Block_hash.of_b58check_exn
      "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU"
  in
  let shell =
    Forge.make_shell
      ~level:0l
      ~predecessor:hash
      ~timestamp:Time.Protocol.epoch
      ~fitness:(Fitness_repr.from_int64 0L)
      ~operations_hash:Operation_list_list_hash.zero
  in
  let contents = Forge.make_contents ~priority:0 ~seed_nonce_hash:None () in
  initial_context ?with_commitments constants shell initial_accounts
  >>=? fun context ->
  let block =
    {
      hash;
      header = {shell; protocol_data = {contents; signature = Signature.zero}};
      operations = [];
      context;
    }
  in
  return block

(********* Baking *************)

let apply header ?(operations = []) pred =
  (let open Environment.Error_monad in
  Main.begin_application
    ~chain_id:Chain_id.zero
    ~predecessor_context:pred.context
    ~predecessor_fitness:pred.header.shell.fitness
    ~predecessor_timestamp:pred.header.shell.timestamp
    header
  >>=? fun vstate ->
  fold_left_s
    (fun vstate op ->
      apply_operation vstate op >>=? fun (state, _result) -> return state)
    vstate
    operations
  >>=? fun vstate ->
  Main.finalize_block vstate
  >>=? fun (validation, _result) -> return validation.context)
  >|= Environment.wrap_error
  >>|? fun context ->
  let hash = Block_header.hash header in
  {hash; header; operations; context}

let bake ?policy ?timestamp ?operation ?operations pred =
  let operations =
    match (operation, operations) with
    | (Some op, Some ops) ->
        Some (op :: ops)
    | (Some op, None) ->
        Some [op]
    | (None, Some ops) ->
        Some ops
    | (None, None) ->
        None
  in
  Forge.forge_header ?timestamp ?policy ?operations pred
  >>=? fun header ->
  Forge.sign_header header >>=? fun header -> apply header ?operations pred

(********** Cycles ****************)

(* This function is duplicated from Context to avoid a cyclic dependency *)
let get_constants b = Alpha_services.Constants.all rpc_ctxt b

let bake_n ?policy n b =
  Error_monad.fold_left_s (fun b _ -> bake ?policy b) b (1 -- n)

let bake_until_cycle_end ?policy b =
  get_constants b
  >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} ->
  let current_level = b.header.shell.level in
  let current_level = Int32.rem current_level blocks_per_cycle in
  let delta = Int32.sub blocks_per_cycle current_level in
  bake_n ?policy (Int32.to_int delta) b

let bake_until_n_cycle_end ?policy n b =
  Error_monad.fold_left_s (fun b _ -> bake_until_cycle_end ?policy b) b (1 -- n)

let bake_until_cycle ?policy cycle (b : t) =
  get_constants b
  >>=? fun Constants.{parametric = {blocks_per_cycle; _}; _} ->
  let rec loop (b : t) =
    let current_cycle =
      let current_level = b.header.shell.level in
      let current_cycle = Int32.div current_level blocks_per_cycle in
      current_cycle
    in
    if Int32.equal (Cycle.to_int32 cycle) current_cycle then return b
    else bake_until_cycle_end ?policy b >>=? fun b -> loop b
  in
  loop b
src/proto_alpha/lib_protocol/test/helpers/block.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

(* ❌ This kind of module is not handled. *)
unhandled_module

Import Alpha_context.

Record t := {
  hash : Tezos_base__TzPervasives.Block_hash.t;
  header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
  operations : list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  context : Tezos_protocol_environment.Context.t }.

Definition block := t.

Definition rpc_context (block : t)
  : Tezos_protocol_alpha.Protocol.Environment.Updater.rpc_context :=
  {| Environment.Updater.block_hash := hash block;
    Environment.Updater.block_header := shell (header block);
    Environment.Updater.context := context block |}.

Definition rpc_ctxt
  : Tezos_protocol_alpha.Protocol.Environment.proto_rpc_context_of_directory t :=
  (* ❌ Creation of new objects is not handled *)
  new rpc_context rpc_services.

Inductive baker_policy : Type :=
| By_priority : Z -> baker_policy
| By_account : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash ->
  baker_policy
| Excluding : (list Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  -> baker_policy.

Definition get_next_baker_by_priority (priority : Z) (block : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  op_gtgteqquestion
    (Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None None
      (Some true) (Some (Z.add priority 1)) block)
    (fun bakers =>
      let '{|
        Alpha_services.Delegate.Baking_rights.delegate := pkh;
          Alpha_services.Delegate.Baking_rights.timestamp := timestamp
          |} :=
        List.find
          (fun function_parameter =>
            let '{| Alpha_services.Delegate.Baking_rights.priority := p |} :=
              function_parameter in
            equiv_decb p priority) bakers in
      _return
        (pkh, priority, (Option.unopt_exn (OCaml.Failure "" % string) timestamp))).

Definition get_next_baker_by_account
  (pkh : Tezos_protocol_environment_alpha__Environment.Signature.public_key_hash)
  (block : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  op_gtgteqquestion
    (Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None
      (Some (cons pkh [])) None (Some 256) block)
    (fun bakers =>
      let '{|
        Alpha_services.Delegate.Baking_rights.delegate := pkh;
          Alpha_services.Delegate.Baking_rights.priority := priority;
          Alpha_services.Delegate.Baking_rights.timestamp := timestamp
          |} := List.hd bakers in
      _return
        (pkh, priority, (Option.unopt_exn (OCaml.Failure "" % string) timestamp))).

Definition get_next_baker_excluding
  (excludes :
    list
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (block : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  op_gtgteqquestion
    (Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None None None
      (Some 256) block)
    (fun bakers =>
      let '{|
        Alpha_services.Delegate.Baking_rights.delegate := pkh;
          Alpha_services.Delegate.Baking_rights.priority := priority;
          Alpha_services.Delegate.Baking_rights.timestamp := timestamp
          |} :=
        List.find
          (fun function_parameter =>
            let '{|
              Alpha_services.Delegate.Baking_rights.delegate := delegate |} :=
              function_parameter in
            negb (List.mem delegate excludes)) bakers in
      _return
        (pkh, priority, (Option.unopt_exn (OCaml.Failure "" % string) timestamp))).

Definition dispatch_policy (function_parameter : baker_policy)
  : t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  match function_parameter with
  | By_priority p => get_next_baker_by_priority p
  | By_account a => get_next_baker_by_account a
  | Excluding al => get_next_baker_excluding al
  end.

Definition get_next_baker (op_staroptstar : option baker_policy)
  : t ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Z * Tezos_raw_protocol_alpha.Alpha_context.Timestamp.t)) :=
  let policy :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => By_priority 0
    end in
  dispatch_policy policy.

Definition get_endorsing_power (b : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Z) :=
  fold_left_s
    (fun acc =>
      fun op =>
        let 'Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data data :=
          protocol_data op in
        match contents data with
        |
          Tezos_protocol_alpha.Protocol.Alpha_context.Single
            (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement _) =>
          op_gtgteqquestion
            (Alpha_services.Delegate.Endorsing_power.get rpc_ctxt b op
              Chain_id.zero)
            (fun endorsement_power => _return (Z.add acc endorsement_power))
        | _ => _return acc
        end) 0 (operations b).

Module Forge.
  Record header := {
    baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash;
    shell :
      Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.shell_header;
    contents : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents
    }.
  
  Definition default_proof_of_work_nonce : Tezos_base__TzPervasives.MBytes.t :=
    MBytes.create Constants.proof_of_work_nonce_size.
  
  Definition make_contents
    (op_staroptstar : option Tezos_base__TzPervasives.MBytes.t)
    : Z ->
      (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
        unit ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents :=
    let proof_of_work_nonce :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_proof_of_work_nonce
      end in
    fun priority =>
      fun seed_nonce_hash =>
        fun function_parameter =>
          let 'tt := function_parameter in
          {| priority := priority; seed_nonce_hash := seed_nonce_hash;
            proof_of_work_nonce := proof_of_work_nonce |}.
  
  Definition make_shell
    (level : Stdlib.Int32.t) (predecessor : Tezos_crypto.Block_hash.t)
    (timestamp : Tezos_base.Time.Protocol.t) (fitness : Tezos_base.Fitness.t)
    (operations_hash : Tezos_crypto.Operation_list_list_hash.t)
    : Tezos_base.Block_header.shell_header :=
    {| level := level; proto_level := 0; predecessor := predecessor;
      timestamp := timestamp; validation_passes := 0;
      operations_hash := operations_hash; fitness := fitness;
      context := Context_hash.zero |}.
  
  Definition set_seed_nonce_hash
    (seed_nonce_hash : option Tezos_raw_protocol_alpha.Nonce_hash.t)
    (function_parameter : header) : header :=
    let '{| baker := baker; shell := shell; contents := contents |} :=
      function_parameter in
    {| baker := baker; shell := shell;
      contents :=
        (* ❌ Record substitution not handled *)
        record_substitution |}.
  
  Definition set_baker
    (baker : Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
    (header : header) : header :=
    (* ❌ Record substitution not handled *)
    record_substitution.
  
  Definition sign_header (function_parameter : header)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t) :=
    let '{| baker := baker; shell := shell; contents := contents |} :=
      function_parameter in
    op_gtgteqquestion (Account.find baker)
      (fun delegate =>
        let unsigned_bytes :=
          Data_encoding.Binary.to_bytes_exn Block_header.unsigned_encoding
            (shell, contents) in
        let signature :=
          Signature.sign
            (Some
              (Tezos_base__TzPervasives.Signature.Block_header Chain_id.zero))
            (sk delegate) unsigned_bytes in
        OCaml.Stdlib.reverse_apply
          {| shell := shell;
            protocol_data := {| contents := contents; signature := signature |}
            |} _return).
  
  Definition forge_header (op_staroptstar : option baker_policy)
    : (option Tezos_protocol_environment_alpha__Environment.Time.t) ->
      (option (list Tezos_raw_protocol_alpha__Alpha_context.packed_operation))
        -> t -> Lwt.t (Tezos_base__TzPervasives.tzresult header) :=
    let policy :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => By_priority 0
      end in
    fun timestamp =>
      fun op_staroptstar =>
        let operations :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => []
          end in
        fun pred =>
          op_gtgteqquestion (dispatch_policy policy pred)
            (fun function_parameter =>
              let '(pkh, priority, _timestamp) := function_parameter in
              op_gtgteqquestion
                (Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt pred
                  priority 0)
                (fun expected_timestamp =>
                  let timestamp := Option.unopt expected_timestamp timestamp in
                  let level := Int32.succ (level (shell (header pred))) in
                  op_gtgteqquestion
                    match Fitness_repr.to_int64 (fitness (shell (header pred)))
                      with
                    | Stdlib.Ok old_fitness =>
                      _return
                        (Fitness_repr.from_int64
                          (Int64.add (Int64.of_int 1) old_fitness))
                    | Stdlib.Error _ =>
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    end
                    (fun fitness =>
                      op_gtgteqquestion
                        (op_gtgtpipequestion
                          (Alpha_services.Helpers.current_level rpc_ctxt
                            (Some
                              (* ❌ Constant of type int32 is converted to int *)
                              1) pred)
                          (fun function_parameter =>
                            match function_parameter with
                            | {| expected_commitment := true |} =>
                              Some (fst (Proto_Nonce.generate tt))
                            | {| expected_commitment := false |} => None
                            end))
                        (fun seed_nonce_hash =>
                          let hashes :=
                            List.map Operation.hash_packed operations in
                          let operations_hash :=
                            Operation_list_list_hash.compute
                              (cons (Operation_list_hash.compute hashes) []) in
                          let shell :=
                            make_shell level (hash pred) timestamp fitness
                              operations_hash in
                          let contents :=
                            make_contents None priority seed_nonce_hash tt in
                          _return
                            {| baker := pkh; shell := shell;
                              contents := contents |})))).
  
  Definition contents
    (op_staroptstar : option Tezos_base__TzPervasives.MBytes.t)
    : (option Z) ->
      (option Tezos_raw_protocol_alpha.Nonce_hash.t) ->
        unit ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.contents :=
    let proof_of_work_nonce :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_proof_of_work_nonce
      end in
    fun op_staroptstar =>
      let priority :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => 0
        end in
      fun seed_nonce_hash =>
        fun function_parameter =>
          let 'tt := function_parameter in
          {| Block_header.priority := priority;
            Block_header.seed_nonce_hash := seed_nonce_hash;
            Block_header.proof_of_work_nonce := proof_of_work_nonce |}.
End Forge.

Definition protocol_param_key : list string :=
  cons "protocol_parameters" % string [].

Definition check_constants_consistency
  (constants : Tezos_protocol_alpha.Protocol.Constants_repr.parametric)
  : Lwt.t (Tezos_base__TzPervasives.tzresult unit) :=
  let '{|
    blocks_per_cycle := blocks_per_cycle;
      blocks_per_commitment := blocks_per_commitment;
      blocks_per_roll_snapshot := blocks_per_roll_snapshot
      |} := constants in
  op_gtgteqquestion
    (Error_monad.unless (OCaml.Stdlib.le blocks_per_commitment blocks_per_cycle)
      (fun function_parameter =>
        let 'tt := function_parameter in
        failwith
          (CamlinternalFormatBasics.Format
            (CamlinternalFormatBasics.String_literal
              "Inconsistent constants : blocks per commitment must be less than blocks per cycle"
                % string CamlinternalFormatBasics.End_of_format)
            "Inconsistent constants : blocks per commitment must be less than blocks per cycle"
              % string)))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion
        (Error_monad.unless
          (OCaml.Stdlib.ge blocks_per_cycle blocks_per_roll_snapshot)
          (fun function_parameter =>
            let 'tt := function_parameter in
            failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Inconsistent constants : blocks per cycle must be superior than blocks per roll snapshot"
                    % string CamlinternalFormatBasics.End_of_format)
                "Inconsistent constants : blocks per cycle must be superior than blocks per roll snapshot"
                  % string))) _return).

Definition initial_context (op_staroptstar : option bool)
  : Tezos_protocol_alpha.Protocol.Constants_repr.parametric ->
    Tezos_protocol_environment_alpha__Environment.Block_header.shell_header ->
      (list
        (Tezos_alpha_test_helpers.Account.t *
          Tezos_protocol_alpha.Protocol.Tez_repr.t)) ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            Tezos_protocol_environment_alpha__Environment.Context.t) :=
  let with_commitments :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun constants =>
    fun header =>
      fun initial_accounts =>
        let bootstrap_accounts :=
          List.map
            (fun function_parameter =>
              let '({| pkh := pkh; pk := pk |}, amount) := function_parameter in
              Default_parameters.make_bootstrap_account (pkh, pk, amount))
            initial_accounts in
        let parameters :=
          Default_parameters.parameters_of_constants (Some bootstrap_accounts)
            None (Some with_commitments) constants in
        let json := Default_parameters.json_of_parameters parameters in
        let proto_params :=
          Data_encoding.Binary.to_bytes_exn Data_encoding.json json in
        op_gtgteq
          (let empty := Memory_context.empty in
          op_gtgteq
            (set empty (cons "version" % string [])
              (MBytes.of_string "genesis" % string))
            (fun ctxt => set ctxt protocol_param_key proto_params))
          (fun ctxt =>
            op_gtgteqquestion
              (op_gtpipeeq (Main.init ctxt header) Environment.wrap_error)
              (fun function_parameter =>
                let '{| context := context |} := function_parameter in
                _return context)).

Definition genesis_with_parameters
  (parameters : Tezos_protocol_alpha.Protocol.Parameters_repr.t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let hash :=
    Block_hash.of_b58check_exn
      "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" % string in
  let shell :=
    Forge.make_shell
      (* ❌ Constant of type int32 is converted to int *)
      0 hash Time.Protocol.epoch
      (Fitness_repr.from_int64
        (* ❌ Constant of type int64 is converted to int *)
        0) Operation_list_list_hash.zero in
  let contents := Forge.make_contents None 0 None tt in
  let json := Default_parameters.json_of_parameters parameters in
  let proto_params := Data_encoding.Binary.to_bytes_exn Data_encoding.json json
    in
  op_gtgteq
    (let empty := Memory_context.empty in
    op_gtgteq
      (set empty (cons "version" % string [])
        (MBytes.of_string "genesis" % string))
      (fun ctxt => set ctxt protocol_param_key proto_params))
    (fun ctxt =>
      op_gtgteqquestion
        (op_gtpipeeq (Main.init ctxt shell) Environment.wrap_error)
        (fun function_parameter =>
          let '{| context := context |} := function_parameter in
          let block :=
            {| hash := hash;
              header :=
                {| shell := shell;
                  protocol_data :=
                    {| contents := contents; signature := Signature.zero |} |};
              operations := []; context := context |} in
          _return block)).

Definition genesis
  (with_commitments : option bool) (endorsers_per_block : option Z)
  (initial_endorsers : option Z) (min_proposal_quorum : option int32)
  (initial_accounts :
    list
      (Tezos_alpha_test_helpers.Account.t *
        Tezos_protocol_alpha.Protocol.Tez_repr.t))
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    if equiv_decb initial_accounts [] then
      Pervasives.failwith "Must have one account with a roll to bake" % string
    else
      tt in
  let constants := Default_parameters.constants_test in
  let endorsers_per_block :=
    Option.unopt (endorsers_per_block constants) endorsers_per_block in
  let initial_endorsers :=
    Option.unopt (initial_endorsers constants) initial_endorsers in
  let min_proposal_quorum :=
    Option.unopt (min_proposal_quorum constants) min_proposal_quorum in
  let constants :=
    (* ❌ Record substitution not handled *)
    record_substitution in
  op_gtgteqquestion
    (* ❌ Try-with are not handled *)
    (try
      (op_gtgteqquestion
        (fold_left_s
          (fun acc =>
            fun function_parameter =>
              let '(_, amount) := function_parameter in
              op_gtgtquestioneq
                (apply Environment.wrap_error
                  (Tez_repr.op_plusquestion acc amount))
                (fun acc =>
                  if OCaml.Stdlib.ge acc (tokens_per_roll constants) then
                    Stdlib.raise Exit
                  else
                    _return acc)) Tez_repr.zero initial_accounts)
        (fun function_parameter =>
          let '_ := function_parameter in
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "Insufficient tokens in initial accounts to create one roll" %
                  string CamlinternalFormatBasics.End_of_format)
              "Insufficient tokens in initial accounts to create one roll" %
                string))))
    (fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (check_constants_consistency constants)
        (fun function_parameter =>
          let 'tt := function_parameter in
          let hash :=
            Block_hash.of_b58check_exn
              "BLockGenesisGenesisGenesisGenesisGenesisCCCCCeZiLHU" % string in
          let shell :=
            Forge.make_shell
              (* ❌ Constant of type int32 is converted to int *)
              0 hash Time.Protocol.epoch
              (Fitness_repr.from_int64
                (* ❌ Constant of type int64 is converted to int *)
                0) Operation_list_list_hash.zero in
          let contents := Forge.make_contents None 0 None tt in
          op_gtgteqquestion
            (initial_context with_commitments constants shell initial_accounts)
            (fun context =>
              let block :=
                {| hash := hash;
                  header :=
                    {| shell := shell;
                      protocol_data :=
                        {| contents := contents; signature := Signature.zero |}
                      |}; operations := []; context := context |} in
              _return block))).

Definition apply
  (header : Tezos_protocol_alpha.Protocol.Main.block_header)
  (op_staroptstar :
    option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
  : t -> Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let operations :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun pred =>
    op_gtgtpipequestion
      (op_gtpipeeq
        (op_gtgteqquestion
          (Main.begin_application Chain_id.zero (context pred)
            (timestamp (shell (header pred))) (fitness (shell (header pred)))
            header)
          (fun vstate =>
            op_gtgteqquestion
              (fold_left_s
                (fun vstate =>
                  fun op =>
                    op_gtgteqquestion (apply_operation vstate op)
                      (fun function_parameter =>
                        let '(state, _result) := function_parameter in
                        _return state)) vstate operations)
              (fun vstate =>
                op_gtgteqquestion (Main.finalize_block vstate)
                  (fun function_parameter =>
                    let '(validation, _result) := function_parameter in
                    _return (context validation))))) Environment.wrap_error)
      (fun context =>
        let hash := Block_header.hash header in
        {| hash := hash; header := header; operations := operations;
          context := context |}).

Definition bake
  (policy : option baker_policy)
  (timestamp : option Tezos_protocol_environment_alpha__Environment.Time.t)
  (operation :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed)
  (operations :
    option (list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed))
  (pred : t) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let operations :=
    match (operation, operations) with
    | (Some op, Some ops) => Some (cons op ops)
    | (Some op, None) => Some (cons op [])
    | (None, Some ops) => Some ops
    | (None, None) => None
    end in
  op_gtgteqquestion (Forge.forge_header policy timestamp operations pred)
    (fun header =>
      op_gtgteqquestion (Forge.sign_header header)
        (fun header => apply header operations pred)).

Definition get_constants (b : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
  Alpha_services.Constants.all rpc_ctxt b.

Definition bake_n (policy : option baker_policy) (n : Z) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult t) :=
  Error_monad.fold_left_s
    (fun b =>
      fun function_parameter =>
        let '_ := function_parameter in
        bake policy None None None b) b (op_minusminus 1 n).

Definition bake_until_cycle_end (policy : option baker_policy) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  op_gtgteqquestion (get_constants b)
    (fun function_parameter =>
      let '{| parametric := {| blocks_per_cycle := blocks_per_cycle |} |} :=
        function_parameter in
      let current_level := level (shell (header b)) in
      let current_level := Int32.rem current_level blocks_per_cycle in
      let delta := Int32.sub blocks_per_cycle current_level in
      bake_n policy (Int32.to_int delta) b).

Definition bake_until_n_cycle_end (policy : option baker_policy) (n : Z) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.Error_monad.tzresult t) :=
  Error_monad.fold_left_s
    (fun b =>
      fun function_parameter =>
        let '_ := function_parameter in
        bake_until_cycle_end policy b) b (op_minusminus 1 n).

Definition bake_until_cycle
  (policy : option baker_policy)
  (cycle : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.cycle) (b : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  op_gtgteqquestion (get_constants b)
    (fun function_parameter =>
      let '{| parametric := {| blocks_per_cycle := blocks_per_cycle |} |} :=
        function_parameter in
      let fix loop (b : t) : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
        let current_cycle :=
          let current_level := level (shell (header b)) in
          let current_cycle := Int32.div current_level blocks_per_cycle in
          current_cycle in
        if Int32.equal (Cycle.to_int32 cycle) current_cycle then
          _return b
        else
          op_gtgteqquestion (bake_until_cycle_end policy b) (fun b => loop b) in
      loop b).

src/proto_alpha/lib_protocol/test/helpers/context.ml 81 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t = B of Block.t | I of Incremental.t

let branch = function B b -> b.hash | I i -> (Incremental.predecessor i).hash

let level = function B b -> b.header.shell.level | I i -> Incremental.level i

let get_level ctxt =
  level ctxt |> Raw_level.of_int32 |> Environment.wrap_error |> Lwt.return

let rpc_ctxt =
  object
    method call_proto_service0
        : 'm 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            Environment.RPC_context.t,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'q -> 'i -> 'o tzresult Lwt.t =
      fun s pr q i ->
        match pr with
        | B b ->
            Block.rpc_ctxt#call_proto_service0 s b q i
        | I b ->
            Incremental.rpc_ctxt#call_proto_service0 s b q i

    method call_proto_service1
        : 'm 'a 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            Environment.RPC_context.t * 'a,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'a -> 'q -> 'i -> 'o tzresult Lwt.t =
      fun s pr a q i ->
        match pr with
        | B bl ->
            Block.rpc_ctxt#call_proto_service1 s bl a q i
        | I bl ->
            Incremental.rpc_ctxt#call_proto_service1 s bl a q i

    method call_proto_service2
        : 'm 'a 'b 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            (Environment.RPC_context.t * 'a) * 'b,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'a -> 'b -> 'q -> 'i -> 'o tzresult Lwt.t =
      fun s pr a b q i ->
        match pr with
        | B bl ->
            Block.rpc_ctxt#call_proto_service2 s bl a b q i
        | I bl ->
            Incremental.rpc_ctxt#call_proto_service2 s bl a b q i

    method call_proto_service3
        : 'm 'a 'b 'c 'q 'i 'o.
          ( ([< RPC_service.meth] as 'm),
            Environment.RPC_context.t,
            ((Environment.RPC_context.t * 'a) * 'b) * 'c,
            'q,
            'i,
            'o )
          RPC_service.t -> t -> 'a -> 'b -> 'c -> 'q -> 'i -> 'o tzresult Lwt.t
        =
      fun s pr a b c q i ->
        match pr with
        | B bl ->
            Block.rpc_ctxt#call_proto_service3 s bl a b c q i
        | I bl ->
            Incremental.rpc_ctxt#call_proto_service3 s bl a b c q i
  end

let get_endorsers ctxt =
  Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt

let get_endorser ctxt =
  Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt ctxt
  >>=? fun endorsers ->
  let endorser = List.hd endorsers in
  return (endorser.delegate, endorser.slots)

let get_bakers ctxt =
  Alpha_services.Delegate.Baking_rights.get ~max_priority:256 rpc_ctxt ctxt
  >>=? fun bakers ->
  return
    (List.map
       (fun p -> p.Alpha_services.Delegate.Baking_rights.delegate)
       bakers)

let get_seed_nonce_hash ctxt =
  let header =
    match ctxt with B {header; _} -> header | I i -> Incremental.header i
  in
  match header.protocol_data.contents.seed_nonce_hash with
  | None ->
      failwith "No committed nonce"
  | Some hash ->
      return hash

let get_seed ctxt = Alpha_services.Seed.get rpc_ctxt ctxt

let get_constants ctxt = Alpha_services.Constants.all rpc_ctxt ctxt

let get_minimal_valid_time ctxt ~priority ~endorsing_power =
  Alpha_services.Delegate.Minimal_valid_time.get
    rpc_ctxt
    ctxt
    priority
    endorsing_power

let get_baking_reward ctxt ~priority ~endorsing_power =
  get_constants ctxt
  >>=? fun Constants.{parametric = {block_reward; endorsers_per_block; _}; _} ->
  let prio_factor_denominator = Int64.(succ (of_int priority)) in
  let endo_factor_numerator =
    Int64.of_int (8 + (2 * endorsing_power / endorsers_per_block))
  in
  let endo_factor_denominator = 10L in
  Lwt.return
    Test_tez.Tez.(
      block_reward *? endo_factor_numerator
      >>? fun val1 ->
      val1 /? endo_factor_denominator
      >>? fun val2 -> val2 /? prio_factor_denominator)

let get_endorsing_reward ctxt ~priority ~endorsing_power =
  get_constants ctxt
  >>=? fun Constants.{parametric = {endorsement_reward; _}; _} ->
  let open Test_utils in
  Test_tez.Tez.(
    (endorsement_reward /? Int64.(succ (of_int priority)))
    >>?= fun reward_per_slot ->
    reward_per_slot *? Int64.of_int endorsing_power
    >>?= fun reward -> return reward)

(* Voting *)

module Vote = struct
  let get_ballots ctxt = Alpha_services.Voting.ballots rpc_ctxt ctxt

  let get_ballot_list ctxt = Alpha_services.Voting.ballot_list rpc_ctxt ctxt

  let get_voting_period ctxt =
    Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt
    >>=? fun l -> return l.voting_period

  let get_voting_period_position ctxt =
    Alpha_services.Helpers.current_level rpc_ctxt ~offset:1l ctxt
    >>=? fun l -> return l.voting_period_position

  let get_current_period_kind ctxt =
    Alpha_services.Voting.current_period_kind rpc_ctxt ctxt

  let get_current_quorum ctxt =
    Alpha_services.Voting.current_quorum rpc_ctxt ctxt

  let get_listings ctxt = Alpha_services.Voting.listings rpc_ctxt ctxt

  let get_proposals ctxt = Alpha_services.Voting.proposals rpc_ctxt ctxt

  let get_current_proposal ctxt =
    Alpha_services.Voting.current_proposal rpc_ctxt ctxt

  let get_protocol (b : Block.t) =
    Tezos_protocol_environment.Context.get b.context ["protocol"]
    >>= function
    | None ->
        assert false
    | Some p ->
        Lwt.return (Protocol_hash.of_bytes_exn p)

  let get_participation_ema (b : Block.t) =
    Environment.Context.get b.context ["votes"; "participation_ema"]
    >>= function
    | None -> assert false | Some bytes -> return (MBytes.get_int32 bytes 0)

  let set_participation_ema (b : Block.t) ema =
    let bytes = Bytes.make 4 '\000' in
    MBytes.set_int32 bytes 0 ema ;
    Environment.Context.set b.context ["votes"; "participation_ema"] bytes
    >>= fun context -> Lwt.return {b with context}
end

module Contract = struct
  let pp = Alpha_context.Contract.pp

  let pkh c =
    Alpha_context.Contract.is_implicit c
    |> function
    | Some p -> return p | None -> failwith "pkh: only for implicit contracts"

  type balance_kind = Main | Deposit | Fees | Rewards

  let balance ?(kind = Main) ctxt contract =
    match kind with
    | Main ->
        Alpha_services.Contract.balance rpc_ctxt ctxt contract
    | _ -> (
      match Alpha_context.Contract.is_implicit contract with
      | None ->
          invalid_arg
            "get_balance: no frozen accounts for an originated contract."
      | Some pkh ->
          Alpha_services.Delegate.frozen_balance_by_cycle rpc_ctxt ctxt pkh
          >>=? fun map ->
          Lwt.return
          @@ Cycle.Map.fold
               (fun _cycle {Delegate.deposit; fees; rewards} acc ->
                 acc
                 >>? fun acc ->
                 match kind with
                 | Deposit ->
                     Test_tez.Tez.(acc +? deposit)
                 | Fees ->
                     Test_tez.Tez.(acc +? fees)
                 | Rewards ->
                     Test_tez.Tez.(acc +? rewards)
                 | _ ->
                     assert false)
               map
               (Ok Tez.zero) )

  let counter ctxt contract =
    match Contract.is_implicit contract with
    | None ->
        invalid_arg "Helpers.Context.counter"
    | Some mgr ->
        Alpha_services.Contract.counter rpc_ctxt ctxt mgr

  let manager _ contract =
    match Contract.is_implicit contract with
    | None ->
        invalid_arg "Helpers.Context.manager"
    | Some pkh ->
        Account.find pkh

  let is_manager_key_revealed ctxt contract =
    match Contract.is_implicit contract with
    | None ->
        invalid_arg "Helpers.Context.is_manager_key_revealed"
    | Some mgr ->
        Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr
        >>=? fun res -> return (res <> None)

  let delegate ctxt contract =
    Alpha_services.Contract.delegate rpc_ctxt ctxt contract

  let delegate_opt ctxt contract =
    Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract
end

module Delegate = struct
  type info = Delegate_services.info = {
    balance : Tez.t;
    frozen_balance : Tez.t;
    frozen_balance_by_cycle : Delegate.frozen_balance Cycle.Map.t;
    staking_balance : Tez.t;
    delegated_contracts : Contract_repr.t list;
    delegated_balance : Tez.t;
    deactivated : bool;
    grace_period : Cycle.t;
  }

  let info ctxt pkh = Alpha_services.Delegate.info rpc_ctxt ctxt pkh
end

let init ?endorsers_per_block ?with_commitments ?(initial_balances = [])
    ?initial_endorsers ?min_proposal_quorum n =
  let accounts = Account.generate_accounts ~initial_balances n in
  let contracts =
    List.map
      (fun (a, _) -> Alpha_context.Contract.implicit_contract Account.(a.pkh))
      accounts
  in
  Block.genesis
    ?endorsers_per_block
    ?with_commitments
    ?initial_endorsers
    ?min_proposal_quorum
    accounts
  >>=? fun blk -> return (blk, contracts)
src/proto_alpha/lib_protocol/test/helpers/context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Inductive t : Type :=
| B : Tezos_alpha_test_helpers.Block.t -> t
| I : Tezos_alpha_test_helpers.Incremental.t -> t.

Definition branch (function_parameter : t)
  : Tezos_base__TzPervasives.Block_hash.t :=
  match function_parameter with
  | B b => hash b
  | I i => hash (Incremental.predecessor i)
  end.

Definition level (function_parameter : t)
  : Tezos_protocol_environment_alpha__Environment.Int32.t :=
  match function_parameter with
  | B b => level (shell (header b))
  | I i => Incremental.level i
  end.

Definition get_level (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.Error_monad.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.raw_level) :=
  OCaml.Stdlib.reverse_apply
    (OCaml.Stdlib.reverse_apply
      (OCaml.Stdlib.reverse_apply (level ctxt) Raw_level.of_int32)
      Environment.wrap_error) Lwt._return.

Definition rpc_ctxt {D F H J a b c i o q : Type}
  : ((((Tezos_base__TzPervasives.RPC_service.t variant
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
    Tezos_protocol_alpha.Protocol.Environment.RPC_context.t q i o) ->
    t -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
    (D * q * i * o)) *
    ((((Tezos_base__TzPervasives.RPC_service.t variant
      Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
      (Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) q i o) ->
      t -> a -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
      (F * a * q * i * o)) *
      ((((Tezos_base__TzPervasives.RPC_service.t variant
        Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
        ((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) q i
        o) ->
        t -> a -> b -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o)) *
        (H * a * b * q * i * o)) *
        ((((Tezos_base__TzPervasives.RPC_service.t variant
          Tezos_protocol_alpha.Protocol.Environment.RPC_context.t
          (((Tezos_protocol_alpha.Protocol.Environment.RPC_context.t * a) * b) *
            c) q i o) ->
          t ->
            a -> b -> c -> q -> i -> Lwt.t (Tezos_base__TzPervasives.tzresult o))
          * (J * a * b * c * q * i * o)) * nil)))) :=
  (* ❌ Creation of objects is not handled *)
  object.

Definition get_endorsers (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list
        Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.Endorsing_rights.t)) :=
  Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt None None None ctxt.

Definition get_endorser (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * (list Z))) :=
  op_gtgteqquestion
    (Alpha_services.Delegate.Endorsing_rights.get rpc_ctxt None None None ctxt)
    (fun endorsers =>
      let endorser := List.hd endorsers in
      _return ((delegate endorser), (slots endorser))).

Definition get_bakers (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (list
        Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)) :=
  op_gtgteqquestion
    (Alpha_services.Delegate.Baking_rights.get rpc_ctxt None None None None
      (Some 256) ctxt)
    (fun bakers =>
      _return
        (List.map (fun p => Alpha_services.Delegate.Baking_rights.delegate p)
          bakers)).

Definition get_seed_nonce_hash (ctxt : t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_raw_protocol_alpha.Nonce_hash.t) :=
  let header :=
    match ctxt with
    | B {| header := header |} => header
    | I i => Incremental.header i
    end in
  match seed_nonce_hash (contents (protocol_data header)) with
  | None =>
    failwith
      (CamlinternalFormatBasics.Format
        (CamlinternalFormatBasics.String_literal "No committed nonce" % string
          CamlinternalFormatBasics.End_of_format) "No committed nonce" % string)
  | Some hash => _return hash
  end.

Definition get_seed (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Seed.seed) :=
  Alpha_services.Seed.get rpc_ctxt ctxt.

Definition get_constants (ctxt : t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Constants.t) :=
  Alpha_services.Constants.all rpc_ctxt ctxt.

Definition get_minimal_valid_time
  (ctxt : t) (priority : Z) (endorsing_power : Z)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_protocol_environment_alpha__Environment.Time.t) :=
  Alpha_services.Delegate.Minimal_valid_time.get rpc_ctxt ctxt priority
    endorsing_power.

Definition get_baking_reward (ctxt : t) (priority : Z) (endorsing_power : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Test_tez.Tez.tez) :=
  op_gtgteqquestion (get_constants ctxt)
    (fun function_parameter =>
      let '{|
        parametric := {|
          endorsers_per_block := endorsers_per_block;
            block_reward := block_reward
            |}
          |} := function_parameter in
      let prio_factor_denominator := succ (of_int priority) in
      let endo_factor_numerator :=
        Int64.of_int
          (Z.add 8 (Z.div (Z.mul 2 endorsing_power) endorsers_per_block)) in
      let endo_factor_denominator :=
        (* ❌ Constant of type int64 is converted to int *)
        10 in
      Lwt._return
        (op_gtgtquestion (op_starquestion block_reward endo_factor_numerator)
          (fun val1 =>
            op_gtgtquestion (op_divquestion val1 endo_factor_denominator)
              (fun val2 => op_divquestion val2 prio_factor_denominator)))).

Definition get_endorsing_reward (ctxt : t) (priority : Z) (endorsing_power : Z)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Test_tez.Tez.tez) :=
  op_gtgteqquestion (get_constants ctxt)
    (fun function_parameter =>
      let '{| parametric := {| endorsement_reward := endorsement_reward |} |} :=
        function_parameter in
      op_gtgtquestioneq
        (op_divquestion endorsement_reward (succ (of_int priority)))
        (fun reward_per_slot =>
          op_gtgtquestioneq
            (op_starquestion reward_per_slot (Int64.of_int endorsing_power))
            (fun reward => _return reward))).

Module Vote.
  Definition get_ballots (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots) :=
    Alpha_services.Voting.ballots rpc_ctxt ctxt.
  
  Definition get_ballot_list (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))) :=
    Alpha_services.Voting.ballot_list rpc_ctxt ctxt.
  
  Definition get_voting_period (ctxt : t)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_raw_protocol_alpha__Alpha_context.Voting_period.t) :=
    op_gtgteqquestion
      (Alpha_services.Helpers.current_level rpc_ctxt
        (Some
          (* ❌ Constant of type int32 is converted to int *)
          1) ctxt) (fun l => _return (voting_period l)).
  
  Definition get_voting_period_position (ctxt : t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int32) :=
    op_gtgteqquestion
      (Alpha_services.Helpers.current_level rpc_ctxt
        (Some
          (* ❌ Constant of type int32 is converted to int *)
          1) ctxt) (fun l => _return (voting_period_position l)).
  
  Definition get_current_period_kind (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind) :=
    Alpha_services.Voting.current_period_kind rpc_ctxt ctxt.
  
  Definition get_current_quorum (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_environment_alpha__Environment.Int32.t) :=
    Alpha_services.Voting.current_quorum rpc_ctxt ctxt.
  
  Definition get_listings (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (list
          (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
            * int32))) := Alpha_services.Voting.listings rpc_ctxt ctxt.
  
  Definition get_proposals (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t
          Tezos_protocol_environment_alpha__Environment.Int32.t)) :=
    Alpha_services.Voting.proposals rpc_ctxt ctxt.
  
  Definition get_current_proposal (ctxt : t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (option
          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))) :=
    Alpha_services.Voting.current_proposal rpc_ctxt ctxt.
  
  Definition get_protocol (b : Tezos_alpha_test_helpers.Block.t)
    : Lwt.t Tezos_base__TzPervasives.Protocol_hash.t :=
    op_gtgteq
      (Tezos_protocol_environment.Context.get (context b)
        (cons "protocol" % string []))
      (fun function_parameter =>
        match function_parameter with
        | None =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Some p => Lwt._return (Protocol_hash.of_bytes_exn p)
        end).
  
  Definition get_participation_ema (b : Tezos_alpha_test_helpers.Block.t)
    : Lwt.t (Tezos_base__TzPervasives.tzresult int32) :=
    op_gtgteq
      (Environment.Context.get (context b)
        (cons "votes" % string (cons "participation_ema" % string [])))
      (fun function_parameter =>
        match function_parameter with
        | None =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Some bytes => _return (MBytes.get_int32 string 0)
        end).
  
  Definition set_participation_ema
    (b : Tezos_alpha_test_helpers.Block.t) (ema : int32)
    : Lwt.t Tezos_alpha_test_helpers.Block.t :=
    let bytes := Stdlib.Bytes.make 4 "000" % char in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := MBytes.set_int32 string 0 ema in
    op_gtgteq
      (Environment.Context.set (context b)
        (cons "votes" % string (cons "participation_ema" % string [])) string)
      (fun context =>
        Lwt._return
          (* ❌ Record substitution not handled *)
          record_substitution).
End Vote.

Module Contract.
  Definition pp
    : Tezos_protocol_environment_alpha__Environment.Format.formatter ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t -> unit :=
    Alpha_context.Contract.pp.
  
  Definition pkh
    (c : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t
      (Tezos_base__TzPervasives.tzresult
        Tezos_raw_protocol_alpha__Alpha_context.public_key_hash) :=
    OCaml.Stdlib.reverse_apply (Alpha_context.Contract.is_implicit c)
      (fun function_parameter =>
        match function_parameter with
        | Some p => _return p
        | None =>
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "pkh: only for implicit contracts" % string
                CamlinternalFormatBasics.End_of_format)
              "pkh: only for implicit contracts" % string)
        end).
  
  Inductive balance_kind : Type :=
  | Main : balance_kind
  | Deposit : balance_kind
  | Fees : balance_kind
  | Rewards : balance_kind.
  
  Definition balance (op_staroptstar : option balance_kind)
    : t ->
      Tezos_raw_protocol_alpha.Alpha_context.Contract.t ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
            Tezos_raw_protocol_alpha.Alpha_context.Tez.t) :=
    let kind :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => Main
      end in
    fun ctxt =>
      fun contract =>
        match kind with
        | Main => Alpha_services.Contract.balance rpc_ctxt ctxt contract
        | _ =>
          match Alpha_context.Contract.is_implicit contract with
          | None =>
            OCaml.Stdlib.invalid_arg
              "get_balance: no frozen accounts for an originated contract." %
                string
          | Some pkh =>
            op_gtgteqquestion
              (Alpha_services.Delegate.frozen_balance_by_cycle rpc_ctxt ctxt pkh)
              (fun map =>
                apply Lwt._return
                  (Cycle.Map.fold
                    (fun _cycle =>
                      fun function_parameter =>
                        let '{|
                          Delegate.deposit := deposit;
                            Delegate.fees := fees;
                            Delegate.rewards := rewards
                            |} := function_parameter in
                        fun acc =>
                          op_gtgtquestion acc
                            (fun acc =>
                              match kind with
                              | Deposit => op_plusquestion acc deposit
                              | Fees => op_plusquestion acc fees
                              | Rewards => op_plusquestion acc rewards
                              | _ =>
                                (* ❌ Assert instruction is not handled. *)
                                assert false
                              end)) map (Stdlib.Ok Tez.zero)))
          end
        end.
  
  Definition counter
    (ctxt : t)
    (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.counter) :=
    match Contract.is_implicit contract with
    | None => OCaml.Stdlib.invalid_arg "Helpers.Context.counter" % string
    | Some mgr => Alpha_services.Contract.counter rpc_ctxt ctxt mgr
    end.
  
  Definition manager {A : Type} (function_parameter : A)
    : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract ->
      Lwt.t
        (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Account.t) :=
    let '_ := function_parameter in
    fun contract =>
      match Contract.is_implicit contract with
      | None => OCaml.Stdlib.invalid_arg "Helpers.Context.manager" % string
      | Some pkh => Account.find pkh
      end.
  
  Definition is_manager_key_revealed
    (ctxt : t)
    (contract : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)
    : Lwt.t (Tezos_base__TzPervasives.tzresult bool) :=
    match Contract.is_implicit contract with
    | None =>
      OCaml.Stdlib.invalid_arg
        "Helpers.Context.is_manager_key_revealed" % string
    | Some mgr =>
      op_gtgteqquestion (Alpha_services.Contract.manager_key rpc_ctxt ctxt mgr)
        (fun res => _return (nequiv_decb res None))
    end.
  
  Definition delegate
    (ctxt : t) (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_raw_protocol_alpha.Alpha_context.public_key_hash) :=
    Alpha_services.Contract.delegate rpc_ctxt ctxt contract.
  
  Definition delegate_opt
    (ctxt : t) (contract : Tezos_raw_protocol_alpha.Alpha_context.Contract.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        (option Tezos_raw_protocol_alpha.Alpha_context.public_key_hash)) :=
    Alpha_services.Contract.delegate_opt rpc_ctxt ctxt contract.
End Contract.

Module Delegate.
  Record info := {
    balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    frozen_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    frozen_balance_by_cycle :
      Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.Map.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Delegate.frozen_balance;
    staking_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    delegated_contracts : list Tezos_protocol_alpha.Protocol.Contract_repr.t;
    delegated_balance : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t;
    deactivated : bool;
    grace_period : Tezos_protocol_alpha.Protocol.Alpha_context.Cycle.t }.
  
  Definition info
    (ctxt : t)
    (pkh :
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
        Tezos_protocol_alpha.Protocol.Alpha_services.Delegate.info) :=
    Alpha_services.Delegate.info rpc_ctxt ctxt pkh.
End Delegate.

Definition init
  (endorsers_per_block : option Z) (with_commitments : option bool)
  (op_staroptstar : option (list int64))
  : (option Z) ->
    (option int32) ->
      Z ->
        Lwt.t
          (Tezos_base__TzPervasives.tzresult
            (Tezos_alpha_test_helpers.Block.block *
              (list
                Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract))) :=
  let initial_balances :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => []
    end in
  fun initial_endorsers =>
    fun min_proposal_quorum =>
      fun n =>
        let accounts := Account.generate_accounts (Some initial_balances) n in
        let contracts :=
          List.map
            (fun function_parameter =>
              let '(a, _) := function_parameter in
              Alpha_context.Contract.implicit_contract (pkh a)) accounts in
        op_gtgteqquestion
          (Block.genesis with_commitments endorsers_per_block initial_endorsers
            min_proposal_quorum accounts) (fun blk => _return (blk, contracts)).

src/proto_alpha/lib_protocol/test/helpers/incremental.ml 15 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

type t = {
  predecessor : Block.t;
  state : validation_state;
  rev_operations : Operation.packed list;
  rev_tickets : operation_receipt list;
  header : Block_header.t;
  delegate : Account.t;
}

type incremental = t

let predecessor {predecessor; _} = predecessor

let header {header; _} = header

let rev_tickets {rev_tickets; _} = rev_tickets

let level st = st.header.shell.level

let rpc_context st =
  let result = Alpha_context.finalize st.state.ctxt in
  {
    Environment.Updater.block_hash = Block_hash.zero;
    block_header = {st.header.shell with fitness = result.fitness};
    context = result.context;
  }

let rpc_ctxt =
  new Environment.proto_rpc_context_of_directory rpc_context rpc_services

let begin_construction ?(priority = 0) ?timestamp ?seed_nonce_hash
    ?(policy = Block.By_priority priority) (predecessor : Block.t) =
  Block.get_next_baker ~policy predecessor
  >>=? fun (delegate, priority, _timestamp) ->
  Alpha_services.Delegate.Minimal_valid_time.get
    Block.rpc_ctxt
    predecessor
    priority
    0
  >>=? fun real_timestamp ->
  Account.find delegate
  >>=? fun delegate ->
  let timestamp = Option.unopt ~default:real_timestamp timestamp in
  let contents = Block.Forge.contents ~priority ?seed_nonce_hash () in
  let protocol_data = {Block_header.contents; signature = Signature.zero} in
  let header =
    {
      Block_header.shell =
        {
          predecessor = predecessor.hash;
          proto_level = predecessor.header.shell.proto_level;
          validation_passes = predecessor.header.shell.validation_passes;
          fitness = predecessor.header.shell.fitness;
          timestamp;
          level = predecessor.header.shell.level;
          context = Context_hash.zero;
          operations_hash = Operation_list_list_hash.zero;
        };
      protocol_data = {contents; signature = Signature.zero};
    }
  in
  begin_construction
    ~chain_id:Chain_id.zero
    ~predecessor_context:predecessor.context
    ~predecessor_timestamp:predecessor.header.shell.timestamp
    ~predecessor_fitness:predecessor.header.shell.fitness
    ~predecessor_level:predecessor.header.shell.level
    ~predecessor:predecessor.hash
    ~timestamp
    ~protocol_data
    ()
  >>= fun state ->
  Lwt.return (Environment.wrap_error state)
  >>=? fun state ->
  return
    {
      predecessor;
      state;
      rev_operations = [];
      rev_tickets = [];
      header;
      delegate;
    }

let detect_script_failure :
    type kind. kind Apply_results.operation_metadata -> _ =
  let rec detect_script_failure :
      type kind. kind Apply_results.contents_result_list -> _ =
    let open Apply_results in
    let detect_script_failure_single (type kind)
        (Manager_operation_result
           {operation_result; internal_operation_results; _} :
          kind Kind.manager Apply_results.contents_result) =
      let detect_script_failure (type kind)
          (result : kind manager_operation_result) =
        match result with
        | Applied _ ->
            Ok ()
        | Skipped _ ->
            assert false
        | Backtracked (_, None) ->
            (* there must be another error for this to happen *)
            Ok ()
        | Backtracked (_, Some errs) ->
            Environment.wrap_error (Error errs)
        | Failed (_, errs) ->
            Environment.wrap_error (Error errs)
      in
      List.fold_left
        (fun acc (Internal_operation_result (_, r)) ->
          acc >>? fun () -> detect_script_failure r)
        (detect_script_failure operation_result)
        internal_operation_results
    in
    function
    | Single_result (Manager_operation_result _ as res) ->
        detect_script_failure_single res
    | Single_result _ ->
        Ok ()
    | Cons_result (res, rest) ->
        detect_script_failure_single res
        >>? fun () -> detect_script_failure rest
  in
  fun {contents} -> detect_script_failure contents

let add_operation ?expect_failure st op =
  let open Apply_results in
  apply_operation st.state op
  >>= fun x ->
  Lwt.return (Environment.wrap_error x)
  >>=? function
  | (state, (Operation_metadata result as metadata)) ->
      Lwt.return @@ detect_script_failure result
      >>= fun result ->
      ( match expect_failure with
      | None ->
          Lwt.return result
      | Some f -> (
        match result with
        | Ok _ ->
            failwith "Error expected while adding operation"
        | Error e ->
            f e ) )
      >>=? fun () ->
      return
        {
          st with
          state;
          rev_operations = op :: st.rev_operations;
          rev_tickets = metadata :: st.rev_tickets;
        }
  | (state, (No_operation_metadata as metadata)) ->
      return
        {
          st with
          state;
          rev_operations = op :: st.rev_operations;
          rev_tickets = metadata :: st.rev_tickets;
        }

let finalize_block st =
  finalize_block st.state
  >>= fun x ->
  Lwt.return (Environment.wrap_error x)
  >>=? fun (result, _) ->
  let operations = List.rev st.rev_operations in
  let operations_hash =
    Operation_list_list_hash.compute
      [Operation_list_hash.compute (List.map Operation.hash_packed operations)]
  in
  let header =
    {
      st.header with
      shell =
        {
          st.header.shell with
          level = Int32.succ st.header.shell.level;
          operations_hash;
          fitness = result.fitness;
        };
    }
  in
  let hash = Block_header.hash header in
  return {Block.hash; header; operations; context = result.context}
src/proto_alpha/lib_protocol/test/helpers/incremental.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Record t := {
  predecessor : Tezos_alpha_test_helpers.Block.t;
  state : Tezos_protocol_alpha.Protocol.validation_state;
  rev_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.Operation.packed;
  rev_tickets : list Tezos_protocol_alpha.Protocol.operation_receipt;
  header : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t;
  delegate : Tezos_alpha_test_helpers.Account.t }.

Definition incremental := t.

Definition predecessor (function_parameter : t)
  : Tezos_alpha_test_helpers.Block.t :=
  let '{| predecessor := predecessor |} := function_parameter in
  predecessor.

Definition header (function_parameter : t)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t :=
  let '{| header := header |} := function_parameter in
  header.

Definition rev_tickets (function_parameter : t)
  : list Tezos_protocol_alpha.Protocol.operation_receipt :=
  let '{| rev_tickets := rev_tickets |} := function_parameter in
  rev_tickets.

Definition level (st : t)
  : Tezos_protocol_environment_alpha__Environment.Int32.t :=
  level (shell (header st)).

Definition rpc_context (st : t)
  : Tezos_protocol_alpha.Protocol.Environment.Updater.rpc_context :=
  let result := Alpha_context.finalize None (ctxt (state st)) in
  {| Environment.Updater.block_hash := Block_hash.zero;
    Environment.Updater.block_header :=
      (* ❌ Record substitution not handled *)
      record_substitution; Environment.Updater.context := context result |}.

Definition rpc_ctxt
  : Tezos_protocol_alpha.Protocol.Environment.proto_rpc_context_of_directory t :=
  (* ❌ Creation of new objects is not handled *)
  new rpc_context rpc_services.

Definition begin_construction (op_staroptstar : option Z)
  : (option Tezos_protocol_environment_alpha__Environment.Time.t) ->
    (option Tezos_protocol_alpha.Protocol.Nonce_hash.t) ->
      (option Tezos_alpha_test_helpers.Block.baker_policy) ->
        Tezos_alpha_test_helpers.Block.t ->
          Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  let priority :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => 0
    end in
  fun timestamp =>
    fun seed_nonce_hash =>
      fun op_staroptstar =>
        let policy :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => Tezos_alpha_test_helpers.Block.By_priority priority
          end in
        fun predecessor =>
          op_gtgteqquestion (Block.get_next_baker (Some policy) predecessor)
            (fun function_parameter =>
              let '(delegate, priority, _timestamp) := function_parameter in
              op_gtgteqquestion
                (Alpha_services.Delegate.Minimal_valid_time.get Block.rpc_ctxt
                  predecessor priority 0)
                (fun real_timestamp =>
                  op_gtgteqquestion (Account.find delegate)
                    (fun delegate =>
                      let timestamp := Option.unopt real_timestamp timestamp in
                      let contents :=
                        Block.Forge.contents None (Some priority)
                          seed_nonce_hash tt in
                      let protocol_data :=
                        {| Block_header.contents := contents;
                          Block_header.signature := Signature.zero |} in
                      let header :=
                        {|
                          Block_header.shell :=
                            {| level := level (shell (header predecessor));
                              proto_level :=
                                proto_level (shell (header predecessor));
                              predecessor := hash predecessor;
                              timestamp := timestamp;
                              validation_passes :=
                                validation_passes (shell (header predecessor));
                              operations_hash := Operation_list_list_hash.zero;
                              fitness := fitness (shell (header predecessor));
                              context := Context_hash.zero |};
                          Block_header.protocol_data :=
                            {| contents := contents; signature := Signature.zero
                              |} |} in
                      op_gtgteq
                        (begin_construction Chain_id.zero (context predecessor)
                          (timestamp (shell (header predecessor)))
                          (level (shell (header predecessor)))
                          (fitness (shell (header predecessor)))
                          (hash predecessor) timestamp (Some protocol_data) tt)
                        (fun state =>
                          op_gtgteqquestion
                            (Lwt._return (Environment.wrap_error state))
                            (fun state =>
                              _return
                                {| predecessor := predecessor; state := state;
                                  rev_operations := []; rev_tickets := [];
                                  header := header; delegate := delegate |}))))).

Definition detect_script_failure {kind : Type}
  : (Tezos_protocol_alpha.Protocol.Apply_results.operation_metadata kind) ->
    Tezos_base__TzPervasives.tzresult unit :=
  let detect_script_failure :=
    let detect_script_failure_single {B : Type}
      (function_parameter :
      Tezos_protocol_alpha.Protocol.Apply_results.contents_result
        (Tezos_protocol_alpha.Protocol.Alpha_context.Kind.manager B))
      : Tezos_base__TzPervasives.tzresult unit :=
      let
        'Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result {|
          operation_result := operation_result;
            internal_operation_results := internal_operation_results
            |} := function_parameter in
      let detect_script_failure {C : Type}
        (result :
        Tezos_protocol_alpha.Protocol.Apply_results.manager_operation_result C)
        : sum unit Tezos_base__TzPervasives.Error_monad.trace :=
        match result with
        | Tezos_protocol_alpha.Protocol.Apply_results.Applied _ => Stdlib.Ok tt
        | Tezos_protocol_alpha.Protocol.Apply_results.Skipped _ =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ None =>
          Stdlib.Ok tt
        | Tezos_protocol_alpha.Protocol.Apply_results.Backtracked _ (Some errs)
          => Environment.wrap_error (Stdlib.Error errs)
        | Tezos_protocol_alpha.Protocol.Apply_results.Failed _ errs =>
          Environment.wrap_error (Stdlib.Error errs)
        end in
      List.fold_left
        (fun acc =>
          fun function_parameter =>
            let
              'Tezos_protocol_alpha.Protocol.Apply_results.Internal_operation_result
                _ r := function_parameter in
            op_gtgtquestion acc
              (fun function_parameter =>
                let 'tt := function_parameter in
                detect_script_failure r))
        (detect_script_failure operation_result) internal_operation_results in
    fun function_parameter =>
      match function_parameter with
      |
        Tezos_protocol_alpha.Protocol.Apply_results.Single_result
          ((Tezos_protocol_alpha.Protocol.Apply_results.Manager_operation_result
            _) as res) => detect_script_failure_single res
      | Tezos_protocol_alpha.Protocol.Apply_results.Single_result _ =>
        Stdlib.Ok tt
      | Tezos_protocol_alpha.Protocol.Apply_results.Cons_result res rest =>
        op_gtgtquestion (detect_script_failure_single res)
          (fun function_parameter =>
            let 'tt := function_parameter in
            detect_script_failure rest)
      end in
  fun function_parameter =>
    let '{| contents := contents |} := function_parameter in
    detect_script_failure contents.

Definition add_operation
  (expect_failure :
    option
      (Tezos_base__TzPervasives.trace ->
        Lwt.t (Tezos_base__TzPervasives.tzresult unit))) (st : t)
  (op : Tezos_protocol_alpha.Protocol.operation)
  : Lwt.t (Tezos_base__TzPervasives.tzresult t) :=
  op_gtgteq (apply_operation (state st) op)
    (fun x =>
      op_gtgteqquestion (Lwt._return (Environment.wrap_error x))
        (fun function_parameter =>
          match function_parameter with
          |
            (state,
              (Tezos_protocol_alpha.Protocol.Apply_results.Operation_metadata
                result) as metadata) =>
            op_gtgteq (apply Lwt._return (detect_script_failure result))
              (fun result =>
                op_gtgteqquestion
                  match expect_failure with
                  | None => Lwt._return result
                  | Some f =>
                    match result with
                    | Stdlib.Ok _ =>
                      failwith
                        (CamlinternalFormatBasics.Format
                          (CamlinternalFormatBasics.String_literal
                            "Error expected while adding operation" % string
                            CamlinternalFormatBasics.End_of_format)
                          "Error expected while adding operation" % string)
                    | Stdlib.Error e => f e
                    end
                  end
                  (fun function_parameter =>
                    let 'tt := function_parameter in
                    _return
                      (* ❌ Record substitution not handled *)
                      record_substitution))
          |
            (state,
              Tezos_protocol_alpha.Protocol.Apply_results.No_operation_metadata
                as metadata) =>
            _return
              (* ❌ Record substitution not handled *)
              record_substitution
          end)).

Definition finalize_block (st : t)
  : Lwt.t (Tezos_base__TzPervasives.tzresult Tezos_alpha_test_helpers.Block.t) :=
  op_gtgteq (finalize_block (state st))
    (fun x =>
      op_gtgteqquestion (Lwt._return (Environment.wrap_error x))
        (fun function_parameter =>
          let '(result, _) := function_parameter in
          let operations := List.rev (rev_operations st) in
          let operations_hash :=
            Operation_list_list_hash.compute
              (cons
                (Operation_list_hash.compute
                  (List.map Operation.hash_packed operations)) []) in
          let header :=
            (* ❌ Record substitution not handled *)
            record_substitution in
          let hash := Block_header.hash header in
          _return
            {| Block.hash := hash; Block.header := header;
              Block.operations := operations; Block.context := context result |})).

src/proto_alpha/lib_protocol/test/helpers/nonce.ml 9 errors
(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2018.                                          *)
(*    Dynamic Ledger Solutions, Inc.< contact@tezos.com >                 *)
(*                                                                        *)
(*    All rights reserved.No warranty, explicit or implicit, provided.    *)
(*                                                                        *)
(**************************************************************************)

open Protocol

module Table = Hashtbl.Make (struct
  type t = Nonce_hash.t

  let hash h = Int32.to_int (MBytes.get_int32 (Nonce_hash.to_bytes h) 0)

  let equal = Nonce_hash.equal
end)

let known_nonces = Table.create 17

let generate () =
  match
    Alpha_context.Nonce.of_bytes
    @@ Rand.generate Alpha_context.Constants.nonce_length
  with
  | Ok nonce ->
      let hash = Alpha_context.Nonce.hash nonce in
      Table.add known_nonces hash nonce ;
      (hash, nonce)
  | Error _ ->
      assert false

let forget_all () = Table.clear known_nonces

let get hash = Table.find known_nonces hash
src/proto_alpha/lib_protocol/test/helpers/nonce.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

(* ❌ Applications of functors are not handled. *)
functor_application

Definition known_nonces
  : Table.t Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  Table.create 17.

Definition generate (function_parameter : unit)
  : Tezos_raw_protocol_alpha.Nonce_hash.t *
    Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  let 'tt := function_parameter in
  match
    apply Alpha_context.Nonce.of_bytes
      (Rand.generate Alpha_context.Constants.nonce_length) with
  | Stdlib.Ok nonce =>
    let hash := Alpha_context.Nonce.hash nonce in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := Table.add known_nonces hash nonce in
    (hash, nonce)
  | Stdlib.Error _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition forget_all (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  Table.clear known_nonces.

Definition get (hash : Table.key)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.nonce :=
  Table.find known_nonces hash.

src/proto_alpha/lib_protocol/test/helpers/op.ml 91 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context

let sign ?(watermark = Signature.Generic_operation) sk ctxt contents =
  let branch = Context.branch ctxt in
  let unsigned =
    Data_encoding.Binary.to_bytes_exn
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  let signature = Some (Signature.sign ~watermark sk unsigned) in
  ({shell = {branch}; protocol_data = {contents; signature}} : _ Operation.t)

let endorsement ?delegate ?level ctxt ?(signing_context = ctxt) () =
  ( match delegate with
  | None ->
      Context.get_endorser ctxt >>=? fun (delegate, _slots) -> return delegate
  | Some delegate ->
      return delegate )
  >>=? fun delegate_pkh ->
  Account.find delegate_pkh
  >>=? fun delegate ->
  ( match level with
  | None ->
      Context.get_level ctxt
  | Some level ->
      return level )
  >>=? fun level ->
  let op = Single (Endorsement {level}) in
  return
    (sign
       ~watermark:Signature.(Endorsement Chain_id.zero)
       delegate.sk
       signing_context
       op)

let sign ?watermark sk ctxt (Contents_list contents) =
  Operation.pack (sign ?watermark sk ctxt contents)

let combine_operations ?public_key ?counter ~source ctxt
    (packed_operations : packed_operation list) =
  assert (List.length packed_operations > 0) ;
  (* Hypothesis : each operation must have the same branch (is this really true?) *)
  let {Tezos_base.Operation.branch} = (List.hd packed_operations).shell in
  assert (
    List.for_all
      (fun {shell = {Tezos_base.Operation.branch = b; _}; _} ->
        Block_hash.(branch = b))
      packed_operations ) ;
  (* TODO? : check signatures consistency *)
  let unpacked_operations =
    List.map
      (function
        | {Alpha_context.protocol_data = Operation_data {contents; _}; _} -> (
          match Contents_list contents with
          | Contents_list (Single o) ->
              Contents o
          | Contents_list
              (Cons (Manager_operation {operation = Reveal _; _}, Single o)) ->
              Contents o
          | _ ->
              (* TODO : decent error *) assert false ))
      packed_operations
  in
  ( match counter with
  | Some counter ->
      return counter
  | None ->
      Context.Contract.counter ctxt source )
  >>=? fun counter ->
  (* We increment the counter *)
  let counter = Z.succ counter in
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let public_key = Option.unopt ~default:account.pk public_key in
  Context.Contract.is_manager_key_revealed ctxt source
  >>=? (function
         | false ->
             let reveal_op =
               Manager_operation
                 {
                   source = Signature.Public_key.hash public_key;
                   fee = Tez.zero;
                   counter;
                   operation = Reveal public_key;
                   gas_limit = Z.of_int 10000;
                   storage_limit = Z.zero;
                 }
             in
             return (Some (Contents reveal_op), Z.succ counter)
         | true ->
             return (None, counter))
  >>=? fun (manager_op, counter) ->
  (* Update counters and transform into a contents_list *)
  let operations =
    List.fold_left
      (fun (counter, acc) -> function Contents (Manager_operation m) ->
            ( Z.succ counter,
              Contents (Manager_operation {m with counter}) :: acc ) | x ->
            (counter, x :: acc))
      (counter, match manager_op with None -> [] | Some op -> [op])
      unpacked_operations
    |> snd |> List.rev
  in
  let operations = Operation.of_list operations in
  return @@ sign account.sk ctxt operations

let manager_operation ?counter ?(fee = Tez.zero) ?gas_limit ?storage_limit
    ?public_key ~source ctxt operation =
  ( match counter with
  | Some counter ->
      return counter
  | None ->
      Context.Contract.counter ctxt source )
  >>=? fun counter ->
  Context.get_constants ctxt
  >>=? fun c ->
  let gas_limit =
    Option.unopt
      ~default:c.parametric.hard_storage_limit_per_operation
      gas_limit
  in
  let storage_limit =
    Option.unopt
      ~default:c.parametric.hard_storage_limit_per_operation
      storage_limit
  in
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let public_key = Option.unopt ~default:account.pk public_key in
  let counter = Z.succ counter in
  Context.Contract.is_manager_key_revealed ctxt source
  >>=? function
  | true ->
      let op =
        Manager_operation
          {
            source = Signature.Public_key.hash public_key;
            fee;
            counter;
            operation;
            gas_limit;
            storage_limit;
          }
      in
      return (Contents_list (Single op))
  | false ->
      let op_reveal =
        Manager_operation
          {
            source = Signature.Public_key.hash public_key;
            fee = Tez.zero;
            counter;
            operation = Reveal public_key;
            gas_limit = Z.of_int 10000;
            storage_limit = Z.zero;
          }
      in
      let op =
        Manager_operation
          {
            source = Signature.Public_key.hash public_key;
            fee;
            counter = Z.succ counter;
            operation;
            gas_limit;
            storage_limit;
          }
      in
      return (Contents_list (Cons (op_reveal, Single op)))

let revelation ctxt public_key =
  let pkh = Signature.Public_key.hash public_key in
  let source = Contract.implicit_contract pkh in
  Context.Contract.counter ctxt source
  >>=? fun counter ->
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let counter = Z.succ counter in
  let sop =
    Contents_list
      (Single
         (Manager_operation
            {
              source = Signature.Public_key.hash public_key;
              fee = Tez.zero;
              counter;
              operation = Reveal public_key;
              gas_limit = Z.of_int 10000;
              storage_limit = Z.zero;
            }))
  in
  return @@ sign account.sk ctxt sop

let originated_contract op =
  let nonce = Contract.initial_origination_nonce (Operation.hash_packed op) in
  Contract.originated_contract nonce

exception Impossible

let origination ?counter ?delegate ~script ?(preorigination = None) ?public_key
    ?credit ?fee ?gas_limit ?storage_limit ctxt source =
  Context.Contract.manager ctxt source
  >>=? fun account ->
  let default_credit = Tez.of_mutez @@ Int64.of_int 1000001 in
  let default_credit = Option.unopt_exn Impossible default_credit in
  let credit = Option.unopt ~default:default_credit credit in
  let operation = Origination {delegate; script; credit; preorigination} in
  manager_operation
    ?counter
    ?public_key
    ?fee
    ?gas_limit
    ?storage_limit
    ~source
    ctxt
    operation
  >>=? fun sop ->
  let op = sign account.sk ctxt sop in
  return (op, originated_contract op)

let miss_signed_endorsement ?level ctxt =
  ( match level with
  | None ->
      Context.get_level ctxt
  | Some level ->
      return level )
  >>=? fun level ->
  Context.get_endorser ctxt
  >>=? fun (real_delegate_pkh, _slots) ->
  let delegate = Account.find_alternate real_delegate_pkh in
  endorsement ~delegate:delegate.pkh ~level ctxt ()

let transaction ?fee ?gas_limit ?storage_limit
    ?(parameters = Script.unit_parameter) ?(entrypoint = "default") ctxt
    (src : Contract.t) (dst : Contract.t) (amount : Tez.t) =
  let top = Transaction {amount; parameters; destination = dst; entrypoint} in
  manager_operation ?fee ?gas_limit ?storage_limit ~source:src ctxt top
  >>=? fun sop ->
  Context.Contract.manager ctxt src
  >>=? fun account -> return @@ sign account.sk ctxt sop

let delegation ?fee ctxt source dst =
  let top = Delegation dst in
  manager_operation ?fee ~source ctxt top
  >>=? fun sop ->
  Context.Contract.manager ctxt source
  >>=? fun account -> return @@ sign account.sk ctxt sop

let activation ctxt (pkh : Signature.Public_key_hash.t) activation_code =
  ( match pkh with
  | Ed25519 edpkh ->
      return edpkh
  | _ ->
      failwith
        "Wrong public key hash : %a - Commitments must be activated with an \
         Ed25519 encrypted public key hash"
        Signature.Public_key_hash.pp
        pkh )
  >>=? fun id ->
  let contents = Single (Activate_account {id; activation_code}) in
  let branch = Context.branch ctxt in
  return
    {
      shell = {branch};
      protocol_data = Operation_data {contents; signature = None};
    }

let double_endorsement ctxt op1 op2 =
  let contents = Single (Double_endorsement_evidence {op1; op2}) in
  let branch = Context.branch ctxt in
  return
    {
      shell = {branch};
      protocol_data = Operation_data {contents; signature = None};
    }

let double_baking ctxt bh1 bh2 =
  let contents = Single (Double_baking_evidence {bh1; bh2}) in
  let branch = Context.branch ctxt in
  return
    {
      shell = {branch};
      protocol_data = Operation_data {contents; signature = None};
    }

let seed_nonce_revelation ctxt level nonce =
  return
    {
      shell = {branch = Context.branch ctxt};
      protocol_data =
        Operation_data
          {
            contents = Single (Seed_nonce_revelation {level; nonce});
            signature = None;
          };
    }

let proposals ctxt (pkh : Contract.t) proposals =
  Context.Contract.pkh pkh
  >>=? fun source ->
  Context.Vote.get_voting_period ctxt
  >>=? fun period ->
  let op = Proposals {source; period; proposals} in
  Account.find source
  >>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op)))

let ballot ctxt (pkh : Contract.t) proposal ballot =
  Context.Contract.pkh pkh
  >>=? fun source ->
  Context.Vote.get_voting_period ctxt
  >>=? fun period ->
  let op = Ballot {source; period; proposal; ballot} in
  Account.find source
  >>=? fun account -> return (sign account.sk ctxt (Contents_list (Single op)))

let dummy_script =
  let open Micheline in
  Script.
    {
      code =
        lazy_expr
          (strip_locations
             (Seq
                ( 0,
                  [ Prim (0, K_parameter, [Prim (0, T_unit, [], [])], []);
                    Prim (0, K_storage, [Prim (0, T_unit, [], [])], []);
                    Prim
                      ( 0,
                        K_code,
                        [ Seq
                            ( 0,
                              [ Prim (0, I_CDR, [], []);
                                Prim
                                  ( 0,
                                    I_NIL,
                                    [Prim (0, T_operation, [], [])],
                                    [] );
                                Prim (0, I_PAIR, [], []) ] ) ],
                        [] ) ] )));
      storage = lazy_expr (strip_locations (Prim (0, D_Unit, [], [])));
    }

let dummy_script_cost = Test_tez.Tez.of_mutez_exn 38_000L
src/proto_alpha/lib_protocol/test/helpers/op.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition sign {A : Type}
  (op_staroptstar : option Tezos_base__TzPervasives.Signature.watermark)
  : Tezos_base__TzPervasives.Signature.Secret_key.t ->
    Tezos_alpha_test_helpers.Context.t ->
      (Tezos_protocol_alpha.Protocol.Alpha_context.contents_list A) ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t A :=
  let watermark :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tezos_base__TzPervasives.Signature.Generic_operation
    end in
  fun sk =>
    fun ctxt =>
      fun contents =>
        let branch := Context.branch ctxt in
        let unsigned :=
          Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding
            ({| branch := branch |},
              (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
                contents)) in
        let signature := Some (Signature.sign (Some watermark) sk unsigned) in
        {| shell := {| branch := branch |};
          protocol_data := {| contents := contents; signature := signature |} |}.

Definition endorsement
  (delegate : option Tezos_protocol_alpha.Protocol.Alpha_context.public_key_hash)
  (level : option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (op_staroptstar : option Tezos_alpha_test_helpers.Context.t)
  : unit ->
    Lwt.t
      (Tezos_base__TzPervasives.tzresult
        (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
          Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)) :=
  let signing_context :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => ctxt
    end in
  fun function_parameter =>
    let 'tt := function_parameter in
    op_gtgteqquestion
      match delegate with
      | None =>
        op_gtgteqquestion (Context.get_endorser ctxt)
          (fun function_parameter =>
            let '(delegate, _slots) := function_parameter in
            _return delegate)
      | Some delegate => _return delegate
      end
      (fun delegate_pkh =>
        op_gtgteqquestion (Account.find delegate_pkh)
          (fun delegate =>
            op_gtgteqquestion
              match level with
              | None => Context.get_level ctxt
              | Some level => _return level
              end
              (fun level =>
                let op :=
                  Tezos_protocol_alpha.Protocol.Alpha_context.Single
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Endorsement
                      {| level := level |}) in
                _return
                  (sign
                    (Some
                      (Tezos_base__TzPervasives.Signature.Endorsement
                        Chain_id.zero)) (sk delegate) signing_context op)))).

Definition sign
  (watermark : option Tezos_base__TzPervasives.Signature.watermark)
  (sk : Tezos_base__TzPervasives.Signature.Secret_key.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.packed_contents_list)
  : Tezos_raw_protocol_alpha__Alpha_context.packed_operation :=
  let 'Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents :=
    function_parameter in
  Operation.pack (sign watermark sk ctxt contents).

Definition combine_operations
  (public_key : option Tezos_base__TzPervasives.Signature.Public_key.t)
  (counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (packed_operations :
    list Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert (OCaml.Stdlib.gt (List.length packed_operations) 0) in
  let '{| Tezos_base.Operation.branch := branch |} :=
    shell (List.hd packed_operations) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ Assert instruction is not handled. *)
    assert
      (List.for_all
        (fun function_parameter =>
          let '{| shell := {| Tezos_base.Operation.branch := b |} |} :=
            function_parameter in
          op_eq branch b) packed_operations) in
  let unpacked_operations :=
    List.map
      (fun function_parameter =>
        let '{|
          Alpha_context.protocol_data :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data {|
              contents := contents |}
            |} := function_parameter in
        match Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list contents
          with
        |
          Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
            (Tezos_protocol_alpha.Protocol.Alpha_context.Single o) =>
          Tezos_protocol_alpha.Protocol.Alpha_context.Contents o
        |
          Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
            (Tezos_protocol_alpha.Protocol.Alpha_context.Cons
              (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation {|
                operation := Tezos_protocol_alpha.Protocol.Alpha_context.Reveal _
                  |}) (Tezos_protocol_alpha.Protocol.Alpha_context.Single o)) =>
          Tezos_protocol_alpha.Protocol.Alpha_context.Contents o
        | _ =>
          (* ❌ Assert instruction is not handled. *)
          assert false
        end) packed_operations in
  op_gtgteqquestion
    match counter with
    | Some counter => _return counter
    | None => Context.Contract.counter ctxt source
    end
    (fun counter =>
      let counter := Z.succ counter in
      op_gtgteqquestion (Context.Contract.manager ctxt source)
        (fun account =>
          let public_key := Option.unopt (pk account) public_key in
          op_gtgteqquestion
            (op_gtgteqquestion
              (Context.Contract.is_manager_key_revealed ctxt source)
              (fun function_parameter =>
                match function_parameter with
                | false =>
                  let reveal_op :=
                    Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                      {| source := Signature.Public_key.hash public_key;
                        fee := Tez.zero; counter := counter;
                        operation :=
                          Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
                            public_key; gas_limit := Z.of_int 10000;
                        storage_limit := Z.zero |} in
                  _return
                    ((Some
                      (Tezos_protocol_alpha.Protocol.Alpha_context.Contents
                        reveal_op)), (Z.succ counter))
                | true => _return (None, counter)
                end))
            (fun function_parameter =>
              let '(manager_op, counter) := function_parameter in
              let operations :=
                OCaml.Stdlib.reverse_apply
                  (OCaml.Stdlib.reverse_apply
                    (List.fold_left
                      (fun function_parameter =>
                        let '(counter, acc) := function_parameter in
                        fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_alpha.Protocol.Alpha_context.Contents
                              (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                                m) =>
                            ((Z.succ counter),
                              (cons
                                (Tezos_protocol_alpha.Protocol.Alpha_context.Contents
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                                    (* ❌ Record substitution not handled *)
                                    record_substitution)) acc))
                          | x => (counter, (cons x acc))
                          end)
                      (counter,
                        match manager_op with
                        | None => []
                        | Some op => cons op []
                        end) unpacked_operations) snd) List.rev in
              let operations := Operation.of_list operations in
              apply _return (sign None (sk account) ctxt operations)))).

Definition manager_operation {A : Type}
  (counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
    (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
      (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
          Tezos_alpha_test_helpers.Context.t ->
            (Tezos_protocol_alpha.Protocol.Alpha_context.manager_operation A) ->
              Lwt.t
                (Tezos_base__TzPervasives.tzresult
                  Tezos_protocol_alpha.Protocol.Alpha_context.packed_contents_list) :=
  let fee :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tez.zero
    end in
  fun gas_limit =>
    fun storage_limit =>
      fun public_key =>
        fun source =>
          fun ctxt =>
            fun operation =>
              op_gtgteqquestion
                match counter with
                | Some counter => _return counter
                | None => Context.Contract.counter ctxt source
                end
                (fun counter =>
                  op_gtgteqquestion (Context.get_constants ctxt)
                    (fun c =>
                      let gas_limit :=
                        Option.unopt
                          (hard_storage_limit_per_operation (parametric c))
                          gas_limit in
                      let storage_limit :=
                        Option.unopt
                          (hard_storage_limit_per_operation (parametric c))
                          storage_limit in
                      op_gtgteqquestion (Context.Contract.manager ctxt source)
                        (fun account =>
                          let public_key := Option.unopt (pk account) public_key
                            in
                          let counter := Z.succ counter in
                          op_gtgteqquestion
                            (Context.Contract.is_manager_key_revealed ctxt
                              source)
                            (fun function_parameter =>
                              match function_parameter with
                              | true =>
                                let op :=
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                                    {|
                                      source :=
                                        Signature.Public_key.hash public_key;
                                      fee := fee; counter := counter;
                                      operation := operation;
                                      gas_limit := gas_limit;
                                      storage_limit := storage_limit |} in
                                _return
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Single
                                      op))
                              | false =>
                                let op_reveal :=
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                                    {|
                                      source :=
                                        Signature.Public_key.hash public_key;
                                      fee := Tez.zero; counter := counter;
                                      operation :=
                                        Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
                                          public_key;
                                      gas_limit := Z.of_int 10000;
                                      storage_limit := Z.zero |} in
                                let op :=
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                                    {|
                                      source :=
                                        Signature.Public_key.hash public_key;
                                      fee := fee; counter := Z.succ counter;
                                      operation := operation;
                                      gas_limit := gas_limit;
                                      storage_limit := storage_limit |} in
                                _return
                                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
                                    (Tezos_protocol_alpha.Protocol.Alpha_context.Cons
                                      op_reveal
                                      (Tezos_protocol_alpha.Protocol.Alpha_context.Single
                                        op)))
                              end)))).

Definition revelation
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (public_key : Tezos_base__TzPervasives.Signature.Public_key.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  let pkh := Signature.Public_key.hash public_key in
  let source := Contract.implicit_contract pkh in
  op_gtgteqquestion (Context.Contract.counter ctxt source)
    (fun counter =>
      op_gtgteqquestion (Context.Contract.manager ctxt source)
        (fun account =>
          let counter := Z.succ counter in
          let sop :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
              (Tezos_protocol_alpha.Protocol.Alpha_context.Single
                (Tezos_protocol_alpha.Protocol.Alpha_context.Manager_operation
                  {| source := Signature.Public_key.hash public_key;
                    fee := Tez.zero; counter := counter;
                    operation :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Reveal
                        public_key; gas_limit := Z.of_int 10000;
                    storage_limit := Z.zero |})) in
          apply _return (sign None (sk account) ctxt sop))).

Definition originated_contract
  (op : Tezos_raw_protocol_alpha__Alpha_context.packed_operation)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract :=
  let nonce := Contract.initial_origination_nonce (Operation.hash_packed op) in
  Contract.originated_contract nonce.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition origination
  (counter : option Tezos_protocol_alpha.Protocol.Environment.Z.t)
  (delegate :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  (script : Tezos_protocol_alpha.Protocol.Alpha_context.Script.t)
  (op_staroptstar :
    option (option Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t))
  : (option Tezos_base__TzPervasives.Signature.Public_key.t) ->
    (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
        (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
          (option Tezos_protocol_environment_alpha__Environment.Z.t) ->
            Tezos_alpha_test_helpers.Context.t ->
              Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
                Lwt.t
                  (Tezos_base__TzPervasives.tzresult
                    (Tezos_raw_protocol_alpha__Alpha_context.packed_operation *
                      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract)) :=
  let preorigination :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => None
    end in
  fun public_key =>
    fun credit =>
      fun fee =>
        fun gas_limit =>
          fun storage_limit =>
            fun ctxt =>
              fun source =>
                op_gtgteqquestion (Context.Contract.manager ctxt source)
                  (fun account =>
                    let default_credit :=
                      apply Tez.of_mutez (Int64.of_int 1000001) in
                    let default_credit :=
                      Option.unopt_exn Impossible default_credit in
                    let credit := Option.unopt default_credit credit in
                    let operation :=
                      Tezos_protocol_alpha.Protocol.Alpha_context.Origination
                        {| delegate := delegate; script := script;
                          credit := credit; preorigination := preorigination |}
                      in
                    op_gtgteqquestion
                      (manager_operation counter fee gas_limit storage_limit
                        public_key source ctxt operation)
                      (fun sop =>
                        let op := sign None (sk account) ctxt sop in
                        _return (op, (originated_contract op)))).

Definition miss_signed_endorsement
  (level : option Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      (Tezos_protocol_alpha.Protocol.Alpha_context.Operation.t
        Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)) :=
  op_gtgteqquestion
    match level with
    | None => Context.get_level ctxt
    | Some level => _return level
    end
    (fun level =>
      op_gtgteqquestion (Context.get_endorser ctxt)
        (fun function_parameter =>
          let '(real_delegate_pkh, _slots) := function_parameter in
          let delegate := Account.find_alternate real_delegate_pkh in
          endorsement (Some (pkh delegate)) (Some level) ctxt None tt)).

Definition transaction
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (gas_limit : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (storage_limit : option Tezos_protocol_environment_alpha__Environment.Z.t)
  (op_staroptstar :
    option Tezos_protocol_alpha.Protocol.Alpha_context.Script.lazy_expr)
  : (option string) ->
    Tezos_alpha_test_helpers.Context.t ->
      Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
        Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t ->
          Tezos_protocol_alpha.Protocol.Alpha_context.Tez.t ->
            Lwt.t
              (Tezos_base__TzPervasives.tzresult
                Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  let parameters :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Script.unit_parameter
    end in
  fun op_staroptstar =>
    let entrypoint :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => "default" % string
      end in
    fun ctxt =>
      fun src =>
        fun dst =>
          fun amount =>
            let top :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Transaction
                {| amount := amount; parameters := parameters;
                  entrypoint := entrypoint; destination := dst |} in
            op_gtgteqquestion
              (manager_operation None fee gas_limit storage_limit None src ctxt
                top)
              (fun sop =>
                op_gtgteqquestion (Context.Contract.manager ctxt src)
                  (fun account =>
                    apply _return (sign None (sk account) ctxt sop))).

Definition delegation
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (source : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (dst :
    option
      Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  let top := Tezos_protocol_alpha.Protocol.Alpha_context.Delegation dst in
  op_gtgteqquestion (manager_operation None fee None None None source ctxt top)
    (fun sop =>
      op_gtgteqquestion (Context.Contract.manager ctxt source)
        (fun account => apply _return (sign None (sk account) ctxt sop))).

Definition activation
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (pkh : Tezos_base__TzPervasives.Signature.Public_key_hash.t)
  (activation_code :
    Tezos_raw_protocol_alpha.Blinded_public_key_hash.activation_code)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  op_gtgteqquestion
    match pkh with
    | Tezos_crypto__Signature.Ed25519 edpkh => _return edpkh
    | _ =>
      failwith
        (CamlinternalFormatBasics.Format
          (CamlinternalFormatBasics.String_literal
            "Wrong public key hash : " % string
            (CamlinternalFormatBasics.Alpha
              (CamlinternalFormatBasics.String_literal
                " - Commitments must be activated with an Ed25519 encrypted public key hash"
                  % string CamlinternalFormatBasics.End_of_format)))
          "Wrong public key hash : %a - Commitments must be activated with an Ed25519 encrypted public key hash"
            % string) Signature.Public_key_hash.pp pkh
    end
    (fun id =>
      let contents :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Single
          (Tezos_protocol_alpha.Protocol.Alpha_context.Activate_account
            {| id := id; activation_code := activation_code |}) in
      let branch := Context.branch ctxt in
      _return
        {| shell := {| branch := branch |};
          protocol_data :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
              {| contents := contents; signature := None |} |}).

Definition double_endorsement
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (op1 :
    Tezos_protocol_alpha.Protocol.Alpha_context.operation
      Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)
  (op2 :
    Tezos_protocol_alpha.Protocol.Alpha_context.operation
      Tezos_protocol_alpha.Protocol.Alpha_context.Kind.endorsement)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  let contents :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Single
      (Tezos_protocol_alpha.Protocol.Alpha_context.Double_endorsement_evidence
        {| op1 := op1; op2 := op2 |}) in
  let branch := Context.branch ctxt in
  _return
    {| shell := {| branch := branch |};
      protocol_data :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
          {| contents := contents; signature := None |} |}.

Definition double_baking
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (bh1 : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t)
  (bh2 : Tezos_protocol_alpha.Protocol.Alpha_context.Block_header.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  let contents :=
    Tezos_protocol_alpha.Protocol.Alpha_context.Single
      (Tezos_protocol_alpha.Protocol.Alpha_context.Double_baking_evidence
        {| bh1 := bh1; bh2 := bh2 |}) in
  let branch := Context.branch ctxt in
  _return
    {| shell := {| branch := branch |};
      protocol_data :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
          {| contents := contents; signature := None |} |}.

Definition seed_nonce_revelation
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (level : Tezos_protocol_alpha.Protocol.Alpha_context.Raw_level.t)
  (nonce : Tezos_protocol_alpha.Protocol.Alpha_context.Nonce.t)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_protocol_alpha.Protocol.Alpha_context.packed_operation) :=
  _return
    {| shell := {| branch := Context.branch ctxt |};
      protocol_data :=
        Tezos_protocol_alpha.Protocol.Alpha_context.Operation_data
          {|
            contents :=
              Tezos_protocol_alpha.Protocol.Alpha_context.Single
                (Tezos_protocol_alpha.Protocol.Alpha_context.Seed_nonce_revelation
                  {| level := level; nonce := nonce |}); signature := None |} |}.

Definition proposals
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (proposals :
    list
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  op_gtgteqquestion (Context.Contract.pkh pkh)
    (fun source =>
      op_gtgteqquestion (Context.Vote.get_voting_period ctxt)
        (fun period =>
          let op :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Proposals
              {| source := source; period := period; proposals := proposals |}
            in
          op_gtgteqquestion (Account.find source)
            (fun account =>
              _return
                (sign None (sk account) ctxt
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Single op)))))).

Definition ballot
  (ctxt : Tezos_alpha_test_helpers.Context.t)
  (pkh : Tezos_protocol_alpha.Protocol.Alpha_context.Contract.t)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (ballot : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballot)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult
      Tezos_raw_protocol_alpha__Alpha_context.packed_operation) :=
  op_gtgteqquestion (Context.Contract.pkh pkh)
    (fun source =>
      op_gtgteqquestion (Context.Vote.get_voting_period ctxt)
        (fun period =>
          let op :=
            Tezos_protocol_alpha.Protocol.Alpha_context.Ballot
              {| source := source; period := period; proposal := proposal;
                ballot := ballot |} in
          op_gtgteqquestion (Account.find source)
            (fun account =>
              _return
                (sign None (sk account) ctxt
                  (Tezos_protocol_alpha.Protocol.Alpha_context.Contents_list
                    (Tezos_protocol_alpha.Protocol.Alpha_context.Single op)))))).

Definition dummy_script
  : Tezos_protocol_alpha.Protocol.Alpha_context.Script.t :=
  {|
    code :=
      lazy_expr
        (strip_locations
          (Tezos_micheline.Micheline.Seq 0
            (cons
              (Tezos_micheline.Micheline.Prim 0
                Tezos_protocol_alpha.Protocol.Alpha_context.Script.K_parameter
                (cons
                  (Tezos_micheline.Micheline.Prim 0
                    Tezos_protocol_alpha.Protocol.Alpha_context.Script.T_unit []
                    []) []) [])
              (cons
                (Tezos_micheline.Micheline.Prim 0
                  Tezos_protocol_alpha.Protocol.Alpha_context.Script.K_storage
                  (cons
                    (Tezos_micheline.Micheline.Prim 0
                      Tezos_protocol_alpha.Protocol.Alpha_context.Script.T_unit
                      [] []) []) [])
                (cons
                  (Tezos_micheline.Micheline.Prim 0
                    Tezos_protocol_alpha.Protocol.Alpha_context.Script.K_code
                    (cons
                      (Tezos_micheline.Micheline.Seq 0
                        (cons
                          (Tezos_micheline.Micheline.Prim 0
                            Tezos_protocol_alpha.Protocol.Alpha_context.Script.I_CDR
                            [] [])
                          (cons
                            (Tezos_micheline.Micheline.Prim 0
                              Tezos_protocol_alpha.Protocol.Alpha_context.Script.I_NIL
                              (cons
                                (Tezos_micheline.Micheline.Prim 0
                                  Tezos_protocol_alpha.Protocol.Alpha_context.Script.T_operation
                                  [] []) []) [])
                            (cons
                              (Tezos_micheline.Micheline.Prim 0
                                Tezos_protocol_alpha.Protocol.Alpha_context.Script.I_PAIR
                                [] []) [])))) []) []) [])))));
    storage :=
      lazy_expr
        (strip_locations
          (Tezos_micheline.Micheline.Prim 0
            Tezos_protocol_alpha.Protocol.Alpha_context.Script.D_Unit [] [])) |}.

Definition dummy_script_cost
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  Test_tez.Tez.of_mutez_exn
    (* ❌ Constant of type int64 is converted to int *)
    38000.

src/proto_alpha/lib_protocol/test/helpers/test_tez.ml 12 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Environment

(* This module is mostly to wrap the errors from the protocol *)
module Tez = struct
  include Tez

  let ( +? ) t1 t2 = t1 +? t2 |> wrap_error

  let ( -? ) t1 t2 = t1 -? t2 |> wrap_error

  let ( *? ) t1 t2 = t1 *? t2 |> wrap_error

  let ( /? ) t1 t2 = t1 /? t2 |> wrap_error

  let ( + ) t1 t2 =
    match t1 +? t2 with
    | Ok r ->
        r
    | Error _ ->
        Pervasives.failwith "adding tez"

  let of_int x =
    match Tez.of_mutez (Int64.mul (Int64.of_int x) 1_000_000L) with
    | None ->
        invalid_arg "tez_of_int"
    | Some x ->
        x

  let of_mutez_exn x =
    match Tez.of_mutez x with
    | None ->
        invalid_arg "tez_of_mutez"
    | Some x ->
        x

  let max_tez =
    match Tez.of_mutez Int64.max_int with None -> assert false | Some p -> p
end
src/proto_alpha/lib_protocol/test/helpers/test_tez.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Import Environment.

Module Tez.
  (* ❌ Structure item `include` not handled. *)
  include
  
  Definition op_plusquestion (t1 : tez) (t2 : tez)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_plusquestion t1 t2) wrap_error.
  
  Definition op_minusquestion (t1 : tez) (t2 : tez)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_minusquestion t1 t2) wrap_error.
  
  Definition op_starquestion (t1 : tez) (t2 : int64)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_starquestion t1 t2) wrap_error.
  
  Definition op_divquestion (t1 : tez) (t2 : int64)
    : Tezos_base__TzPervasives.Error_monad.tzresult tez :=
    OCaml.Stdlib.reverse_apply (op_divquestion t1 t2) wrap_error.
  
  Definition op_plus (t1 : tez) (t2 : tez) : tez :=
    match op_plusquestion t1 t2 with
    | Stdlib.Ok r => r
    | Stdlib.Error _ => Pervasives.failwith "adding tez" % string
    end.
  
  Definition of_int (x : Z)
    : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
    match
      Tez.of_mutez
        (Int64.mul (Int64.of_int x)
          (* ❌ Constant of type int64 is converted to int *)
          1000000) with
    | None => OCaml.Stdlib.invalid_arg "tez_of_int" % string
    | Some x => x
    end.
  
  Definition of_mutez_exn (x : int64)
    : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
    match Tez.of_mutez x with
    | None => OCaml.Stdlib.invalid_arg "tez_of_mutez" % string
    | Some x => x
    end.
  
  Definition max_tez : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
    match Tez.of_mutez Int64.max_int with
    | None =>
      (* ❌ Assert instruction is not handled. *)
      assert false
    | Some p => p
    end.
End Tez.

src/proto_alpha/lib_protocol/test/helpers/test_utils.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* This file should not depend on any other file from tests. *)

let ( >>?= ) x y = match x with Ok a -> y a | Error b -> fail @@ List.hd b

(** Like List.find but returns the index of the found element *)
let findi p =
  let rec aux p i = function
    | [] ->
        raise Not_found
    | x :: l ->
        if p x then (x, i) else aux p (i + 1) l
  in
  aux p 0

exception Pair_of_list

let pair_of_list = function [a; b] -> (a, b) | _ -> raise Pair_of_list
src/proto_alpha/lib_protocol/test/helpers/test_utils.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition op_gtgtquestioneq {A B : Type}
  (x : sum A (list Tezos_base__TzPervasives.error))
  (y : A -> Lwt.t (Tezos_base__TzPervasives.tzresult B))
  : Lwt.t (Tezos_base__TzPervasives.tzresult B) :=
  match x with
  | Stdlib.Ok a => y a
  | Stdlib.Error b => apply fail (List.hd b)
  end.

Definition findi {A : Type} (p : A -> bool) : (list A) -> A * Z :=
  let fix aux {B : Type} (p : B -> bool) (i : Z) (function_parameter : list B)
    : B * Z :=
    match function_parameter with
    | [] => Stdlib.raise OCaml.Not_found
    | cons x l =>
      if p x then
        (x, i)
      else
        aux p (Z.add i 1) l
    end in
  aux p 0.

(* ❌ The definition of exceptions is not handled. *)
exception

Definition pair_of_list {A : Type} (function_parameter : list A) : A * A :=
  match function_parameter with
  | cons a (cons b []) => (a, b)
  | _ => Stdlib.raise Pair_of_list
  end.

src/proto_alpha/lib_protocol/test/main.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let () =
  Alcotest.run
    "protocol_alpha"
    [ ("transfer", Transfer.tests);
      ("origination", Origination.tests);
      ("activation", Activation.tests);
      ("endorsement", Endorsement.tests);
      ("double endorsement", Double_endorsement.tests);
      ("double baking", Double_baking.tests);
      ("seed", Seed.tests);
      ("baking", Baking.tests);
      ("delegation", Delegation.tests);
      ("rolls", Rolls.tests);
      ("combined", Combined_operations.tests);
      ("qty", Qty.tests);
      ("voting", Voting.tests) ]
src/proto_alpha/lib_protocol/test/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.



src/proto_alpha/lib_protocol/test/origination.ml 118 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Test_utils
open Test_tez

let ten_tez = Tez.of_int 10

(** [register_origination fee credit spendable delegatable] takes four
    optional parameter: fee for the fee need to be paid if set to
    create an originated contract; credit is the amount of tez that
    send to this originated contract; spendable default is set to true
    meaning that this contract is spendable; delegatable default is
    set to true meaning that this contract is able to delegate. *)
let register_origination ?(fee = Tez.zero) ?(credit = Tez.zero) () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let source = List.hd contracts in
  Context.Contract.balance (B b) source
  >>=? fun source_balance ->
  Op.origination (B b) source ~fee ~credit ~script:Op.dummy_script
  >>=? fun (operation, originated) ->
  Block.bake ~operation b
  >>=? fun b ->
  (* fee + credit + block security deposit were debited from source *)
  Context.get_constants (B b)
  >>=? fun { parametric =
               {origination_size; cost_per_byte; block_security_deposit; _};
             _ } ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return
    ( Tez.( +? ) credit block_security_deposit
    >>? Tez.( +? ) fee
    >>? Tez.( +? ) origination_burn
    >>? Tez.( +? ) Op.dummy_script_cost )
  >>=? fun total_fee ->
  Assert.balance_was_debited ~loc:__LOC__ (B b) source source_balance total_fee
  >>=? fun () ->
  (* originated contract has been credited *)
  Assert.balance_was_credited ~loc:__LOC__ (B b) originated Tez.zero credit
  >>=? fun () ->
  (* TODO spendable or not and delegatable or not if relevant for some
     test. Not the case at the moment, cf. uses of
     register_origination *)
  return (b, source, originated)

(* [test_origination_balances fee credit spendable delegatable]
   takes four optional parameter: fee is the fee that pay if require to create
   an originated contract; credit is the amount of tez that will send to this
   contract; delegatable default is set to true meaning that this contract is
   able to delegate.
   This function will create a contract, get the balance of this contract, call
   the origination operation to create a new originated contract from this
   contract with all the possible fees; and check the balance before/after
   originated operation valid.
   - the source contract has payed all the fees
   - the originated has been credited correctly *)
let test_origination_balances ~loc:_ ?(fee = Tez.zero) ?(credit = Tez.zero) ()
    =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.hd contracts in
  Context.Contract.balance (B b) contract
  >>=? fun balance ->
  Op.origination (B b) contract ~fee ~credit ~script:Op.dummy_script
  >>=? fun (operation, new_contract) ->
  (* The possible fees are: a given credit, an origination burn fee
     (constants_repr.default.origination_burn = 257 mtez),
     a fee that is paid when creating an originate contract.

     We also take into account a block security deposit. Note that it
     is not related to origination but to the baking done in the
     tests.*)
  Context.get_constants (B b)
  >>=? fun { parametric =
               {origination_size; cost_per_byte; block_security_deposit; _};
             _ } ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  Lwt.return
    ( Tez.( +? ) credit block_security_deposit
    >>? Tez.( +? ) fee
    >>? Tez.( +? ) origination_burn
    >>? Tez.( +? ) Op.dummy_script_cost )
  >>=? fun total_fee ->
  Block.bake ~operation b
  >>=? fun b ->
  (* check that after the block has been baked the source contract
     was debited all the fees *)
  Assert.balance_was_debited ~loc:__LOC__ (B b) contract balance total_fee
  >>=? fun _ ->
  (* check the balance of the originate contract is equal to credit *)
  Assert.balance_is ~loc:__LOC__ (B b) new_contract credit

(******************************************************)
(** Tests *)

(******************************************************)

(** compute half of the balance and divided it by nth times *)

let two_nth_of_balance incr contract nth =
  Context.Contract.balance (I incr) contract
  >>=? fun balance ->
  Tez.( /? ) balance nth
  >>?= fun res -> Tez.( *? ) res 2L >>?= fun balance -> return balance

(*******************)
(** Basic test *)

(*******************)

let balances_simple () = test_origination_balances ~loc:__LOC__ ()

let balances_credit () =
  test_origination_balances ~loc:__LOC__ ~credit:ten_tez ()

let balances_credit_fee () =
  test_origination_balances ~loc:__LOC__ ~credit:(Tez.of_int 2) ~fee:ten_tez ()

let balances_undelegatable () = test_origination_balances ~loc:__LOC__ ()

(*******************)
(** ask source contract to pay a fee when originating a contract *)

(*******************)

let pay_fee () =
  register_origination ~credit:(Tez.of_int 2) ~fee:ten_tez ()
  >>=? fun (_b, _contract, _new_contract) -> return_unit

(******************************************************)
(** Errors *)

(******************************************************)

(*******************)
(** create an originate contract where the contract
    does not have enough tez to pay for the fee *)

(*******************)

let not_tez_in_contract_to_pay_fee () =
  Context.init 2
  >>=? fun (b, contracts) ->
  let contract_1 = List.nth contracts 0 in
  let contract_2 = List.nth contracts 1 in
  Incremental.begin_construction b
  >>=? fun inc ->
  (* transfer everything but one tez from 1 to 2 and check balance of 1 *)
  Context.Contract.balance (I inc) contract_1
  >>=? fun balance ->
  Lwt.return @@ Tez.( -? ) balance Tez.one
  >>=? fun amount ->
  Op.transaction (I inc) contract_1 contract_2 amount
  >>=? fun operation ->
  Incremental.add_operation inc operation
  >>=? fun inc ->
  Assert.balance_was_debited ~loc:__LOC__ (I inc) contract_1 balance amount
  >>=? fun _ ->
  (* use this source contract to create an originate contract where it requires
     to pay a fee and add an amount of credit into this new contract *)
  Op.origination
    (I inc)
    ~fee:ten_tez
    ~credit:Tez.one
    contract_1
    ~script:Op.dummy_script
  >>=? fun (op, _) ->
  Incremental.add_operation inc op
  >>= fun inc ->
  Assert.proto_error ~loc:__LOC__ inc (function
      | Contract_storage.Balance_too_low _ ->
          true
      | _ ->
          false)

(***************************************************)
(* set the endorser of the block as manager/delegate of the originated
   account *)
(***************************************************)

let register_contract_get_endorser () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.hd contracts in
  Incremental.begin_construction b
  >>=? fun inc ->
  Context.get_endorser (I inc)
  >>=? fun (account_endorser, _slots) ->
  return (inc, contract, account_endorser)

(*******************)
(** create multiple originated contracts and
    ask contract to pay the fee *)

(*******************)

let n_originations n ?credit ?fee () =
  fold_left_s
    (fun new_contracts _ ->
      register_origination ?fee ?credit ()
      >>=? fun (_b, _source, new_contract) ->
      let contracts = new_contract :: new_contracts in
      return contracts)
    []
    (1 -- n)

let multiple_originations () =
  n_originations 100 ~credit:(Tez.of_int 2) ~fee:ten_tez ()
  >>=? fun contracts ->
  Assert.equal_int ~loc:__LOC__ (List.length contracts) 100

(*******************)
(** cannot originate two contracts with the same context's counter *)

(*******************)

let counter () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.hd contracts in
  Incremental.begin_construction b
  >>=? fun inc ->
  Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script
  >>=? fun (op1, _) ->
  Op.origination (I inc) ~credit:Tez.one contract ~script:Op.dummy_script
  >>=? fun (op2, _) ->
  Incremental.add_operation inc op1
  >>=? fun inc ->
  Incremental.add_operation inc op2
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Counter_in_the_past _ ->
          true
      | _ ->
          false)

(******************************************************)

let tests =
  [ Test.tztest "balances_simple" `Quick balances_simple;
    Test.tztest "balances_credit" `Quick balances_credit;
    Test.tztest "balances_credit_fee" `Quick balances_credit_fee;
    Test.tztest "balances_undelegatable" `Quick balances_undelegatable;
    Test.tztest "pay_fee" `Quick pay_fee;
    Test.tztest
      "not enough tez in contract to pay fee"
      `Quick
      not_tez_in_contract_to_pay_fee;
    Test.tztest "multiple originations" `Quick multiple_originations;
    Test.tztest "counter" `Quick counter ]
src/proto_alpha/lib_protocol/test/origination.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition ten_tez {A : Type} : A := op_startypeminuserrorstar 10.

Definition register_origination {A B C : Type} (op_staroptstar : option A)
  : (option B) ->
    unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let fee :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => op_startypeminuserrorstar
    end in
  fun op_staroptstar =>
    let credit :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => op_startypeminuserrorstar
      end in
    fun function_parameter =>
      let 'tt := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar 1)
        (fun function_parameter =>
          let '(b, contracts) := function_parameter in
          let source := List.hd contracts in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar source)
            (fun source_balance =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar source fee
                  credit op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(operation, originated) := function_parameter in
                  op_gtgteqquestion (op_startypeminuserrorstar operation b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          op_startypeminuserrorstar op_startypeminuserrorstar
                            (fun origination_burn =>
                              op_gtgteqquestion
                                (Lwt._return
                                  (op_gtgtquestion
                                    (op_gtgtquestion
                                      (op_gtgtquestion
                                        (op_startypeminuserrorstar credit
                                          op_startypeminuserrorstar)
                                        (op_startypeminuserrorstar fee))
                                      (op_startypeminuserrorstar
                                        origination_burn))
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar)))
                                (fun total_fee =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar __LOC__
                                      op_startypeminuserrorstar source
                                      source_balance total_fee)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar originated
                                          op_startypeminuserrorstar credit)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          _return (b, source, originated)))))))))).

Definition test_origination_balances {A B C D : Type} (function_parameter : A)
  : (option B) ->
    (option C) ->
      unit ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
  let '_ := function_parameter in
  fun op_staroptstar =>
    let fee :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => op_startypeminuserrorstar
      end in
    fun op_staroptstar =>
      let credit :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => op_startypeminuserrorstar
        end in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteqquestion (op_startypeminuserrorstar 1)
          (fun function_parameter =>
            let '(b, contracts) := function_parameter in
            let contract := List.hd contracts in
            op_gtgteqquestion
              (op_startypeminuserrorstar op_startypeminuserrorstar contract)
              (fun balance =>
                op_gtgteqquestion
                  (op_startypeminuserrorstar op_startypeminuserrorstar contract
                    fee credit op_startypeminuserrorstar)
                  (fun function_parameter =>
                    let '(operation, new_contract) := function_parameter in
                    op_gtgteqquestion
                      (op_startypeminuserrorstar op_startypeminuserrorstar)
                      (fun function_parameter =>
                        let '_ := function_parameter in
                        op_startypeminuserrorstar op_startypeminuserrorstar
                          (fun origination_burn =>
                            op_gtgteqquestion
                              (Lwt._return
                                (op_gtgtquestion
                                  (op_gtgtquestion
                                    (op_gtgtquestion
                                      (op_startypeminuserrorstar credit
                                        op_startypeminuserrorstar)
                                      (op_startypeminuserrorstar fee))
                                    (op_startypeminuserrorstar origination_burn))
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar)))
                              (fun total_fee =>
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar operation b)
                                  (fun b =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar __LOC__
                                        op_startypeminuserrorstar contract
                                        balance total_fee)
                                      (fun function_parameter =>
                                        let '_ := function_parameter in
                                        op_startypeminuserrorstar __LOC__
                                          op_startypeminuserrorstar new_contract
                                          credit)))))))).

Definition two_nth_of_balance {A B C D : Type}
  (incr : A) (contract : B) (nth : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult D) :=
  op_gtgteqquestion
    (op_startypeminuserrorstar op_startypeminuserrorstar contract)
    (fun balance =>
      op_startypeminuserrorstar (op_startypeminuserrorstar balance nth)
        (fun res =>
          op_startypeminuserrorstar
            (op_startypeminuserrorstar res
              (* ❌ Constant of type int64 is converted to int *)
              2) (fun balance => _return balance))).

Definition balances_simple {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  test_origination_balances __LOC__ None None tt.

Definition balances_credit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  test_origination_balances __LOC__ None (Some ten_tez) tt.

Definition balances_credit_fee {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  test_origination_balances __LOC__ (Some ten_tez)
    (Some (op_startypeminuserrorstar 2)) tt.

Definition balances_undelegatable {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  test_origination_balances __LOC__ None None tt.

Definition pay_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    (register_origination (Some ten_tez) (Some (op_startypeminuserrorstar 2)) tt)
    (fun function_parameter =>
      let '(_b, _contract, _new_contract) := function_parameter in
      return_unit).

Definition not_tez_in_contract_to_pay_fee {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract_1 := op_startypeminuserrorstar contracts 0 in
      let contract_2 := op_startypeminuserrorstar contracts 1 in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun inc =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
            (fun balance =>
              op_gtgteqquestion
                (op_atat Lwt._return
                  (op_startypeminuserrorstar balance op_startypeminuserrorstar))
                (fun amount =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      contract_1 contract_2 amount)
                    (fun operation =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar inc operation)
                        (fun inc =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar __LOC__
                              op_startypeminuserrorstar contract_1 balance
                              amount)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar ten_tez
                                  op_startypeminuserrorstar contract_1
                                  op_startypeminuserrorstar)
                                (fun function_parameter =>
                                  let '(op, _) := function_parameter in
                                  op_gtgteq (op_startypeminuserrorstar inc op)
                                    (fun inc =>
                                      op_startypeminuserrorstar __LOC__ inc
                                        (fun function_parameter =>
                                          match function_parameter with
                                          |
                                            Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                              _ _ _ => true
                                          | _ => false
                                          end)))))))))).

Definition register_contract_get_endorser {A B C : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A * B * C)) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract := List.hd contracts in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun inc =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(account_endorser, _slots) := function_parameter in
              _return (inc, contract, account_endorser)))).

Definition n_originations {A B C D : Type}
  (n : A) (credit : option B) (fee : option C) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list D)) :=
  let 'tt := function_parameter in
  fold_left_s
    (fun new_contracts =>
      fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteqquestion (register_origination fee credit tt)
          (fun function_parameter =>
            let '(_b, _source, new_contract) := function_parameter in
            let contracts := cons new_contract new_contracts in
            _return contracts)) [] (op_startypeminuserrorstar 1 n).

Definition multiple_originations {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion
    (n_originations 100 (Some (op_startypeminuserrorstar 2)) (Some ten_tez) tt)
    (fun contracts =>
      op_startypeminuserrorstar __LOC__ (List.length contracts) 100).

Definition counter {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract := List.hd contracts in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun inc =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar
              op_startypeminuserrorstar contract op_startypeminuserrorstar)
            (fun function_parameter =>
              let '(op1, _) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  op_startypeminuserrorstar contract op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(op2, _) := function_parameter in
                  op_gtgteqquestion (op_startypeminuserrorstar inc op1)
                    (fun inc =>
                      op_gtgteq (op_startypeminuserrorstar inc op2)
                        (fun res =>
                          op_startypeminuserrorstar __LOC__ res
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
                                  _ _ _ => true
                              | _ => false
                              end))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "balances_simple" % string
      (* ❌ Variants not supported *)
      variant balances_simple)
    (cons
      (op_startypeminuserrorstar "balances_credit" % string
        (* ❌ Variants not supported *)
        variant balances_credit)
      (cons
        (op_startypeminuserrorstar "balances_credit_fee" % string
          (* ❌ Variants not supported *)
          variant balances_credit_fee)
        (cons
          (op_startypeminuserrorstar "balances_undelegatable" % string
            (* ❌ Variants not supported *)
            variant balances_undelegatable)
          (cons
            (op_startypeminuserrorstar "pay_fee" % string
              (* ❌ Variants not supported *)
              variant pay_fee)
            (cons
              (op_startypeminuserrorstar
                "not enough tez in contract to pay fee" % string
                (* ❌ Variants not supported *)
                variant not_tez_in_contract_to_pay_fee)
              (cons
                (op_startypeminuserrorstar "multiple originations" % string
                  (* ❌ Variants not supported *)
                  variant multiple_originations)
                (cons
                  (op_startypeminuserrorstar "counter" % string
                    (* ❌ Variants not supported *)
                    variant counter) []))))))).

src/proto_alpha/lib_protocol/test/qty.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol

let known_ok_tez_literals =
  [ (0L, "0");
    (10L, "0.00001");
    (100L, "0.0001");
    (1_000L, "0.001");
    (10_000L, "0.01");
    (100_000L, "0.1");
    (1_000_000L, "1");
    (10_000_000L, "10");
    (100_000_000L, "100");
    (1_000_000_000L, "1000");
    (10_000_000_000L, "10000");
    (100_000_000_000L, "100000");
    (1_000_000_000_000L, "1000000");
    (1_000_000_000_001L, "1000000.000001");
    (1_000_000_000_010L, "1000000.00001");
    (1_000_000_000_100L, "1000000.0001");
    (1_000_000_001_000L, "1000000.001");
    (1_000_000_010_000L, "1000000.01");
    (1_000_000_100_000L, "1000000.1");
    (123_123_123_123_123_123L, "123123123123.123123");
    (999_999_999_999_999_999L, "999999999999.999999") ]

let known_bad_tez_literals =
  [ "10000.";
    "100,.";
    "100,";
    "1,0000";
    "0.0000,1";
    "0.00,1";
    "0,1";
    "HAHA";
    "0.000,000,1";
    "0.0000000";
    "9,999,999,999,999.999,999" ]

let fail expected given msg =
  Format.kasprintf
    Pervasives.failwith
    "@[%s@ expected: %s@ got: %s@]"
    msg
    expected
    given

let fail_msg fmt = Format.kasprintf (fail "" "") fmt

let default_printer _ = ""

let equal ?(eq = ( = )) ?(prn = default_printer) ?(msg = "") x y =
  if not (eq x y) then fail (prn x) (prn y) msg

let is_none ?(msg = "") x = if x <> None then fail "None" "Some _" msg

let is_some ?(msg = "") x = if x = None then fail "Some _" "None" msg

let test_known_tez_literals () =
  List.iter
    (fun (v, s) ->
      let vv = Tez_repr.of_mutez v in
      let vs = Tez_repr.of_string s in
      let vs' =
        Tez_repr.of_string (String.concat "" (String.split_on_char ',' s))
      in
      let vv =
        match vv with
        | None ->
            fail_msg "could not unopt %Ld" v
        | Some vv ->
            vv
      in
      let vs =
        match vs with None -> fail_msg "could not unopt %s" s | Some vs -> vs
      in
      let vs' =
        match vs' with
        | None ->
            fail_msg "could not unopt %s" s
        | Some vs' ->
            vs'
      in
      equal ~prn:Tez_repr.to_string vv vs ;
      equal ~prn:Tez_repr.to_string vv vs' ;
      equal ~prn:(fun s -> s) (Tez_repr.to_string vv) s)
    known_ok_tez_literals ;
  List.iter
    (fun s ->
      let vs = Tez_repr.of_string s in
      is_none ~msg:("Unexpected successful parsing of " ^ s) vs)
    known_bad_tez_literals ;
  return_unit

let test_random_tez_literals () =
  for _ = 0 to 100_000 do
    let v = Random.int64 12L in
    let vv = Tez_repr.of_mutez v in
    let vv =
      match vv with None -> fail_msg "could not unopt %Ld" v | Some vv -> vv
    in
    let s = Tez_repr.to_string vv in
    let vs = Tez_repr.of_string s in
    let s' = String.concat "" (String.split_on_char ',' s) in
    let vs' = Tez_repr.of_string s' in
    is_some ~msg:("Could not parse " ^ s ^ " back") vs ;
    is_some ~msg:("Could not parse " ^ s ^ " back") vs' ;
    ( match vs with
    | None ->
        assert false
    | Some vs ->
        let rev = Tez_repr.to_int64 vs in
        equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev ) ;
    match vs' with
    | None ->
        assert false
    | Some vs' ->
        let rev = Tez_repr.to_int64 vs' in
        equal ~prn:Int64.to_string ~msg:(Tez_repr.to_string vv) v rev
  done ;
  return_unit

let tests =
  [ ("tez-literals", fun _ -> test_known_tez_literals ());
    ("rnd-tez-literals", fun _ -> test_random_tez_literals ()) ]

let wrap (n, f) =
  Alcotest_lwt.test_case n `Quick (fun _ () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error error ->
          Format.kasprintf Pervasives.failwith "%a" pp_print_error error)

let tests = List.map wrap tests
src/proto_alpha/lib_protocol/test/qty.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition known_ok_tez_literals : list (int64 * string) :=
  cons
    ((* ❌ Constant of type int64 is converted to int *)
    0, "0" % string)
    (cons
      ((* ❌ Constant of type int64 is converted to int *)
      10, "0.00001" % string)
      (cons
        ((* ❌ Constant of type int64 is converted to int *)
        100, "0.0001" % string)
        (cons
          ((* ❌ Constant of type int64 is converted to int *)
          1000, "0.001" % string)
          (cons
            ((* ❌ Constant of type int64 is converted to int *)
            10000, "0.01" % string)
            (cons
              ((* ❌ Constant of type int64 is converted to int *)
              100000, "0.1" % string)
              (cons
                ((* ❌ Constant of type int64 is converted to int *)
                1000000, "1" % string)
                (cons
                  ((* ❌ Constant of type int64 is converted to int *)
                  10000000, "10" % string)
                  (cons
                    ((* ❌ Constant of type int64 is converted to int *)
                    100000000, "100" % string)
                    (cons
                      ((* ❌ Constant of type int64 is converted to int *)
                      1000000000, "1000" % string)
                      (cons
                        ((* ❌ Constant of type int64 is converted to int *)
                        10000000000, "10000" % string)
                        (cons
                          ((* ❌ Constant of type int64 is converted to int *)
                          100000000000, "100000" % string)
                          (cons
                            ((* ❌ Constant of type int64 is converted to int *)
                            1000000000000, "1000000" % string)
                            (cons
                              ((* ❌ Constant of type int64 is converted to int *)
                              1000000000001, "1000000.000001" % string)
                              (cons
                                ((* ❌ Constant of type int64 is converted to int *)
                                1000000000010, "1000000.00001" % string)
                                (cons
                                  ((* ❌ Constant of type int64 is converted to int *)
                                  1000000000100, "1000000.0001" % string)
                                  (cons
                                    ((* ❌ Constant of type int64 is converted to int *)
                                    1000000001000, "1000000.001" % string)
                                    (cons
                                      ((* ❌ Constant of type int64 is converted to int *)
                                      1000000010000, "1000000.01" % string)
                                      (cons
                                        ((* ❌ Constant of type int64 is converted to int *)
                                        1000000100000, "1000000.1" % string)
                                        (cons
                                          ((* ❌ Constant of type int64 is converted to int *)
                                          123123123123123123,
                                            "123123123123.123123" % string)
                                          (cons
                                            ((* ❌ Constant of type int64 is converted to int *)
                                            999999999999999999,
                                              "999999999999.999999" % string) [])))))))))))))))))))).

Definition known_bad_tez_literals : list string :=
  cons "10000." % string
    (cons "100,." % string
      (cons "100," % string
        (cons "1,0000" % string
          (cons "0.0000,1" % string
            (cons "0.00,1" % string
              (cons "0,1" % string
                (cons "HAHA" % string
                  (cons "0.000,000,1" % string
                    (cons "0.0000000" % string
                      (cons "9,999,999,999,999.999,999" % string [])))))))))).

Definition fail {A : Type} (expected : string) (given : string) (msg : string)
  : A :=
  Format.kasprintf Pervasives.failwith
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_gen
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Open_box
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
            Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format
            "" % string))
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Break
              "@ " % string 1 0)
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
              "expected: " % string
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Break
                    "@ " % string 1 0)
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                    "got: " % string
                    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                      Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Formatting_lit
                        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Close_box
                        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)))))))))
      "@[%s@ expected: %s@ got: %s@]" % string) msg expected given.

Definition fail_msg {A B : Type}
  (fmt :
    Tezos_protocol_environment_alpha__Environment.Pervasives.format4 A
      Tezos_protocol_environment_alpha__Environment.Format.formatter unit B)
  : A := Format.kasprintf (fail "" % string "" % string) fmt.

Definition default_printer {A : Type} (function_parameter : A) : string :=
  let '_ := function_parameter in
  "" % string.

Definition equal {A : Type} (op_staroptstar : option (A -> A -> bool))
  : (option (A -> string)) -> (option string) -> A -> A -> unit :=
  let eq :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => op_startypeminuserrorstar
    end in
  fun op_staroptstar =>
    let prn :=
      match op_staroptstar with
      | Some op_starsthstar => op_starsthstar
      | None => default_printer
      end in
    fun op_staroptstar =>
      let msg :=
        match op_staroptstar with
        | Some op_starsthstar => op_starsthstar
        | None => "" % string
        end in
      fun x =>
        fun y =>
          if not (eq x y) then
            fail (prn x) (prn y) msg
          else
            tt.

Definition is_none {A : Type} (op_staroptstar : option string) : A -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    if op_startypeminuserrorstar x None then
      fail "None" % string "Some _" % string msg
    else
      tt.

Definition is_some {A : Type} (op_staroptstar : option string) : A -> unit :=
  let msg :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => "" % string
    end in
  fun x =>
    if op_startypeminuserrorstar x None then
      fail "Some _" % string "None" % string msg
    else
      tt.

Definition test_known_tez_literals (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun function_parameter =>
        let '(v, s) := function_parameter in
        let vv := Tez_repr.of_mutez v in
        let vs := Tez_repr.of_string s in
        let vs' :=
          Tez_repr.of_string
            (String.concat "" % string (String.split_on_char "," % char s)) in
        let vv :=
          match vv with
          | None =>
            fail_msg
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                  "could not unopt " % string
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int64
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
                "could not unopt %Ld" % string) v
          | Some vv => vv
          end in
        let vs :=
          match vs with
          | None =>
            fail_msg
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                  "could not unopt " % string
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
                "could not unopt %s" % string) s
          | Some vs => vs
          end in
        let vs' :=
          match vs' with
          | None =>
            fail_msg
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                  "could not unopt " % string
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))
                "could not unopt %s" % string) s
          | Some vs' => vs'
          end in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := equal None (Some Tez_repr.to_string) None vv vs in
        (* ❌ Sequences of instructions are not handled (operator ";") *)
        let _ := equal None (Some Tez_repr.to_string) None vv vs' in
        equal None (Some (fun s => s)) None (Tez_repr.to_string vv) s)
      known_ok_tez_literals in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    List.iter
      (fun s =>
        let vs := Tez_repr.of_string s in
        is_none (Some (op_caret "Unexpected successful parsing of " % string s))
          vs) known_bad_tez_literals in
  return_unit.

Definition test_random_tez_literals (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    (* ❌ For loops not handled. *)
    for in
  return_unit.

Definition tests {A : Type}
  : list
    (string *
      (A ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            unit))) :=
  cons
    ("tez-literals" % string,
      (fun function_parameter =>
        let '_ := function_parameter in
        test_known_tez_literals tt))
    (cons
      ("rnd-tez-literals" % string,
        (fun function_parameter =>
          let '_ := function_parameter in
          test_random_tez_literals tt)) []).

Definition wrap {A B C : Type}
  (function_parameter :
    A *
      (unit ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Pervasives.result unit
            B))) : C :=
  let '(n, f) := function_parameter in
  op_startypeminuserrorstar n
    (* ❌ Variants not supported *)
    variant
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (f tt)
          (fun function_parameter =>
            match function_parameter with
            | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt =>
              Lwt.return_unit
            |
              Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                error =>
              Format.kasprintf Pervasives.failwith
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
                  (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Alpha
                    Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
                  "%a" % string) op_startypeminuserrorstar error
            end)).

Definition tests {A : Type} : list A := List.map wrap tests.

src/proto_alpha/lib_protocol/test/rolls.ml 257 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_tez
open Test_utils

let account_pair = function [a1; a2] -> (a1, a2) | _ -> assert false

let wrap e = Lwt.return (Environment.wrap_error e)

let traverse_rolls ctxt head =
  let rec loop acc roll =
    Storage.Roll.Successor.get_option ctxt roll
    >>= wrap
    >>=? function
    | None -> return (List.rev acc) | Some next -> loop (next :: acc) next
  in
  loop [head] head

let get_rolls ctxt delegate =
  Storage.Roll.Delegate_roll_list.get_option ctxt delegate
  >>= wrap
  >>=? function
  | None -> return_nil | Some head_roll -> traverse_rolls ctxt head_roll

let check_rolls b (account : Account.t) =
  Context.get_constants (B b)
  >>=? fun constants ->
  Context.Delegate.info (B b) account.pkh
  >>=? fun {staking_balance; _} ->
  let token_per_roll = constants.parametric.tokens_per_roll in
  let expected_rolls =
    Int64.div (Tez.to_mutez staking_balance) (Tez.to_mutez token_per_roll)
  in
  Raw_context.prepare
    b.context
    ~level:b.header.shell.level
    ~predecessor_timestamp:b.header.shell.timestamp
    ~timestamp:b.header.shell.timestamp
    ~fitness:b.header.shell.fitness
  >>= wrap
  >>=? fun ctxt ->
  get_rolls ctxt account.pkh
  >>=? fun rolls ->
  Assert.equal_int
    ~loc:__LOC__
    (List.length rolls)
    (Int64.to_int expected_rolls)

let check_no_rolls (b : Block.t) (account : Account.t) =
  Raw_context.prepare
    b.context
    ~level:b.header.shell.level
    ~predecessor_timestamp:b.header.shell.timestamp
    ~timestamp:b.header.shell.timestamp
    ~fitness:b.header.shell.fitness
  >>= wrap
  >>=? fun ctxt ->
  get_rolls ctxt account.pkh
  >>=? fun rolls -> Assert.equal_int ~loc:__LOC__ (List.length rolls) 0

let simple_staking_rights () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, _a2) = account_pair accounts in
  Context.Contract.balance (B b) a1
  >>=? fun balance ->
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Delegate.info (B b) m1.pkh
  >>=? fun info ->
  Assert.equal_tez ~loc:__LOC__ balance info.staking_balance
  >>=? fun () -> check_rolls b m1

let simple_staking_rights_after_baking () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, a2) = account_pair accounts in
  Context.Contract.balance (B b) a1
  >>=? fun balance ->
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Contract.manager (B b) a2
  >>=? fun m2 ->
  Block.bake_n ~policy:(By_account m2.pkh) 5 b
  >>=? fun b ->
  Context.Delegate.info (B b) m1.pkh
  >>=? fun info ->
  Assert.equal_tez ~loc:__LOC__ balance info.staking_balance
  >>=? fun () -> check_rolls b m1 >>=? fun () -> check_rolls b m2

let frozen_deposit (info : Context.Delegate.info) =
  Cycle.Map.fold
    (fun _ {Delegate.deposit; _} acc -> Test_tez.Tez.(deposit + acc))
    info.frozen_balance_by_cycle
    Tez.zero

let check_activate_staking_balance ~loc ~deactivated b (a, (m : Account.t)) =
  Context.Delegate.info (B b) m.pkh
  >>=? fun info ->
  Assert.equal_bool ~loc info.deactivated deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) a
  >>=? fun balance ->
  let deposit = frozen_deposit info in
  Assert.equal_tez ~loc Test_tez.Tez.(balance + deposit) info.staking_balance

let run_until_deactivation () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, a2) = account_pair accounts in
  Context.Contract.balance (B b) a1
  >>=? fun balance_start ->
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Contract.manager (B b) a2
  >>=? fun m2 ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1, m1)
  >>=? fun () ->
  Context.Delegate.info (B b) m1.pkh
  >>=? fun info ->
  Block.bake_until_cycle ~policy:(By_account m2.pkh) info.grace_period b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a1, m1)
  >>=? fun () ->
  Block.bake_until_cycle_end ~policy:(By_account m2.pkh) b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:true b (a1, m1)
  >>=? fun () -> return (b, ((a1, m1), balance_start), (a2, m2))

let deactivation_then_bake () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((_deactivated_contract, deactivated_account) as deactivated),
               _start_balance ),
             (_a2, _m2) ) ->
  Block.bake ~policy:(By_account deactivated_account.pkh) b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () -> check_rolls b deactivated_account

let deactivation_then_self_delegation () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((deactivated_contract, deactivated_account) as deactivated),
               start_balance ),
             (_a2, m2) ) ->
  Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
  >>=? fun self_delegation ->
  Block.bake ~policy:(By_account m2.pkh) b ~operation:self_delegation
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ start_balance balance
  >>=? fun () -> check_rolls b deactivated_account

let deactivation_then_empty_then_self_delegation () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((deactivated_contract, deactivated_account) as deactivated),
               _start_balance ),
             (_a2, m2) ) ->
  (* empty the contract *)
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  let sink_account = Account.new_account () in
  let sink_contract = Contract.implicit_contract sink_account.pkh in
  Context.get_constants (B b)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  let amount =
    match Tez.(balance -? origination_burn) with
    | Ok r ->
        r
    | Error _ ->
        assert false
  in
  Op.transaction (B b) deactivated_contract sink_contract amount
  >>=? fun empty_contract ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b
  >>=? fun b ->
  (* self delegation *)
  Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
  >>=? fun self_delegation ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ Tez.zero balance
  >>=? fun () -> check_rolls b deactivated_account

let deactivation_then_empty_then_self_delegation_then_recredit () =
  run_until_deactivation ()
  >>=? fun ( b,
             ( ((deactivated_contract, deactivated_account) as deactivated),
               balance ),
             (_a2, m2) ) ->
  (* empty the contract *)
  let sink_account = Account.new_account () in
  let sink_contract = Contract.implicit_contract sink_account.pkh in
  Context.get_constants (B b)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  let amount =
    match Tez.(balance -? origination_burn) with
    | Ok r ->
        r
    | Error _ ->
        assert false
  in
  Op.transaction (B b) deactivated_contract sink_contract amount
  >>=? fun empty_contract ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:empty_contract b
  >>=? fun b ->
  (* self delegation *)
  Op.delegation (B b) deactivated_contract (Some deactivated_account.pkh)
  >>=? fun self_delegation ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:self_delegation b
  >>=? fun b ->
  (* recredit *)
  Op.transaction (B b) sink_contract deactivated_contract amount
  >>=? fun recredit_contract ->
  Block.bake ~policy:(By_account m2.pkh) ~operation:recredit_contract b
  >>=? fun b ->
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b deactivated
  >>=? fun () ->
  Context.Contract.balance (B b) deactivated_contract
  >>=? fun balance ->
  Assert.equal_tez ~loc:__LOC__ amount balance
  >>=? fun () -> check_rolls b deactivated_account

let delegation () =
  Context.init 2
  >>=? fun (b, accounts) ->
  let (a1, a2) = account_pair accounts in
  let m3 = Account.new_account () in
  Account.add_account m3 ;
  Context.Contract.manager (B b) a1
  >>=? fun m1 ->
  Context.Contract.manager (B b) a2
  >>=? fun m2 ->
  let a3 = Contract.implicit_contract m3.pkh in
  Context.Contract.delegate_opt (B b) a1
  >>=? fun delegate ->
  ( match delegate with
  | None ->
      assert false
  | Some pkh ->
      assert (Signature.Public_key_hash.equal pkh m1.pkh) ) ;
  Op.transaction (B b) a1 a3 Tez.fifty_cents
  >>=? fun transact ->
  Block.bake ~policy:(By_account m2.pkh) b ~operation:transact
  >>=? fun b ->
  Context.Contract.delegate_opt (B b) a3
  >>=? fun delegate ->
  (match delegate with None -> () | Some _ -> assert false) ;
  check_no_rolls b m3
  >>=? fun () ->
  Op.delegation (B b) a3 (Some m3.pkh)
  >>=? fun delegation ->
  Block.bake ~policy:(By_account m2.pkh) b ~operation:delegation
  >>=? fun b ->
  Context.Contract.delegate_opt (B b) a3
  >>=? fun delegate ->
  ( match delegate with
  | None ->
      assert false
  | Some pkh ->
      assert (Signature.Public_key_hash.equal pkh m3.pkh) ) ;
  check_activate_staking_balance ~loc:__LOC__ ~deactivated:false b (a3, m3)
  >>=? fun () -> check_rolls b m3 >>=? fun () -> check_rolls b m1

let tests =
  [ Test.tztest "simple staking rights" `Quick simple_staking_rights;
    Test.tztest
      "simple staking rights after baking"
      `Quick
      simple_staking_rights_after_baking;
    Test.tztest "deactivation then bake" `Quick deactivation_then_bake;
    Test.tztest
      "deactivation then self delegation"
      `Quick
      deactivation_then_self_delegation;
    Test.tztest
      "deactivation then empty then self delegation"
      `Quick
      deactivation_then_empty_then_self_delegation;
    Test.tztest
      "deactivation then empty then self delegation then recredit"
      `Quick
      deactivation_then_empty_then_self_delegation_then_recredit;
    Test.tztest "delegation" `Quick delegation ]
src/proto_alpha/lib_protocol/test/rolls.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition account_pair {A : Type} (function_parameter : list A) : A * A :=
  match function_parameter with
  | cons a1 (cons a2 []) => (a1, a2)
  | _ =>
    (* ❌ Assert instruction is not handled. *)
    assert false
  end.

Definition wrap {A : Type}
  (e : Tezos_protocol_alpha.Protocol.Environment.Error_monad.tzresult A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_base__TzPervasives.Error_monad.tzresult A) :=
  Lwt._return (Environment.wrap_error e).

Definition traverse_rolls
  (ctxt : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.context)
  (head : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
  let fix loop
    (acc : list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)
    (roll : Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.key)
    : Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        (list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
    op_gtgteqquestion op_startypeminuserrorstar
      (fun function_parameter =>
        match function_parameter with
        | None => _return (List.rev acc)
        | Some next => loop (cons next acc) next
        end) in
  loop (cons head []) head.

Definition get_rolls
  (ctxt : Tezos_protocol_alpha.Protocol.Storage.Roll.Delegate_roll_list.context)
  (delegate : Tezos_protocol_alpha.Protocol.Storage.Roll.Delegate_roll_list.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (list Tezos_protocol_alpha.Protocol.Storage.Roll.Successor.value)) :=
  op_gtgteqquestion op_startypeminuserrorstar
    (fun function_parameter =>
      match function_parameter with
      | None => return_nil
      | Some head_roll => traverse_rolls ctxt head_roll
      end).

Definition check_rolls {A B : Type} (b : A) (function_parameter : B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let '_ := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
    (fun constants =>
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar
          (pkh op_startypeminuserrorstar))
        (fun function_parameter =>
          let '_ := function_parameter in
          let token_per_roll := tokens_per_roll (parametric constants) in
          let expected_rolls :=
            Int64.div (Tez.to_mutez op_startypeminuserrorstar)
              (Tez.to_mutez token_per_roll) in
          op_gtgteqquestion op_startypeminuserrorstar
            (fun ctxt =>
              op_gtgteqquestion (get_rolls ctxt (pkh op_startypeminuserrorstar))
                (fun rolls =>
                  op_startypeminuserrorstar __LOC__ (List.length rolls)
                    (Int64.to_int expected_rolls))))).

Definition check_no_rolls {A B : Type} (function_parameter : A)
  : B ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    op_gtgteqquestion op_startypeminuserrorstar
      (fun ctxt =>
        op_gtgteqquestion (get_rolls ctxt (pkh op_startypeminuserrorstar))
          (fun rolls => op_startypeminuserrorstar __LOC__ (List.length rolls) 0)).

Definition simple_staking_rights (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, accounts) := function_parameter in
      let '(a1, _a2) := account_pair accounts in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
        (fun balance =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar a1)
            (fun m1 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar (pkh m1))
                (fun info =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar __LOC__ balance
                      (staking_balance info))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      check_rolls b m1))))).

Definition simple_staking_rights_after_baking (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, accounts) := function_parameter in
      let '(a1, a2) := account_pair accounts in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
        (fun balance =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar a1)
            (fun m1 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar a2)
                (fun m2 =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar 5 b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          (pkh m1))
                        (fun info =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar __LOC__ balance
                              (staking_balance info))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion (check_rolls b m1)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  check_rolls b m2)))))))).

Definition frozen_deposit {A : Type} (function_parameter : A)
  : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez :=
  let '_ := function_parameter in
  Cycle.Map.fold
    (fun function_parameter =>
      let '_ := function_parameter in
      fun function_parameter =>
        let '{| Delegate.deposit := deposit |} := function_parameter in
        fun acc => op_startypeminuserrorstar)
    (frozen_balance_by_cycle op_startypeminuserrorstar) Tez.zero.

Definition check_activate_staking_balance {A B : Type}
  (loc : string) (deactivated : bool) (b : A)
  (function_parameter :
    Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let '_ := function_parameter in
  op_gtgteqquestion
    (op_startypeminuserrorstar op_startypeminuserrorstar
      (pkh op_startypeminuserrorstar))
    (fun info =>
      op_gtgteqquestion
        (op_startypeminuserrorstar loc (deactivated info) deactivated)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar a)
            (fun balance =>
              let deposit := frozen_deposit info in
              op_startypeminuserrorstar loc op_startypeminuserrorstar
                (staking_balance info)))).

Definition run_until_deactivation {A B C D : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A *
        ((Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * B) * C)
        * (Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract * D))) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, accounts) := function_parameter in
      let '(a1, a2) := account_pair accounts in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
        (fun balance_start =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar a1)
            (fun m1 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar a2)
                (fun m2 =>
                  op_gtgteqquestion
                    (check_activate_staking_balance __LOC__ false b (a1, m1))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          (pkh m1))
                        (fun info =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              (grace_period info) b)
                            (fun b =>
                              op_gtgteqquestion
                                (check_activate_staking_balance __LOC__ false b
                                  (a1, m1))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar b)
                                    (fun b =>
                                      op_gtgteqquestion
                                        (check_activate_staking_balance __LOC__
                                          true b (a1, m1))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          _return
                                            (b, ((a1, m1), balance_start),
                                              (a2, m2)))))))))))).

Definition deactivation_then_bake (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (run_until_deactivation tt)
    (fun function_parameter =>
      let
        '(b,
          ((_deactivated_contract, deactivated_account) as deactivated,
            _start_balance), (_a2, _m2)) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (check_activate_staking_balance __LOC__ false b deactivated)
            (fun function_parameter =>
              let 'tt := function_parameter in
              check_rolls b deactivated_account))).

Definition deactivation_then_self_delegation (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (run_until_deactivation tt)
    (fun function_parameter =>
      let
        '(b,
          ((deactivated_contract, deactivated_account) as deactivated,
            start_balance), (_a2, m2)) := function_parameter in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar
          deactivated_contract (Some (pkh deactivated_account)))
        (fun self_delegation =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar b
              self_delegation)
            (fun b =>
              op_gtgteqquestion
                (check_activate_staking_balance __LOC__ false b deactivated)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      deactivated_contract)
                    (fun balance =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar __LOC__ start_balance balance)
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          check_rolls b deactivated_account)))))).

Definition deactivation_then_empty_then_self_delegation {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (run_until_deactivation tt)
    (fun function_parameter =>
      let
        '(b,
          ((deactivated_contract, deactivated_account) as deactivated,
            _start_balance), (_a2, m2)) := function_parameter in
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar
          deactivated_contract)
        (fun balance =>
          let sink_account := op_startypeminuserrorstar tt in
          let sink_contract := Contract.implicit_contract (pkh sink_account) in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_startypeminuserrorstar
                (op_starquestion op_startypeminuserrorstar
                  (Int64.of_int op_startypeminuserrorstar))
                (fun origination_burn =>
                  let amount :=
                    match op_minusquestion balance origination_burn with
                    |
                      Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                        r => r
                    |
                      Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                        _ =>
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    end in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      deactivated_contract sink_contract amount)
                    (fun empty_contract =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          empty_contract b)
                        (fun b =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              deactivated_contract
                              (Some (pkh deactivated_account)))
                            (fun self_delegation =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar self_delegation b)
                                (fun b =>
                                  op_gtgteqquestion
                                    (check_activate_staking_balance __LOC__
                                      false b deactivated)
                                    (fun function_parameter =>
                                      let 'tt := function_parameter in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar
                                          deactivated_contract)
                                        (fun balance =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              Tez.zero balance)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              check_rolls b deactivated_account))))))))))).

Definition deactivation_then_empty_then_self_delegation_then_recredit {A : Type}
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (run_until_deactivation tt)
    (fun function_parameter =>
      let
        '(b,
          ((deactivated_contract, deactivated_account) as deactivated, balance),
          (_a2, m2)) := function_parameter in
      let sink_account := op_startypeminuserrorstar tt in
      let sink_contract := Contract.implicit_contract (pkh sink_account) in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_startypeminuserrorstar
            (op_starquestion op_startypeminuserrorstar
              (Int64.of_int op_startypeminuserrorstar))
            (fun origination_burn =>
              let amount :=
                match op_minusquestion balance origination_burn with
                | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok r
                  => r
                |
                  Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                    _ =>
                  (* ❌ Assert instruction is not handled. *)
                  assert false
                end in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  deactivated_contract sink_contract amount)
                (fun empty_contract =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      empty_contract b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          deactivated_contract (Some (pkh deactivated_account)))
                        (fun self_delegation =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              self_delegation b)
                            (fun b =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar sink_contract
                                  deactivated_contract amount)
                                (fun recredit_contract =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar
                                      recredit_contract b)
                                    (fun b =>
                                      op_gtgteqquestion
                                        (check_activate_staking_balance __LOC__
                                          false b deactivated)
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar
                                              deactivated_contract)
                                            (fun balance =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  __LOC__ amount balance)
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  check_rolls b
                                                    deactivated_account)))))))))))).

Definition delegation (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, accounts) := function_parameter in
      let '(a1, a2) := account_pair accounts in
      let m3 := op_startypeminuserrorstar tt in
      (* ❌ Sequences of instructions are not handled (operator ";") *)
      let _ := op_startypeminuserrorstar m3 in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar a1)
        (fun m1 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar a2)
            (fun m2 =>
              let a3 := Contract.implicit_contract (pkh m3) in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar a1)
                (fun delegate =>
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    match delegate with
                    | None =>
                      (* ❌ Assert instruction is not handled. *)
                      assert false
                    | Some pkh =>
                      (* ❌ Assert instruction is not handled. *)
                      assert (Signature.Public_key_hash.equal pkh (pkh m1))
                    end in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar a1 a3
                      Tez.fifty_cents)
                    (fun transact =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar b
                          transact)
                        (fun b =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              a3)
                            (fun delegate =>
                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                              let _ :=
                                match delegate with
                                | None => tt
                                | Some _ =>
                                  (* ❌ Assert instruction is not handled. *)
                                  assert false
                                end in
                              op_gtgteqquestion (check_no_rolls b m3)
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar
                                      op_startypeminuserrorstar a3
                                      (Some (pkh m3)))
                                    (fun delegation =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar b delegation)
                                        (fun b =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar a3)
                                            (fun delegate =>
                                              (* ❌ Sequences of instructions are not handled (operator ";") *)
                                              let _ :=
                                                match delegate with
                                                | None =>
                                                  (* ❌ Assert instruction is not handled. *)
                                                  assert false
                                                | Some pkh =>
                                                  (* ❌ Assert instruction is not handled. *)
                                                  assert
                                                    (Signature.Public_key_hash.equal
                                                      pkh (pkh m3))
                                                end in
                                              op_gtgteqquestion
                                                (check_activate_staking_balance
                                                  __LOC__ false b (a3, m3))
                                                (fun function_parameter =>
                                                  let 'tt := function_parameter
                                                    in
                                                  op_gtgteqquestion
                                                    (check_rolls b m3)
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      check_rolls b m1))))))))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "simple staking rights" % string
      (* ❌ Variants not supported *)
      variant simple_staking_rights)
    (cons
      (op_startypeminuserrorstar "simple staking rights after baking" % string
        (* ❌ Variants not supported *)
        variant simple_staking_rights_after_baking)
      (cons
        (op_startypeminuserrorstar "deactivation then bake" % string
          (* ❌ Variants not supported *)
          variant deactivation_then_bake)
        (cons
          (op_startypeminuserrorstar
            "deactivation then self delegation" % string
            (* ❌ Variants not supported *)
            variant deactivation_then_self_delegation)
          (cons
            (op_startypeminuserrorstar
              "deactivation then empty then self delegation" % string
              (* ❌ Variants not supported *)
              variant deactivation_then_empty_then_self_delegation)
            (cons
              (op_startypeminuserrorstar
                "deactivation then empty then self delegation then recredit" %
                  string
                (* ❌ Variants not supported *)
                variant
                deactivation_then_empty_then_self_delegation_then_recredit)
              (cons
                (op_startypeminuserrorstar "delegation" % string
                  (* ❌ Variants not supported *)
                  variant delegation) [])))))).

src/proto_alpha/lib_protocol/test/seed.ml 27 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(** Tests about
    - seed_nonce_hash included in some blocks
    - revelation operation of seed_nonce that should correspond to each
      seed_nonce_hash
*)

open Protocol
open Test_tez

(** Tests that baking [blocks_per_commitment] blocks without a
    [seed_nonce_hash] commitment fails with [Invalid_commitment] *)
let no_commitment () =
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_commitment; _}; _} ->
  let blocks_per_commitment = Int32.to_int blocks_per_commitment in
  (* Bake normally until before the commitment *)
  Block.bake_n (blocks_per_commitment - 2) b
  >>=? fun b ->
  (* Forge a block with empty commitment and apply it *)
  Block.Forge.forge_header b
  >>=? fun header ->
  Block.Forge.set_seed_nonce_hash None header
  |> Block.Forge.sign_header
  >>=? fun header ->
  Block.apply header b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Apply.Invalid_commitment _ ->
          true
      | _ ->
          false)

let baking_reward ctxt (b : Block.t) =
  let priority = b.header.protocol_data.contents.priority in
  Block.get_endorsing_power b
  >>=? fun endorsing_power ->
  Context.get_baking_reward ctxt ~priority ~endorsing_power

(** Choose a baker, denote it by id. In the first cycle, make id bake only once.
    Test that:
    - after id bakes with a commitment the bond is frozen and the reward allocated
    - when id reveals the nonce too early, there's an error
    - when id reveals at the right time but the wrong value, there's an error
    - when another baker reveals correctly, it receives the tip
    - revealing twice produces an error
    - after [preserved cycles] a committer that correctly revealed
      receives back the bond and the reward
*)
let revelation_early_wrong_right_twice () =
  let open Assert in
  Context.init 5
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun csts ->
  let bond = csts.parametric.block_security_deposit in
  let tip = csts.parametric.seed_nonce_revelation_tip in
  let blocks_per_commitment =
    Int32.to_int csts.parametric.blocks_per_commitment
  in
  let preserved_cycles = csts.parametric.preserved_cycles in
  (* get the pkh of a baker *)
  Block.get_next_baker b
  >>=? fun (pkh, _, _) ->
  let id = Alpha_context.Contract.implicit_contract pkh in
  let policy = Block.Excluding [pkh] in
  (* bake until commitment, excluding id *)
  Block.bake_n ~policy (blocks_per_commitment - 2) b
  >>=? fun b ->
  Context.Contract.balance ~kind:Main (B b) id
  >>=? fun bal_main ->
  Context.Contract.balance ~kind:Deposit (B b) id
  >>=? fun bal_deposit ->
  Context.Contract.balance ~kind:Rewards (B b) id
  >>=? fun bal_rewards ->
  (* the baker [id] will include a seed_nonce commitment *)
  Block.bake ~policy:(Block.By_account pkh) b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun level_commitment ->
  Context.get_seed_nonce_hash (B b)
  >>=? fun committed_hash ->
  baking_reward (B b) b
  >>=? fun reward ->
  (* test that the bond was frozen and the reward allocated *)
  balance_was_debited ~loc:__LOC__ (B b) id bal_main bond
  >>=? fun () ->
  balance_was_credited ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit bond
  >>=? fun () ->
  balance_was_credited ~loc:__LOC__ (B b) id ~kind:Rewards bal_rewards reward
  >>=? fun () ->
  (* test that revealing too early produces an error *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
  >>=? fun operation ->
  Block.bake ~policy ~operation b
  >>= fun e ->
  let expected = function
    | Nonce_storage.Too_early_revelation ->
        true
    | _ ->
        false
  in
  Assert.proto_error ~loc:__LOC__ e expected
  >>=? fun () ->
  (* finish the cycle excluding the committing baker, id *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  (* test that revealing at the right time but the wrong value produces an error *)
  let (wrong_hash, _) = Nonce.generate () in
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash)
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Nonce_storage.Unexpected_nonce ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* reveals correctly *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
  >>=? fun operation ->
  Block.get_next_baker ~policy b
  >>=? fun (baker_pkh, _, _) ->
  let baker = Alpha_context.Contract.implicit_contract baker_pkh in
  Context.Contract.balance ~kind:Main (B b) baker
  >>=? fun baker_bal_main ->
  Context.Contract.balance ~kind:Deposit (B b) baker
  >>=? fun baker_bal_deposit ->
  Context.Contract.balance ~kind:Rewards (B b) baker
  >>=? fun baker_bal_rewards ->
  (* bake the operation in a block *)
  Block.bake ~policy ~operation b
  >>=? fun b ->
  baking_reward (B b) b
  >>=? fun baker_reward ->
  (* test that the baker gets the tip reward *)
  balance_was_debited ~loc:__LOC__ (B b) baker ~kind:Main baker_bal_main bond
  >>=? fun () ->
  balance_was_credited
    ~loc:__LOC__
    (B b)
    baker
    ~kind:Deposit
    baker_bal_deposit
    bond
  >>=? fun () ->
  Lwt.return @@ Tez.( +? ) baker_reward tip
  >>=? fun expected_rewards ->
  balance_was_credited
    ~loc:__LOC__
    (B b)
    baker
    ~kind:Rewards
    baker_bal_rewards
    expected_rewards
  >>=? fun () ->
  (* test that revealing twice produces an error *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get wrong_hash)
  >>=? fun operation ->
  Block.bake ~operation ~policy b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Nonce_storage.Previously_revealed_nonce ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* bake [preserved_cycles] cycles excluding [id] *)
  Error_monad.fold_left_s
    (fun b _ -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- preserved_cycles)
  >>=? fun b ->
  (* test that [id] receives back the bond and the reward *)
  (* note that in order to have that new_bal = bal_main + reward,
     id can only bake once; this is why we exclude id from all other bake ops. *)
  balance_was_credited ~loc:__LOC__ (B b) id ~kind:Main bal_main reward
  >>=? fun () ->
  balance_is ~loc:__LOC__ (B b) id ~kind:Deposit Tez.zero
  >>=? fun () -> balance_is ~loc:__LOC__ (B b) id ~kind:Rewards Tez.zero

(** Tests that:
    - a committer at cycle 0, which doesn't reveal at cycle 1,
      at the end of the cycle 1 looses the bond and the reward
    - revealing too late produces an error
*)
let revelation_missing_and_late () =
  let open Context in
  let open Assert in
  Context.init 5
  >>=? fun (b, _) ->
  get_constants (B b)
  >>=? fun csts ->
  baking_reward (B b) b
  >>=? fun reward ->
  let blocks_per_commitment =
    Int32.to_int csts.parametric.blocks_per_commitment
  in
  (* bake until commitment *)
  Block.bake_n (blocks_per_commitment - 2) b
  >>=? fun b ->
  (* the next baker [id] will include a seed_nonce commitment *)
  Block.get_next_baker b
  >>=? fun (pkh, _, _) ->
  let id = Alpha_context.Contract.implicit_contract pkh in
  Block.bake b
  >>=? fun b ->
  Context.get_level (B b)
  >>=? fun level_commitment ->
  Context.get_seed_nonce_hash (B b)
  >>=? fun committed_hash ->
  Context.Contract.balance ~kind:Main (B b) id
  >>=? fun bal_main ->
  Context.Contract.balance ~kind:Deposit (B b) id
  >>=? fun bal_deposit ->
  Context.Contract.balance ~kind:Rewards (B b) id
  >>=? fun bal_rewards ->
  (* finish cycle 0 excluding the committing baker [id] *)
  let policy = Block.Excluding [pkh] in
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  (* finish cycle 1 excluding the committing baker [id] *)
  Block.bake_until_cycle_end ~policy b
  >>=? fun b ->
  (* test that baker [id], which didn't reveal at cycle 1 like it was supposed to,
     at the end of the cycle 1 looses the reward but not the bond *)
  balance_is ~loc:__LOC__ (B b) id ~kind:Main bal_main
  >>=? fun () ->
  balance_is ~loc:__LOC__ (B b) id ~kind:Deposit bal_deposit
  >>=? fun () ->
  balance_was_debited ~loc:__LOC__ (B b) id ~kind:Rewards bal_rewards reward
  >>=? fun () ->
  (* test that revealing too late (after cycle 1) produces an error *)
  Op.seed_nonce_revelation (B b) level_commitment (Nonce.get committed_hash)
  >>=? fun operation ->
  Block.bake ~operation b
  >>= fun e ->
  Assert.proto_error ~loc:__LOC__ e (function
      | Nonce_storage.Too_late_revelation ->
          true
      | _ ->
          false)

let tests =
  [ Test.tztest "no commitment" `Quick no_commitment;
    Test.tztest
      "revelation_early_wrong_right_twice"
      `Quick
      revelation_early_wrong_right_twice;
    Test.tztest
      "revelation_missing_and_late"
      `Quick
      revelation_missing_and_late ]
src/proto_alpha/lib_protocol/test/seed.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition no_commitment {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 5)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          let blocks_per_commitment := Int32.to_int op_startypeminuserrorstar in
          op_gtgteqquestion
            (op_startypeminuserrorstar (op_minus blocks_per_commitment 2) b)
            (fun b =>
              op_gtgteqquestion (op_startypeminuserrorstar b)
                (fun header =>
                  op_gtgteqquestion
                    (op_pipegt (op_startypeminuserrorstar None header)
                      op_startypeminuserrorstar)
                    (fun header =>
                      op_gtgteq (op_startypeminuserrorstar header b)
                        (fun e =>
                          op_startypeminuserrorstar __LOC__ e
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Invalid_commitment
                                  _ => true
                              | _ => false
                              end))))))).

Definition baking_reward {A B C : Type} (ctxt : A) (function_parameter : B)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  let '_ := function_parameter in
  let priority :=
    priority (contents (protocol_data (header op_startypeminuserrorstar))) in
  op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
    (fun endorsing_power =>
      op_startypeminuserrorstar ctxt priority endorsing_power).

Definition revelation_early_wrong_right_twice {A : Type}
  (function_parameter : unit) : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

Definition revelation_missing_and_late {A : Type} (function_parameter : unit)
  : A :=
  let 'tt := function_parameter in
  op_startypeminuserrorstar.

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "no commitment" % string
      (* ❌ Variants not supported *)
      variant no_commitment)
    (cons
      (op_startypeminuserrorstar "revelation_early_wrong_right_twice" % string
        (* ❌ Variants not supported *)
        variant revelation_early_wrong_right_twice)
      (cons
        (op_startypeminuserrorstar "revelation_missing_and_late" % string
          (* ❌ Variants not supported *)
          variant revelation_missing_and_late) [])).

src/proto_alpha/lib_protocol/test/test.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

(* Wraps an alcotest so that it prints correcly errors from the Error_monad. *)
let tztest name speed f =
  Alcotest_lwt.test_case name speed (fun _sw () ->
      f ()
      >>= function
      | Ok () ->
          Lwt.return_unit
      | Error err ->
          Tezos_stdlib_unix.Internal_event_unix.close ()
          >>= fun () ->
          Format.printf "@.%a@." pp_print_error err ;
          Lwt.fail Alcotest.Test_error)
src/proto_alpha/lib_protocol/test/test.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition tztest {A B C D : Type}
  (name : A) (speed : B)
  (f :
    unit ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Pervasives.result unit C))
  : D :=
  op_startypeminuserrorstar name speed
    (fun _sw =>
      fun function_parameter =>
        let 'tt := function_parameter in
        op_gtgteq (f tt)
          (fun function_parameter =>
            match function_parameter with
            | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok tt =>
              Lwt.return_unit
            | Tezos_protocol_environment_alpha__Environment.Pervasives.Error err
              =>
              op_gtgteq (Tezos_stdlib_unix.Internal_event_unix.close tt)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    op_startypeminuserrorstar "@.%a@." % string
                      op_startypeminuserrorstar err in
                  op_startypeminuserrorstar op_startypeminuserrorstar)
            end)).

src/proto_alpha/lib_protocol/test/transfer.ml 309 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Alpha_context
open Test_utils
open Test_tez

(*********************************************************************)
(* Utility functions                                                 *)
(*********************************************************************)

(**
   [transfer_and_check_balances b fee src dst amount]
   this function takes a block, an optional parameter fee if fee does not
   given it will be set to zero tez, a source contract, a destination contract
   and the amount that one wants to transfer.

   1- Transfer the amount of tez (w/wo fee) from a source contract to a
       destination contract.

    2- Check the equivalent of the balance of the source/destination
       contract before and after transfer is valided.

   This function returns a pair:
   - A block that added a valid operation
   - a valid operation
*)
let transfer_and_check_balances ?(with_burn = false) ~loc b ?(fee = Tez.zero)
    ?expect_failure src dst amount =
  Tez.( +? ) fee amount
  >>?= fun amount_fee ->
  Context.Contract.balance (I b) src
  >>=? fun bal_src ->
  Context.Contract.balance (I b) dst
  >>=? fun bal_dst ->
  Op.transaction (I b) ~fee src dst amount
  >>=? fun op ->
  Incremental.add_operation ?expect_failure b op
  >>=? fun b ->
  Context.get_constants (I b)
  >>=? fun {parametric = {origination_size; cost_per_byte; _}; _} ->
  Tez.(cost_per_byte *? Int64.of_int origination_size)
  >>?= fun origination_burn ->
  let amount_fee_maybe_burn =
    if with_burn then
      match Tez.(amount_fee +? origination_burn) with
      | Ok r ->
          r
      | Error _ ->
          assert false
    else amount_fee
  in
  Assert.balance_was_debited ~loc (I b) src bal_src amount_fee_maybe_burn
  >>=? fun () ->
  Assert.balance_was_credited ~loc (I b) dst bal_dst amount
  >>=? fun () -> return (b, op)

(**
   [transfer_to_itself_and_check_balances b fee contract amount]
   this function takes a block, an optional parameter fee,
   a contract that is a source and a destination contract,
   and an amount of tez that one wants to transfer.

   1- Transfer the amount of tez (w/wo transfer fee) from/to a contract itself.

   2- Check the equivalent of the balance of the contract before
       and after transfer.

   This function returns a pair:
   - a block that added the valid transaction
   - an valid transaction
*)
let transfer_to_itself_and_check_balances ~loc b ?(fee = Tez.zero) contract
    amount =
  Context.Contract.balance (I b) contract
  >>=? fun bal ->
  Op.transaction (I b) ~fee contract contract amount
  >>=? fun op ->
  Incremental.add_operation b op
  >>=? fun b ->
  Assert.balance_was_debited ~loc (I b) contract bal fee
  >>=? fun () -> return (b, op)

(**
   [n_transactions n b fee source dest amount]
   this function takes a number of "n" that one wish to transfer,
   a block, an optional parameter fee, a source contract,
   a destination contract and an amount one wants to transfer.

   This function will do a transaction from a source contract to
   a destination contract with the amount "n" times.
*)
let n_transactions n b ?fee source dest amount =
  fold_left_s
    (fun b _ ->
      transfer_and_check_balances ~loc:__LOC__ b ?fee source dest amount
      >>=? fun (b, _) -> return b)
    b
    (1 -- n)

let ten_tez = Tez.of_int 10

(*********************************************************************)
(* Tests                                                             *)
(*********************************************************************)

let register_two_contracts () =
  Context.init 2
  >>=? fun (b, contracts) ->
  let contract_1 = List.nth contracts 0 in
  let contract_2 = List.nth contracts 1 in
  return (b, contract_1, contract_2)

(** compute half of the balance and divided by nth
    times *)

let two_nth_of_balance incr contract nth =
  Context.Contract.balance (I incr) contract
  >>=? fun balance ->
  Tez.( /? ) balance nth
  >>?= fun res -> Tez.( *? ) res 2L >>?= fun balance -> return balance

(********************)
(** Single transfer *)

(********************)

let single_transfer ?fee ?expect_failure amount =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  transfer_and_check_balances
    ~loc:__LOC__
    ?fee
    ?expect_failure
    b
    contract_1
    contract_2
    amount
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** single transfer without fee *)
let block_with_a_single_transfer () = single_transfer Tez.one

(** single transfer with fee *)
let block_with_a_single_transfer_with_fee () =
  single_transfer ~fee:Tez.one Tez.one

(** single transfer without fee *)

let transfer_zero_tez () =
  single_transfer
    ~expect_failure:(function
      | Environment.Ecoproto_error (Contract_storage.Empty_transaction _) :: _
        ->
          return_unit
      | _ ->
          failwith "Empty transaction should fail")
    Tez.zero

(********************)
(** Transfer zero tez from an implicit contract *)

(********************)

let transfer_zero_implicit () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let dest = List.nth contracts 0 in
  let account = Account.new_account () in
  Incremental.begin_construction b
  >>=? fun i ->
  let src = Contract.implicit_contract account.Account.pkh in
  Op.transaction (I i) src dest Tez.zero
  >>=? fun op ->
  Incremental.add_operation i op
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Empty_implicit_contract _ ->
          true
      | _ ->
          false)

(********************)
(** Transfer to originted contract *)

(********************)

let transfer_to_originate_with_fee () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.nth contracts 0 in
  Incremental.begin_construction b
  >>=? fun b ->
  two_nth_of_balance b contract 10L
  >>=? fun fee ->
  (* originated contract, paying a fee to originated this contract *)
  Op.origination (I b) ~fee:ten_tez contract ~script:Op.dummy_script
  >>=? fun (operation, new_contract) ->
  Incremental.add_operation b operation
  >>=? fun b ->
  two_nth_of_balance b contract 3L
  >>=? fun amount ->
  transfer_and_check_balances ~loc:__LOC__ b ~fee contract new_contract amount
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Transfer from balance *)

(********************)

let transfer_amount_of_contract_balance () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Context.Contract.pkh contract_1
  >>=? fun pkh1 ->
  (* given that contract_1 no longer has a sufficient balance to bake,
     make sure it cannot be chosen as baker *)
  Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
  >>=? fun b ->
  (* get the balance of the source contract *)
  Context.Contract.balance (I b) contract_1
  >>=? fun balance ->
  (* transfer all the tez inside contract 1 *)
  transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 balance
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Transfer to itself *)

(********************)

let transfers_to_self () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let contract = List.nth contracts 0 in
  Incremental.begin_construction b
  >>=? fun b ->
  two_nth_of_balance b contract 3L
  >>=? fun amount ->
  transfer_to_itself_and_check_balances ~loc:__LOC__ b contract amount
  >>=? fun (b, _) ->
  two_nth_of_balance b contract 5L
  >>=? fun fee ->
  transfer_to_itself_and_check_balances ~loc:__LOC__ b ~fee contract ten_tez
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Forgot to add the valid transaction into the block *)

(********************)

let missing_transaction () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  (* given that contract_1 no longer has a sufficient balance to bake,
     make sure it cannot be chosen as baker *)
  Context.Contract.pkh contract_1
  >>=? fun pkh1 ->
  Incremental.begin_construction b ~policy:(Block.Excluding [pkh1])
  >>=? fun b ->
  two_nth_of_balance b contract_1 6L
  >>=? fun amount ->
  (* do the transfer 3 times from source contract to destination contract *)
  n_transactions 3 b contract_1 contract_2 amount
  >>=? fun b ->
  (* do the fourth transfer from source contract to destination contract *)
  Op.transaction (I b) contract_1 contract_2 amount
  >>=? fun _ -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** These following tests are for different kind of contracts:
    - implicit to implicit
    - implicit to originated
    - originated to implicit
    - originted to originted *)

(********************)

(** Implicit to Implicit *)

let transfer_from_implicit_to_implicit_contract () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let bootstrap_contract = List.nth contracts 0 in
  let account_a = Account.new_account () in
  let account_b = Account.new_account () in
  Incremental.begin_construction b
  >>=? fun b ->
  let src = Contract.implicit_contract account_a.Account.pkh in
  two_nth_of_balance b bootstrap_contract 3L
  >>=? fun amount1 ->
  two_nth_of_balance b bootstrap_contract 10L
  >>=? fun fee1 ->
  transfer_and_check_balances
    ~with_burn:true
    ~loc:__LOC__
    ~fee:fee1
    b
    bootstrap_contract
    src
    amount1
  >>=? fun (b, _) ->
  (* create an implicit contract as a destination contract *)
  let dest = Contract.implicit_contract account_b.pkh in
  two_nth_of_balance b bootstrap_contract 4L
  >>=? fun amount2 ->
  two_nth_of_balance b bootstrap_contract 10L
  >>=? fun fee2 ->
  (* transfer from implicit contract to another implicit contract *)
  transfer_and_check_balances
    ~with_burn:true
    ~loc:__LOC__
    ~fee:fee2
    b
    src
    dest
    amount2
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** Implicit to originated *)

let transfer_from_implicit_to_originated_contract () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let bootstrap_contract = List.nth contracts 0 in
  let contract = List.nth contracts 0 in
  let account = Account.new_account () in
  let src = Contract.implicit_contract account.Account.pkh in
  Incremental.begin_construction b
  >>=? fun b ->
  two_nth_of_balance b bootstrap_contract 3L
  >>=? fun amount1 ->
  (* transfer the money to implicit contract *)
  transfer_and_check_balances
    ~with_burn:true
    ~loc:__LOC__
    b
    bootstrap_contract
    src
    amount1
  >>=? fun (b, _) ->
  (* originated contract *)
  Op.origination (I b) contract ~script:Op.dummy_script
  >>=? fun (operation, new_contract) ->
  Incremental.add_operation b operation
  >>=? fun b ->
  two_nth_of_balance b bootstrap_contract 4L
  >>=? fun amount2 ->
  (* transfer from implicit contract to originated contract *)
  transfer_and_check_balances ~loc:__LOC__ b src new_contract amount2
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Slow tests case *)

(********************)

let multiple_transfer n ?fee amount =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  n_transactions n b ?fee contract_1 contract_2 amount
  >>=? fun b -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** 1- Create a block with two contracts;
    2- Apply 100 transfers. *)
let block_with_multiple_transfers () = multiple_transfer 99 (Tez.of_int 1000)

(** 1- Create a block with two contracts;
    2- Apply 100 transfers with 10tz fee. *)
let block_with_multiple_transfers_pay_fee () =
  multiple_transfer 10 ~fee:ten_tez (Tez.of_int 1000)

(* TODO : increase the number of operations and add a `Slow tag to it in `tests` *)

(** 1- Create a block with 8 contracts;
    2- Apply multiple transfers without fees;
    3- Apply multiple transfers with fees. *)
let block_with_multiple_transfers_with_without_fee () =
  Context.init 8
  >>=? fun (b, contracts) ->
  let contracts = Array.of_list contracts in
  Incremental.begin_construction b
  >>=? fun b ->
  let hundred = Tez.of_int 100 in
  let ten = Tez.of_int 10 in
  let twenty = Tez.of_int 20 in
  n_transactions 10 b contracts.(0) contracts.(1) Tez.one
  >>=? fun b ->
  n_transactions 30 b contracts.(1) contracts.(2) hundred
  >>=? fun b ->
  n_transactions 30 b contracts.(1) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 30 b contracts.(4) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 20 b contracts.(0) contracts.(1) hundred
  >>=? fun b ->
  n_transactions 10 b contracts.(1) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 10 b contracts.(1) contracts.(3) hundred
  >>=? fun b ->
  n_transactions 20 ~fee:ten b contracts.(3) contracts.(4) ten
  >>=? fun b ->
  n_transactions 10 ~fee:twenty b contracts.(4) contracts.(5) ten
  >>=? fun b ->
  n_transactions 70 ~fee:twenty b contracts.(6) contracts.(0) twenty
  >>=? fun b ->
  n_transactions 550 ~fee:twenty b contracts.(6) contracts.(4) twenty
  >>=? fun b ->
  n_transactions 50 ~fee:ten b contracts.(7) contracts.(5) twenty
  >>=? fun b ->
  n_transactions 30 ~fee:ten b contracts.(0) contracts.(7) hundred
  >>=? fun b ->
  n_transactions 20 ~fee:ten b contracts.(1) contracts.(0) twenty
  >>=? fun b -> Incremental.finalize_block b >>=? fun _ -> return_unit

(********************)
(** Build a chain that has 10 blocks. *)

(********************)

let build_a_chain () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  let ten = Tez.of_int 10 in
  fold_left_s
    (fun b _ ->
      Incremental.begin_construction b
      >>=? fun b ->
      transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten
      >>=? fun (b, _) -> Incremental.finalize_block b)
    b
    (1 -- 10)
  >>=? fun _ -> return_unit

(*********************************************************************)
(* Expected error test cases                                         *)
(*********************************************************************)

(********************)
(** transfer zero tez is forbidden in implicit contract *)

(********************)

let empty_implicit () =
  Context.init 1
  >>=? fun (b, contracts) ->
  let dest = List.nth contracts 0 in
  let account = Account.new_account () in
  Incremental.begin_construction b
  >>=? fun incr ->
  let src = Contract.implicit_contract account.Account.pkh in
  two_nth_of_balance incr dest 3L
  >>=? fun amount ->
  (* transfer zero tez from an implicit contract *)
  Op.transaction (I incr) src dest amount
  >>=? fun op ->
  Incremental.add_operation incr op
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Contract_storage.Empty_implicit_contract _ ->
          true
      | _ ->
          false)

(********************)
(** Balance is too low to transfer *)

(********************)

let balance_too_low fee () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.balance (I i) contract_1
  >>=? fun balance1 ->
  Context.Contract.balance (I i) contract_2
  >>=? fun balance2 ->
  (* transfer the amount of tez that is bigger than the balance in the source contract *)
  Op.transaction ~fee (I i) contract_1 contract_2 Tez.max_tez
  >>=? fun op ->
  let expect_failure = function
    | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
        return_unit
    | _ ->
        failwith "balance too low should fail"
  in
  (* the fee is higher than the balance then raise an error "Balance_too_low" *)
  if fee > balance1 then
    Incremental.add_operation ~expect_failure i op >>= fun _res -> return_unit
    (* the fee is smaller than the balance, then the transfer is accepted
     but it is not processed, and fees are taken *)
  else
    Incremental.add_operation ~expect_failure i op
    >>=? fun i ->
    (* contract_1 loses the fees *)
    Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee
    >>=? fun () ->
    (* contract_2 is not credited *)
    Assert.balance_was_credited ~loc:__LOC__ (I i) contract_2 balance2 Tez.zero

(** 1- Create a block, and three contracts;
    2- Add a transfer that at the end the balance of a contract is
       zero into this block;
    3- Add another transfer that send tez from a zero balance contract;
    4- Catch the expected error: Balance_too_low. *)
let balance_too_low_two_transfers fee () =
  Context.init 3
  >>=? fun (b, contracts) ->
  let contract_1 = List.nth contracts 0 in
  let contract_2 = List.nth contracts 1 in
  let contract_3 = List.nth contracts 2 in
  Incremental.begin_construction b
  >>=? fun i ->
  Context.Contract.balance (I i) contract_1
  >>=? fun balance ->
  Tez.( /? ) balance 3L
  >>?= fun res ->
  Tez.( *? ) res 2L
  >>?= fun two_third_of_balance ->
  transfer_and_check_balances
    ~loc:__LOC__
    i
    contract_1
    contract_2
    two_third_of_balance
  >>=? fun (i, _) ->
  Context.Contract.balance (I i) contract_1
  >>=? fun balance1 ->
  Context.Contract.balance (I i) contract_3
  >>=? fun balance3 ->
  Op.transaction ~fee (I i) contract_1 contract_3 two_third_of_balance
  >>=? fun operation ->
  let expect_failure = function
    | Environment.Ecoproto_error (Contract_storage.Balance_too_low _) :: _ ->
        return_unit
    | _ ->
        failwith "balance too low should fail"
  in
  Incremental.add_operation ~expect_failure i operation
  >>=? fun i ->
  (* contract_1 loses the fees *)
  Assert.balance_was_debited ~loc:__LOC__ (I i) contract_1 balance1 fee
  >>=? fun () ->
  (* contract_3 is not credited *)
  Assert.balance_was_credited ~loc:__LOC__ (I i) contract_3 balance3 Tez.zero

(********************)
(** The counter is already used for the previous operation *)

(********************)

let invalid_counter () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  Op.transaction (I b) contract_1 contract_2 Tez.one
  >>=? fun op1 ->
  Op.transaction (I b) contract_1 contract_2 Tez.one
  >>=? fun op2 ->
  Incremental.add_operation b op1
  >>=? fun b ->
  Incremental.add_operation b op2
  >>= fun b ->
  Assert.proto_error ~loc:__LOC__ b (function
      | Contract_storage.Counter_in_the_past _ ->
          true
      | _ ->
          false)

(* same as before but different way to perform this error *)

let add_the_same_operation_twice () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  transfer_and_check_balances ~loc:__LOC__ b contract_1 contract_2 ten_tez
  >>=? fun (b, op_transfer) ->
  Op.transaction (I b) contract_1 contract_2 ten_tez
  >>=? fun _ ->
  Incremental.add_operation b op_transfer
  >>= fun b ->
  Assert.proto_error ~loc:__LOC__ b (function
      | Contract_storage.Counter_in_the_past _ ->
          true
      | _ ->
          false)

(********************)
(** check ownership *)

(********************)

let ownership_sender () =
  register_two_contracts ()
  >>=? fun (b, contract_1, contract_2) ->
  Incremental.begin_construction b
  >>=? fun b ->
  (* get the manager of the contract_1 as a sender *)
  Context.Contract.manager (I b) contract_1
  >>=? fun manager ->
  (* create an implicit_contract *)
  let imcontract_1 = Alpha_context.Contract.implicit_contract manager.pkh in
  transfer_and_check_balances ~loc:__LOC__ b imcontract_1 contract_2 Tez.one
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(*********************************************************************)
(** Random transfer *)

(** Return a pair of minimum and maximum random number *)
let random_range (min, max) =
  let interv = max - min + 1 in
  let init =
    Random.self_init () ;
    Random.int interv + min
  in
  init

(** Return a random contract *)
let random_contract contract_array =
  let i = Random.int (Array.length contract_array) in
  contract_array.(i)

(** Transfer by randomly choose amount 10 contracts, and randomly
    choose the amount in the source contract *)
let random_transfer () =
  Context.init 10
  >>=? fun (b, contracts) ->
  let contracts = Array.of_list contracts in
  let source = random_contract contracts in
  let dest = random_contract contracts in
  Context.Contract.pkh source
  >>=? fun source_pkh ->
  (* given that source may not have a sufficient balance for the transfer + to bake,
     make sure it cannot be chosen as baker *)
  Incremental.begin_construction b ~policy:(Block.Excluding [source_pkh])
  >>=? fun b ->
  Context.Contract.balance (I b) source
  >>=? fun amount ->
  ( if source = dest then
    transfer_to_itself_and_check_balances ~loc:__LOC__ b source amount
  else transfer_and_check_balances ~loc:__LOC__ b source dest amount )
  >>=? fun (b, _) -> Incremental.finalize_block b >>=? fun _ -> return_unit

(** Transfer random transactions *)
let random_multi_transactions () =
  let n = random_range (1, 100) in
  multiple_transfer n (Tez.of_int 100)

(*********************************************************************)

let tests =
  [ (* single transfer *)
    Test.tztest "single transfer" `Quick block_with_a_single_transfer;
    Test.tztest
      "single transfer with fee"
      `Quick
      block_with_a_single_transfer_with_fee;
    (* transfer zero tez *)
    Test.tztest "single transfer zero tez" `Quick transfer_zero_tez;
    Test.tztest
      "transfer zero tez from implicit contract"
      `Quick
      transfer_zero_implicit;
    (* transfer to originated contract *)
    Test.tztest
      "transfer to originated contract paying transaction fee"
      `Quick
      transfer_to_originate_with_fee;
    (* transfer by the balance of contract *)
    Test.tztest
      "transfer the amount from source contract balance"
      `Quick
      transfer_amount_of_contract_balance;
    (* transfer to itself *)
    Test.tztest "transfers to itself" `Quick transfers_to_self;
    (* missing operation *)
    Test.tztest "missing transaction" `Quick missing_transaction;
    (* transfer from/to implicit/originted contracts*)
    Test.tztest
      "transfer from an implicit to implicit contract "
      `Quick
      transfer_from_implicit_to_implicit_contract;
    Test.tztest
      "transfer from an implicit to an originated contract"
      `Quick
      transfer_from_implicit_to_originated_contract;
    (* Slow tests *)
    Test.tztest
      "block with multiple transfers"
      `Slow
      block_with_multiple_transfers;
    (* TODO increase the number of transaction times *)
    Test.tztest
      "block with multiple transfer paying fee"
      `Slow
      block_with_multiple_transfers_pay_fee;
    Test.tztest
      "block with multiple transfer without paying fee"
      `Slow
      block_with_multiple_transfers_with_without_fee;
    (* build the chain *)
    Test.tztest "build a chain" `Quick build_a_chain;
    (* Erroneous *)
    Test.tztest "empty implicit" `Quick empty_implicit;
    Test.tztest
      "balance too low - transfer zero"
      `Quick
      (balance_too_low Tez.zero);
    Test.tztest "balance too low" `Quick (balance_too_low Tez.one);
    Test.tztest
      "balance too low (max fee)"
      `Quick
      (balance_too_low Tez.max_tez);
    Test.tztest
      "balance too low with two transfers - transfer zero"
      `Quick
      (balance_too_low_two_transfers Tez.zero);
    Test.tztest
      "balance too low with two transfers"
      `Quick
      (balance_too_low_two_transfers Tez.one);
    Test.tztest "invalid_counter" `Quick invalid_counter;
    Test.tztest
      "add the same operation twice"
      `Quick
      add_the_same_operation_twice;
    Test.tztest "ownership sender" `Quick ownership_sender;
    (* Random tests *)
    Test.tztest "random transfer" `Quick random_transfer;
    Test.tztest "random multi transfer" `Quick random_multi_transactions ]
src/proto_alpha/lib_protocol/test/transfer.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Alpha_context.

Definition transfer_and_check_balances {A B C D E F : Type}
  (op_staroptstar : option bool)
  : A ->
    B ->
      (option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez) ->
        (option C) ->
          D -> E -> Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez -> F :=
  let with_burn :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => false
    end in
  fun loc =>
    fun b =>
      fun op_staroptstar =>
        let fee :=
          match op_staroptstar with
          | Some op_starsthstar => op_starsthstar
          | None => Tez.zero
          end in
        fun expect_failure =>
          fun src =>
            fun dst =>
              fun amount =>
                op_startypeminuserrorstar (Tez.op_plusquestion fee amount)
                  (fun amount_fee =>
                    op_gtgteqquestion
                      (op_startypeminuserrorstar op_startypeminuserrorstar src)
                      (fun bal_src =>
                        op_gtgteqquestion
                          (op_startypeminuserrorstar op_startypeminuserrorstar
                            dst)
                          (fun bal_dst =>
                            op_gtgteqquestion
                              (op_startypeminuserrorstar
                                op_startypeminuserrorstar fee src dst amount)
                              (fun op =>
                                op_gtgteqquestion
                                  (op_startypeminuserrorstar expect_failure b op)
                                  (fun b =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar
                                        op_startypeminuserrorstar)
                                      (fun function_parameter =>
                                        let '_ := function_parameter in
                                        op_startypeminuserrorstar
                                          (op_starquestion
                                            op_startypeminuserrorstar
                                            (Int64.of_int
                                              op_startypeminuserrorstar))
                                          (fun origination_burn =>
                                            let amount_fee_maybe_burn :=
                                              if with_burn then
                                                match
                                                  op_plusquestion amount_fee
                                                    origination_burn with
                                                |
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.Ok
                                                    r => r
                                                |
                                                  Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                                                    _ =>
                                                  (* ❌ Assert instruction is not handled. *)
                                                  assert false
                                                end
                                              else
                                                amount_fee in
                                            op_gtgteqquestion
                                              (op_startypeminuserrorstar loc
                                                op_startypeminuserrorstar src
                                                bal_src amount_fee_maybe_burn)
                                              (fun function_parameter =>
                                                let 'tt := function_parameter in
                                                op_gtgteqquestion
                                                  (op_startypeminuserrorstar loc
                                                    op_startypeminuserrorstar
                                                    dst bal_dst amount)
                                                  (fun function_parameter =>
                                                    let 'tt :=
                                                      function_parameter in
                                                    _return (b, op)))))))))).

Definition transfer_to_itself_and_check_balances {A B C D E F : Type}
  (loc : A) (b : B)
  (op_staroptstar : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : C ->
    D ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          (E * F)) :=
  let fee :=
    match op_staroptstar with
    | Some op_starsthstar => op_starsthstar
    | None => Tez.zero
    end in
  fun contract =>
    fun amount =>
      op_gtgteqquestion
        (op_startypeminuserrorstar op_startypeminuserrorstar contract)
        (fun bal =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar fee contract
              contract amount)
            (fun op =>
              op_gtgteqquestion (op_startypeminuserrorstar b op)
                (fun b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar loc op_startypeminuserrorstar
                      contract bal fee)
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      _return (b, op))))).

Definition n_transactions {A B C D : Type}
  (n : A) (b : B)
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (source : C) (dest : D)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  fold_left_s
    (fun b =>
      fun function_parameter =>
        let '_ := function_parameter in
        op_gtgteqquestion
          (transfer_and_check_balances None __LOC__ b fee None source dest
            amount)
          (fun function_parameter =>
            let '(b, _) := function_parameter in
            _return b)) b (op_startypeminuserrorstar 1 n).

Definition ten_tez {A : Type} : A := op_startypeminuserrorstar 10.

Definition register_two_contracts {A B C : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (A * B * C)) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 2)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract_1 := op_startypeminuserrorstar contracts 0 in
      let contract_2 := op_startypeminuserrorstar contracts 1 in
      _return (b, contract_1, contract_2)).

Definition two_nth_of_balance {A B C : Type}
  (incr : A) (contract : B) (nth : int64)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult C) :=
  op_gtgteqquestion
    (op_startypeminuserrorstar op_startypeminuserrorstar contract)
    (fun balance =>
      op_startypeminuserrorstar (Tez.op_divquestion balance nth)
        (fun res =>
          op_startypeminuserrorstar
            (Tez.op_starquestion res
              (* ❌ Constant of type int64 is converted to int *)
              2) (fun balance => _return balance))).

Definition single_transfer {A : Type}
  (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (expect_failure : option A)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (transfer_and_check_balances None __LOC__ b fee expect_failure
              contract_1 contract_2 amount)
            (fun function_parameter =>
              let '(b, _) := function_parameter in
              op_gtgteqquestion (op_startypeminuserrorstar b)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  return_unit)))).

Definition block_with_a_single_transfer (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  single_transfer None None Tez.one.

Definition block_with_a_single_transfer_with_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  single_transfer (Some Tez.one) None Tez.one.

Definition transfer_zero_tez (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  single_transfer None
    (Some
      (fun function_parameter =>
        match function_parameter with
        |
          cons
            (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
              (Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_transaction
                _)) _ => return_unit
        | _ => failwith "Empty transaction should fail" % string
        end)) Tez.zero.

Definition transfer_zero_implicit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let dest := op_startypeminuserrorstar contracts 0 in
      let account := op_startypeminuserrorstar tt in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          let src := Contract.implicit_contract (Account.pkh account) in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar src dest
              Tez.zero)
            (fun op =>
              op_gtgteq (op_startypeminuserrorstar i op)
                (fun res =>
                  op_startypeminuserrorstar __LOC__ res
                    (fun function_parameter =>
                      match function_parameter with
                      |
                        Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
                          _ => true
                      | _ => false
                      end))))).

Definition transfer_to_originate_with_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract := op_startypeminuserrorstar contracts 0 in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (two_nth_of_balance b contract
              (* ❌ Constant of type int64 is converted to int *)
              10)
            (fun fee =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar ten_tez
                  contract op_startypeminuserrorstar)
                (fun function_parameter =>
                  let '(operation, new_contract) := function_parameter in
                  op_gtgteqquestion (op_startypeminuserrorstar b operation)
                    (fun b =>
                      op_gtgteqquestion
                        (two_nth_of_balance b contract
                          (* ❌ Constant of type int64 is converted to int *)
                          3)
                        (fun amount =>
                          op_gtgteqquestion
                            (transfer_and_check_balances None __LOC__ b
                              (Some fee) None contract new_contract amount)
                            (fun function_parameter =>
                              let '(b, _) := function_parameter in
                              op_gtgteqquestion (op_startypeminuserrorstar b)
                                (fun function_parameter =>
                                  let '_ := function_parameter in
                                  return_unit)))))))).

Definition transfer_amount_of_contract_balance (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar contract_1)
        (fun pkh1 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar b op_startypeminuserrorstar)
            (fun b =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
                (fun balance =>
                  op_gtgteqquestion
                    (transfer_and_check_balances None __LOC__ b None None
                      contract_1 contract_2 balance)
                    (fun function_parameter =>
                      let '(b, _) := function_parameter in
                      op_gtgteqquestion (op_startypeminuserrorstar b)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          return_unit)))))).

Definition transfers_to_self (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract := op_startypeminuserrorstar contracts 0 in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (two_nth_of_balance b contract
              (* ❌ Constant of type int64 is converted to int *)
              3)
            (fun amount =>
              op_gtgteqquestion
                (transfer_to_itself_and_check_balances __LOC__ b None contract
                  amount)
                (fun function_parameter =>
                  let '(b, _) := function_parameter in
                  op_gtgteqquestion
                    (two_nth_of_balance b contract
                      (* ❌ Constant of type int64 is converted to int *)
                      5)
                    (fun fee =>
                      op_gtgteqquestion
                        (transfer_to_itself_and_check_balances __LOC__ b
                          (Some fee) contract ten_tez)
                        (fun function_parameter =>
                          let '(b, _) := function_parameter in
                          op_gtgteqquestion (op_startypeminuserrorstar b)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              return_unit))))))).

Definition missing_transaction (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar contract_1)
        (fun pkh1 =>
          op_gtgteqquestion
            (op_startypeminuserrorstar b op_startypeminuserrorstar)
            (fun b =>
              op_gtgteqquestion
                (two_nth_of_balance b contract_1
                  (* ❌ Constant of type int64 is converted to int *)
                  6)
                (fun amount =>
                  op_gtgteqquestion
                    (n_transactions 3 b None contract_1 contract_2 amount)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar
                          contract_1 contract_2 amount)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          op_gtgteqquestion (op_startypeminuserrorstar b)
                            (fun function_parameter =>
                              let '_ := function_parameter in
                              return_unit))))))).

Definition transfer_from_implicit_to_implicit_contract
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let bootstrap_contract := op_startypeminuserrorstar contracts 0 in
      let account_a := op_startypeminuserrorstar tt in
      let account_b := op_startypeminuserrorstar tt in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          let src := Contract.implicit_contract (Account.pkh account_a) in
          op_gtgteqquestion
            (two_nth_of_balance b bootstrap_contract
              (* ❌ Constant of type int64 is converted to int *)
              3)
            (fun amount1 =>
              op_gtgteqquestion
                (two_nth_of_balance b bootstrap_contract
                  (* ❌ Constant of type int64 is converted to int *)
                  10)
                (fun fee1 =>
                  op_gtgteqquestion
                    (transfer_and_check_balances (Some true) __LOC__ b
                      (Some fee1) None bootstrap_contract src amount1)
                    (fun function_parameter =>
                      let '(b, _) := function_parameter in
                      let dest := Contract.implicit_contract (pkh account_b) in
                      op_gtgteqquestion
                        (two_nth_of_balance b bootstrap_contract
                          (* ❌ Constant of type int64 is converted to int *)
                          4)
                        (fun amount2 =>
                          op_gtgteqquestion
                            (two_nth_of_balance b bootstrap_contract
                              (* ❌ Constant of type int64 is converted to int *)
                              10)
                            (fun fee2 =>
                              op_gtgteqquestion
                                (transfer_and_check_balances (Some true) __LOC__
                                  b (Some fee2) None src dest amount2)
                                (fun function_parameter =>
                                  let '(b, _) := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar b)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      return_unit))))))))).

Definition transfer_from_implicit_to_originated_contract
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let bootstrap_contract := op_startypeminuserrorstar contracts 0 in
      let contract := op_startypeminuserrorstar contracts 0 in
      let account := op_startypeminuserrorstar tt in
      let src := Contract.implicit_contract (Account.pkh account) in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (two_nth_of_balance b bootstrap_contract
              (* ❌ Constant of type int64 is converted to int *)
              3)
            (fun amount1 =>
              op_gtgteqquestion
                (transfer_and_check_balances (Some true) __LOC__ b None None
                  bootstrap_contract src amount1)
                (fun function_parameter =>
                  let '(b, _) := function_parameter in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      contract op_startypeminuserrorstar)
                    (fun function_parameter =>
                      let '(operation, new_contract) := function_parameter in
                      op_gtgteqquestion (op_startypeminuserrorstar b operation)
                        (fun b =>
                          op_gtgteqquestion
                            (two_nth_of_balance b bootstrap_contract
                              (* ❌ Constant of type int64 is converted to int *)
                              4)
                            (fun amount2 =>
                              op_gtgteqquestion
                                (transfer_and_check_balances None __LOC__ b None
                                  None src new_contract amount2)
                                (fun function_parameter =>
                                  let '(b, _) := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar b)
                                    (fun function_parameter =>
                                      let '_ := function_parameter in
                                      return_unit))))))))).

Definition multiple_transfer {A : Type}
  (n : A) (fee : option Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  (amount : Tezos_protocol_alpha.Protocol.Alpha_context.Tez.tez)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (n_transactions n b fee contract_1 contract_2 amount)
            (fun b =>
              op_gtgteqquestion (op_startypeminuserrorstar b)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  return_unit)))).

Definition block_with_multiple_transfers (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  multiple_transfer 99 None (op_startypeminuserrorstar 1000).

Definition block_with_multiple_transfers_pay_fee (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  multiple_transfer 10 (Some ten_tez) (op_startypeminuserrorstar 1000).

Definition block_with_multiple_transfers_with_without_fee
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 8)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contracts := op_startypeminuserrorstar contracts in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          let hundred := op_startypeminuserrorstar 100 in
          let ten := op_startypeminuserrorstar 10 in
          let twenty := op_startypeminuserrorstar 20 in
          op_gtgteqquestion
            (n_transactions 10 b None (op_startypeminuserrorstar contracts 0)
              (op_startypeminuserrorstar contracts 1) Tez.one)
            (fun b =>
              op_gtgteqquestion
                (n_transactions 30 b None
                  (op_startypeminuserrorstar contracts 1)
                  (op_startypeminuserrorstar contracts 2) hundred)
                (fun b =>
                  op_gtgteqquestion
                    (n_transactions 30 b None
                      (op_startypeminuserrorstar contracts 1)
                      (op_startypeminuserrorstar contracts 3) hundred)
                    (fun b =>
                      op_gtgteqquestion
                        (n_transactions 30 b None
                          (op_startypeminuserrorstar contracts 4)
                          (op_startypeminuserrorstar contracts 3) hundred)
                        (fun b =>
                          op_gtgteqquestion
                            (n_transactions 20 b None
                              (op_startypeminuserrorstar contracts 0)
                              (op_startypeminuserrorstar contracts 1) hundred)
                            (fun b =>
                              op_gtgteqquestion
                                (n_transactions 10 b None
                                  (op_startypeminuserrorstar contracts 1)
                                  (op_startypeminuserrorstar contracts 3)
                                  hundred)
                                (fun b =>
                                  op_gtgteqquestion
                                    (n_transactions 10 b None
                                      (op_startypeminuserrorstar contracts 1)
                                      (op_startypeminuserrorstar contracts 3)
                                      hundred)
                                    (fun b =>
                                      op_gtgteqquestion
                                        (n_transactions 20 b (Some ten)
                                          (op_startypeminuserrorstar contracts 3)
                                          (op_startypeminuserrorstar contracts 4)
                                          ten)
                                        (fun b =>
                                          op_gtgteqquestion
                                            (n_transactions 10 b (Some twenty)
                                              (op_startypeminuserrorstar
                                                contracts 4)
                                              (op_startypeminuserrorstar
                                                contracts 5) ten)
                                            (fun b =>
                                              op_gtgteqquestion
                                                (n_transactions 70 b
                                                  (Some twenty)
                                                  (op_startypeminuserrorstar
                                                    contracts 6)
                                                  (op_startypeminuserrorstar
                                                    contracts 0) twenty)
                                                (fun b =>
                                                  op_gtgteqquestion
                                                    (n_transactions 550 b
                                                      (Some twenty)
                                                      (op_startypeminuserrorstar
                                                        contracts 6)
                                                      (op_startypeminuserrorstar
                                                        contracts 4) twenty)
                                                    (fun b =>
                                                      op_gtgteqquestion
                                                        (n_transactions 50 b
                                                          (Some ten)
                                                          (op_startypeminuserrorstar
                                                            contracts 7)
                                                          (op_startypeminuserrorstar
                                                            contracts 5) twenty)
                                                        (fun b =>
                                                          op_gtgteqquestion
                                                            (n_transactions 30 b
                                                              (Some ten)
                                                              (op_startypeminuserrorstar
                                                                contracts 0)
                                                              (op_startypeminuserrorstar
                                                                contracts 7)
                                                              hundred)
                                                            (fun b =>
                                                              op_gtgteqquestion
                                                                (n_transactions
                                                                  20 b
                                                                  (Some ten)
                                                                  (op_startypeminuserrorstar
                                                                    contracts 1)
                                                                  (op_startypeminuserrorstar
                                                                    contracts 0)
                                                                  twenty)
                                                                (fun b =>
                                                                  op_gtgteqquestion
                                                                    (op_startypeminuserrorstar
                                                                      b)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let '_ :=
                                                                        function_parameter
                                                                        in
                                                                      return_unit))))))))))))))))).

Definition build_a_chain (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      let ten := op_startypeminuserrorstar 10 in
      op_gtgteqquestion
        (fold_left_s
          (fun b =>
            fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteqquestion (op_startypeminuserrorstar b)
                (fun b =>
                  op_gtgteqquestion
                    (transfer_and_check_balances None __LOC__ b None None
                      contract_1 contract_2 ten)
                    (fun function_parameter =>
                      let '(b, _) := function_parameter in
                      op_startypeminuserrorstar b))) b
          (op_startypeminuserrorstar 1 10))
        (fun function_parameter =>
          let '_ := function_parameter in
          return_unit)).

Definition empty_implicit {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let dest := op_startypeminuserrorstar contracts 0 in
      let account := op_startypeminuserrorstar tt in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun incr =>
          let src := Contract.implicit_contract (Account.pkh account) in
          op_gtgteqquestion
            (two_nth_of_balance incr dest
              (* ❌ Constant of type int64 is converted to int *)
              3)
            (fun amount =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar src dest
                  amount)
                (fun op =>
                  op_gtgteq (op_startypeminuserrorstar incr op)
                    (fun res =>
                      op_startypeminuserrorstar __LOC__ res
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_implicit_contract
                              _ => true
                          | _ => false
                          end)))))).

Definition balance_too_low {A : Type} (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
            (fun balance1 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar contract_2)
                (fun balance2 =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar fee op_startypeminuserrorstar
                      contract_1 contract_2 op_startypeminuserrorstar)
                    (fun op =>
                      let expect_failure
                        (function_parameter :
                        list Tezos_base__TzPervasives.Error_monad.error)
                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                            unit) :=
                        match function_parameter with
                        |
                          cons
                            (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
                              (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                _ _ _)) _ => return_unit
                        | _ => failwith "balance too low should fail" % string
                        end in
                      if op_startypeminuserrorstar fee balance1 then
                        op_gtgteq
                          (op_startypeminuserrorstar expect_failure i op)
                          (fun _res => return_unit)
                      else
                        op_gtgteqquestion
                          (op_startypeminuserrorstar expect_failure i op)
                          (fun i =>
                            op_gtgteqquestion
                              (op_startypeminuserrorstar __LOC__
                                op_startypeminuserrorstar contract_1 balance1
                                fee)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                op_startypeminuserrorstar __LOC__
                                  op_startypeminuserrorstar contract_2 balance2
                                  Tez.zero))))))).

Definition balance_too_low_two_transfers {A B : Type}
  (fee : A) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult B) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 3)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contract_1 := op_startypeminuserrorstar contracts 0 in
      let contract_2 := op_startypeminuserrorstar contracts 1 in
      let contract_3 := op_startypeminuserrorstar contracts 2 in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun i =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
            (fun balance =>
              op_startypeminuserrorstar
                (Tez.op_divquestion balance
                  (* ❌ Constant of type int64 is converted to int *)
                  3)
                (fun res =>
                  op_startypeminuserrorstar
                    (Tez.op_starquestion res
                      (* ❌ Constant of type int64 is converted to int *)
                      2)
                    (fun two_third_of_balance =>
                      op_gtgteqquestion
                        (transfer_and_check_balances None __LOC__ i None None
                          contract_1 contract_2 two_third_of_balance)
                        (fun function_parameter =>
                          let '(i, _) := function_parameter in
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              contract_1)
                            (fun balance1 =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar
                                  op_startypeminuserrorstar contract_3)
                                (fun balance3 =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar fee
                                      op_startypeminuserrorstar contract_1
                                      contract_3 two_third_of_balance)
                                    (fun operation =>
                                      let expect_failure
                                        (function_parameter :
                                        list
                                          Tezos_base__TzPervasives.Error_monad.error)
                                        : Tezos_protocol_environment_alpha__Environment.Lwt.t
                                          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
                                            unit) :=
                                        match function_parameter with
                                        |
                                          cons
                                            (Tezos_base__TzPervasives.Error_monad.Ecoproto_error
                                              (Tezos_protocol_environment_alpha__Environment.Error_monad.Balance_too_low
                                                _ _ _)) _ => return_unit
                                        | _ =>
                                          failwith
                                            "balance too low should fail" %
                                              string
                                        end in
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          expect_failure i operation)
                                        (fun i =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar __LOC__
                                              op_startypeminuserrorstar
                                              contract_1 balance1 fee)
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_startypeminuserrorstar __LOC__
                                                op_startypeminuserrorstar
                                                contract_3 balance3 Tez.zero))))))))))).

Definition invalid_counter {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar contract_1
              contract_2 Tez.one)
            (fun op1 =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar contract_1
                  contract_2 Tez.one)
                (fun op2 =>
                  op_gtgteqquestion (op_startypeminuserrorstar b op1)
                    (fun b =>
                      op_gtgteq (op_startypeminuserrorstar b op2)
                        (fun b =>
                          op_startypeminuserrorstar __LOC__ b
                            (fun function_parameter =>
                              match function_parameter with
                              |
                                Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
                                  _ _ _ => true
                              | _ => false
                              end))))))).

Definition add_the_same_operation_twice {A : Type} (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (transfer_and_check_balances None __LOC__ b None None contract_1
              contract_2 ten_tez)
            (fun function_parameter =>
              let '(b, op_transfer) := function_parameter in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar contract_1
                  contract_2 ten_tez)
                (fun function_parameter =>
                  let '_ := function_parameter in
                  op_gtgteq (op_startypeminuserrorstar b op_transfer)
                    (fun b =>
                      op_startypeminuserrorstar __LOC__ b
                        (fun function_parameter =>
                          match function_parameter with
                          |
                            Tezos_protocol_environment_alpha__Environment.Error_monad.Counter_in_the_past
                              _ _ _ => true
                          | _ => false
                          end)))))).

Definition ownership_sender (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (register_two_contracts tt)
    (fun function_parameter =>
      let '(b, contract_1, contract_2) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar b)
        (fun b =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar contract_1)
            (fun manager =>
              let imcontract_1 :=
                Alpha_context.Contract.implicit_contract (pkh manager) in
              op_gtgteqquestion
                (transfer_and_check_balances None __LOC__ b None None
                  imcontract_1 contract_2 Tez.one)
                (fun function_parameter =>
                  let '(b, _) := function_parameter in
                  op_gtgteqquestion (op_startypeminuserrorstar b)
                    (fun function_parameter =>
                      let '_ := function_parameter in
                      return_unit))))).

Definition random_range (function_parameter : Z * Z) : Z :=
  let '(min, max) := function_parameter in
  let interv := op_plus (op_minus max min) 1 in
  let init :=
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := op_startypeminuserrorstar tt in
    op_plus (op_startypeminuserrorstar interv) min in
  init.

Definition random_contract {A B : Type} (contract_array : A) : B :=
  let i := op_startypeminuserrorstar (op_startypeminuserrorstar contract_array)
    in
  op_startypeminuserrorstar contract_array i.

Definition random_transfer (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 10)
    (fun function_parameter =>
      let '(b, contracts) := function_parameter in
      let contracts := op_startypeminuserrorstar contracts in
      let source := random_contract contracts in
      let dest := random_contract contracts in
      op_gtgteqquestion (op_startypeminuserrorstar source)
        (fun source_pkh =>
          op_gtgteqquestion
            (op_startypeminuserrorstar b op_startypeminuserrorstar)
            (fun b =>
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar source)
                (fun amount =>
                  op_gtgteqquestion
                    (if op_startypeminuserrorstar source dest then
                      transfer_to_itself_and_check_balances __LOC__ b None
                        source amount
                    else
                      transfer_and_check_balances None __LOC__ b None None
                        source dest amount)
                    (fun function_parameter =>
                      let '(b, _) := function_parameter in
                      op_gtgteqquestion (op_startypeminuserrorstar b)
                        (fun function_parameter =>
                          let '_ := function_parameter in
                          return_unit)))))).

Definition random_multi_transactions (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let n := random_range (1, 100) in
  multiple_transfer n None (op_startypeminuserrorstar 100).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "single transfer" % string
      (* ❌ Variants not supported *)
      variant block_with_a_single_transfer)
    (cons
      (op_startypeminuserrorstar "single transfer with fee" % string
        (* ❌ Variants not supported *)
        variant block_with_a_single_transfer_with_fee)
      (cons
        (op_startypeminuserrorstar "single transfer zero tez" % string
          (* ❌ Variants not supported *)
          variant transfer_zero_tez)
        (cons
          (op_startypeminuserrorstar
            "transfer zero tez from implicit contract" % string
            (* ❌ Variants not supported *)
            variant transfer_zero_implicit)
          (cons
            (op_startypeminuserrorstar
              "transfer to originated contract paying transaction fee" % string
              (* ❌ Variants not supported *)
              variant transfer_to_originate_with_fee)
            (cons
              (op_startypeminuserrorstar
                "transfer the amount from source contract balance" % string
                (* ❌ Variants not supported *)
                variant transfer_amount_of_contract_balance)
              (cons
                (op_startypeminuserrorstar "transfers to itself" % string
                  (* ❌ Variants not supported *)
                  variant transfers_to_self)
                (cons
                  (op_startypeminuserrorstar "missing transaction" % string
                    (* ❌ Variants not supported *)
                    variant missing_transaction)
                  (cons
                    (op_startypeminuserrorstar
                      "transfer from an implicit to implicit contract " % string
                      (* ❌ Variants not supported *)
                      variant transfer_from_implicit_to_implicit_contract)
                    (cons
                      (op_startypeminuserrorstar
                        "transfer from an implicit to an originated contract" %
                          string
                        (* ❌ Variants not supported *)
                        variant transfer_from_implicit_to_originated_contract)
                      (cons
                        (op_startypeminuserrorstar
                          "block with multiple transfers" % string
                          (* ❌ Variants not supported *)
                          variant block_with_multiple_transfers)
                        (cons
                          (op_startypeminuserrorstar
                            "block with multiple transfer paying fee" % string
                            (* ❌ Variants not supported *)
                            variant block_with_multiple_transfers_pay_fee)
                          (cons
                            (op_startypeminuserrorstar
                              "block with multiple transfer without paying fee"
                                % string
                              (* ❌ Variants not supported *)
                              variant
                              block_with_multiple_transfers_with_without_fee)
                            (cons
                              (op_startypeminuserrorstar
                                "build a chain" % string
                                (* ❌ Variants not supported *)
                                variant build_a_chain)
                              (cons
                                (op_startypeminuserrorstar
                                  "empty implicit" % string
                                  (* ❌ Variants not supported *)
                                  variant empty_implicit)
                                (cons
                                  (op_startypeminuserrorstar
                                    "balance too low - transfer zero" % string
                                    (* ❌ Variants not supported *)
                                    variant (balance_too_low Tez.zero))
                                  (cons
                                    (op_startypeminuserrorstar
                                      "balance too low" % string
                                      (* ❌ Variants not supported *)
                                      variant (balance_too_low Tez.one))
                                    (cons
                                      (op_startypeminuserrorstar
                                        "balance too low (max fee)" % string
                                        (* ❌ Variants not supported *)
                                        variant
                                        (balance_too_low
                                          op_startypeminuserrorstar))
                                      (cons
                                        (op_startypeminuserrorstar
                                          "balance too low with two transfers - transfer zero"
                                            % string
                                          (* ❌ Variants not supported *)
                                          variant
                                          (balance_too_low_two_transfers
                                            Tez.zero))
                                        (cons
                                          (op_startypeminuserrorstar
                                            "balance too low with two transfers"
                                              % string
                                            (* ❌ Variants not supported *)
                                            variant
                                            (balance_too_low_two_transfers
                                              Tez.one))
                                          (cons
                                            (op_startypeminuserrorstar
                                              "invalid_counter" % string
                                              (* ❌ Variants not supported *)
                                              variant invalid_counter)
                                            (cons
                                              (op_startypeminuserrorstar
                                                "add the same operation twice" %
                                                  string
                                                (* ❌ Variants not supported *)
                                                variant
                                                add_the_same_operation_twice)
                                              (cons
                                                (op_startypeminuserrorstar
                                                  "ownership sender" % string
                                                  (* ❌ Variants not supported *)
                                                  variant ownership_sender)
                                                (cons
                                                  (op_startypeminuserrorstar
                                                    "random transfer" % string
                                                    (* ❌ Variants not supported *)
                                                    variant random_transfer)
                                                  (cons
                                                    (op_startypeminuserrorstar
                                                      "random multi transfer" %
                                                        string
                                                      (* ❌ Variants not supported *)
                                                      variant
                                                      random_multi_transactions)
                                                    [])))))))))))))))))))))))).

src/proto_alpha/lib_protocol/test/voting.ml 562 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Test_utils

(* missing stuff in Alpha_context.Vote *)
let ballots_zero = Alpha_context.Vote.{yay = 0l; nay = 0l; pass = 0l}

let ballots_equal b1 b2 =
  Alpha_context.Vote.(b1.yay = b2.yay && b1.nay = b2.nay && b1.pass = b2.pass)

let ballots_pp ppf v =
  Alpha_context.Vote.(
    Format.fprintf
      ppf
      "{ yay = %ld ; nay = %ld ; pass = %ld"
      v.yay
      v.nay
      v.pass)

(* constants and ratios used in voting:
   percent_mul denotes the percent multiplier
   initial_participation is 7000 that is, 7/10 * percent_mul
   the participation EMA ratio pr_ema_weight / den = 7 / 10
   the participation ratio pr_num / den = 2 / 10
   note: we use the same denominator for both participation EMA and participation rate.
   supermajority rate is s_num / s_den = 8 / 10 *)
let percent_mul = 100_00

let initial_participation_num = 7

let initial_participation = initial_participation_num * percent_mul / 10

let pr_ema_weight = 8

let den = 10

let pr_num = den - pr_ema_weight

let s_num = 8

let s_den = 10

let qr_min_num = 2

let qr_max_num = 7

let expected_qr_num =
  Float.(
    of_int qr_min_num
    +. of_int initial_participation_num
       *. (of_int qr_max_num -. of_int qr_min_num)
       /. of_int den)

(* Protocol_hash.zero is "PrihK96nBAFSxVL1GLJTVhu9YnzkMFiBeuJRPA8NwuZVZCE1L6i" *)
let protos =
  Array.map
    (fun s -> Protocol_hash.of_b58check_exn s)
    [| "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH";
       "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB";
       "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm";
       "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS";
       "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN";
       "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr";
       "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC";
       "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC";
       "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ";
       "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk";
       "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD";
       "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi";
       "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj";
       "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7";
       "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG";
       "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR";
       "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW";
       "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ";
       "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh";
       "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx";
       "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" |]

(** helper functions *)
let mk_contracts_from_pkh pkh_list =
  List.map Alpha_context.Contract.implicit_contract pkh_list

(* get the list of delegates and the list of their rolls from listings *)
let get_delegates_and_rolls_from_listings b =
  Context.Vote.get_listings (B b)
  >>=? fun l -> return (mk_contracts_from_pkh (List.map fst l), List.map snd l)

(* compute the rolls of each delegate *)
let get_rolls b delegates loc =
  Context.Vote.get_listings (B b)
  >>=? fun l ->
  map_s
    (fun delegate ->
      Context.Contract.pkh delegate
      >>=? fun pkh ->
      match List.find_opt (fun (del, _) -> del = pkh) l with
      | None ->
          failwith "%s - Missing delegate" loc
      | Some (_, rolls) ->
          return rolls)
    delegates

let test_successful_vote num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  (* no ballots in proposal period *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    ballots_zero
  >>=? fun () ->
  (* no ballots in proposal period *)
  Context.Vote.get_ballot_list (B b)
  >>=? (function
         | [] ->
             return_unit
         | _ ->
             failwith "%s - Unexpected ballot list" __LOC__)
  >>=? fun () ->
  (* period 0 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(root)
  >>=? fun () ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* participation EMA starts at initial_participation *)
  Context.Vote.get_participation_ema b
  >>=? fun v ->
  Assert.equal_int ~loc:__LOC__ initial_participation (Int32.to_int v)
  >>=? fun () ->
  (* listings must be populated in proposal period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty listings" __LOC__
         | _ ->
             return_unit)
  >>=? fun () ->
  (* beginning of proposal, denoted by _p1;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p1, rolls_p1) ->
  (* no proposals at the beginning of proposal period *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  ( if Environment.Protocol_hash.Map.is_empty ps then return_unit
  else failwith "%s - Unexpected proposals" __LOC__ )
  >>=? fun () ->
  (* no current proposal during proposal period *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | None ->
             return_unit
         | Some _ ->
             failwith "%s - Unexpected proposal" __LOC__)
  >>=? fun () ->
  let del1 = List.nth delegates_p1 0 in
  let del2 = List.nth delegates_p1 1 in
  let props =
    List.map (fun i -> protos.(i)) (2 -- Constants.max_proposals_per_delegate)
  in
  Op.proposals (B b) del1 (Protocol_hash.zero :: props)
  >>=? fun ops1 ->
  Op.proposals (B b) del2 [Protocol_hash.zero]
  >>=? fun ops2 ->
  Block.bake ~operations:[ops1; ops2] b
  >>=? fun b ->
  (* proposals are now populated *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  (* correctly count the double proposal for zero *)
  (let weight = Int32.add (List.nth rolls_p1 0) (List.nth rolls_p1 1) in
   match Environment.Protocol_hash.(Map.find_opt zero ps) with
   | Some v ->
       if v = weight then return_unit
       else failwith "%s - Wrong count %ld is not %ld" __LOC__ v weight
   | None ->
       failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* proposing more than maximum_proposals fails *)
  Op.proposals (B b) del1 (Protocol_hash.zero :: props)
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Amendment.Too_many_proposals ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* proposing less than one proposal fails *)
  Op.proposals (B b) del1 []
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Amendment.Empty_proposal ->
          true
      | _ ->
          false)
  >>=? fun () ->
  (* skip to testing_vote period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* period 1 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(succ root)
  >>=? fun () ->
  (* listings must be populated in testing_vote period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty listings" __LOC__
         | _ ->
             return_unit)
  >>=? fun () ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, rolls_p2) ->
  (* no proposals during testing_vote period *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  ( if Environment.Protocol_hash.Map.is_empty ps then return_unit
  else failwith "%s - Unexpected proposals" __LOC__ )
  >>=? fun () ->
  (* current proposal must be set during testing_vote period *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | Some v ->
             if Protocol_hash.(equal zero v) then return_unit
             else failwith "%s - Wrong proposal" __LOC__
         | None ->
             failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* unanimous vote: all delegates --active when p2 started-- vote *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    delegates_p2
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  Op.ballot (B b) del1 Protocol_hash.zero Vote.Nay
  >>=? fun op ->
  Block.bake ~operations:[op] b
  >>= fun res ->
  Assert.proto_error ~loc:__LOC__ res (function
      | Amendment.Unauthorized_ballot ->
          true
      | _ ->
          false)
  >>=? fun () ->
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p2
  >>=? fun rolls_sum ->
  (* # of Yays in ballots matches rolls of the delegate *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    Vote.{yay = rolls_sum; nay = 0l; pass = 0l}
  >>=? fun () ->
  (* One Yay ballot per delegate *)
  Context.Vote.get_ballot_list (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty ballot list" __LOC__
         | l ->
             iter_s
               (fun delegate ->
                 Context.Contract.pkh delegate
                 >>=? fun pkh ->
                 match List.find_opt (fun (del, _) -> del = pkh) l with
                 | None ->
                     failwith "%s - Missing delegate" __LOC__
                 | Some (_, Vote.Yay) ->
                     return_unit
                 | Some _ ->
                     failwith "%s - Wrong ballot" __LOC__)
               delegates_p2)
  >>=? fun () ->
  (* skip to testing period
     -1 because we already baked one block with the ballot *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* period 2 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(succ (succ root))
  >>=? fun () ->
  (* no ballots in testing period *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    ballots_zero
  >>=? fun () ->
  (* listings must be empty in testing period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] -> return_unit | _ -> failwith "%s - Unexpected listings" __LOC__)
  >>=? fun () ->
  (* skip to promotion_vote period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Promotion_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* period 3 *)
  Context.Vote.get_voting_period (B b)
  >>=? fun v ->
  let open Alpha_context in
  Assert.equal
    ~loc:__LOC__
    Voting_period.equal
    "Unexpected period"
    Voting_period.pp
    v
    Voting_period.(succ (succ (succ root)))
  >>=? fun () ->
  (* listings must be populated in promotion_vote period *)
  Context.Vote.get_listings (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty listings" __LOC__
         | _ ->
             return_unit)
  >>=? fun () ->
  (* beginning of promotion_vote period, denoted by _p4;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p4, rolls_p4) ->
  (* no proposals during promotion_vote period *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  ( if Environment.Protocol_hash.Map.is_empty ps then return_unit
  else failwith "%s - Unexpected proposals" __LOC__ )
  >>=? fun () ->
  (* current proposal must be set during promotion_vote period *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | Some v ->
             if Protocol_hash.(equal zero v) then return_unit
             else failwith "%s - Wrong proposal" __LOC__
         | None ->
             failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* unanimous vote: all delegates --active when p4 started-- vote *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    delegates_p4
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls_p4
  >>=? fun rolls_sum ->
  (* # of Yays in ballots matches rolls of the delegate *)
  Context.Vote.get_ballots (B b)
  >>=? fun v ->
  Assert.equal
    ~loc:__LOC__
    ballots_equal
    "Unexpected ballots"
    ballots_pp
    v
    Vote.{yay = rolls_sum; nay = 0l; pass = 0l}
  >>=? fun () ->
  (* One Yay ballot per delegate *)
  Context.Vote.get_ballot_list (B b)
  >>=? (function
         | [] ->
             failwith "%s - Unexpected empty ballot list" __LOC__
         | l ->
             iter_s
               (fun delegate ->
                 Context.Contract.pkh delegate
                 >>=? fun pkh ->
                 match List.find_opt (fun (del, _) -> del = pkh) l with
                 | None ->
                     failwith "%s - Missing delegate" __LOC__
                 | Some (_, Vote.Yay) ->
                     return_unit
                 | Some _ ->
                     failwith "%s - Wrong ballot" __LOC__)
               delegates_p4)
  >>=? fun () ->
  (* skip to end of promotion_vote period and activation*)
  Block.bake_n Int32.(to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* zero is the new protocol (before the vote this value is unset) *)
  Context.Vote.get_protocol b
  >>= fun p ->
  Assert.equal
    ~loc:__LOC__
    Protocol_hash.equal
    "Unexpected proposal"
    Protocol_hash.pp
    p
    Protocol_hash.zero
  >>=? fun () -> return_unit

(* given a list of active delegates,
   return the first k active delegates with which one can have quorum, that is:
   their roll sum divided by the total roll sum is bigger than pr_ema_weight/den *)
let get_smallest_prefix_voters_for_quorum active_delegates active_rolls =
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l active_rolls
  >>=? fun active_rolls_sum ->
  let rec loop delegates rolls sum selected =
    match (delegates, rolls) with
    | ([], []) ->
        selected
    | (del :: delegates, del_rolls :: rolls) ->
        if
          den * sum
          < Float.to_int (expected_qr_num *. Int32.to_float active_rolls_sum)
        then
          loop delegates rolls (sum + Int32.to_int del_rolls) (del :: selected)
        else selected
    | (_, _) ->
        []
  in
  return (loop active_delegates active_rolls 0 [])

let get_expected_participation_ema rolls voter_rolls old_participation_ema =
  (* formula to compute the updated participation_ema *)
  let get_updated_participation_ema old_participation_ema participation =
    ( (pr_ema_weight * Int32.to_int old_participation_ema)
    + (pr_num * participation) )
    / den
  in
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l rolls
  >>=? fun rolls_sum ->
  fold_left_s (fun v acc -> return Int32.(add v acc)) 0l voter_rolls
  >>=? fun voter_rolls_sum ->
  let participation =
    Int32.to_int voter_rolls_sum * percent_mul / Int32.to_int rolls_sum
  in
  return (get_updated_participation_ema old_participation_ema participation)

(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in testing vote,
   go back to proposal period *)
let test_not_enough_quorum_in_testing_vote num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  (* proposal period *)
  let open Alpha_context in
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [Protocol_hash.zero]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  Context.Vote.get_participation_ema b
  >>=? fun initial_participation_ema ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, rolls_p2) ->
  get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2
  >>=? fun voters ->
  (* take the first two voters out so there cannot be quorum *)
  let voters_without_quorum = List.tl voters in
  get_rolls b voters_without_quorum __LOC__
  >>=? fun voters_rolls_in_testing_vote ->
  (* all voters_without_quorum vote, for yays;
     no nays, so supermajority is satisfied *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    voters_without_quorum
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to testing period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we move back to the proposal period because not enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* check participation_ema update *)
  get_expected_participation_ema
    rolls_p2
    voters_rolls_in_testing_vote
    initial_participation_ema
  >>=? fun expected_participation_ema ->
  Context.Vote.get_participation_ema b
  >>=? fun new_participation_ema ->
  (* assert the formula to calculate participation_ema is correct *)
  Assert.equal_int
    ~loc:__LOC__
    expected_participation_ema
    (Int32.to_int new_participation_ema)
  >>=? fun () -> return_unit

(* if not enough quorum -- get_updated_participation_ema < pr_ema_weight/den -- in promotion vote,
   go back to proposal period *)
let test_not_enough_quorum_in_promotion_vote num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [Protocol_hash.zero]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, rolls_p2) ->
  get_smallest_prefix_voters_for_quorum delegates_p2 rolls_p2
  >>=? fun voters ->
  let open Alpha_context in
  (* all voters vote, for yays;
       no nays, so supermajority is satisfied *)
  map_s (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay) voters
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to testing period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we move to testing because we have supermajority and enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* skip to promotion_vote period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Promotion_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  Context.Vote.get_participation_ema b
  >>=? fun initial_participation_ema ->
  (* beginning of promotion period, denoted by _p4;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p4, rolls_p4) ->
  get_smallest_prefix_voters_for_quorum delegates_p4 rolls_p4
  >>=? fun voters ->
  (* take the first voter out so there cannot be quorum *)
  let voters_without_quorum = List.tl voters in
  get_rolls b voters_without_quorum __LOC__
  >>=? fun voter_rolls ->
  (* all voters_without_quorum vote, for yays;
     no nays, so supermajority is satisfied *)
  map_s
    (fun del -> Op.ballot (B b) del Protocol_hash.zero Vote.Yay)
    voters_without_quorum
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to end of promotion_vote period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  get_expected_participation_ema rolls_p4 voter_rolls initial_participation_ema
  >>=? fun expected_participation_ema ->
  Context.Vote.get_participation_ema b
  >>=? fun new_participation_ema ->
  (* assert the formula to calculate participation_ema is correct *)
  Assert.equal_int
    ~loc:__LOC__
    expected_participation_ema
    (Int32.to_int new_participation_ema)
  >>=? fun () ->
  (* we move back to the proposal period because not enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

let test_multiple_identical_proposals_count_as_one () =
  Context.init 1
  >>=? fun (b, delegates) ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  let proposer = List.hd delegates in
  Op.proposals (B b) proposer [Protocol_hash.zero; Protocol_hash.zero]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* compute the weight of proposals *)
  Context.Vote.get_proposals (B b)
  >>=? fun ps ->
  (* compute the rolls of proposer *)
  Context.Contract.pkh proposer
  >>=? fun pkh ->
  Context.Vote.get_listings (B b)
  >>=? fun l ->
  ( match List.find_opt (fun (del, _) -> del = pkh) l with
  | None ->
      failwith "%s - Missing delegate" __LOC__
  | Some (_, proposer_rolls) ->
      return proposer_rolls )
  >>=? fun proposer_rolls ->
  (* correctly count the double proposal for zero as one proposal *)
  let expected_weight_proposer = proposer_rolls in
  match Environment.Protocol_hash.(Map.find_opt zero ps) with
  | Some v ->
      if v = expected_weight_proposer then return_unit
      else
        failwith
          "%s - Wrong count %ld is not %ld; identical proposals count as one"
          __LOC__
          v
          expected_weight_proposer
  | None ->
      failwith "%s - Missing proposal" __LOC__

(* assumes the initial balance of allocated by Context.init is at
   least 4 time the value of the tokens_per_roll constant *)
let test_supermajority_in_proposal there_is_a_winner () =
  let min_proposal_quorum = 0l in
  Context.init ~min_proposal_quorum ~initial_balances:[1L; 1L; 1L] 10
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun { parametric =
               {blocks_per_cycle; blocks_per_voting_period; tokens_per_roll; _};
             _ } ->
  let del1 = List.nth delegates 0 in
  let del2 = List.nth delegates 1 in
  let del3 = List.nth delegates 2 in
  map_s (fun del -> Context.Contract.pkh del) [del1; del2; del3]
  >>=? fun pkhs ->
  let policy = Block.Excluding pkhs in
  Op.transaction (B b) (List.nth delegates 3) del1 tokens_per_roll
  >>=? fun op1 ->
  Op.transaction (B b) (List.nth delegates 4) del2 tokens_per_roll
  >>=? fun op2 ->
  ( if there_is_a_winner then Test_tez.Tez.( *? ) tokens_per_roll 3L
  else Test_tez.Tez.( *? ) tokens_per_roll 2L )
  >>?= fun bal3 ->
  Op.transaction (B b) (List.nth delegates 5) del3 bal3
  >>=? fun op3 ->
  Block.bake ~policy ~operations:[op1; op2; op3] b
  >>=? fun b ->
  (* we let one voting period pass; we make sure that:
     - the three selected delegates remain active by re-registering as delegates
     - their number of rolls do not change *)
  fold_left_s
    (fun b _ ->
      Error_monad.map_s
        (fun del ->
          Context.Contract.pkh del
          >>=? fun pkh -> Op.delegation (B b) del (Some pkh))
        delegates
      >>=? fun ops ->
      Block.bake ~policy ~operations:ops b
      >>=? fun b -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))
  >>=? fun b ->
  (* make the proposals *)
  Op.proposals (B b) del1 [protos.(0)]
  >>=? fun ops1 ->
  Op.proposals (B b) del2 [protos.(0)]
  >>=? fun ops2 ->
  Op.proposals (B b) del3 [protos.(1)]
  >>=? fun ops3 ->
  Block.bake ~policy ~operations:[ops1; ops2; ops3] b
  >>=? fun b ->
  Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we remain in the proposal period when there is no winner,
     otherwise we move to the testing vote period *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             if there_is_a_winner then return_unit
             else
               failwith
                 "%s - Expected period kind Proposal, obtained Testing_vote"
                 __LOC__
         | Proposal ->
             if not there_is_a_winner then return_unit
             else
               failwith
                 "%s - Expected period kind Testing_vote, obtained Proposal"
                 __LOC__
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

let test_quorum_in_proposal has_quorum () =
  let total_tokens = 32_000_000_000_000L in
  let half_tokens = Int64.div total_tokens 2L in
  Context.init ~initial_balances:[1L; half_tokens; half_tokens] 3
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun { parametric =
               { blocks_per_cycle;
                 blocks_per_voting_period;
                 min_proposal_quorum;
                 _ };
             _ } ->
  let del1 = List.nth delegates 0 in
  let del2 = List.nth delegates 1 in
  map_s (fun del -> Context.Contract.pkh del) [del1; del2]
  >>=? fun pkhs ->
  let policy = Block.Excluding pkhs in
  let quorum =
    if has_quorum then Int64.of_int32 min_proposal_quorum
    else Int64.(sub (of_int32 min_proposal_quorum) 10L)
  in
  let bal =
    Int64.(div (mul total_tokens quorum) 100_00L) |> Test_tez.Tez.of_mutez_exn
  in
  Op.transaction (B b) del2 del1 bal
  >>=? fun op2 ->
  Block.bake ~policy ~operations:[op2] b
  >>=? fun b ->
  (* we let one voting period pass; we make sure that:
     - the two selected delegates remain active by re-registering as delegates
     - their number of rolls do not change *)
  fold_left_s
    (fun b _ ->
      Error_monad.map_s
        (fun del ->
          Context.Contract.pkh del
          >>=? fun pkh -> Op.delegation (B b) del (Some pkh))
        [del1; del2]
      >>=? fun ops ->
      Block.bake ~policy ~operations:ops b
      >>=? fun b -> Block.bake_until_cycle_end ~policy b)
    b
    (1 -- Int32.to_int (Int32.div blocks_per_voting_period blocks_per_cycle))
  >>=? fun b ->
  (* make the proposal *)
  Op.proposals (B b) del1 [protos.(0)]
  >>=? fun ops ->
  Block.bake ~policy ~operations:[ops] b
  >>=? fun b ->
  Block.bake_n ~policy (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we remain in the proposal period when there is no quorum,
     otherwise we move to the testing vote period *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             if has_quorum then return_unit
             else
               failwith
                 "%s - Expected period kind Proposal, obtained Testing_vote"
                 __LOC__
         | Proposal ->
             if not has_quorum then return_unit
             else
               failwith
                 "%s - Expected period kind Testing_vote, obtained Proposal"
                 __LOC__
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

let test_supermajority_in_testing_vote supermajority () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / 100)) in
  Context.init ~min_proposal_quorum 100
  >>=? fun (b, delegates) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  let del1 = List.nth delegates 0 in
  let proposal = protos.(0) in
  Op.proposals (B b) del1 [proposal]
  >>=? fun ops1 ->
  Block.bake ~operations:[ops1] b
  >>=? fun b ->
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* move to testing_vote *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* assert our proposal won *)
  Context.Vote.get_current_proposal (B b)
  >>=? (function
         | Some v ->
             if Protocol_hash.(equal proposal v) then return_unit
             else failwith "%s - Wrong proposal" __LOC__
         | None ->
             failwith "%s - Missing proposal" __LOC__)
  >>=? fun () ->
  (* beginning of testing_vote period, denoted by _p2;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p2, _olls_p2) ->
  (* supermajority means [num_yays / (num_yays + num_nays) >= s_num / s_den],
     which is equivalent with [num_yays >= num_nays * s_num / (s_den - s_num)] *)
  let num_delegates = List.length delegates_p2 in
  let num_nays = num_delegates / 5 in
  (* any smaller number will do as well *)
  let num_yays = num_nays * s_num / (s_den - s_num) in
  (* majority/minority vote depending on the [supermajority] parameter *)
  let num_yays = if supermajority then num_yays else num_yays - 1 in
  let open Alpha_context in
  let (nays_delegates, rest) = List.split_n num_nays delegates_p2 in
  let (yays_delegates, _) = List.split_n num_yays rest in
  map_s (fun del -> Op.ballot (B b) del proposal Vote.Yay) yays_delegates
  >>=? fun operations_yays ->
  map_s (fun del -> Op.ballot (B b) del proposal Vote.Nay) nays_delegates
  >>=? fun operations_nays ->
  let operations = operations_yays @ operations_nays in
  Block.bake ~operations b
  >>=? fun b ->
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing ->
             if supermajority then return_unit
             else
               failwith
                 "%s - Expected period kind Proposal, obtained Testing"
                 __LOC__
         | Proposal ->
             if not supermajority then return_unit
             else
               failwith
                 "%s - Expected period kind Testing_vote, obtained Proposal"
                 __LOC__
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

(* test also how the selection scales: all delegates propose max proposals *)
let test_no_winning_proposal num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, _) ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; _}; _} ->
  (* beginning of proposal, denoted by _p1;
     take a snapshot of the active delegates and their rolls from listings *)
  get_delegates_and_rolls_from_listings b
  >>=? fun (delegates_p1, _rolls_p1) ->
  let open Alpha_context in
  let props =
    List.map (fun i -> protos.(i)) (1 -- Constants.max_proposals_per_delegate)
  in
  (* all delegates active in p1 propose the same proposals *)
  map_s (fun del -> Op.proposals (B b) del props) delegates_p1
  >>=? fun ops_list ->
  Block.bake ~operations:ops_list b
  >>=? fun b ->
  (* skip to testing_vote period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 2) b
  >>=? fun b ->
  (* we stay in the same proposal period because no winning proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () -> return_unit

(** Test that for the vote to pass with maximum possible participation_ema
    (100%), it is sufficient for the vote quorum to be equal or greater than
    the maximum quorum cap. *)
let test_quorum_capped_maximum num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  (* set the participation EMA to 100% *)
  Context.Vote.set_participation_ema b 100_00l
  >>= fun b ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; quorum_max; _}; _} ->
  (* proposal period *)
  let open Alpha_context in
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* propose a new protocol *)
  let protocol = Protocol_hash.zero in
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [protocol]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* take percentage of the delegates equal or greater than quorum_max *)
  let minimum_to_pass =
    Float.of_int (List.length delegates)
    *. Int32.(to_float quorum_max)
    /. 100_00.
    |> Float.ceil |> Float.to_int
  in
  let voters = List.take_n minimum_to_pass delegates in
  (* all voters vote for yays; no nays, so supermajority is satisfied *)
  map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to next period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* expect to move to testing because we have supermajority and enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? function
  | Testing ->
      return_unit
  | _ ->
      failwith "%s - Unexpected period kind" __LOC__

(** Test that for the vote to pass with minimum possible participation_ema
    (0%), it is sufficient for the vote quorum to be equal or greater than
    the minimum quorum cap. *)
let test_quorum_capped_minimum num_delegates () =
  let min_proposal_quorum = Int32.(of_int @@ (100_00 / num_delegates)) in
  Context.init ~min_proposal_quorum num_delegates
  >>=? fun (b, delegates) ->
  (* set the participation EMA to 0% *)
  Context.Vote.set_participation_ema b 0l
  >>= fun b ->
  Context.get_constants (B b)
  >>=? fun {parametric = {blocks_per_voting_period; quorum_min; _}; _} ->
  (* proposal period *)
  let open Alpha_context in
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Proposal ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* propose a new protocol *)
  let protocol = Protocol_hash.zero in
  let proposer = List.nth delegates 0 in
  Op.proposals (B b) proposer [protocol]
  >>=? fun ops ->
  Block.bake ~operations:[ops] b
  >>=? fun b ->
  (* skip to vote_testing period
     -1 because we already baked one block with the proposal *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* we moved to a testing_vote period with one proposal *)
  Context.Vote.get_current_period_kind (B b)
  >>=? (function
         | Testing_vote ->
             return_unit
         | _ ->
             failwith "%s - Unexpected period kind" __LOC__)
  >>=? fun () ->
  (* take percentage of the delegates equal or greater than quorum_min *)
  let minimum_to_pass =
    Float.of_int (List.length delegates)
    *. Int32.(to_float quorum_min)
    /. 100_00.
    |> Float.ceil |> Float.to_int
  in
  let voters = List.take_n minimum_to_pass delegates in
  (* all voters vote for yays; no nays, so supermajority is satisfied *)
  map_s (fun del -> Op.ballot (B b) del protocol Vote.Yay) voters
  >>=? fun operations ->
  Block.bake ~operations b
  >>=? fun b ->
  (* skip to next period *)
  Block.bake_n (Int32.to_int blocks_per_voting_period - 1) b
  >>=? fun b ->
  (* expect to move to testing because we have supermajority and enough quorum *)
  Context.Vote.get_current_period_kind (B b)
  >>=? function
  | Testing ->
      return_unit
  | _ ->
      failwith "%s - Unexpected period kind" __LOC__

let tests =
  [ Test.tztest "voting successful_vote" `Quick (test_successful_vote 137);
    Test.tztest
      "voting testing vote, not enough quorum"
      `Quick
      (test_not_enough_quorum_in_testing_vote 245);
    Test.tztest
      "voting promotion vote, not enough quorum"
      `Quick
      (test_not_enough_quorum_in_promotion_vote 432);
    Test.tztest
      "voting counting double proposal"
      `Quick
      test_multiple_identical_proposals_count_as_one;
    Test.tztest
      "voting proposal, with supermajority"
      `Quick
      (test_supermajority_in_proposal true);
    Test.tztest
      "voting proposal, without supermajority"
      `Quick
      (test_supermajority_in_proposal false);
    Test.tztest
      "voting proposal, with quorum"
      `Quick
      (test_quorum_in_proposal true);
    Test.tztest
      "voting proposal, without quorum"
      `Quick
      (test_quorum_in_proposal false);
    Test.tztest
      "voting testing vote, with supermajority"
      `Quick
      (test_supermajority_in_testing_vote true);
    Test.tztest
      "voting testing vote, without supermajority"
      `Quick
      (test_supermajority_in_testing_vote false);
    Test.tztest
      "voting proposal, no winning proposal"
      `Quick
      (test_no_winning_proposal 400);
    Test.tztest
      "voting quorum, quorum capped maximum"
      `Quick
      (test_quorum_capped_maximum 400);
    Test.tztest
      "voting quorum, quorum capped minimum"
      `Quick
      (test_quorum_capped_minimum 401) ]
src/proto_alpha/lib_protocol/test/voting.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Definition ballots_zero
  : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots :=
  {|
    yay :=
      (* ❌ Constant of type int32 is converted to int *)
      0;
    nay :=
      (* ❌ Constant of type int32 is converted to int *)
      0;
    pass :=
      (* ❌ Constant of type int32 is converted to int *)
      0 |}.

Definition ballots_equal
  (b1 : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots)
  (b2 : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots) : bool :=
  op_andand (op_startypeminuserrorstar (yay b1) (yay b2))
    (op_andand (op_startypeminuserrorstar (nay b1) (nay b2))
      (op_startypeminuserrorstar (pass b1) (pass b2))).

Definition ballots_pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (v : Tezos_protocol_alpha.Protocol.Alpha_context.Vote.ballots) : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
        "{ yay = " % string
        (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
          Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
          (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
            " ; nay = " % string
            (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
              Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
              (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.String_literal
                " ; pass = " % string
                (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
                  Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format))))))
      "{ yay = %ld ; nay = %ld ; pass = %ld" % string) (yay v) (nay v) (pass v).

Definition percent_mul : Z := 10000.

Definition initial_participation_num : Z := 7.

Definition initial_participation : Z :=
  op_div (op_star initial_participation_num percent_mul) 10.

Definition pr_ema_weight : Z := 8.

Definition den : Z := 10.

Definition pr_num : Z := op_minus den pr_ema_weight.

Definition s_num : Z := 8.

Definition s_den : Z := 10.

Definition qr_min_num : Z := 2.

Definition qr_max_num : Z := 7.

Definition expected_qr_num {A : Type} : A := op_startypeminuserrorstar.

Definition protos {A : Type} : A :=
  op_startypeminuserrorstar
    (fun s =>
      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.of_b58check_exn)
        s)
    (* ❌ Arrays not handled. *)
    [
      "ProtoALphaALphaALphaALphaALphaALphaALpha61322gcLUGH" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphabc2a7ebx6WB" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha84efbeiF6cm" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha91249Z65tWS" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha537f5h25LnN" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha5c8fefgDYkr" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha3f31feSSarC" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphabe31ahnkxSC" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphabab3bgRb7zQ" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphaf8d39cctbpk" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha3b981byuYxD" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphaa116bccYowi" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphacce68eHqboj" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha225c7YrWwR7" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha58743cJL6FG" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphac91bcdvmJFR" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha1faaadhV7oW" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha98232gD94QJ" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha9d1d8cijvAh" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALphaeec52dKF6Gx" % string;
      "ProtoALphaALphaALphaALphaALphaALphaALpha841f2cQqajX" % string
    ].

Definition mk_contracts_from_pkh
  (pkh_list : list Tezos_raw_protocol_alpha__Alpha_context.public_key_hash)
  : list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract :=
  List.map Alpha_context.Contract.implicit_contract pkh_list.

Definition get_delegates_and_rolls_from_listings {A B : Type} (b : A)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      ((list Tezos_protocol_alpha.Protocol.Alpha_context.Contract.contract) *
        (list B))) :=
  op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
    (fun l =>
      _return ((mk_contracts_from_pkh (List.map fst l)), (List.map snd l))).

Definition get_rolls {A B C D : Type} (b : A) (delegates : list B) (loc : C)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list D)) :=
  op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
    (fun l =>
      map_s
        (fun delegate =>
          op_gtgteqquestion (op_startypeminuserrorstar delegate)
            (fun pkh =>
              match
                List.find_opt
                  (fun function_parameter =>
                    let '(del, _) := function_parameter in
                    op_startypeminuserrorstar del pkh) l with
              | None => failwith "%s - Missing delegate" % string loc
              | Some (_, rolls) => _return rolls
              end)) delegates).

Definition test_successful_vote (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum num_delegates)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun v =>
              op_gtgteqquestion
                (op_startypeminuserrorstar __LOC__ ballots_equal
                  "Unexpected ballots" % string ballots_pp v ballots_zero)
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  op_gtgteqquestion
                    (op_gtgteqquestion
                      (op_startypeminuserrorstar op_startypeminuserrorstar)
                      (fun function_parameter =>
                        match function_parameter with
                        | [] => return_unit
                        | _ =>
                          failwith "%s - Unexpected ballot list" % string
                            __LOC__
                        end))
                    (fun function_parameter =>
                      let 'tt := function_parameter in
                      op_gtgteqquestion
                        (op_startypeminuserrorstar op_startypeminuserrorstar)
                        (fun v =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar __LOC__
                              Voting_period.equal "Unexpected period" % string
                              Voting_period.pp v root)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ => return_unit
                                    | _ =>
                                      failwith
                                        "%s - Unexpected period kind" % string
                                        __LOC__
                                    end))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar b)
                                    (fun v =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar __LOC__
                                          initial_participation (Int32.to_int v))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          op_gtgteqquestion
                                            (op_gtgteqquestion
                                              (op_startypeminuserrorstar
                                                op_startypeminuserrorstar)
                                              (fun function_parameter =>
                                                match function_parameter with
                                                | [] =>
                                                  failwith
                                                    "%s - Unexpected empty listings"
                                                      % string __LOC__
                                                | _ => return_unit
                                                end))
                                            (fun function_parameter =>
                                              let 'tt := function_parameter in
                                              op_gtgteqquestion
                                                (get_delegates_and_rolls_from_listings
                                                  b)
                                                (fun function_parameter =>
                                                  let
                                                    '(delegates_p1, rolls_p1) :=
                                                    function_parameter in
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      op_startypeminuserrorstar)
                                                    (fun ps =>
                                                      op_gtgteqquestion
                                                        (if
                                                          Environment.Protocol_hash.Map.is_empty
                                                            ps then
                                                          return_unit
                                                        else
                                                          failwith
                                                            "%s - Unexpected proposals"
                                                              % string __LOC__)
                                                        (fun function_parameter
                                                          =>
                                                          let 'tt :=
                                                            function_parameter
                                                            in
                                                          op_gtgteqquestion
                                                            (op_gtgteqquestion
                                                              (op_startypeminuserrorstar
                                                                op_startypeminuserrorstar)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | None =>
                                                                  return_unit
                                                                | Some _ =>
                                                                  failwith
                                                                    "%s - Unexpected proposal"
                                                                      % string
                                                                    __LOC__
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              let del1 :=
                                                                op_startypeminuserrorstar
                                                                  delegates_p1 0
                                                                in
                                                              let del2 :=
                                                                op_startypeminuserrorstar
                                                                  delegates_p1 1
                                                                in
                                                              let props :=
                                                                List.map
                                                                  (fun i =>
                                                                    op_startypeminuserrorstar
                                                                      protos i)
                                                                  (op_startypeminuserrorstar
                                                                    2
                                                                    Constants.max_proposals_per_delegate)
                                                                in
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  op_startypeminuserrorstar
                                                                  del1
                                                                  (cons
                                                                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                    props))
                                                                (fun ops1 =>
                                                                  op_gtgteqquestion
                                                                    (op_startypeminuserrorstar
                                                                      op_startypeminuserrorstar
                                                                      del2
                                                                      (cons
                                                                        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                        []))
                                                                    (fun ops2 =>
                                                                      op_gtgteqquestion
                                                                        (op_startypeminuserrorstar
                                                                          (cons
                                                                            ops1
                                                                            (cons
                                                                              ops2
                                                                              []))
                                                                          b)
                                                                        (fun b
                                                                          =>
                                                                          op_gtgteqquestion
                                                                            (op_startypeminuserrorstar
                                                                              op_startypeminuserrorstar)
                                                                            (fun
                                                                              ps
                                                                              =>
                                                                              op_gtgteqquestion
                                                                                (let
                                                                                  weight :=
                                                                                  Int32.add
                                                                                    (op_startypeminuserrorstar
                                                                                      rolls_p1
                                                                                      0)
                                                                                    (op_startypeminuserrorstar
                                                                                      rolls_p1
                                                                                      1)
                                                                                  in
                                                                                match
                                                                                  Map.find_opt
                                                                                    zero
                                                                                    ps
                                                                                  with
                                                                                |
                                                                                  Some
                                                                                    v
                                                                                  =>
                                                                                  if
                                                                                    op_startypeminuserrorstar
                                                                                      v
                                                                                      weight
                                                                                    then
                                                                                    return_unit
                                                                                  else
                                                                                    failwith
                                                                                      "%s - Wrong count %ld is not %ld"
                                                                                        %
                                                                                        string
                                                                                      __LOC__
                                                                                      v
                                                                                      weight
                                                                                |
                                                                                  None
                                                                                  =>
                                                                                  failwith
                                                                                    "%s - Missing proposal"
                                                                                      %
                                                                                      string
                                                                                    __LOC__
                                                                                end)
                                                                                (fun
                                                                                  function_parameter
                                                                                  =>
                                                                                  let
                                                                                    'tt :=
                                                                                    function_parameter
                                                                                    in
                                                                                  op_gtgteqquestion
                                                                                    (op_startypeminuserrorstar
                                                                                      op_startypeminuserrorstar
                                                                                      del1
                                                                                      (cons
                                                                                        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                        props))
                                                                                    (fun
                                                                                      ops
                                                                                      =>
                                                                                      op_gtgteq
                                                                                        (op_startypeminuserrorstar
                                                                                          (cons
                                                                                            ops
                                                                                            [])
                                                                                          b)
                                                                                        (fun
                                                                                          res
                                                                                          =>
                                                                                          op_gtgteqquestion
                                                                                            (op_startypeminuserrorstar
                                                                                              __LOC__
                                                                                              res
                                                                                              (fun
                                                                                                function_parameter
                                                                                                =>
                                                                                                match
                                                                                                  function_parameter
                                                                                                  with
                                                                                                |
                                                                                                  Tezos_protocol_environment_alpha__Environment.Error_monad.Too_many_proposals
                                                                                                  =>
                                                                                                  true
                                                                                                |
                                                                                                  _
                                                                                                  =>
                                                                                                  false
                                                                                                end))
                                                                                            (fun
                                                                                              function_parameter
                                                                                              =>
                                                                                              let
                                                                                                'tt :=
                                                                                                function_parameter
                                                                                                in
                                                                                              op_gtgteqquestion
                                                                                                (op_startypeminuserrorstar
                                                                                                  op_startypeminuserrorstar
                                                                                                  del1
                                                                                                  [])
                                                                                                (fun
                                                                                                  ops
                                                                                                  =>
                                                                                                  op_gtgteq
                                                                                                    (op_startypeminuserrorstar
                                                                                                      (cons
                                                                                                        ops
                                                                                                        [])
                                                                                                      b)
                                                                                                    (fun
                                                                                                      res
                                                                                                      =>
                                                                                                      op_gtgteqquestion
                                                                                                        (op_startypeminuserrorstar
                                                                                                          __LOC__
                                                                                                          res
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              Tezos_protocol_environment_alpha__Environment.Error_monad.Empty_proposal
                                                                                                              =>
                                                                                                              true
                                                                                                            |
                                                                                                              _
                                                                                                              =>
                                                                                                              false
                                                                                                            end))
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          op_gtgteqquestion
                                                                                                            (op_startypeminuserrorstar
                                                                                                              (op_minus
                                                                                                                (Int32.to_int
                                                                                                                  op_startypeminuserrorstar)
                                                                                                                2)
                                                                                                              b)
                                                                                                            (fun
                                                                                                              b
                                                                                                              =>
                                                                                                              op_gtgteqquestion
                                                                                                                (op_gtgteqquestion
                                                                                                                  (op_startypeminuserrorstar
                                                                                                                    op_startypeminuserrorstar)
                                                                                                                  (fun
                                                                                                                    function_parameter
                                                                                                                    =>
                                                                                                                    match
                                                                                                                      function_parameter
                                                                                                                      with
                                                                                                                    |
                                                                                                                      _
                                                                                                                      =>
                                                                                                                      return_unit
                                                                                                                    |
                                                                                                                      _
                                                                                                                      =>
                                                                                                                      failwith
                                                                                                                        "%s - Unexpected period kind"
                                                                                                                          %
                                                                                                                          string
                                                                                                                        __LOC__
                                                                                                                    end))
                                                                                                                (fun
                                                                                                                  function_parameter
                                                                                                                  =>
                                                                                                                  let
                                                                                                                    'tt :=
                                                                                                                    function_parameter
                                                                                                                    in
                                                                                                                  op_gtgteqquestion
                                                                                                                    (op_startypeminuserrorstar
                                                                                                                      op_startypeminuserrorstar)
                                                                                                                    (fun
                                                                                                                      v
                                                                                                                      =>
                                                                                                                      op_gtgteqquestion
                                                                                                                        (op_startypeminuserrorstar
                                                                                                                          __LOC__
                                                                                                                          Voting_period.equal
                                                                                                                          "Unexpected period"
                                                                                                                            %
                                                                                                                            string
                                                                                                                          Voting_period.pp
                                                                                                                          v
                                                                                                                          (succ
                                                                                                                            root))
                                                                                                                        (fun
                                                                                                                          function_parameter
                                                                                                                          =>
                                                                                                                          let
                                                                                                                            'tt :=
                                                                                                                            function_parameter
                                                                                                                            in
                                                                                                                          op_gtgteqquestion
                                                                                                                            (op_gtgteqquestion
                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                op_startypeminuserrorstar)
                                                                                                                              (fun
                                                                                                                                function_parameter
                                                                                                                                =>
                                                                                                                                match
                                                                                                                                  function_parameter
                                                                                                                                  with
                                                                                                                                |
                                                                                                                                  []
                                                                                                                                  =>
                                                                                                                                  failwith
                                                                                                                                    "%s - Unexpected empty listings"
                                                                                                                                      %
                                                                                                                                      string
                                                                                                                                    __LOC__
                                                                                                                                |
                                                                                                                                  _
                                                                                                                                  =>
                                                                                                                                  return_unit
                                                                                                                                end))
                                                                                                                            (fun
                                                                                                                              function_parameter
                                                                                                                              =>
                                                                                                                              let
                                                                                                                                'tt :=
                                                                                                                                function_parameter
                                                                                                                                in
                                                                                                                              op_gtgteqquestion
                                                                                                                                (get_delegates_and_rolls_from_listings
                                                                                                                                  b)
                                                                                                                                (fun
                                                                                                                                  function_parameter
                                                                                                                                  =>
                                                                                                                                  let
                                                                                                                                    '(delegates_p2,
                                                                                                                                      rolls_p2) :=
                                                                                                                                    function_parameter
                                                                                                                                    in
                                                                                                                                  op_gtgteqquestion
                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                      op_startypeminuserrorstar)
                                                                                                                                    (fun
                                                                                                                                      ps
                                                                                                                                      =>
                                                                                                                                      op_gtgteqquestion
                                                                                                                                        (if
                                                                                                                                          Environment.Protocol_hash.Map.is_empty
                                                                                                                                            ps
                                                                                                                                          then
                                                                                                                                          return_unit
                                                                                                                                        else
                                                                                                                                          failwith
                                                                                                                                            "%s - Unexpected proposals"
                                                                                                                                              %
                                                                                                                                              string
                                                                                                                                            __LOC__)
                                                                                                                                        (fun
                                                                                                                                          function_parameter
                                                                                                                                          =>
                                                                                                                                          let
                                                                                                                                            'tt :=
                                                                                                                                            function_parameter
                                                                                                                                            in
                                                                                                                                          op_gtgteqquestion
                                                                                                                                            (op_gtgteqquestion
                                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                                op_startypeminuserrorstar)
                                                                                                                                              (fun
                                                                                                                                                function_parameter
                                                                                                                                                =>
                                                                                                                                                match
                                                                                                                                                  function_parameter
                                                                                                                                                  with
                                                                                                                                                |
                                                                                                                                                  Some
                                                                                                                                                    v
                                                                                                                                                  =>
                                                                                                                                                  if
                                                                                                                                                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                      v
                                                                                                                                                    then
                                                                                                                                                    return_unit
                                                                                                                                                  else
                                                                                                                                                    failwith
                                                                                                                                                      "%s - Wrong proposal"
                                                                                                                                                        %
                                                                                                                                                        string
                                                                                                                                                      __LOC__
                                                                                                                                                |
                                                                                                                                                  None
                                                                                                                                                  =>
                                                                                                                                                  failwith
                                                                                                                                                    "%s - Missing proposal"
                                                                                                                                                      %
                                                                                                                                                      string
                                                                                                                                                    __LOC__
                                                                                                                                                end))
                                                                                                                                            (fun
                                                                                                                                              function_parameter
                                                                                                                                              =>
                                                                                                                                              let
                                                                                                                                                'tt :=
                                                                                                                                                function_parameter
                                                                                                                                                in
                                                                                                                                              op_gtgteqquestion
                                                                                                                                                (map_s
                                                                                                                                                  (fun
                                                                                                                                                    del
                                                                                                                                                    =>
                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                      op_startypeminuserrorstar
                                                                                                                                                      del
                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                      Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                                                                                                                                  delegates_p2)
                                                                                                                                                (fun
                                                                                                                                                  operations
                                                                                                                                                  =>
                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                      operations
                                                                                                                                                      b)
                                                                                                                                                    (fun
                                                                                                                                                      b
                                                                                                                                                      =>
                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                          del1
                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Nay)
                                                                                                                                                        (fun
                                                                                                                                                          op
                                                                                                                                                          =>
                                                                                                                                                          op_gtgteq
                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                              (cons
                                                                                                                                                                op
                                                                                                                                                                [])
                                                                                                                                                              b)
                                                                                                                                                            (fun
                                                                                                                                                              res
                                                                                                                                                              =>
                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                  __LOC__
                                                                                                                                                                  res
                                                                                                                                                                  (fun
                                                                                                                                                                    function_parameter
                                                                                                                                                                    =>
                                                                                                                                                                    match
                                                                                                                                                                      function_parameter
                                                                                                                                                                      with
                                                                                                                                                                    |
                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Error_monad.Unauthorized_ballot
                                                                                                                                                                      =>
                                                                                                                                                                      true
                                                                                                                                                                    |
                                                                                                                                                                      _
                                                                                                                                                                      =>
                                                                                                                                                                      false
                                                                                                                                                                    end))
                                                                                                                                                                (fun
                                                                                                                                                                  function_parameter
                                                                                                                                                                  =>
                                                                                                                                                                  let
                                                                                                                                                                    'tt :=
                                                                                                                                                                    function_parameter
                                                                                                                                                                    in
                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                    (fold_left_s
                                                                                                                                                                      (fun
                                                                                                                                                                        v
                                                                                                                                                                        =>
                                                                                                                                                                        fun
                                                                                                                                                                          acc
                                                                                                                                                                          =>
                                                                                                                                                                          _return
                                                                                                                                                                            (add
                                                                                                                                                                              v
                                                                                                                                                                              acc))
                                                                                                                                                                      (* ❌ Constant of type int32 is converted to int *)
                                                                                                                                                                      0
                                                                                                                                                                      rolls_p2)
                                                                                                                                                                    (fun
                                                                                                                                                                      rolls_sum
                                                                                                                                                                      =>
                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                                                        (fun
                                                                                                                                                                          v
                                                                                                                                                                          =>
                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                              __LOC__
                                                                                                                                                                              ballots_equal
                                                                                                                                                                              "Unexpected ballots"
                                                                                                                                                                                %
                                                                                                                                                                                string
                                                                                                                                                                              ballots_pp
                                                                                                                                                                              v
                                                                                                                                                                              {|
                                                                                                                                                                                yay :=
                                                                                                                                                                                  rolls_sum;
                                                                                                                                                                                nay :=
                                                                                                                                                                                  (* ❌ Constant of type int32 is converted to int *)
                                                                                                                                                                                  0;
                                                                                                                                                                                pass :=
                                                                                                                                                                                  (* ❌ Constant of type int32 is converted to int *)
                                                                                                                                                                                  0
                                                                                                                                                                                |})
                                                                                                                                                                            (fun
                                                                                                                                                                              function_parameter
                                                                                                                                                                              =>
                                                                                                                                                                              let
                                                                                                                                                                                'tt :=
                                                                                                                                                                                function_parameter
                                                                                                                                                                                in
                                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                                (op_gtgteqquestion
                                                                                                                                                                                  (op_startypeminuserrorstar
                                                                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                                                                  (fun
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    =>
                                                                                                                                                                                    match
                                                                                                                                                                                      function_parameter
                                                                                                                                                                                      with
                                                                                                                                                                                    |
                                                                                                                                                                                      []
                                                                                                                                                                                      =>
                                                                                                                                                                                      failwith
                                                                                                                                                                                        "%s - Unexpected empty ballot list"
                                                                                                                                                                                          %
                                                                                                                                                                                          string
                                                                                                                                                                                        __LOC__
                                                                                                                                                                                    |
                                                                                                                                                                                      l
                                                                                                                                                                                      =>
                                                                                                                                                                                      iter_s
                                                                                                                                                                                        (fun
                                                                                                                                                                                          delegate
                                                                                                                                                                                          =>
                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                              delegate)
                                                                                                                                                                                            (fun
                                                                                                                                                                                              pkh
                                                                                                                                                                                              =>
                                                                                                                                                                                              match
                                                                                                                                                                                                List.find_opt
                                                                                                                                                                                                  (fun
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    =>
                                                                                                                                                                                                    let
                                                                                                                                                                                                      '(del,
                                                                                                                                                                                                        _) :=
                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                      in
                                                                                                                                                                                                    op_startypeminuserrorstar
                                                                                                                                                                                                      del
                                                                                                                                                                                                      pkh)
                                                                                                                                                                                                  l
                                                                                                                                                                                                with
                                                                                                                                                                                              |
                                                                                                                                                                                                None
                                                                                                                                                                                                =>
                                                                                                                                                                                                failwith
                                                                                                                                                                                                  "%s - Missing delegate"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string
                                                                                                                                                                                                  __LOC__
                                                                                                                                                                                              |
                                                                                                                                                                                                Some
                                                                                                                                                                                                  (_,
                                                                                                                                                                                                    Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                                                                                                                                                                                =>
                                                                                                                                                                                                return_unit
                                                                                                                                                                                              |
                                                                                                                                                                                                Some
                                                                                                                                                                                                  _
                                                                                                                                                                                                =>
                                                                                                                                                                                                failwith
                                                                                                                                                                                                  "%s - Wrong ballot"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string
                                                                                                                                                                                                  __LOC__
                                                                                                                                                                                              end))
                                                                                                                                                                                        delegates_p2
                                                                                                                                                                                    end))
                                                                                                                                                                                (fun
                                                                                                                                                                                  function_parameter
                                                                                                                                                                                  =>
                                                                                                                                                                                  let
                                                                                                                                                                                    'tt :=
                                                                                                                                                                                    function_parameter
                                                                                                                                                                                    in
                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                      (op_minus
                                                                                                                                                                                        (Int32.to_int
                                                                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                                                                        1)
                                                                                                                                                                                      b)
                                                                                                                                                                                    (fun
                                                                                                                                                                                      b
                                                                                                                                                                                      =>
                                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                                        (op_gtgteqquestion
                                                                                                                                                                                          (op_startypeminuserrorstar
                                                                                                                                                                                            op_startypeminuserrorstar)
                                                                                                                                                                                          (fun
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            =>
                                                                                                                                                                                            match
                                                                                                                                                                                              function_parameter
                                                                                                                                                                                              with
                                                                                                                                                                                            |
                                                                                                                                                                                              _
                                                                                                                                                                                              =>
                                                                                                                                                                                              return_unit
                                                                                                                                                                                            |
                                                                                                                                                                                              _
                                                                                                                                                                                              =>
                                                                                                                                                                                              failwith
                                                                                                                                                                                                "%s - Unexpected period kind"
                                                                                                                                                                                                  %
                                                                                                                                                                                                  string
                                                                                                                                                                                                __LOC__
                                                                                                                                                                                            end))
                                                                                                                                                                                        (fun
                                                                                                                                                                                          function_parameter
                                                                                                                                                                                          =>
                                                                                                                                                                                          let
                                                                                                                                                                                            'tt :=
                                                                                                                                                                                            function_parameter
                                                                                                                                                                                            in
                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                              op_startypeminuserrorstar)
                                                                                                                                                                                            (fun
                                                                                                                                                                                              v
                                                                                                                                                                                              =>
                                                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                  __LOC__
                                                                                                                                                                                                  Voting_period.equal
                                                                                                                                                                                                  "Unexpected period"
                                                                                                                                                                                                    %
                                                                                                                                                                                                    string
                                                                                                                                                                                                  Voting_period.pp
                                                                                                                                                                                                  v
                                                                                                                                                                                                  (succ
                                                                                                                                                                                                    (succ
                                                                                                                                                                                                      root)))
                                                                                                                                                                                                (fun
                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                  =>
                                                                                                                                                                                                  let
                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                    in
                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                      op_startypeminuserrorstar)
                                                                                                                                                                                                    (fun
                                                                                                                                                                                                      v
                                                                                                                                                                                                      =>
                                                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                                          __LOC__
                                                                                                                                                                                                          ballots_equal
                                                                                                                                                                                                          "Unexpected ballots"
                                                                                                                                                                                                            %
                                                                                                                                                                                                            string
                                                                                                                                                                                                          ballots_pp
                                                                                                                                                                                                          v
                                                                                                                                                                                                          ballots_zero)
                                                                                                                                                                                                        (fun
                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                          =>
                                                                                                                                                                                                          let
                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                            in
                                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                                            (op_gtgteqquestion
                                                                                                                                                                                                              (op_startypeminuserrorstar
                                                                                                                                                                                                                op_startypeminuserrorstar)
                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                =>
                                                                                                                                                                                                                match
                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                  with
                                                                                                                                                                                                                |
                                                                                                                                                                                                                  []
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  return_unit
                                                                                                                                                                                                                |
                                                                                                                                                                                                                  _
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  failwith
                                                                                                                                                                                                                    "%s - Unexpected listings"
                                                                                                                                                                                                                      %
                                                                                                                                                                                                                      string
                                                                                                                                                                                                                    __LOC__
                                                                                                                                                                                                                end))
                                                                                                                                                                                                            (fun
                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                              =>
                                                                                                                                                                                                              let
                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                in
                                                                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                                  (Int32.to_int
                                                                                                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                                                                                                  b)
                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                  b
                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                                    (op_gtgteqquestion
                                                                                                                                                                                                                      (op_startypeminuserrorstar
                                                                                                                                                                                                                        op_startypeminuserrorstar)
                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                        match
                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                          with
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          _
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          return_unit
                                                                                                                                                                                                                        |
                                                                                                                                                                                                                          _
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          failwith
                                                                                                                                                                                                                            "%s - Unexpected period kind"
                                                                                                                                                                                                                              %
                                                                                                                                                                                                                              string
                                                                                                                                                                                                                            __LOC__
                                                                                                                                                                                                                        end))
                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                      let
                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                        in
                                                                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                          v
                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                                                              __LOC__
                                                                                                                                                                                                                              Voting_period.equal
                                                                                                                                                                                                                              "Unexpected period"
                                                                                                                                                                                                                                %
                                                                                                                                                                                                                                string
                                                                                                                                                                                                                              Voting_period.pp
                                                                                                                                                                                                                              v
                                                                                                                                                                                                                              (succ
                                                                                                                                                                                                                                (succ
                                                                                                                                                                                                                                  (succ
                                                                                                                                                                                                                                    root))))
                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                in
                                                                                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                                                                                (op_gtgteqquestion
                                                                                                                                                                                                                                  (op_startypeminuserrorstar
                                                                                                                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                      []
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      failwith
                                                                                                                                                                                                                                        "%s - Unexpected empty listings"
                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                        __LOC__
                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                      _
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      return_unit
                                                                                                                                                                                                                                    end))
                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                                                    (get_delegates_and_rolls_from_listings
                                                                                                                                                                                                                                      b)
                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                        '(delegates_p4,
                                                                                                                                                                                                                                          rolls_p4) :=
                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                                                                          op_startypeminuserrorstar)
                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                          ps
                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                                                                            (if
                                                                                                                                                                                                                                              Environment.Protocol_hash.Map.is_empty
                                                                                                                                                                                                                                                ps
                                                                                                                                                                                                                                              then
                                                                                                                                                                                                                                              return_unit
                                                                                                                                                                                                                                            else
                                                                                                                                                                                                                                              failwith
                                                                                                                                                                                                                                                "%s - Unexpected proposals"
                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                __LOC__)
                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                              let
                                                                                                                                                                                                                                                'tt :=
                                                                                                                                                                                                                                                function_parameter
                                                                                                                                                                                                                                                in
                                                                                                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                                                                                                (op_gtgteqquestion
                                                                                                                                                                                                                                                  (op_startypeminuserrorstar
                                                                                                                                                                                                                                                    op_startypeminuserrorstar)
                                                                                                                                                                                                                                                  (fun
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    =>
                                                                                                                                                                                                                                                    match
                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                      with
                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                      Some
                                                                                                                                                                                                                                                        v
                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                      if
                                                                                                                                                                                                                                                        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                                                                                          v
                                                                                                                                                                                                                                                        then
                                                                                                                                                                                                                                                        return_unit
                                                                                                                                                                                                                                                      else
                                                                                                                                                                                                                                                        failwith
                                                                                                                                                                                                                                                          "%s - Wrong proposal"
                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                          __LOC__
                                                                                                                                                                                                                                                    |
                                                                                                                                                                                                                                                      None
                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                      failwith
                                                                                                                                                                                                                                                        "%s - Missing proposal"
                                                                                                                                                                                                                                                          %
                                                                                                                                                                                                                                                          string
                                                                                                                                                                                                                                                        __LOC__
                                                                                                                                                                                                                                                    end))
                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                  function_parameter
                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                  let
                                                                                                                                                                                                                                                    'tt :=
                                                                                                                                                                                                                                                    function_parameter
                                                                                                                                                                                                                                                    in
                                                                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                                                                    (map_s
                                                                                                                                                                                                                                                      (fun
                                                                                                                                                                                                                                                        del
                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                        op_startypeminuserrorstar
                                                                                                                                                                                                                                                          op_startypeminuserrorstar
                                                                                                                                                                                                                                                          del
                                                                                                                                                                                                                                                          Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                                                                                                                                                                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                                                                                                                                                                                                                                      delegates_p4)
                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                      operations
                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                                                                                                        (op_startypeminuserrorstar
                                                                                                                                                                                                                                                          operations
                                                                                                                                                                                                                                                          b)
                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                          b
                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                                                                                            (fold_left_s
                                                                                                                                                                                                                                                              (fun
                                                                                                                                                                                                                                                                v
                                                                                                                                                                                                                                                                =>
                                                                                                                                                                                                                                                                fun
                                                                                                                                                                                                                                                                  acc
                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                  _return
                                                                                                                                                                                                                                                                    (add
                                                                                                                                                                                                                                                                      v
                                                                                                                                                                                                                                                                      acc))
                                                                                                                                                                                                                                                              (* ❌ Constant of type int32 is converted to int *)
                                                                                                                                                                                                                                                              0
                                                                                                                                                                                                                                                              rolls_p4)
                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                              rolls_sum
                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                              op_gtgteqquestion
                                                                                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                  op_startypeminuserrorstar)
                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                  v
                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                      __LOC__
                                                                                                                                                                                                                                                                      ballots_equal
                                                                                                                                                                                                                                                                      "Unexpected ballots"
                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                      ballots_pp
                                                                                                                                                                                                                                                                      v
                                                                                                                                                                                                                                                                      {|
                                                                                                                                                                                                                                                                        yay :=
                                                                                                                                                                                                                                                                          rolls_sum;
                                                                                                                                                                                                                                                                        nay :=
                                                                                                                                                                                                                                                                          (* ❌ Constant of type int32 is converted to int *)
                                                                                                                                                                                                                                                                          0;
                                                                                                                                                                                                                                                                        pass :=
                                                                                                                                                                                                                                                                          (* ❌ Constant of type int32 is converted to int *)
                                                                                                                                                                                                                                                                          0
                                                                                                                                                                                                                                                                        |})
                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                      op_gtgteqquestion
                                                                                                                                                                                                                                                                        (op_gtgteqquestion
                                                                                                                                                                                                                                                                          (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                            op_startypeminuserrorstar)
                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                            match
                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                              with
                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                              []
                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                              failwith
                                                                                                                                                                                                                                                                                "%s - Unexpected empty ballot list"
                                                                                                                                                                                                                                                                                  %
                                                                                                                                                                                                                                                                                  string
                                                                                                                                                                                                                                                                                __LOC__
                                                                                                                                                                                                                                                                            |
                                                                                                                                                                                                                                                                              l
                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                              iter_s
                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                  delegate
                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                      delegate)
                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                      pkh
                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                      match
                                                                                                                                                                                                                                                                                        List.find_opt
                                                                                                                                                                                                                                                                                          (fun
                                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                                            =>
                                                                                                                                                                                                                                                                                            let
                                                                                                                                                                                                                                                                                              '(del,
                                                                                                                                                                                                                                                                                                _) :=
                                                                                                                                                                                                                                                                                              function_parameter
                                                                                                                                                                                                                                                                                              in
                                                                                                                                                                                                                                                                                            op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                              del
                                                                                                                                                                                                                                                                                              pkh)
                                                                                                                                                                                                                                                                                          l
                                                                                                                                                                                                                                                                                        with
                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                        None
                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                        failwith
                                                                                                                                                                                                                                                                                          "%s - Missing delegate"
                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                          __LOC__
                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                        Some
                                                                                                                                                                                                                                                                                          (_,
                                                                                                                                                                                                                                                                                            Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                        return_unit
                                                                                                                                                                                                                                                                                      |
                                                                                                                                                                                                                                                                                        Some
                                                                                                                                                                                                                                                                                          _
                                                                                                                                                                                                                                                                                        =>
                                                                                                                                                                                                                                                                                        failwith
                                                                                                                                                                                                                                                                                          "%s - Wrong ballot"
                                                                                                                                                                                                                                                                                            %
                                                                                                                                                                                                                                                                                            string
                                                                                                                                                                                                                                                                                          __LOC__
                                                                                                                                                                                                                                                                                      end))
                                                                                                                                                                                                                                                                                delegates_p4
                                                                                                                                                                                                                                                                            end))
                                                                                                                                                                                                                                                                        (fun
                                                                                                                                                                                                                                                                          function_parameter
                                                                                                                                                                                                                                                                          =>
                                                                                                                                                                                                                                                                          let
                                                                                                                                                                                                                                                                            'tt :=
                                                                                                                                                                                                                                                                            function_parameter
                                                                                                                                                                                                                                                                            in
                                                                                                                                                                                                                                                                          op_gtgteqquestion
                                                                                                                                                                                                                                                                            (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                              (op_minus
                                                                                                                                                                                                                                                                                (to_int
                                                                                                                                                                                                                                                                                  op_startypeminuserrorstar)
                                                                                                                                                                                                                                                                                1)
                                                                                                                                                                                                                                                                              b)
                                                                                                                                                                                                                                                                            (fun
                                                                                                                                                                                                                                                                              b
                                                                                                                                                                                                                                                                              =>
                                                                                                                                                                                                                                                                              op_gtgteq
                                                                                                                                                                                                                                                                                (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                  b)
                                                                                                                                                                                                                                                                                (fun
                                                                                                                                                                                                                                                                                  p
                                                                                                                                                                                                                                                                                  =>
                                                                                                                                                                                                                                                                                  op_gtgteqquestion
                                                                                                                                                                                                                                                                                    (op_startypeminuserrorstar
                                                                                                                                                                                                                                                                                      __LOC__
                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                                                                                                                                                                                                                                                                      "Unexpected proposal"
                                                                                                                                                                                                                                                                                        %
                                                                                                                                                                                                                                                                                        string
                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.pp)
                                                                                                                                                                                                                                                                                      p
                                                                                                                                                                                                                                                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero))
                                                                                                                                                                                                                                                                                    (fun
                                                                                                                                                                                                                                                                                      function_parameter
                                                                                                                                                                                                                                                                                      =>
                                                                                                                                                                                                                                                                                      let
                                                                                                                                                                                                                                                                                        'tt :=
                                                                                                                                                                                                                                                                                        function_parameter
                                                                                                                                                                                                                                                                                        in
                                                                                                                                                                                                                                                                                      return_unit))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))).

Definition get_smallest_prefix_voters_for_quorum {A : Type}
  (active_delegates : list A) (active_rolls : list int32)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult (list A)) :=
  op_gtgteqquestion
    (fold_left_s (fun v => fun acc => _return (add v acc))
      (* ❌ Constant of type int32 is converted to int *)
      0 active_rolls)
    (fun active_rolls_sum =>
      let fix loop {B : Type}
        (delegates : list B) (rolls : list int32) (sum : Z) (selected : list B)
        : list B :=
        match (delegates, rolls) with
        | ([], []) => selected
        | (cons del delegates, cons del_rolls rolls) =>
          if
            op_startypeminuserrorstar (op_star den sum)
              (op_startypeminuserrorstar
                (op_startypeminuserrorstar expected_qr_num
                  (Int32.to_float active_rolls_sum))) then
            loop delegates rolls (op_plus sum (Int32.to_int del_rolls))
              (cons del selected)
          else
            selected
        | (_, _) => []
        end in
      _return (loop active_delegates active_rolls 0 [])).

Definition get_expected_participation_ema
  (rolls : list int32) (voter_rolls : list int32)
  (old_participation_ema : int32)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult Z) :=
  let get_updated_participation_ema
    (old_participation_ema : int32) (participation : Z) : Z :=
    op_div
      (op_plus (op_star pr_ema_weight (Int32.to_int old_participation_ema))
        (op_star pr_num participation)) den in
  op_gtgteqquestion
    (fold_left_s (fun v => fun acc => _return (add v acc))
      (* ❌ Constant of type int32 is converted to int *)
      0 rolls)
    (fun rolls_sum =>
      op_gtgteqquestion
        (fold_left_s (fun v => fun acc => _return (add v acc))
          (* ❌ Constant of type int32 is converted to int *)
          0 voter_rolls)
        (fun voter_rolls_sum =>
          let participation :=
            op_div (op_star (Int32.to_int voter_rolls_sum) percent_mul)
              (Int32.to_int rolls_sum) in
          _return
            (get_updated_participation_ema old_participation_ema participation))).

Definition test_not_enough_quorum_in_testing_vote
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum num_delegates)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteqquestion
            (op_gtgteqquestion
              (op_startypeminuserrorstar op_startypeminuserrorstar)
              (fun function_parameter =>
                match function_parameter with
                | _ => return_unit
                | _ => failwith "%s - Unexpected period kind" % string __LOC__
                end))
            (fun function_parameter =>
              let 'tt := function_parameter in
              let proposer := op_startypeminuserrorstar delegates 0 in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar proposer
                  (cons
                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                    []))
                (fun ops =>
                  op_gtgteqquestion (op_startypeminuserrorstar (cons ops []) b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar
                          (op_minus (Int32.to_int op_startypeminuserrorstar) 2)
                          b)
                        (fun b =>
                          op_gtgteqquestion
                            (op_gtgteqquestion
                              (op_startypeminuserrorstar
                                op_startypeminuserrorstar)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => return_unit
                                | _ =>
                                  failwith
                                    "%s - Unexpected period kind" % string
                                    __LOC__
                                end))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion (op_startypeminuserrorstar b)
                                (fun initial_participation_ema =>
                                  op_gtgteqquestion
                                    (get_delegates_and_rolls_from_listings b)
                                    (fun function_parameter =>
                                      let '(delegates_p2, rolls_p2) :=
                                        function_parameter in
                                      op_gtgteqquestion
                                        (get_smallest_prefix_voters_for_quorum
                                          delegates_p2 rolls_p2)
                                        (fun voters =>
                                          let voters_without_quorum :=
                                            List.tl voters in
                                          op_gtgteqquestion
                                            (get_rolls b voters_without_quorum
                                              __LOC__)
                                            (fun voters_rolls_in_testing_vote =>
                                              op_gtgteqquestion
                                                (map_s
                                                  (fun del =>
                                                    op_startypeminuserrorstar
                                                      op_startypeminuserrorstar
                                                      del
                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                      Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                                  voters_without_quorum)
                                                (fun operations =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      operations b)
                                                    (fun b =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          (op_minus
                                                            (Int32.to_int
                                                              op_startypeminuserrorstar)
                                                            1) b)
                                                        (fun b =>
                                                          op_gtgteqquestion
                                                            (op_gtgteqquestion
                                                              (op_startypeminuserrorstar
                                                                op_startypeminuserrorstar)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ =>
                                                                  return_unit
                                                                | _ =>
                                                                  failwith
                                                                    "%s - Unexpected period kind"
                                                                      % string
                                                                    __LOC__
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteqquestion
                                                                (get_expected_participation_ema
                                                                  rolls_p2
                                                                  voters_rolls_in_testing_vote
                                                                  initial_participation_ema)
                                                                (fun
                                                                  expected_participation_ema
                                                                  =>
                                                                  op_gtgteqquestion
                                                                    (op_startypeminuserrorstar
                                                                      b)
                                                                    (fun
                                                                      new_participation_ema
                                                                      =>
                                                                      op_gtgteqquestion
                                                                        (op_startypeminuserrorstar
                                                                          __LOC__
                                                                          expected_participation_ema
                                                                          (Int32.to_int
                                                                            new_participation_ema))
                                                                        (fun
                                                                          function_parameter
                                                                          =>
                                                                          let
                                                                            'tt :=
                                                                            function_parameter
                                                                            in
                                                                          return_unit)))))))))))))))))).

Definition test_not_enough_quorum_in_promotion_vote
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum num_delegates)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteqquestion
            (op_gtgteqquestion
              (op_startypeminuserrorstar op_startypeminuserrorstar)
              (fun function_parameter =>
                match function_parameter with
                | _ => return_unit
                | _ => failwith "%s - Unexpected period kind" % string __LOC__
                end))
            (fun function_parameter =>
              let 'tt := function_parameter in
              let proposer := op_startypeminuserrorstar delegates 0 in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar proposer
                  (cons
                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                    []))
                (fun ops =>
                  op_gtgteqquestion (op_startypeminuserrorstar (cons ops []) b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar
                          (op_minus (Int32.to_int op_startypeminuserrorstar) 2)
                          b)
                        (fun b =>
                          op_gtgteqquestion
                            (op_gtgteqquestion
                              (op_startypeminuserrorstar
                                op_startypeminuserrorstar)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => return_unit
                                | _ =>
                                  failwith
                                    "%s - Unexpected period kind" % string
                                    __LOC__
                                end))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (get_delegates_and_rolls_from_listings b)
                                (fun function_parameter =>
                                  let '(delegates_p2, rolls_p2) :=
                                    function_parameter in
                                  op_gtgteqquestion
                                    (get_smallest_prefix_voters_for_quorum
                                      delegates_p2 rolls_p2)
                                    (fun voters =>
                                      op_gtgteqquestion
                                        (map_s
                                          (fun del =>
                                            op_startypeminuserrorstar
                                              op_startypeminuserrorstar del
                                              Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                          voters)
                                        (fun operations =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              operations b)
                                            (fun b =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  (op_minus
                                                    (Int32.to_int
                                                      op_startypeminuserrorstar)
                                                    1) b)
                                                (fun b =>
                                                  op_gtgteqquestion
                                                    (op_gtgteqquestion
                                                      (op_startypeminuserrorstar
                                                        op_startypeminuserrorstar)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | _ => return_unit
                                                        | _ =>
                                                          failwith
                                                            "%s - Unexpected period kind"
                                                              % string __LOC__
                                                        end))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          (Int32.to_int
                                                            op_startypeminuserrorstar)
                                                          b)
                                                        (fun b =>
                                                          op_gtgteqquestion
                                                            (op_gtgteqquestion
                                                              (op_startypeminuserrorstar
                                                                op_startypeminuserrorstar)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ =>
                                                                  return_unit
                                                                | _ =>
                                                                  failwith
                                                                    "%s - Unexpected period kind"
                                                                      % string
                                                                    __LOC__
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              op_gtgteqquestion
                                                                (op_startypeminuserrorstar
                                                                  b)
                                                                (fun
                                                                  initial_participation_ema
                                                                  =>
                                                                  op_gtgteqquestion
                                                                    (get_delegates_and_rolls_from_listings
                                                                      b)
                                                                    (fun
                                                                      function_parameter
                                                                      =>
                                                                      let
                                                                        '(delegates_p4,
                                                                          rolls_p4) :=
                                                                        function_parameter
                                                                        in
                                                                      op_gtgteqquestion
                                                                        (get_smallest_prefix_voters_for_quorum
                                                                          delegates_p4
                                                                          rolls_p4)
                                                                        (fun
                                                                          voters
                                                                          =>
                                                                          let
                                                                            voters_without_quorum :=
                                                                            List.tl
                                                                              voters
                                                                            in
                                                                          op_gtgteqquestion
                                                                            (get_rolls
                                                                              b
                                                                              voters_without_quorum
                                                                              __LOC__)
                                                                            (fun
                                                                              voter_rolls
                                                                              =>
                                                                              op_gtgteqquestion
                                                                                (map_s
                                                                                  (fun
                                                                                    del
                                                                                    =>
                                                                                    op_startypeminuserrorstar
                                                                                      op_startypeminuserrorstar
                                                                                      del
                                                                                      Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                                                                                      Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                                                                  voters_without_quorum)
                                                                                (fun
                                                                                  operations
                                                                                  =>
                                                                                  op_gtgteqquestion
                                                                                    (op_startypeminuserrorstar
                                                                                      operations
                                                                                      b)
                                                                                    (fun
                                                                                      b
                                                                                      =>
                                                                                      op_gtgteqquestion
                                                                                        (op_startypeminuserrorstar
                                                                                          (op_minus
                                                                                            (Int32.to_int
                                                                                              op_startypeminuserrorstar)
                                                                                            1)
                                                                                          b)
                                                                                        (fun
                                                                                          b
                                                                                          =>
                                                                                          op_gtgteqquestion
                                                                                            (get_expected_participation_ema
                                                                                              rolls_p4
                                                                                              voter_rolls
                                                                                              initial_participation_ema)
                                                                                            (fun
                                                                                              expected_participation_ema
                                                                                              =>
                                                                                              op_gtgteqquestion
                                                                                                (op_startypeminuserrorstar
                                                                                                  b)
                                                                                                (fun
                                                                                                  new_participation_ema
                                                                                                  =>
                                                                                                  op_gtgteqquestion
                                                                                                    (op_startypeminuserrorstar
                                                                                                      __LOC__
                                                                                                      expected_participation_ema
                                                                                                      (Int32.to_int
                                                                                                        new_participation_ema))
                                                                                                    (fun
                                                                                                      function_parameter
                                                                                                      =>
                                                                                                      let
                                                                                                        'tt :=
                                                                                                        function_parameter
                                                                                                        in
                                                                                                      op_gtgteqquestion
                                                                                                        (op_gtgteqquestion
                                                                                                          (op_startypeminuserrorstar
                                                                                                            op_startypeminuserrorstar)
                                                                                                          (fun
                                                                                                            function_parameter
                                                                                                            =>
                                                                                                            match
                                                                                                              function_parameter
                                                                                                              with
                                                                                                            |
                                                                                                              _
                                                                                                              =>
                                                                                                              return_unit
                                                                                                            |
                                                                                                              _
                                                                                                              =>
                                                                                                              failwith
                                                                                                                "%s - Unexpected period kind"
                                                                                                                  %
                                                                                                                  string
                                                                                                                __LOC__
                                                                                                            end))
                                                                                                        (fun
                                                                                                          function_parameter
                                                                                                          =>
                                                                                                          let
                                                                                                            'tt :=
                                                                                                            function_parameter
                                                                                                            in
                                                                                                          return_unit)))))))))))))))))))))))))).

Definition test_multiple_identical_proposals_count_as_one
  (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  op_gtgteqquestion (op_startypeminuserrorstar 1)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteqquestion
        (op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
          (fun function_parameter =>
            match function_parameter with
            | _ => return_unit
            | _ => failwith "%s - Unexpected period kind" % string __LOC__
            end))
        (fun function_parameter =>
          let 'tt := function_parameter in
          let proposer := List.hd delegates in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar proposer
              (cons
                Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                (cons
                  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                  [])))
            (fun ops =>
              op_gtgteqquestion (op_startypeminuserrorstar (cons ops []) b)
                (fun b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar)
                    (fun ps =>
                      op_gtgteqquestion (op_startypeminuserrorstar proposer)
                        (fun pkh =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar)
                            (fun l =>
                              op_gtgteqquestion
                                match
                                  List.find_opt
                                    (fun function_parameter =>
                                      let '(del, _) := function_parameter in
                                      op_startypeminuserrorstar del pkh) l with
                                | None =>
                                  failwith "%s - Missing delegate" % string
                                    __LOC__
                                | Some (_, proposer_rolls) =>
                                  _return proposer_rolls
                                end
                                (fun proposer_rolls =>
                                  let expected_weight_proposer := proposer_rolls
                                    in
                                  match Map.find_opt zero ps with
                                  | Some v =>
                                    if
                                      op_startypeminuserrorstar v
                                        expected_weight_proposer then
                                      return_unit
                                    else
                                      failwith
                                        "%s - Wrong count %ld is not %ld; identical proposals count as one"
                                          % string __LOC__ v
                                        expected_weight_proposer
                                  | None =>
                                    failwith "%s - Missing proposal" % string
                                      __LOC__
                                  end)))))))).

Definition test_supermajority_in_proposal {A : Type}
  (there_is_a_winner : bool) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult A) :=
  let 'tt := function_parameter in
  let min_proposal_quorum :=
    (* ❌ Constant of type int32 is converted to int *)
    0 in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum
      (cons
        (* ❌ Constant of type int64 is converted to int *)
        1
        (cons
          (* ❌ Constant of type int64 is converted to int *)
          1
          (cons
            (* ❌ Constant of type int64 is converted to int *)
            1 []))) 10)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          let del1 := op_startypeminuserrorstar delegates 0 in
          let del2 := op_startypeminuserrorstar delegates 1 in
          let del3 := op_startypeminuserrorstar delegates 2 in
          op_gtgteqquestion
            (map_s (fun del => op_startypeminuserrorstar del)
              (cons del1 (cons del2 (cons del3 []))))
            (fun pkhs =>
              let policy := op_startypeminuserrorstar in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar
                  (op_startypeminuserrorstar delegates 3) del1
                  op_startypeminuserrorstar)
                (fun op1 =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      (op_startypeminuserrorstar delegates 4) del2
                      op_startypeminuserrorstar)
                    (fun op2 =>
                      op_startypeminuserrorstar
                        (if there_is_a_winner then
                          op_startypeminuserrorstar op_startypeminuserrorstar
                            (* ❌ Constant of type int64 is converted to int *)
                            3
                        else
                          op_startypeminuserrorstar op_startypeminuserrorstar
                            (* ❌ Constant of type int64 is converted to int *)
                            2)
                        (fun bal3 =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              (op_startypeminuserrorstar delegates 5) del3 bal3)
                            (fun op3 =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar policy
                                  (cons op1 (cons op2 (cons op3 []))) b)
                                (fun b =>
                                  op_gtgteqquestion
                                    (fold_left_s
                                      (fun b =>
                                        fun function_parameter =>
                                          let '_ := function_parameter in
                                          op_gtgteqquestion
                                            (Error_monad.map_s
                                              (fun del =>
                                                op_gtgteqquestion
                                                  (op_startypeminuserrorstar del)
                                                  (fun pkh =>
                                                    op_startypeminuserrorstar
                                                      op_startypeminuserrorstar
                                                      del (Some pkh))) delegates)
                                            (fun ops =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  policy ops b)
                                                (fun b =>
                                                  op_startypeminuserrorstar
                                                    policy b))) b
                                      (op_startypeminuserrorstar 1
                                        (Int32.to_int
                                          (Int32.div op_startypeminuserrorstar
                                            op_startypeminuserrorstar))))
                                    (fun b =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar
                                          op_startypeminuserrorstar del1
                                          (cons
                                            (op_startypeminuserrorstar protos 0)
                                            []))
                                        (fun ops1 =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              op_startypeminuserrorstar del2
                                              (cons
                                                (op_startypeminuserrorstar
                                                  protos 0) []))
                                            (fun ops2 =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar del3
                                                  (cons
                                                    (op_startypeminuserrorstar
                                                      protos 1) []))
                                                (fun ops3 =>
                                                  op_gtgteqquestion
                                                    (op_startypeminuserrorstar
                                                      policy
                                                      (cons ops1
                                                        (cons ops2
                                                          (cons ops3 []))) b)
                                                    (fun b =>
                                                      op_gtgteqquestion
                                                        (op_startypeminuserrorstar
                                                          policy
                                                          (op_minus
                                                            (Int32.to_int
                                                              op_startypeminuserrorstar)
                                                            1) b)
                                                        (fun b =>
                                                          op_gtgteqquestion
                                                            (op_gtgteqquestion
                                                              (op_startypeminuserrorstar
                                                                op_startypeminuserrorstar)
                                                              (fun
                                                                function_parameter
                                                                =>
                                                                match
                                                                  function_parameter
                                                                  with
                                                                | _ =>
                                                                  if
                                                                    there_is_a_winner
                                                                    then
                                                                    return_unit
                                                                  else
                                                                    failwith
                                                                      "%s - Expected period kind Proposal, obtained Testing_vote"
                                                                        % string
                                                                      __LOC__
                                                                | _ =>
                                                                  if
                                                                    not
                                                                      there_is_a_winner
                                                                    then
                                                                    return_unit
                                                                  else
                                                                    failwith
                                                                      "%s - Expected period kind Testing_vote, obtained Proposal"
                                                                        % string
                                                                      __LOC__
                                                                | _ =>
                                                                  failwith
                                                                    "%s - Unexpected period kind"
                                                                      % string
                                                                    __LOC__
                                                                end))
                                                            (fun
                                                              function_parameter
                                                              =>
                                                              let 'tt :=
                                                                function_parameter
                                                                in
                                                              return_unit))))))))))))))).

Definition test_quorum_in_proposal
  (has_quorum : bool) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let total_tokens :=
    (* ❌ Constant of type int64 is converted to int *)
    32000000000000 in
  let half_tokens :=
    Int64.div total_tokens
      (* ❌ Constant of type int64 is converted to int *)
      2 in
  op_gtgteqquestion
    (op_startypeminuserrorstar
      (cons
        (* ❌ Constant of type int64 is converted to int *)
        1 (cons half_tokens (cons half_tokens []))) 3)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          let del1 := op_startypeminuserrorstar delegates 0 in
          let del2 := op_startypeminuserrorstar delegates 1 in
          op_gtgteqquestion
            (map_s (fun del => op_startypeminuserrorstar del)
              (cons del1 (cons del2 [])))
            (fun pkhs =>
              let policy := op_startypeminuserrorstar in
              let quorum :=
                if has_quorum then
                  Int64.of_int32 op_startypeminuserrorstar
                else
                  sub (of_int32 op_startypeminuserrorstar)
                    (* ❌ Constant of type int64 is converted to int *)
                    10 in
              let bal :=
                op_pipegt
                  (div (mul total_tokens quorum)
                    (* ❌ Constant of type int64 is converted to int *)
                    10000) op_startypeminuserrorstar in
              op_gtgteqquestion
                (op_startypeminuserrorstar op_startypeminuserrorstar del2 del1
                  bal)
                (fun op2 =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar policy (cons op2 []) b)
                    (fun b =>
                      op_gtgteqquestion
                        (fold_left_s
                          (fun b =>
                            fun function_parameter =>
                              let '_ := function_parameter in
                              op_gtgteqquestion
                                (Error_monad.map_s
                                  (fun del =>
                                    op_gtgteqquestion
                                      (op_startypeminuserrorstar del)
                                      (fun pkh =>
                                        op_startypeminuserrorstar
                                          op_startypeminuserrorstar del
                                          (Some pkh)))
                                  (cons del1 (cons del2 [])))
                                (fun ops =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar policy ops b)
                                    (fun b => op_startypeminuserrorstar policy b)))
                          b
                          (op_startypeminuserrorstar 1
                            (Int32.to_int
                              (Int32.div op_startypeminuserrorstar
                                op_startypeminuserrorstar))))
                        (fun b =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar op_startypeminuserrorstar
                              del1
                              (cons (op_startypeminuserrorstar protos 0) []))
                            (fun ops =>
                              op_gtgteqquestion
                                (op_startypeminuserrorstar policy (cons ops [])
                                  b)
                                (fun b =>
                                  op_gtgteqquestion
                                    (op_startypeminuserrorstar policy
                                      (op_minus
                                        (Int32.to_int op_startypeminuserrorstar)
                                        1) b)
                                    (fun b =>
                                      op_gtgteqquestion
                                        (op_gtgteqquestion
                                          (op_startypeminuserrorstar
                                            op_startypeminuserrorstar)
                                          (fun function_parameter =>
                                            match function_parameter with
                                            | _ =>
                                              if has_quorum then
                                                return_unit
                                              else
                                                failwith
                                                  "%s - Expected period kind Proposal, obtained Testing_vote"
                                                    % string __LOC__
                                            | _ =>
                                              if not has_quorum then
                                                return_unit
                                              else
                                                failwith
                                                  "%s - Expected period kind Testing_vote, obtained Proposal"
                                                    % string __LOC__
                                            | _ =>
                                              failwith
                                                "%s - Unexpected period kind" %
                                                  string __LOC__
                                            end))
                                        (fun function_parameter =>
                                          let 'tt := function_parameter in
                                          return_unit)))))))))).

Definition test_supermajority_in_testing_vote
  (supermajority : bool) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 100) in
  op_gtgteqquestion (op_startypeminuserrorstar min_proposal_quorum 100)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          let del1 := op_startypeminuserrorstar delegates 0 in
          let proposal := op_startypeminuserrorstar protos 0 in
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar del1
              (cons proposal []))
            (fun ops1 =>
              op_gtgteqquestion (op_startypeminuserrorstar (cons ops1 []) b)
                (fun b =>
                  op_gtgteqquestion
                    (op_startypeminuserrorstar
                      (op_minus (Int32.to_int op_startypeminuserrorstar) 1) b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_gtgteqquestion
                          (op_startypeminuserrorstar op_startypeminuserrorstar)
                          (fun function_parameter =>
                            match function_parameter with
                            | _ => return_unit
                            | _ =>
                              failwith "%s - Unexpected period kind" % string
                                __LOC__
                            end))
                        (fun function_parameter =>
                          let 'tt := function_parameter in
                          op_gtgteqquestion
                            (op_gtgteqquestion
                              (op_startypeminuserrorstar
                                op_startypeminuserrorstar)
                              (fun function_parameter =>
                                match function_parameter with
                                | Some v =>
                                  if
                                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.equal)
                                      proposal v then
                                    return_unit
                                  else
                                    failwith "%s - Wrong proposal" % string
                                      __LOC__
                                | None =>
                                  failwith "%s - Missing proposal" % string
                                    __LOC__
                                end))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              op_gtgteqquestion
                                (get_delegates_and_rolls_from_listings b)
                                (fun function_parameter =>
                                  let '(delegates_p2, _olls_p2) :=
                                    function_parameter in
                                  let num_delegates := List.length delegates_p2
                                    in
                                  let num_nays := op_div num_delegates 5 in
                                  let num_yays :=
                                    op_div (op_star num_nays s_num)
                                      (op_minus s_den s_num) in
                                  let num_yays :=
                                    if supermajority then
                                      num_yays
                                    else
                                      op_minus num_yays 1 in
                                  let '(nays_delegates, rest) :=
                                    op_startypeminuserrorstar num_nays
                                      delegates_p2 in
                                  let '(yays_delegates, _) :=
                                    op_startypeminuserrorstar num_yays rest in
                                  op_gtgteqquestion
                                    (map_s
                                      (fun del =>
                                        op_startypeminuserrorstar
                                          op_startypeminuserrorstar del proposal
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                      yays_delegates)
                                    (fun operations_yays =>
                                      op_gtgteqquestion
                                        (map_s
                                          (fun del =>
                                            op_startypeminuserrorstar
                                              op_startypeminuserrorstar del
                                              proposal
                                              Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Nay)
                                          nays_delegates)
                                        (fun operations_nays =>
                                          let operations :=
                                            op_at operations_yays
                                              operations_nays in
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              operations b)
                                            (fun b =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  (op_minus
                                                    (Int32.to_int
                                                      op_startypeminuserrorstar)
                                                    1) b)
                                                (fun b =>
                                                  op_gtgteqquestion
                                                    (op_gtgteqquestion
                                                      (op_startypeminuserrorstar
                                                        op_startypeminuserrorstar)
                                                      (fun function_parameter =>
                                                        match function_parameter
                                                          with
                                                        | _ =>
                                                          if supermajority then
                                                            return_unit
                                                          else
                                                            failwith
                                                              "%s - Expected period kind Proposal, obtained Testing"
                                                                % string __LOC__
                                                        | _ =>
                                                          if not supermajority
                                                            then
                                                            return_unit
                                                          else
                                                            failwith
                                                              "%s - Expected period kind Testing_vote, obtained Proposal"
                                                                % string __LOC__
                                                        | _ =>
                                                          failwith
                                                            "%s - Unexpected period kind"
                                                              % string __LOC__
                                                        end))
                                                    (fun function_parameter =>
                                                      let 'tt :=
                                                        function_parameter in
                                                      return_unit))))))))))))).

Definition test_no_winning_proposal
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum num_delegates)
    (fun function_parameter =>
      let '(b, _) := function_parameter in
      op_gtgteqquestion (op_startypeminuserrorstar op_startypeminuserrorstar)
        (fun function_parameter =>
          let '_ := function_parameter in
          op_gtgteqquestion (get_delegates_and_rolls_from_listings b)
            (fun function_parameter =>
              let '(delegates_p1, _rolls_p1) := function_parameter in
              let props :=
                List.map (fun i => op_startypeminuserrorstar protos i)
                  (op_startypeminuserrorstar 1
                    Constants.max_proposals_per_delegate) in
              op_gtgteqquestion
                (map_s
                  (fun del =>
                    op_startypeminuserrorstar op_startypeminuserrorstar del
                      props) delegates_p1)
                (fun ops_list =>
                  op_gtgteqquestion (op_startypeminuserrorstar ops_list b)
                    (fun b =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar
                          (op_minus (Int32.to_int op_startypeminuserrorstar) 2)
                          b)
                        (fun b =>
                          op_gtgteqquestion
                            (op_gtgteqquestion
                              (op_startypeminuserrorstar
                                op_startypeminuserrorstar)
                              (fun function_parameter =>
                                match function_parameter with
                                | _ => return_unit
                                | _ =>
                                  failwith
                                    "%s - Unexpected period kind" % string
                                    __LOC__
                                end))
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit))))))).

Definition test_quorum_capped_maximum
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum num_delegates)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteq
        (op_startypeminuserrorstar b
          (* ❌ Constant of type int32 is converted to int *)
          10000)
        (fun b =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteqquestion
                (op_gtgteqquestion
                  (op_startypeminuserrorstar op_startypeminuserrorstar)
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => return_unit
                    | _ =>
                      failwith "%s - Unexpected period kind" % string __LOC__
                    end))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let protocol :=
                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                    in
                  let proposer := op_startypeminuserrorstar delegates 0 in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      proposer (cons protocol []))
                    (fun ops =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar (cons ops []) b)
                        (fun b =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar
                              (op_minus (Int32.to_int op_startypeminuserrorstar)
                                1) b)
                            (fun b =>
                              op_gtgteqquestion
                                (op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ => return_unit
                                    | _ =>
                                      failwith
                                        "%s - Unexpected period kind" % string
                                        __LOC__
                                    end))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  let minimum_to_pass :=
                                    op_pipegt
                                      (op_pipegt
                                        (op_startypeminuserrorstar
                                          (op_startypeminuserrorstar
                                            (op_startypeminuserrorstar
                                              (List.length delegates))
                                            (to_float op_startypeminuserrorstar))
                                          (* ❌ Float constant 100_00. is approximated by the integer 10000 *)
                                          10000) op_startypeminuserrorstar)
                                      op_startypeminuserrorstar in
                                  let voters :=
                                    op_startypeminuserrorstar minimum_to_pass
                                      delegates in
                                  op_gtgteqquestion
                                    (map_s
                                      (fun del =>
                                        op_startypeminuserrorstar
                                          op_startypeminuserrorstar del protocol
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                      voters)
                                    (fun operations =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar operations b)
                                        (fun b =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              (op_minus
                                                (Int32.to_int
                                                  op_startypeminuserrorstar) 1)
                                              b)
                                            (fun b =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | _ => return_unit
                                                  | _ =>
                                                    failwith
                                                      "%s - Unexpected period kind"
                                                        % string __LOC__
                                                  end)))))))))))).

Definition test_quorum_capped_minimum
  (num_delegates : Z) (function_parameter : unit)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult unit) :=
  let 'tt := function_parameter in
  let min_proposal_quorum := op_atat of_int (op_div 10000 num_delegates) in
  op_gtgteqquestion
    (op_startypeminuserrorstar min_proposal_quorum num_delegates)
    (fun function_parameter =>
      let '(b, delegates) := function_parameter in
      op_gtgteq
        (op_startypeminuserrorstar b
          (* ❌ Constant of type int32 is converted to int *)
          0)
        (fun b =>
          op_gtgteqquestion
            (op_startypeminuserrorstar op_startypeminuserrorstar)
            (fun function_parameter =>
              let '_ := function_parameter in
              op_gtgteqquestion
                (op_gtgteqquestion
                  (op_startypeminuserrorstar op_startypeminuserrorstar)
                  (fun function_parameter =>
                    match function_parameter with
                    | _ => return_unit
                    | _ =>
                      failwith "%s - Unexpected period kind" % string __LOC__
                    end))
                (fun function_parameter =>
                  let 'tt := function_parameter in
                  let protocol :=
                    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.zero)
                    in
                  let proposer := op_startypeminuserrorstar delegates 0 in
                  op_gtgteqquestion
                    (op_startypeminuserrorstar op_startypeminuserrorstar
                      proposer (cons protocol []))
                    (fun ops =>
                      op_gtgteqquestion
                        (op_startypeminuserrorstar (cons ops []) b)
                        (fun b =>
                          op_gtgteqquestion
                            (op_startypeminuserrorstar
                              (op_minus (Int32.to_int op_startypeminuserrorstar)
                                1) b)
                            (fun b =>
                              op_gtgteqquestion
                                (op_gtgteqquestion
                                  (op_startypeminuserrorstar
                                    op_startypeminuserrorstar)
                                  (fun function_parameter =>
                                    match function_parameter with
                                    | _ => return_unit
                                    | _ =>
                                      failwith
                                        "%s - Unexpected period kind" % string
                                        __LOC__
                                    end))
                                (fun function_parameter =>
                                  let 'tt := function_parameter in
                                  let minimum_to_pass :=
                                    op_pipegt
                                      (op_pipegt
                                        (op_startypeminuserrorstar
                                          (op_startypeminuserrorstar
                                            (op_startypeminuserrorstar
                                              (List.length delegates))
                                            (to_float op_startypeminuserrorstar))
                                          (* ❌ Float constant 100_00. is approximated by the integer 10000 *)
                                          10000) op_startypeminuserrorstar)
                                      op_startypeminuserrorstar in
                                  let voters :=
                                    op_startypeminuserrorstar minimum_to_pass
                                      delegates in
                                  op_gtgteqquestion
                                    (map_s
                                      (fun del =>
                                        op_startypeminuserrorstar
                                          op_startypeminuserrorstar del protocol
                                          Tezos_protocol_alpha.Protocol.Alpha_context.Vote.Yay)
                                      voters)
                                    (fun operations =>
                                      op_gtgteqquestion
                                        (op_startypeminuserrorstar operations b)
                                        (fun b =>
                                          op_gtgteqquestion
                                            (op_startypeminuserrorstar
                                              (op_minus
                                                (Int32.to_int
                                                  op_startypeminuserrorstar) 1)
                                              b)
                                            (fun b =>
                                              op_gtgteqquestion
                                                (op_startypeminuserrorstar
                                                  op_startypeminuserrorstar)
                                                (fun function_parameter =>
                                                  match function_parameter with
                                                  | _ => return_unit
                                                  | _ =>
                                                    failwith
                                                      "%s - Unexpected period kind"
                                                        % string __LOC__
                                                  end)))))))))))).

Definition tests {A : Type} : list A :=
  cons
    (op_startypeminuserrorstar "voting successful_vote" % string
      (* ❌ Variants not supported *)
      variant (test_successful_vote 137))
    (cons
      (op_startypeminuserrorstar
        "voting testing vote, not enough quorum" % string
        (* ❌ Variants not supported *)
        variant (test_not_enough_quorum_in_testing_vote 245))
      (cons
        (op_startypeminuserrorstar
          "voting promotion vote, not enough quorum" % string
          (* ❌ Variants not supported *)
          variant (test_not_enough_quorum_in_promotion_vote 432))
        (cons
          (op_startypeminuserrorstar "voting counting double proposal" % string
            (* ❌ Variants not supported *)
            variant test_multiple_identical_proposals_count_as_one)
          (cons
            (op_startypeminuserrorstar
              "voting proposal, with supermajority" % string
              (* ❌ Variants not supported *)
              variant (test_supermajority_in_proposal true))
            (cons
              (op_startypeminuserrorstar
                "voting proposal, without supermajority" % string
                (* ❌ Variants not supported *)
                variant (test_supermajority_in_proposal false))
              (cons
                (op_startypeminuserrorstar
                  "voting proposal, with quorum" % string
                  (* ❌ Variants not supported *)
                  variant (test_quorum_in_proposal true))
                (cons
                  (op_startypeminuserrorstar
                    "voting proposal, without quorum" % string
                    (* ❌ Variants not supported *)
                    variant (test_quorum_in_proposal false))
                  (cons
                    (op_startypeminuserrorstar
                      "voting testing vote, with supermajority" % string
                      (* ❌ Variants not supported *)
                      variant (test_supermajority_in_testing_vote true))
                    (cons
                      (op_startypeminuserrorstar
                        "voting testing vote, without supermajority" % string
                        (* ❌ Variants not supported *)
                        variant (test_supermajority_in_testing_vote false))
                      (cons
                        (op_startypeminuserrorstar
                          "voting proposal, no winning proposal" % string
                          (* ❌ Variants not supported *)
                          variant (test_no_winning_proposal 400))
                        (cons
                          (op_startypeminuserrorstar
                            "voting quorum, quorum capped maximum" % string
                            (* ❌ Variants not supported *)
                            variant (test_quorum_capped_maximum 400))
                          (cons
                            (op_startypeminuserrorstar
                              "voting quorum, quorum capped minimum" % string
                              (* ❌ Variants not supported *)
                              variant (test_quorum_capped_minimum 401)) [])))))))))))).

src/proto_alpha/lib_protocol/tez_repr.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Qty_repr.Make (struct
  let id = "tez"
end)

type t = qty

type tez = qty

let encoding = Data_encoding.def "mutez" @@ encoding
src/proto_alpha/lib_protocol/tez_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition t := qty.

Definition tez := qty.

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding qty :=
  op_atat
    (let arg := Data_encoding.def "mutez" % string in
    fun eta => arg None None eta) encoding.

src/proto_alpha/lib_protocol/time_repr.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

include Time

type time = t

type error += Timestamp_add (* `Permanent *)

type error += Timestamp_sub (* `Permanent *)

let () =
  register_error_kind
    `Permanent
    ~id:"timestamp_add"
    ~title:"Timestamp add"
    ~description:"Overflow when adding timestamps."
    ~pp:(fun ppf () -> Format.fprintf ppf "Overflow when adding timestamps.")
    Data_encoding.empty
    (function Timestamp_add -> Some () | _ -> None)
    (fun () -> Timestamp_add) ;
  register_error_kind
    `Permanent
    ~id:"timestamp_sub"
    ~title:"Timestamp sub"
    ~description:"Substracting timestamps resulted in negative period."
    ~pp:(fun ppf () ->
      Format.fprintf ppf "Substracting timestamps resulted in negative period.")
    Data_encoding.empty
    (function Timestamp_sub -> Some () | _ -> None)
    (fun () -> Timestamp_sub)

let of_seconds s = try Some (of_seconds (Int64.of_string s)) with _ -> None

let to_seconds = to_seconds

let to_seconds_string s = Int64.to_string (to_seconds s)

let pp = pp_hum

let ( +? ) x y =
  try ok (add x (Period_repr.to_seconds y)) with _exn -> error Timestamp_add

let ( -? ) x y = record_trace Timestamp_sub (Period_repr.of_seconds (diff x y))
src/proto_alpha/lib_protocol/time_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `include` not handled. *)
include

Definition time := t.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension



Definition of_seconds (s : string) : option t :=
  (* ❌ Try-with are not handled *)
  try (Some (of_seconds (Int64.of_string s))).

Definition to_seconds : t -> int64 := to_seconds.

Definition to_seconds_string (s : t) : string := Int64.to_string (to_seconds s).

Definition pp
  : Tezos_protocol_environment_alpha__Environment.Format.formatter -> t -> unit :=
  pp_hum.

Definition op_plusquestion
  (x : t) (y : Tezos_raw_protocol_alpha.Period_repr.period)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult t :=
  (* ❌ Try-with are not handled *)
  try (ok (add x (Period_repr.to_seconds y))).

Definition op_minusquestion (x : t) (y : t)
  : Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
    Tezos_raw_protocol_alpha.Period_repr.period :=
  record_trace
    Tezos_protocol_environment_alpha__Environment.Error_monad.Timestamp_sub
    (Period_repr.of_seconds (diff x y)).

src/proto_alpha/lib_protocol/vote_repr.ml 2 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type proposal = Protocol_hash.t

type ballot = Yay | Nay | Pass

let ballot_encoding =
  let of_int8 = function
    | 0 ->
        Yay
    | 1 ->
        Nay
    | 2 ->
        Pass
    | _ ->
        invalid_arg "ballot_of_int8"
  in
  let to_int8 = function Yay -> 0 | Nay -> 1 | Pass -> 2 in
  let open Data_encoding in
  (* union *)
  splitted
    ~binary:(conv to_int8 of_int8 int8)
    ~json:(string_enum [("yay", Yay); ("nay", Nay); ("pass", Pass)])
src/proto_alpha/lib_protocol/vote_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition proposal :=
  Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t).

Inductive ballot : Type :=
| Yay : ballot
| Nay : ballot
| Pass : ballot.

Definition ballot_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding ballot :=
  let of_int8 (function_parameter : Z) : ballot :=
    match function_parameter with
    | 0 => Yay
    | 1 => Nay
    | 2 => Pass
    | _ => invalid_arg "ballot_of_int8" % string
    end in
  let to_int8 (function_parameter : ballot) : Z :=
    match function_parameter with
    | Yay => 0
    | Nay => 1
    | Pass => 2
    end in
  splitted
    (string_enum
      (cons ("yay" % string, Yay)
        (cons ("nay" % string, Nay) (cons ("pass" % string, Pass) []))))
    (conv to_int8 of_int8 None int8).

src/proto_alpha/lib_protocol/vote_storage.ml 149 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let recorded_proposal_count_for_delegate ctxt proposer =
  Storage.Vote.Proposals_count.get_option ctxt proposer
  >>=? function None -> return 0 | Some count -> return count

let record_proposal ctxt proposal proposer =
  recorded_proposal_count_for_delegate ctxt proposer
  >>=? fun count ->
  Storage.Vote.Proposals_count.init_set ctxt proposer (count + 1)
  >>= fun ctxt ->
  Storage.Vote.Proposals.add ctxt (proposal, proposer)
  >>= fun ctxt -> return ctxt

let get_proposals ctxt =
  Storage.Vote.Proposals.fold
    ctxt
    ~init:(ok Protocol_hash.Map.empty)
    ~f:(fun (proposal, delegate) acc ->
      (* Assuming the same listings is used at votings *)
      Storage.Vote.Listings.get ctxt delegate
      >>=? fun weight ->
      Lwt.return
        ( acc
        >>? fun acc ->
        let previous =
          match Protocol_hash.Map.find_opt proposal acc with
          | None ->
              0l
          | Some x ->
              x
        in
        ok (Protocol_hash.Map.add proposal (Int32.add weight previous) acc) ))

let clear_proposals ctxt =
  Storage.Vote.Proposals_count.clear ctxt
  >>= fun ctxt -> Storage.Vote.Proposals.clear ctxt

type ballots = {yay : int32; nay : int32; pass : int32}

let ballots_encoding =
  let open Data_encoding in
  conv
    (fun {yay; nay; pass} -> (yay, nay, pass))
    (fun (yay, nay, pass) -> {yay; nay; pass})
  @@ obj3 (req "yay" int32) (req "nay" int32) (req "pass" int32)

let has_recorded_ballot = Storage.Vote.Ballots.mem

let record_ballot = Storage.Vote.Ballots.init

let get_ballots ctxt =
  Storage.Vote.Ballots.fold
    ctxt
    ~f:(fun delegate ballot (ballots : ballots tzresult) ->
      (* Assuming the same listings is used at votings *)
      Storage.Vote.Listings.get ctxt delegate
      >>=? fun weight ->
      let count = Int32.add weight in
      Lwt.return
        ( ballots
        >>? fun ballots ->
        match ballot with
        | Yay ->
            ok {ballots with yay = count ballots.yay}
        | Nay ->
            ok {ballots with nay = count ballots.nay}
        | Pass ->
            ok {ballots with pass = count ballots.pass} ))
    ~init:(ok {yay = 0l; nay = 0l; pass = 0l})

let get_ballot_list = Storage.Vote.Ballots.bindings

let clear_ballots = Storage.Vote.Ballots.clear

let listings_encoding =
  Data_encoding.(
    list
      (obj2 (req "pkh" Signature.Public_key_hash.encoding) (req "rolls" int32)))

let freeze_listings ctxt =
  Roll_storage.fold ctxt (ctxt, 0l) ~f:(fun _roll delegate (ctxt, total) ->
      (* TODO use snapshots *)
      let delegate = Signature.Public_key.hash delegate in
      Storage.Vote.Listings.get_option ctxt delegate
      >>=? (function None -> return 0l | Some count -> return count)
      >>=? fun count ->
      Storage.Vote.Listings.init_set ctxt delegate (Int32.succ count)
      >>= fun ctxt -> return (ctxt, Int32.succ total))
  >>=? fun (ctxt, total) ->
  Storage.Vote.Listings_size.init ctxt total >>=? fun ctxt -> return ctxt

let listing_size = Storage.Vote.Listings_size.get

let in_listings = Storage.Vote.Listings.mem

let get_listings = Storage.Vote.Listings.bindings

let clear_listings ctxt =
  Storage.Vote.Listings.clear ctxt
  >>= fun ctxt ->
  Storage.Vote.Listings_size.remove ctxt >>= fun ctxt -> return ctxt

let get_current_period_kind = Storage.Vote.Current_period_kind.get

let set_current_period_kind = Storage.Vote.Current_period_kind.set

let get_current_quorum ctxt =
  Storage.Vote.Participation_ema.get ctxt
  >>=? fun participation_ema ->
  let quorum_min = Constants_storage.quorum_min ctxt in
  let quorum_max = Constants_storage.quorum_max ctxt in
  let quorum_diff = Int32.sub quorum_max quorum_min in
  return
    Int32.(add quorum_min (div (mul participation_ema quorum_diff) 100_00l))

let get_participation_ema = Storage.Vote.Participation_ema.get

let set_participation_ema = Storage.Vote.Participation_ema.set

let get_current_proposal = Storage.Vote.Current_proposal.get

let init_current_proposal = Storage.Vote.Current_proposal.init

let clear_current_proposal = Storage.Vote.Current_proposal.delete

let init ctxt =
  (* participation EMA is in centile of a percentage *)
  let participation_ema = Constants_storage.quorum_max ctxt in
  Storage.Vote.Participation_ema.init ctxt participation_ema
  >>=? fun ctxt ->
  Storage.Vote.Current_period_kind.init ctxt Proposal
  >>=? fun ctxt -> return ctxt
src/proto_alpha/lib_protocol/vote_storage.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition recorded_proposal_count_for_delegate
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
  (proposer : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.value) :=
  op_gtgteqquestion (Storage.Vote.Proposals_count.get_option ctxt proposer)
    (fun function_parameter =>
      match function_parameter with
      | None => _return 0
      | Some count => _return count
      end).

Definition record_proposal
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
  (proposal :
    Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))
  (proposer : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.key)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion (recorded_proposal_count_for_delegate ctxt proposer)
    (fun count =>
      op_gtgteq
        (Storage.Vote.Proposals_count.init_set ctxt proposer (op_plus count 1))
        (fun ctxt =>
          op_gtgteq (Storage.Vote.Proposals.add ctxt (proposal, proposer))
            (fun ctxt => _return ctxt))).

Definition get_proposals
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)) :=
  Storage.Vote.Proposals.fold ctxt (ok Protocol_hash.Map.empty)
    (fun function_parameter =>
      let '(proposal, delegate) := function_parameter in
      fun acc =>
        op_gtgteqquestion (Storage.Vote.Listings.get ctxt delegate)
          (fun weight =>
            Lwt._return
              (op_gtgtquestion acc
                (fun acc =>
                  let previous :=
                    match Protocol_hash.Map.find_opt proposal acc with
                    | None =>
                      (* ❌ Constant of type int32 is converted to int *)
                      0
                    | Some x => x
                    end in
                  ok
                    (Protocol_hash.Map.add proposal (Int32.add weight previous)
                      acc))))).

Definition clear_proposals
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Proposals_count.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    Tezos_raw_protocol_alpha.Raw_context.t :=
  op_gtgteq (Storage.Vote.Proposals_count.clear ctxt)
    (fun ctxt => Storage.Vote.Proposals.clear ctxt).

Record ballots := {
  yay : int32;
  nay : int32;
  pass : int32 }.

Definition ballots_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding ballots :=
  op_atat
    (let arg :=
      conv
        (fun function_parameter =>
          let '{| yay := yay; nay := nay; pass := pass |} := function_parameter
            in
          (yay, nay, pass))
        (fun function_parameter =>
          let '(yay, nay, pass) := function_parameter in
          {| yay := yay; nay := nay; pass := pass |}) in
    fun eta => arg None eta)
    (obj3 (req None None "yay" % string int32)
      (req None None "nay" % string int32) (req None None "pass" % string int32)).

Definition has_recorded_ballot
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Storage.Vote.Ballots.mem.

Definition record_ballot
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key ->
      Tezos_raw_protocol_alpha.Storage.Vote.Ballots.value ->
        Tezos_protocol_environment_alpha__Environment.Lwt.t
          (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
            Tezos_raw_protocol_alpha.Raw_context.t) := Storage.Vote.Ballots.init.

Definition get_ballots
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult ballots) :=
  Storage.Vote.Ballots.fold ctxt
    (ok
      {|
        yay :=
          (* ❌ Constant of type int32 is converted to int *)
          0;
        nay :=
          (* ❌ Constant of type int32 is converted to int *)
          0;
        pass :=
          (* ❌ Constant of type int32 is converted to int *)
          0 |})
    (fun delegate =>
      fun ballot =>
        fun ballots =>
          op_gtgteqquestion (Storage.Vote.Listings.get ctxt delegate)
            (fun weight =>
              let count := Int32.add weight in
              Lwt._return
                (op_gtgtquestion ballots
                  (fun ballots =>
                    match ballot with
                    | Tezos_raw_protocol_alpha.Vote_repr.Yay =>
                      ok
                        (* ❌ Record substitution not handled *)
                        record_substitution
                    | Tezos_raw_protocol_alpha.Vote_repr.Nay =>
                      ok
                        (* ❌ Record substitution not handled *)
                        record_substitution
                    | Tezos_raw_protocol_alpha.Vote_repr.Pass =>
                      ok
                        (* ❌ Record substitution not handled *)
                        record_substitution
                    end)))).

Definition get_ballot_list
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list
        (Tezos_raw_protocol_alpha.Storage.Vote.Ballots.key *
          Tezos_raw_protocol_alpha.Storage.Vote.Ballots.value)) :=
  Storage.Vote.Ballots.bindings.

Definition clear_ballots
  : Tezos_raw_protocol_alpha.Storage.Vote.Ballots.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      Tezos_raw_protocol_alpha.Raw_context.t := Storage.Vote.Ballots.clear.

Definition listings_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding
    (list
      (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
        * int32)) :=
  list None
    (obj2 (req None None "pkh" % string Signature.Public_key_hash.encoding)
      (req None None "rolls" % string int32)).

Definition freeze_listings (ctxt : Tezos_raw_protocol_alpha.Raw_context.t)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteqquestion
    (Roll_storage.fold ctxt
      (fun _roll =>
        fun delegate =>
          fun function_parameter =>
            let '(ctxt, total) := function_parameter in
            let delegate := Signature.Public_key.hash delegate in
            op_gtgteqquestion
              (op_gtgteqquestion
                (Storage.Vote.Listings.get_option ctxt delegate)
                (fun function_parameter =>
                  match function_parameter with
                  | None =>
                    _return
                      (* ❌ Constant of type int32 is converted to int *)
                      0
                  | Some count => _return count
                  end))
              (fun count =>
                op_gtgteq
                  (Storage.Vote.Listings.init_set ctxt delegate
                    (Int32.succ count))
                  (fun ctxt => _return (ctxt, (Int32.succ total)))))
      (ctxt,
        (* ❌ Constant of type int32 is converted to int *)
        0))
    (fun function_parameter =>
      let '(ctxt, total) := function_parameter in
      op_gtgteqquestion (Storage.Vote.Listings_size.init ctxt total)
        (fun ctxt => _return ctxt)).

Definition listing_size
  : Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Listings_size.value) :=
  Storage.Vote.Listings_size.get.

Definition in_listings
  : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Listings.key ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t bool :=
  Storage.Vote.Listings.mem.

Definition get_listings
  : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (list
        (Tezos_raw_protocol_alpha.Storage.Vote.Listings.key *
          Tezos_raw_protocol_alpha.Storage.Vote.Listings.value)) :=
  Storage.Vote.Listings.bindings.

Definition clear_listings
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Listings.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  op_gtgteq (Storage.Vote.Listings.clear ctxt)
    (fun ctxt =>
      op_gtgteq (Storage.Vote.Listings_size.remove ctxt)
        (fun ctxt => _return ctxt)).

Definition get_current_period_kind
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.value) :=
  Storage.Vote.Current_period_kind.get.

Definition set_current_period_kind
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Current_period_kind.value ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Vote.Current_period_kind.set.

Definition get_current_quorum
  (ctxt : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult int32) :=
  op_gtgteqquestion (Storage.Vote.Participation_ema.get ctxt)
    (fun participation_ema =>
      let quorum_min := Constants_storage.quorum_min ctxt in
      let quorum_max := Constants_storage.quorum_max ctxt in
      let quorum_diff := Int32.sub quorum_max quorum_min in
      _return
        (add quorum_min
          (div (mul participation_ema quorum_diff)
            (* ❌ Constant of type int32 is converted to int *)
            10000))).

Definition get_participation_ema
  : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.value) :=
  Storage.Vote.Participation_ema.get.

Definition set_participation_ema
  : Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Participation_ema.value ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Vote.Participation_ema.set.

Definition get_current_proposal
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.value) :=
  Storage.Vote.Current_proposal.get.

Definition init_current_proposal
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
    Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.value ->
      Tezos_protocol_environment_alpha__Environment.Lwt.t
        (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
          Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Vote.Current_proposal.init.

Definition clear_current_proposal
  : Tezos_raw_protocol_alpha.Storage.Vote.Current_proposal.context ->
    Tezos_protocol_environment_alpha__Environment.Lwt.t
      (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
        Tezos_raw_protocol_alpha.Raw_context.t) :=
  Storage.Vote.Current_proposal.delete.

Definition init (ctxt : Tezos_raw_protocol_alpha.Raw_context.context)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.tzresult
      Tezos_raw_protocol_alpha.Raw_context.t) :=
  let participation_ema := Constants_storage.quorum_max ctxt in
  op_gtgteqquestion (Storage.Vote.Participation_ema.init ctxt participation_ema)
    (fun ctxt =>
      op_gtgteqquestion
        (Storage.Vote.Current_period_kind.init ctxt
          Tezos_raw_protocol_alpha.Voting_period_repr.Proposal)
        (fun ctxt => _return ctxt)).

src/proto_alpha/lib_protocol/voting_period_repr.ml 7 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type t = int32

type voting_period = t

include (Compare.Int32 : Compare.S with type t := t)

let encoding = Data_encoding.int32

let pp ppf level = Format.fprintf ppf "%ld" level

let rpc_arg =
  let construct voting_period = Int32.to_string voting_period in
  let destruct str =
    match Int32.of_string str with
    | exception _ ->
        Error "Cannot parse voting period"
    | voting_period ->
        Ok voting_period
  in
  RPC_arg.make
    ~descr:"A voting period"
    ~name:"voting_period"
    ~construct
    ~destruct
    ()

let root = 0l

let succ = Int32.succ

let to_int32 l = l

let of_int32_exn l =
  if Compare.Int32.(l >= 0l) then l
  else invalid_arg "Voting_period_repr.of_int32"

type kind = Proposal | Testing_vote | Testing | Promotion_vote

let kind_encoding =
  let open Data_encoding in
  union
    ~tag_size:`Uint8
    [ case
        (Tag 0)
        ~title:"Proposal"
        (constant "proposal")
        (function Proposal -> Some () | _ -> None)
        (fun () -> Proposal);
      case
        (Tag 1)
        ~title:"Testing_vote"
        (constant "testing_vote")
        (function Testing_vote -> Some () | _ -> None)
        (fun () -> Testing_vote);
      case
        (Tag 2)
        ~title:"Testing"
        (constant "testing")
        (function Testing -> Some () | _ -> None)
        (fun () -> Testing);
      case
        (Tag 3)
        ~title:"Promotion_vote"
        (constant "promotion_vote")
        (function Promotion_vote -> Some () | _ -> None)
        (fun () -> Promotion_vote) ]
src/proto_alpha/lib_protocol/voting_period_repr.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition t := int32.

Definition voting_period := t.

(* ❌ Structure item `include` not handled. *)
include

Definition encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding int32 :=
  Data_encoding.int32.

Definition pp
  (ppf : Tezos_protocol_environment_alpha__Environment.Format.formatter)
  (level : int32) : unit :=
  Format.fprintf ppf
    (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Format
      (Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int32
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.Int_d
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_padding
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.No_precision
        Tezos_protocol_environment_alpha__Environment.CamlinternalFormatBasics.End_of_format)
      "%ld" % string) level.

Definition rpc_arg
  : Tezos_protocol_environment_alpha__Environment.RPC_arg.arg int32 :=
  let construct (voting_period : int32) : string :=
    Int32.to_string voting_period in
  let destruct (str : string)
    : Tezos_protocol_environment_alpha__Environment.Pervasives.result int32
      string :=
    let 'voting_period := Int32.of_string str in
    Tezos_protocol_environment_alpha__Environment.Pervasives.Ok voting_period in
  RPC_arg.make (Some "A voting period" % string) "voting_period" % string
    destruct construct tt.

Definition root : int32 :=
  (* ❌ Constant of type int32 is converted to int *)
  0.

Definition succ : int32 -> int32 := Int32.succ.

Definition to_int32 {A : Type} (l : A) : A := l.

Definition of_int32_exn
  (l :
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t))
  : Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.t) :=
  if
    Tezos_protocol_environment_alpha__Environment.Compare.Int32.(Tezos_protocol_environment_alpha__Environment.S.Compare.op_gteq)
      l
      (* ❌ Constant of type int32 is converted to int *)
      0 then
    l
  else
    invalid_arg "Voting_period_repr.of_int32" % string.

Inductive kind : Type :=
| Proposal : kind
| Testing_vote : kind
| Testing : kind
| Promotion_vote : kind.

Definition kind_encoding
  : Tezos_protocol_environment_alpha__Environment.Data_encoding.encoding kind :=
  union
    (Some
      (* ❌ Variants not supported *)
      variant)
    (cons
      (case "Proposal" % string None
        (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 0)
        (constant "proposal" % string)
        (fun function_parameter =>
          match function_parameter with
          | Proposal => Some tt
          | _ => None
          end)
        (fun function_parameter =>
          let 'tt := function_parameter in
          Proposal))
      (cons
        (case "Testing_vote" % string None
          (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 1)
          (constant "testing_vote" % string)
          (fun function_parameter =>
            match function_parameter with
            | Testing_vote => Some tt
            | _ => None
            end)
          (fun function_parameter =>
            let 'tt := function_parameter in
            Testing_vote))
        (cons
          (case "Testing" % string None
            (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 2)
            (constant "testing" % string)
            (fun function_parameter =>
              match function_parameter with
              | Testing => Some tt
              | _ => None
              end)
            (fun function_parameter =>
              let 'tt := function_parameter in
              Testing))
          (cons
            (case "Promotion_vote" % string None
              (Tezos_protocol_environment_alpha__Environment.Data_encoding.Tag 3)
              (constant "promotion_vote" % string)
              (fun function_parameter =>
                match function_parameter with
                | Promotion_vote => Some tt
                | _ => None
                end)
              (fun function_parameter =>
                let 'tt := function_parameter in
                Promotion_vote)) [])))).

src/proto_alpha/lib_protocol/voting_services.ml 128 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Alpha_context

module S = struct
  let path = RPC_path.(open_root / "votes")

  let ballots =
    RPC_service.get_service
      ~description:"Sum of ballots casted so far during a voting period."
      ~query:RPC_query.empty
      ~output:Vote.ballots_encoding
      RPC_path.(path / "ballots")

  let ballot_list =
    RPC_service.get_service
      ~description:"Ballots casted so far during a voting period."
      ~query:RPC_query.empty
      ~output:
        Data_encoding.(
          list
            (obj2
               (req "pkh" Signature.Public_key_hash.encoding)
               (req "ballot" Vote.ballot_encoding)))
      RPC_path.(path / "ballot_list")

  let current_period_kind =
    RPC_service.get_service
      ~description:"Current period kind."
      ~query:RPC_query.empty
      ~output:Voting_period.kind_encoding
      RPC_path.(path / "current_period_kind")

  let current_quorum =
    RPC_service.get_service
      ~description:"Current expected quorum."
      ~query:RPC_query.empty
      ~output:Data_encoding.int32
      RPC_path.(path / "current_quorum")

  let listings =
    RPC_service.get_service
      ~description:
        "List of delegates with their voting weight, in number of rolls."
      ~query:RPC_query.empty
      ~output:Vote.listings_encoding
      RPC_path.(path / "listings")

  let proposals =
    RPC_service.get_service
      ~description:"List of proposals with number of supporters."
      ~query:RPC_query.empty
      ~output:(Protocol_hash.Map.encoding Data_encoding.int32)
      RPC_path.(path / "proposals")

  let current_proposal =
    RPC_service.get_service
      ~description:"Current proposal under evaluation."
      ~query:RPC_query.empty
      ~output:(Data_encoding.option Protocol_hash.encoding)
      RPC_path.(path / "current_proposal")
end

let register () =
  let open Services_registration in
  register0 S.ballots (fun ctxt () () -> Vote.get_ballots ctxt) ;
  register0 S.ballot_list (fun ctxt () () -> Vote.get_ballot_list ctxt >|= ok) ;
  register0 S.current_period_kind (fun ctxt () () ->
      Vote.get_current_period_kind ctxt) ;
  register0 S.current_quorum (fun ctxt () () -> Vote.get_current_quorum ctxt) ;
  register0 S.proposals (fun ctxt () () -> Vote.get_proposals ctxt) ;
  register0 S.listings (fun ctxt () () -> Vote.get_listings ctxt >|= ok) ;
  register0 S.current_proposal (fun ctxt () () ->
      (* this would be better implemented using get_option in get_current_proposal *)
      Vote.get_current_proposal ctxt
      >>= function
      | Ok p ->
          return_some p
      | Error (Raw_context.Storage_error (Missing_key _) :: _) ->
          return_none
      | Error _ as e ->
          Lwt.return e)

let ballots ctxt block = RPC_context.make_call0 S.ballots ctxt block () ()

let ballot_list ctxt block =
  RPC_context.make_call0 S.ballot_list ctxt block () ()

let current_period_kind ctxt block =
  RPC_context.make_call0 S.current_period_kind ctxt block () ()

let current_quorum ctxt block =
  RPC_context.make_call0 S.current_quorum ctxt block () ()

let listings ctxt block = RPC_context.make_call0 S.listings ctxt block () ()

let proposals ctxt block = RPC_context.make_call0 S.proposals ctxt block () ()

let current_proposal ctxt block =
  RPC_context.make_call0 S.current_proposal ctxt block () ()
src/proto_alpha/lib_protocol/voting_services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Alpha_context.

Module S.
  Definition path
    : Tezos_protocol_environment_alpha__Environment.RPC_path.path
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context :=
    op_div open_root "votes" % string.
  
  Definition ballots
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots :=
    RPC_service.get_service
      (Some "Sum of ballots casted so far during a voting period." % string)
      RPC_query.empty Vote.ballots_encoding (op_div path "ballots" % string).
  
  Definition ballot_list
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot)) :=
    RPC_service.get_service
      (Some "Ballots casted so far during a voting period." % string)
      RPC_query.empty
      (list None
        (obj2 (req None None "pkh" % string Signature.Public_key_hash.encoding)
          (req None None "ballot" % string Vote.ballot_encoding)))
      (op_div path "ballot_list" % string).
  
  Definition current_period_kind
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind :=
    RPC_service.get_service (Some "Current period kind." % string)
      RPC_query.empty Voting_period.kind_encoding
      (op_div path "current_period_kind" % string).
  
  Definition current_quorum
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit int32 :=
    RPC_service.get_service (Some "Current expected quorum." % string)
      RPC_query.empty Data_encoding.int32
      (op_div path "current_quorum" % string).
  
  Definition listings
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * int32)) :=
    RPC_service.get_service
      (Some
        "List of delegates with their voting weight, in number of rolls." %
          string) RPC_query.empty Vote.listings_encoding
      (op_div path "listings" % string).
  
  Definition proposals
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32) :=
    RPC_service.get_service
      (Some "List of proposals with number of supporters." % string)
      RPC_query.empty (Protocol_hash.Map.encoding Data_encoding.int32)
      (op_div path "proposals" % string).
  
  Definition current_proposal
    : Tezos_protocol_environment_alpha__Environment.RPC_service.service variant
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context
      Tezos_protocol_environment_alpha__Environment.Updater.rpc_context unit
      unit
      (option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t)) :=
    RPC_service.get_service (Some "Current proposal under evaluation." % string)
      RPC_query.empty
      (Data_encoding.option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.encoding))
      (op_div path "current_proposal" % string).
End S.

Definition register (function_parameter : unit) : unit :=
  let 'tt := function_parameter in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.ballots
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            Vote.get_ballots ctxt) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.ballot_list
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtpipeeq (Vote.get_ballot_list ctxt) ok) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.current_period_kind
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            Vote.get_current_period_kind ctxt) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.current_quorum
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            Vote.get_current_quorum ctxt) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.proposals
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            Vote.get_proposals ctxt) in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    register0 S.listings
      (fun ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let 'tt := function_parameter in
            op_gtpipeeq (Vote.get_listings ctxt) ok) in
  register0 S.current_proposal
    (fun ctxt =>
      fun function_parameter =>
        let 'tt := function_parameter in
        fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteq (Vote.get_current_proposal ctxt)
            (fun function_parameter =>
              match function_parameter with
              | Tezos_protocol_environment_alpha__Environment.Pervasives.Ok p =>
                return_some p
              |
                Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                  (cons
                    (Tezos_protocol_environment_alpha__Environment.Error_monad.Storage_error
                      (Tezos_raw_protocol_alpha.Raw_context.Missing_key _ _)) _)
                => return_none
              |
                (Tezos_protocol_environment_alpha__Environment.Pervasives.Error
                  _) as e => Lwt._return e
              end)).

Definition ballots {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Vote.ballots) :=
  RPC_context.make_call0 S.ballots ctxt block tt tt.

Definition ballot_list {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * Tezos_raw_protocol_alpha.Alpha_context.Vote.ballot))) :=
  RPC_context.make_call0 S.ballot_list ctxt block tt tt.

Definition current_period_kind {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      Tezos_raw_protocol_alpha.Alpha_context.Voting_period.kind) :=
  RPC_context.make_call0 S.current_period_kind ctxt block tt tt.

Definition current_quorum {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      int32) := RPC_context.make_call0 S.current_quorum ctxt block tt tt.

Definition listings {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (list
        (Tezos_protocol_environment_alpha__Environment.Signature.Public_key_hash.t
          * int32))) := RPC_context.make_call0 S.listings ctxt block tt tt.

Definition proposals {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (Tezos_protocol_environment_alpha__Environment.Protocol_hash.Map.t int32)) :=
  RPC_context.make_call0 S.proposals ctxt block tt tt.

Definition current_proposal {D E G I K L a b c i o q : Type}
  (ctxt :
    ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
      Tezos_protocol_environment_alpha__Environment.RPC_context.t
      Tezos_protocol_environment_alpha__Environment.RPC_context.t q i o) ->
      D ->
        q ->
          i ->
            Tezos_protocol_environment_alpha__Environment.Lwt.t
              (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                o)) * (E * q * i * o)) *
      ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
        Tezos_protocol_environment_alpha__Environment.RPC_context.t
        (Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) q i o)
        ->
        D ->
          a ->
            q ->
              i ->
                Tezos_protocol_environment_alpha__Environment.Lwt.t
                  (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                    o)) * (G * a * q * i * o)) *
        ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t variant
          Tezos_protocol_environment_alpha__Environment.RPC_context.t
          ((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a) * b)
          q i o) ->
          D ->
            a ->
              b ->
                q ->
                  i ->
                    Tezos_protocol_environment_alpha__Environment.Lwt.t
                      (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                        o)) * (I * a * b * q * i * o)) *
          ((((Tezos_protocol_environment_alpha__Environment.RPC_service.t
            variant Tezos_protocol_environment_alpha__Environment.RPC_context.t
            (((Tezos_protocol_environment_alpha__Environment.RPC_context.t * a)
              * b) * c) q i o) ->
            D ->
              a ->
                b ->
                  c ->
                    q ->
                      i ->
                        Tezos_protocol_environment_alpha__Environment.Lwt.t
                          (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
                            o)) * (K * a * b * c * q * i * o)) * L)))) * L * D)
  (block : D)
  : Tezos_protocol_environment_alpha__Environment.Lwt.t
    (Tezos_protocol_environment_alpha__Environment.Error_monad.shell_tzresult
      (option
        Tezos_protocol_environment_alpha__Environment.Protocol_hash.(Tezos_protocol_environment_alpha__Environment.HASH.S.t))) :=
  RPC_context.make_call0 S.current_proposal ctxt block tt tt.

src/proto_demo_noops/lib_protocol/main.ml 17 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

let max_block_length = 100

let max_operation_data_length = 0

let validation_passes = []

let acceptable_passes _op = []

type block_header_data = string

let block_header_data_encoding =
  Data_encoding.(obj1 (req "block_header_data" string))

type block_header = {
  shell : Block_header.shell_header;
  protocol_data : block_header_data;
}

type block_header_metadata = unit

let block_header_metadata_encoding = Data_encoding.unit

type operation_data = unit

let operation_data_encoding = Data_encoding.unit

type operation_receipt = unit

let operation_receipt_encoding = Data_encoding.unit

let operation_data_and_receipt_encoding =
  Data_encoding.conv
    (function ((), ()) -> ())
    (fun () -> ((), ()))
    Data_encoding.unit

type operation = {
  shell : Operation.shell_header;
  protocol_data : operation_data;
}

let compare_operations _ _ = 0

type validation_state = {context : Context.t; fitness : Fitness.t}

let current_context {context; _} = return context

let begin_application ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_fitness (raw_block : block_header) =
  let fitness = raw_block.shell.fitness in
  Logging.log_notice
    "begin_application: pred_fitness = %a  block_fitness = %a%!"
    Fitness.pp
    predecessor_fitness
    Fitness.pp
    fitness ;
  (* Note: Logging is only available for debugging purposes and should
     not appear in a real protocol. *)
  return {context; fitness}

let begin_partial_application ~chain_id ~ancestor_context
    ~predecessor_timestamp ~predecessor_fitness block_header =
  Logging.log_notice "begin_partial_application%!" ;
  begin_application
    ~chain_id
    ~predecessor_context:ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    block_header

let version_number = "\001"

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i ; b

let fitness_from_level level =
  [MBytes.of_string version_number; int64_to_bytes level]

let begin_construction ~chain_id:_ ~predecessor_context:context
    ~predecessor_timestamp:_ ~predecessor_level ~predecessor_fitness
    ~predecessor:_ ~timestamp:_ ?protocol_data () =
  let fitness = fitness_from_level Int64.(succ (of_int32 predecessor_level)) in
  let mode =
    match protocol_data with Some _ -> "block" | None -> "mempool"
  in
  Logging.log_notice
    "begin_construction (%s): pred_fitness = %a  constructed fitness = %a%!"
    mode
    Fitness.pp
    predecessor_fitness
    Fitness.pp
    fitness ;
  return {context; fitness}

let apply_operation _state _op = Lwt.return (Error [])

let finalize_block state =
  let fitness = state.fitness in
  Logging.log_notice "finalize_block: fitness = %a%!" Fitness.pp fitness ;
  return
    ( {
        Updater.message = None;
        context = state.context;
        fitness;
        max_operations_ttl = 0;
        last_allowed_fork_level = 0l;
      },
      () )

let init context block_header =
  let open Block_header in
  let fitness = block_header.fitness in
  Logging.log_notice "init: fitness = %a%!" Fitness.pp fitness ;
  return
    {
      Updater.message = None;
      context;
      fitness;
      max_operations_ttl = 0;
      last_allowed_fork_level = 0l;
    }

let rpc_services = RPC_directory.empty
src/proto_demo_noops/lib_protocol/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Definition max_block_length : Z := 100.

Definition max_operation_data_length : Z := 0.

Definition validation_passes {A : Type} : list A := [].

Definition acceptable_passes {A B : Type} (_op : A) : list B := [].

Definition block_header_data := string.

Definition block_header_data_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    string := obj1 (req None None "block_header_data" % string string).

Record block_header := {
  shell :
    Tezos_protocol_environment_demo_noops__Environment.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_metadata := unit.

Definition block_header_metadata_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    unit := Data_encoding.unit.

Definition operation_data := unit.

Definition operation_data_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    unit := Data_encoding.unit.

Definition operation_receipt := unit.

Definition operation_receipt_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    unit := Data_encoding.unit.

Definition operation_data_and_receipt_encoding
  : Tezos_protocol_environment_demo_noops__Environment.Data_encoding.encoding
    (unit * unit) :=
  Data_encoding.conv
    (fun function_parameter =>
      let '(tt, tt) := function_parameter in
      tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      (tt, tt)) None Data_encoding.unit.

Record operation := {
  shell :
    Tezos_protocol_environment_demo_noops__Environment.Operation.shell_header;
  protocol_data : operation_data }.

Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    0.

Record validation_state := {
  context : Tezos_protocol_environment_demo_noops__Environment.Context.t;
  fitness :
    Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
  }.

Definition current_context (function_parameter : validation_state)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      Tezos_protocol_environment_demo_noops__Environment.Context.t) :=
  let '{| context := context |} := function_parameter in
  _return context.

Definition begin_application {A B : Type} (function_parameter : A)
  : Tezos_protocol_environment_demo_noops__Environment.Context.t ->
    B ->
      Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
        ->
        block_header ->
          Tezos_protocol_environment_demo_noops__Environment.Lwt.t
            (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
              validation_state) :=
  let '_ := function_parameter in
  fun context =>
    fun function_parameter =>
      let '_ := function_parameter in
      fun predecessor_fitness =>
        fun raw_block =>
          let fitness := fitness (shell raw_block) in
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            Logging.log_notice
              (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
                (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
                  "begin_application: pred_fitness = " % string
                  (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
                    (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
                      "  block_fitness = " % string
                      (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
                        (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
                          Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))))
                "begin_application: pred_fitness = %a  block_fitness = %a%!" %
                  string)
              Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
              predecessor_fitness
              Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
              fitness in
          _return {| context := context; fitness := fitness |}.

Definition begin_partial_application {A B : Type}
  (chain_id : A)
  (ancestor_context :
    Tezos_protocol_environment_demo_noops__Environment.Context.t)
  (predecessor_timestamp : B)
  (predecessor_fitness :
    Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t))
  (block_header : block_header)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      validation_state) :=
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Logging.log_notice
      (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
          "begin_partial_application" % string
          (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
            Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format))
        "begin_partial_application%!" % string) in
  begin_application chain_id ancestor_context predecessor_timestamp
    predecessor_fitness block_header.

Definition version_number : string := "" % string.

Definition int64_to_bytes (i : int64)
  : Tezos_protocol_environment_demo_noops__Environment.MBytes.t :=
  let b := MBytes.create 8 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := MBytes.set_int64 b 0 i in
  b.

Definition fitness_from_level (level : int64)
  : list Tezos_protocol_environment_demo_noops__Environment.MBytes.t :=
  cons (MBytes.of_string version_number) (cons (int64_to_bytes level) []).

Definition begin_construction {A B C D E : Type} (function_parameter : A)
  : Tezos_protocol_environment_demo_noops__Environment.Context.t ->
    B ->
      int32 ->
        Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.t)
          ->
          C ->
            D ->
              (option E) ->
                unit ->
                  Tezos_protocol_environment_demo_noops__Environment.Lwt.t
                    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
                      validation_state) :=
  let '_ := function_parameter in
  fun context =>
    fun function_parameter =>
      let '_ := function_parameter in
      fun predecessor_level =>
        fun predecessor_fitness =>
          fun function_parameter =>
            let '_ := function_parameter in
            fun function_parameter =>
              let '_ := function_parameter in
              fun protocol_data =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  let fitness :=
                    fitness_from_level (succ (of_int32 predecessor_level)) in
                  let mode :=
                    match protocol_data with
                    | Some _ => "block" % string
                    | None => "mempool" % string
                    end in
                  (* ❌ Sequences of instructions are not handled (operator ";") *)
                  let _ :=
                    Logging.log_notice
                      (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
                        (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
                          "begin_construction (" % string
                          (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String
                            Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.No_padding
                            (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
                              "): pred_fitness = " % string
                              (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
                                (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
                                  "  constructed fitness = " % string
                                  (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
                                    (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
                                      Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))))))
                        "begin_construction (%s): pred_fitness = %a  constructed fitness = %a%!"
                          % string) mode
                      Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
                      predecessor_fitness
                      Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
                      fitness in
                  _return {| context := context; fitness := fitness |}.

Definition apply_operation {A B C D : Type} (_state : A) (_op : B)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Pervasives.result C
      (list D)) :=
  Lwt._return
    (Tezos_protocol_environment_demo_noops__Environment.Pervasives.Error []).

Definition finalize_block (state : validation_state)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      (Tezos_protocol_environment_demo_noops__Environment.Updater.validation_result
        * unit)) :=
  let fitness := fitness state in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Logging.log_notice
      (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
          "finalize_block: fitness = " % string
          (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
            (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
              Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))
        "finalize_block: fitness = %a%!" % string)
      Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
      fitness in
  _return
    ({| Updater.context := context state; Updater.fitness := fitness;
      Updater.message := None; Updater.max_operations_ttl := 0;
      Updater.last_allowed_fork_level :=
        (* ❌ Constant of type int32 is converted to int *)
        0 |}, tt).

Definition init
  (context : Tezos_protocol_environment_demo_noops__Environment.Context.t)
  (block_header :
    Tezos_protocol_environment_demo_noops__Environment.Block_header.shell_header)
  : Tezos_protocol_environment_demo_noops__Environment.Lwt.t
    (Tezos_protocol_environment_demo_noops__Environment.Error_monad.tzresult
      Tezos_protocol_environment_demo_noops__Environment.Updater.validation_result) :=
  let fitness := fitness block_header in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ :=
    Logging.log_notice
      (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Format
        (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.String_literal
          "init: fitness = " % string
          (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Alpha
            (Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.Flush
              Tezos_protocol_environment_demo_noops__Environment.CamlinternalFormatBasics.End_of_format)))
        "init: fitness = %a%!" % string)
      Tezos_protocol_environment_demo_noops__Environment.Fitness.(Tezos_protocol_environment_demo_noops__Environment.T.S.pp)
      fitness in
  _return
    {| Updater.context := context; Updater.fitness := fitness;
      Updater.message := None; Updater.max_operations_ttl := 0;
      Updater.last_allowed_fork_level :=
        (* ❌ Constant of type int32 is converted to int *)
        0 |}.

Definition rpc_services {A : Type}
  : Tezos_protocol_environment_demo_noops__Environment.RPC_directory.directory A :=
  RPC_directory.empty.

src/proto_genesis/lib_client/client_proto_main.ml 45 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Protocol
open Protocol_client_context

let protocol =
  Protocol_hash.of_b58check_exn
    "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im"

let bake cctxt ?timestamp block command sk =
  let timestamp =
    match timestamp with
    | Some t ->
        t
    | None ->
        Time.System.(to_protocol (Tezos_stdlib_unix.Systime_os.now ()))
  in
  let protocol_data = {command; signature = Signature.zero} in
  Genesis_block_services.Helpers.Preapply.block
    cctxt
    ~block
    ~timestamp
    ~protocol_data
    []
  >>=? fun (shell_header, _) ->
  let blk = Data.Command.forge shell_header command in
  Shell_services.Chain.chain_id cctxt ~chain:`Main ()
  >>=? fun chain_id ->
  Client_keys.append cctxt sk ~watermark:(Block_header chain_id) blk
  >>=? fun signed_blk -> Shell_services.Injection.block cctxt signed_blk []

let int64_parameter =
  Clic.parameter (fun _ p ->
      try return (Int64.of_string p) with _ -> failwith "Cannot read int64")

let file_parameter =
  Clic.parameter (fun _ p ->
      if not (Sys.file_exists p) then failwith "File doesn't exist: '%s'" p
      else return p)

let fitness_from_int64 fitness =
  (* definition taken from src/proto_alpha/lib_protocol/src/constants_repr.ml *)
  let version_number = "\000" in
  (* definitions taken from src/proto_alpha/lib_protocol/src/fitness_repr.ml *)
  let int64_to_bytes i =
    let b = Bytes.create 8 in
    TzEndian.set_int64 b 0 i ; b
  in
  [Bytes.of_string version_number; int64_to_bytes fitness]

let timestamp_arg =
  Clic.arg
    ~long:"timestamp"
    ~placeholder:"date"
    ~doc:"Set the timestamp of the block (and initial time of the chain)"
    (Clic.parameter (fun _ t ->
         match Time.System.of_notation_opt t with
         | None ->
             Error_monad.failwith
               "Could not parse value provided to -timestamp option"
         | Some t ->
             return t))

let test_delay_arg =
  Clic.default_arg
    ~long:"delay"
    ~placeholder:"time"
    ~doc:"Set the life span of the test chain (in seconds)"
    ~default:(Int64.to_string (Int64.mul 24L 3600L))
    (Clic.parameter (fun _ t ->
         match Int64.of_string_opt t with
         | None ->
             Error_monad.failwith
               "Could not parse value provided to -delay option"
         | Some t ->
             return t))

let proto_param ~name ~desc t =
  Clic.param
    ~name
    ~desc
    (Clic.parameter (fun _ str -> Lwt.return (Protocol_hash.of_b58check str)))
    t

let commands () =
  let open Clic in
  let args =
    args1
      (arg
         ~long:"timestamp"
         ~placeholder:"date"
         ~doc:"Set the timestamp of the block (and initial time of the chain)"
         (parameter (fun _ t ->
              match Time.Protocol.of_notation t with
              | None ->
                  Error_monad.failwith
                    "Could not parse value provided to -timestamp option"
              | Some t ->
                  return t)))
  in
  [ command
      ~desc:"Activate a protocol"
      args
      ( prefixes ["activate"; "protocol"]
      @@ proto_param ~name:"version" ~desc:"Protocol version (b58check)"
      @@ prefixes ["with"; "fitness"]
      @@ param
           ~name:"fitness"
           ~desc:"Hardcoded fitness of the first block (integer)"
           int64_parameter
      @@ prefixes ["and"; "key"]
      @@ Client_keys.Secret_key.source_param
           ~name:"password"
           ~desc:"Activator's key"
      @@ prefixes ["and"; "parameters"]
      @@ param
           ~name:"parameters"
           ~desc:"Protocol parameters (as JSON file)"
           file_parameter
      @@ stop )
      (fun timestamp
           hash
           fitness
           sk
           param_json_file
           (cctxt : Client_context.full) ->
        let fitness = fitness_from_int64 fitness in
        Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file
        >>=? fun json ->
        let protocol_parameters =
          Data_encoding.Binary.to_bytes_exn Data_encoding.json json
        in
        bake
          cctxt
          ?timestamp
          cctxt#block
          (Activate {protocol = hash; fitness; protocol_parameters})
          sk
        >>=? fun hash ->
        cctxt#answer "Injected %a" Block_hash.pp_short hash
        >>= fun () -> return_unit);
    command
      ~desc:"Fork a test protocol"
      (args2 timestamp_arg test_delay_arg)
      ( prefixes ["fork"; "test"; "protocol"]
      @@ proto_param ~name:"version" ~desc:"Protocol version (b58check)"
      @@ prefixes ["with"; "fitness"]
      @@ param
           ~name:"fitness"
           ~desc:
             "Hardcoded fitness of the first block of the testchain (integer)"
           int64_parameter
      @@ prefixes ["and"; "key"]
      @@ Client_keys.Secret_key.source_param
           ~name:"password"
           ~desc:"Activator's key"
      @@ prefixes ["and"; "parameters"]
      @@ param
           ~name:"parameters"
           ~desc:"Testchain protocol parameters (as JSON file)"
           file_parameter
      @@ stop )
      (fun (timestamp, delay) hash fitness sk param_json_file cctxt ->
        let fitness = fitness_from_int64 fitness in
        Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file param_json_file
        >>=? fun json ->
        let protocol_parameters =
          Data_encoding.Binary.to_bytes_exn Data_encoding.json json
        in
        let timestamp = Option.map ~f:Time.System.to_protocol timestamp in
        bake
          cctxt
          ?timestamp
          cctxt#block
          (Activate_testchain
             {protocol = hash; fitness; protocol_parameters; delay})
          sk
        >>=? fun hash ->
        cctxt#answer "Injected %a" Block_hash.pp_short hash
        >>= fun () -> return_unit) ]

let () = Client_commands.register protocol @@ fun _network -> commands ()
src/proto_genesis/lib_client/client_proto_main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Import Protocol.

Import Protocol_client_context.

Definition protocol : Tezos_base__TzPervasives.Protocol_hash.t :=
  Protocol_hash.of_b58check_exn
    "ProtoGenesisGenesisGenesisGenesisGenesisGenesk612im" % string.

Definition bake {E G a i o p q : Type}
  (cctxt :
    ((((Tezos_rpc.RPC_service.t variant unit p q i o) ->
      p -> q -> i -> Lwt.t (Tezos_error_monad.Error_monad.tzresult o)) *
      (E * p * q * i * o)) *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * G))))))
      *
      (((string ->
        a ->
          (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
            Lwt.t (Tezos_base__TzPervasives.tzresult a)) * (a)) *
        ((option (Lwt_stream.t string)) *
          ((string -> Lwt.t (Tezos_base__TzPervasives.tzresult string)) *
            ((((unit -> Lwt.t a) -> Lwt.t a) * (a)) *
              (((string ->
                a ->
                  (Tezos_base__TzPervasives.Data_encoding.encoding a) ->
                    Lwt.t (Tezos_base__TzPervasives.tzresult unit)) * (a)) * G))))))
  (timestamp : option Tezos_base__TzPervasives.Time.Protocol.t)
  (block : Tezos_shell_services__Block_services.block)
  (command : Tezos_raw_protocol_genesis.Data.Command.t)
  (sk : Tezos_client_base.Client_keys.sk_uri)
  : Lwt.t
    (Tezos_base__TzPervasives.tzresult Tezos_base__TzPervasives.Block_hash.t) :=
  let timestamp :=
    match timestamp with
    | Some t => t
    | None => to_protocol (Tezos_stdlib_unix.Systime_os.now tt)
    end in
  let protocol_data := {| command := command; signature := Signature.zero |} in
  op_gtgteqquestion
    (Genesis_block_services.Helpers.Preapply.block cctxt None (Some block) None
      (Some timestamp) protocol_data [])
    (fun function_parameter =>
      let '(shell_header, _) := function_parameter in
      let blk := Data.Command.forge shell_header command in
      op_gtgteqquestion
        (Shell_services.Chain.chain_id cctxt
          (Some
            (* ❌ Variants not supported *)
            variant) tt)
        (fun chain_id =>
          op_gtgteqquestion
            (Client_keys.append cctxt
              (Some (Tezos_base__TzPervasives.Signature.Block_header chain_id))
              sk blk)
            (fun signed_blk =>
              Shell_services.Injection.block cctxt None None None signed_blk []))).

Definition int64_parameter
  : Tezos_base__TzPervasives.Clic.parameter int64
    Tezos_client_base.Client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun p =>
        (* ❌ Try-with are not handled *)
        try (_return (Int64.of_string p))).

Definition file_parameter
  : Tezos_base__TzPervasives.Clic.parameter string
    Tezos_client_base.Client_context.full :=
  Clic.parameter None
    (fun function_parameter =>
      let '_ := function_parameter in
      fun p =>
        if negb (Sys.file_exists p) then
          failwith
            (CamlinternalFormatBasics.Format
              (CamlinternalFormatBasics.String_literal
                "File doesn't exist: '" % string
                (CamlinternalFormatBasics.String
                  CamlinternalFormatBasics.No_padding
                  (CamlinternalFormatBasics.Char_literal "'" % char
                    CamlinternalFormatBasics.End_of_format)))
              "File doesn't exist: '%s'" % string) p
        else
          _return p).

Definition fitness_from_int64 (fitness : int64) : list string :=
  let version_number := "" % string in
  let int64_to_bytes (i : int64) : string :=
    let b := Stdlib.Bytes.create 8 in
    (* ❌ Sequences of instructions are not handled (operator ";") *)
    let _ := TzEndian.set_int64 b 0 i in
    b in
  cons (Stdlib.Bytes.of_string version_number)
    (cons (int64_to_bytes fitness) []).

Definition timestamp_arg
  : Tezos_base__TzPervasives.Clic.arg
    (option Tezos_base__TzPervasives.Time.System.t)
    Tezos_client_base.Client_context.full :=
  Clic.arg
    "Set the timestamp of the block (and initial time of the chain)" % string
    None "timestamp" % string "date" % string
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun t =>
          match Time.System.of_notation_opt t with
          | None =>
            Error_monad.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Could not parse value provided to -timestamp option" % string
                  CamlinternalFormatBasics.End_of_format)
                "Could not parse value provided to -timestamp option" % string)
          | Some t => _return t
          end)).

Definition test_delay_arg
  : Tezos_base__TzPervasives.Clic.arg int64
    Tezos_client_base.Client_context.full :=
  Clic.default_arg "Set the life span of the test chain (in seconds)" % string
    None "delay" % string "time" % string
    (Int64.to_string
      (Int64.mul
        (* ❌ Constant of type int64 is converted to int *)
        24
        (* ❌ Constant of type int64 is converted to int *)
        3600))
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun t =>
          match Int64.of_string_opt t with
          | None =>
            Error_monad.failwith
              (CamlinternalFormatBasics.Format
                (CamlinternalFormatBasics.String_literal
                  "Could not parse value provided to -delay option" % string
                  CamlinternalFormatBasics.End_of_format)
                "Could not parse value provided to -delay option" % string)
          | Some t => _return t
          end)).

Definition proto_param {A B : Type}
  (name : string) (desc : string) (t : Tezos_base__TzPervasives.Clic.params A B)
  : Tezos_base__TzPervasives.Clic.params
    (Tezos_base__TzPervasives.Protocol_hash.t -> A) B :=
  Clic.param name desc
    (Clic.parameter None
      (fun function_parameter =>
        let '_ := function_parameter in
        fun str => Lwt._return (Protocol_hash.of_b58check str))) t.

Definition commands (function_parameter : unit)
  : list
    (Tezos_base__TzPervasives.Clic.command Tezos_client_base.Client_context.full) :=
  let 'tt := function_parameter in
  let args :=
    args1
      (arg
        "Set the timestamp of the block (and initial time of the chain)" %
          string None "timestamp" % string "date" % string
        (parameter None
          (fun function_parameter =>
            let '_ := function_parameter in
            fun t =>
              match Time.Protocol.of_notation t with
              | None =>
                Error_monad.failwith
                  (CamlinternalFormatBasics.Format
                    (CamlinternalFormatBasics.String_literal
                      "Could not parse value provided to -timestamp option" %
                        string CamlinternalFormatBasics.End_of_format)
                    "Could not parse value provided to -timestamp option" %
                      string)
              | Some t => _return t
              end))) in
  cons
    (command None "Activate a protocol" % string args
      (apply (prefixes (cons "activate" % string (cons "protocol" % string [])))
        (apply
          (proto_param "version" % string "Protocol version (b58check)" % string)
          (apply (prefixes (cons "with" % string (cons "fitness" % string [])))
            (apply
              (param "fitness" % string
                "Hardcoded fitness of the first block (integer)" % string
                int64_parameter)
              (apply (prefixes (cons "and" % string (cons "key" % string [])))
                (apply
                  (Client_keys.Secret_key.source_param
                    (Some "password" % string) (Some "Activator's key" % string))
                  (apply
                    (prefixes
                      (cons "and" % string (cons "parameters" % string [])))
                    (apply
                      (param "parameters" % string
                        "Protocol parameters (as JSON file)" % string
                        file_parameter) stop))))))))
      (fun timestamp =>
        fun hash =>
          fun fitness =>
            fun sk =>
              fun param_json_file =>
                fun cctxt =>
                  let fitness := fitness_from_int64 fitness in
                  op_gtgteqquestion
                    (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
                      param_json_file)
                    (fun json =>
                      let protocol_parameters :=
                        Data_encoding.Binary.to_bytes_exn Data_encoding.json
                          json in
                      op_gtgteqquestion
                        (bake cctxt timestamp
                          (* ❌ Sending method message is not handled *)
                          send
                          (Tezos_raw_protocol_genesis.Data.Command.Activate
                            {| protocol := hash; fitness := fitness;
                              protocol_parameters := protocol_parameters |}) sk)
                        (fun hash =>
                          op_gtgteq
                            ((* ❌ Sending method message is not handled *)
                            send
                              (CamlinternalFormatBasics.Format
                                (CamlinternalFormatBasics.String_literal
                                  "Injected " % string
                                  (CamlinternalFormatBasics.Alpha
                                    CamlinternalFormatBasics.End_of_format))
                                "Injected %a" % string) Block_hash.pp_short hash)
                            (fun function_parameter =>
                              let 'tt := function_parameter in
                              return_unit)))))
    (cons
      (command None "Fork a test protocol" % string
        (args2 timestamp_arg test_delay_arg)
        (apply
          (prefixes
            (cons "fork" % string
              (cons "test" % string (cons "protocol" % string []))))
          (apply
            (proto_param "version" % string
              "Protocol version (b58check)" % string)
            (apply
              (prefixes (cons "with" % string (cons "fitness" % string [])))
              (apply
                (param "fitness" % string
                  "Hardcoded fitness of the first block of the testchain (integer)"
                    % string int64_parameter)
                (apply (prefixes (cons "and" % string (cons "key" % string [])))
                  (apply
                    (Client_keys.Secret_key.source_param
                      (Some "password" % string)
                      (Some "Activator's key" % string))
                    (apply
                      (prefixes
                        (cons "and" % string (cons "parameters" % string [])))
                      (apply
                        (param "parameters" % string
                          "Testchain protocol parameters (as JSON file)" %
                            string file_parameter) stop))))))))
        (fun function_parameter =>
          let '(timestamp, delay) := function_parameter in
          fun hash =>
            fun fitness =>
              fun sk =>
                fun param_json_file =>
                  fun cctxt =>
                    let fitness := fitness_from_int64 fitness in
                    op_gtgteqquestion
                      (Tezos_stdlib_unix.Lwt_utils_unix.Json.read_file
                        param_json_file)
                      (fun json =>
                        let protocol_parameters :=
                          Data_encoding.Binary.to_bytes_exn Data_encoding.json
                            json in
                        let timestamp :=
                          Option.map Time.System.to_protocol timestamp in
                        op_gtgteqquestion
                          (bake cctxt timestamp
                            (* ❌ Sending method message is not handled *)
                            send
                            (Tezos_raw_protocol_genesis.Data.Command.Activate_testchain
                              {| protocol := hash; fitness := fitness;
                                protocol_parameters := protocol_parameters;
                                delay := delay |}) sk)
                          (fun hash =>
                            op_gtgteq
                              ((* ❌ Sending method message is not handled *)
                              send
                                (CamlinternalFormatBasics.Format
                                  (CamlinternalFormatBasics.String_literal
                                    "Injected " % string
                                    (CamlinternalFormatBasics.Alpha
                                      CamlinternalFormatBasics.End_of_format))
                                  "Injected %a" % string) Block_hash.pp_short
                                hash)
                              (fun function_parameter =>
                                let 'tt := function_parameter in
                                return_unit))))) []).



src/proto_genesis/lib_client/protocol_client_context.ml 1 error
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Genesis_block_services = Block_services.Make (Protocol) (Protocol)
src/proto_genesis/lib_client/protocol_client_context.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Applications of functors are not handled. *)
functor_application

src/proto_genesis/lib_protocol/data.ml 16 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Command = struct

  type t =
    (* Activate a protocol *)
    | Activate of {
        protocol: Protocol_hash.t ;
        fitness: Fitness.t ;
        protocol_parameters : MBytes.t ;
      }

    (* Activate a protocol as a testchain *)
    | Activate_testchain of {
        protocol: Protocol_hash.t ;
        fitness: Fitness.t ;
        protocol_parameters : MBytes.t ;
        delay: Int64.t ;
      }

  let mk_case name args =
    let open Data_encoding in
    conv
      (fun o -> ((), o))
      (fun ((), o) -> o)
      (merge_objs
         (obj1 (req "command" (constant name)))
         args)

  let encoding =
    let open Data_encoding in
    union ~tag_size:`Uint8 [
      case (Tag 0)
        ~title:"Activate"
        (mk_case "activate"
           (obj3
              (req "hash" Protocol_hash.encoding)
              (req "fitness" Fitness.encoding)
              (req "protocol_parameters" Variable.bytes)
           ))
        (function
          | Activate { protocol ; fitness ; protocol_parameters} ->
              Some (protocol, fitness, protocol_parameters)
          | _ -> None)
        (fun (protocol, fitness, protocol_parameters) ->
           Activate { protocol ; fitness ; protocol_parameters }) ;
      case (Tag 1)
        ~title:"Activate_testchain"
        (mk_case "activate_testchain"
           (obj4
              (req "hash" Protocol_hash.encoding)
              (req "fitness" Fitness.encoding)
              (req "protocol_parameters" Variable.bytes)
              (req "validity_time" int64)))
        (function
          | Activate_testchain { protocol ; fitness ; protocol_parameters ; delay } ->
              Some (protocol, fitness, protocol_parameters, delay)
          | _ -> None)
        (fun (protocol, fitness, protocol_parameters, delay) ->
           Activate_testchain { protocol ; fitness ; protocol_parameters ; delay }) ;
    ]

  let signed_encoding =
    let open Data_encoding in
    obj2
      (req "content" encoding)
      (req "signature" Signature.encoding)

  let forge shell command =
    Data_encoding.Binary.to_bytes_exn
      (Data_encoding.tup2 Block_header.shell_header_encoding encoding)
      (shell, command)

end

module Pubkey = struct

  let pubkey_key = ["genesis_key"]

  let default =
    Signature.Public_key.of_b58check_exn
      "edpkvVCdQtDJHPnkmfRZuuHWKzFetH9N9nGP8F7zkwM2BJpjbvAU1N"

  let get_pubkey ctxt =
    Context.get ctxt pubkey_key >>= function
    | None -> Lwt.return default
    | Some b ->
        match Data_encoding.Binary.of_bytes Signature.Public_key.encoding b with
        | None -> Lwt.return default
        | Some pk -> Lwt.return pk

  let set_pubkey ctxt v =
    Context.set ctxt pubkey_key @@
    Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding v

  let sandbox_encoding =
    let open Data_encoding in
    merge_objs
      (obj1 (req "genesis_pubkey" Signature.Public_key.encoding))
      Data_encoding.unit

  let may_change_default ctxt json =
    match Data_encoding.Json.destruct sandbox_encoding json with
    | exception _ ->
        Lwt.return ctxt
    | (pubkey, ()) ->
        set_pubkey ctxt pubkey >>= fun ctxt ->
        Lwt.return ctxt

end

module Init = struct

  type error += Incompatible_protocol_version

  let version_key = ["version"]

  (* This key should always be populated for every version of the
     protocol.  It's absence meaning that the context is empty. *)
  let version_value = "genesis"

  let check_inited ctxt =
    Context.get ctxt version_key >>= function
    | None -> failwith "Internal error: uninitialized context."
    | Some version ->
        if Compare.String.(version_value <> MBytes.to_string version) then
          failwith "Internal error: incompatible protocol version" ;
        return_unit

  let tag_first_block ctxt =
    Context.get ctxt version_key >>= function
    | None ->
        Context.set
          ctxt version_key (MBytes.of_string version_value) >>= fun ctxt ->
        return ctxt
    | Some _version ->
        failwith "Internal error: previously initialized context." ;

end
src/proto_genesis/lib_protocol/data.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Command.
  Inductive t : Type :=
  | Activate :
    Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
    -> Tezos_protocol_environment_genesis__Environment.MBytes.t -> t
  | Activate_testchain :
    Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
    ->
    Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
    -> Tezos_protocol_environment_genesis__Environment.MBytes.t ->
    Tezos_protocol_environment_genesis__Environment.Int64.t -> t.
  
  Definition mk_case {A : Type}
    (name : string)
    (args :
      Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding A)
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding A :=
    conv (fun o => (tt, o))
      (fun function_parameter =>
        let '(tt, o) := function_parameter in
        o) None
      (merge_objs (obj1 (req None None "command" % string (constant name))) args).
  
  Definition encoding
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding t :=
    union
      (Some
        (* ❌ Variants not supported *)
        variant)
      (cons
        (case "Activate" % string None
          (Tezos_protocol_environment_genesis__Environment.Data_encoding.Tag 0)
          (mk_case "activate" % string
            (obj3
              (req None None "hash" % string
                Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
              (req None None "fitness" % string
                Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
              (req None None "protocol_parameters" % string Variable.bytes)))
          (fun function_parameter =>
            match function_parameter with
            |
              Activate {|
                protocol := protocol;
                  fitness := fitness;
                  protocol_parameters := protocol_parameters
                  |} => Some (protocol, fitness, protocol_parameters)
            | _ => None
            end)
          (fun function_parameter =>
            let '(protocol, fitness, protocol_parameters) := function_parameter
              in
            Activate
              {| protocol := protocol; fitness := fitness;
                protocol_parameters := protocol_parameters |}))
        (cons
          (case "Activate_testchain" % string None
            (Tezos_protocol_environment_genesis__Environment.Data_encoding.Tag 1)
            (mk_case "activate_testchain" % string
              (obj4
                (req None None "hash" % string
                  Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
                (req None None "fitness" % string
                  Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
                (req None None "protocol_parameters" % string Variable.bytes)
                (req None None "validity_time" % string int64)))
            (fun function_parameter =>
              match function_parameter with
              |
                Activate_testchain {|
                  protocol := protocol;
                    fitness := fitness;
                    protocol_parameters := protocol_parameters;
                    delay := delay
                    |} => Some (protocol, fitness, protocol_parameters, delay)
              | _ => None
              end)
            (fun function_parameter =>
              let '(protocol, fitness, protocol_parameters, delay) :=
                function_parameter in
              Activate_testchain
                {| protocol := protocol; fitness := fitness;
                  protocol_parameters := protocol_parameters; delay := delay |}))
          [])).
  
  Definition signed_encoding
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
      (t * Tezos_protocol_environment_genesis__Environment.Signature.t) :=
    obj2 (req None None "content" % string encoding)
      (req None None "signature" % string Signature.encoding).
  
  Definition forge
    (shell :
      Tezos_protocol_environment_genesis__Environment.Block_header.shell_header)
    (command : t) : Tezos_protocol_environment_genesis__Environment.MBytes.t :=
    Data_encoding.Binary.to_bytes_exn
      (Data_encoding.tup2 Block_header.shell_header_encoding encoding)
      (shell, command).
End Command.

Module Pubkey.
  Definition pubkey_key : list string := cons "genesis_key" % string [].
  
  Definition default
    : Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t :=
    Signature.Public_key.of_b58check_exn
      "edpkvVCdQtDJHPnkmfRZuuHWKzFetH9N9nGP8F7zkwM2BJpjbvAU1N" % string.
  
  Definition get_pubkey
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t :=
    op_gtgteq (Context.get ctxt pubkey_key)
      (fun function_parameter =>
        match function_parameter with
        | None => Lwt._return default
        | Some b =>
          match Data_encoding.Binary.of_bytes Signature.Public_key.encoding b
            with
          | None => Lwt._return default
          | Some pk => Lwt._return pk
          end
        end).
  
  Definition set_pubkey
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    (v : Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      Tezos_protocol_environment_genesis__Environment.Context.t :=
    op_atat (Context.set ctxt pubkey_key)
      (Data_encoding.Binary.to_bytes_exn Signature.Public_key.encoding v).
  
  Definition sandbox_encoding
    : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
      (Tezos_protocol_environment_genesis__Environment.Signature.Public_key.t *
        unit) :=
    merge_objs
      (obj1
        (req None None "genesis_pubkey" % string Signature.Public_key.encoding))
      Data_encoding.unit.
  
  Definition may_change_default
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    (json : Tezos_protocol_environment_genesis__Environment.Data_encoding.json)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      Tezos_protocol_environment_genesis__Environment.Context.t :=
    let '(pubkey, tt) := Data_encoding.Json.destruct sandbox_encoding json in
    op_gtgteq (set_pubkey ctxt pubkey) (fun ctxt => Lwt._return ctxt).
End Pubkey.

Module Init.
  (* ❌ Structure item `typext` not handled. *)
  type_extension
  
  Definition version_key : list string := cons "version" % string [].
  
  Definition version_value : string := "genesis" % string.
  
  Definition check_inited
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult unit) :=
    op_gtgteq (Context.get ctxt version_key)
      (fun function_parameter =>
        match function_parameter with
        | None => failwith "Internal error: uninitialized context." % string
        | Some version =>
          (* ❌ Sequences of instructions are not handled (operator ";") *)
          let _ :=
            if
              Tezos_protocol_environment_genesis__Environment.Compare.String.(Tezos_protocol_environment_genesis__Environment.S.Compare.op_ltgt)
                version_value (MBytes.to_string version) then
              failwith "Internal error: incompatible protocol version" % string
            else
              tt in
          return_unit
        end).
  
  Definition tag_first_block
    (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
    : Tezos_protocol_environment_genesis__Environment.Lwt.t
      (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
        Tezos_protocol_environment_genesis__Environment.Context.t) :=
    op_gtgteq (Context.get ctxt version_key)
      (fun function_parameter =>
        match function_parameter with
        | None =>
          op_gtgteq
            (Context.set ctxt version_key (MBytes.of_string version_value))
            (fun ctxt => _return ctxt)
        | Some _version =>
          failwith "Internal error: previously initialized context." % string
        end).
End Init.

src/proto_genesis/lib_protocol/main.ml 22 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type error += Parsing_error
type error += Invalid_signature

let () =
  register_error_kind
    `Permanent
    ~id:"parsing_error"
    ~title:"Parsing error"
    ~description:"Raised when a block header has not been parsed correctly"
    ~pp:(fun ppf () -> Format.fprintf ppf "Block header parsing error")
    Data_encoding.empty
    (function Parsing_error -> Some () | _ -> None)
    (fun () -> Parsing_error)

let () =
  register_error_kind
    `Permanent
    ~id:"invalid_signature"
    ~title:"Invalid signature"
    ~description:"Raised when the provided signature is invalid"
    ~pp:(fun ppf () -> Format.fprintf ppf "Invalid signature")
    Data_encoding.empty
    (function Invalid_signature -> Some () | _ -> None)
    (fun () -> Invalid_signature)

type operation_data = unit
let operation_data_encoding = Data_encoding.unit

type operation_receipt = unit
let operation_receipt_encoding = Data_encoding.unit

let operation_data_and_receipt_encoding =
  Data_encoding.conv
    (function ((), ()) -> ())
    (fun () -> ((), ()))
    Data_encoding.unit

type operation = {
  shell: Operation.shell_header ;
  protocol_data: operation_data ;
}

let acceptable_passes _op = []
let compare_operations _ _ = 0
let validation_passes = []

type block_header_data = {
  command: Data.Command.t ;
  signature: Signature.t ;
}
type block_header = {
  shell: Block_header.shell_header ;
  protocol_data: block_header_data ;
}

let block_header_data_encoding =
  Data_encoding.conv
    (fun { command ; signature } -> (command, signature))
    (fun (command, signature) ->  { command ; signature })
    Data.Command.signed_encoding

type block_header_metadata = unit
let block_header_metadata_encoding = Data_encoding.unit

let max_block_length =
  Data_encoding.Binary.length
    Data.Command.encoding
    (Activate_testchain { protocol = Protocol_hash.zero ;
                          fitness = [ MBytes.create 1 ] ;
                          protocol_parameters = MBytes.create 1 ;
                          delay = 0L })
  + Signature.size

let max_operation_data_length = 0

let check_signature ctxt ~chain_id { shell ; protocol_data = { command ; signature } } =
  let bytes = Data.Command.forge shell command in
  Data.Pubkey.get_pubkey ctxt >>= fun public_key ->
  fail_unless
    (Signature.check ~watermark:(Block_header chain_id) public_key signature bytes)
    Invalid_signature

type validation_state = Updater.validation_result

let current_context ({ context ; _ } : validation_state) =
  return context

(* temporary hardcoded key to be removed... *)
let protocol_parameters_key = [ "protocol_parameters" ]

let prepare_application ctxt command level timestamp _fitness =
  match command with
  | Data.Command.Activate { protocol = hash ; fitness ; protocol_parameters } ->
      let message =
        Some (Format.asprintf "activate %a" Protocol_hash.pp_short hash) in
      Context.set ctxt protocol_parameters_key protocol_parameters >>= fun ctxt ->
      Updater.activate ctxt hash >>= fun ctxt ->
      return { Updater.message ; context = ctxt ;
               fitness ; max_operations_ttl = 0 ;
               last_allowed_fork_level = level ;
             }
  | Activate_testchain { protocol = hash ; fitness ; protocol_parameters ; delay } ->
      let message =
        Some (Format.asprintf "activate testchain %a" Protocol_hash.pp_short hash) in
      Context.set ctxt protocol_parameters_key protocol_parameters >>= fun ctxt ->
      let expiration = Time.add timestamp delay in
      Updater.fork_test_chain ctxt ~protocol:hash ~expiration >>= fun ctxt ->
      return { Updater.message ; context = ctxt ; fitness ;
               max_operations_ttl = 0 ;
               last_allowed_fork_level = level ;
             }

let begin_application
    ~chain_id
    ~predecessor_context:ctxt
    ~predecessor_timestamp:_
    ~predecessor_fitness:_
    block_header =
  Data.Init.check_inited ctxt >>=? fun () ->
  check_signature ctxt ~chain_id block_header >>=? fun () ->
  prepare_application ctxt block_header.protocol_data.command
    block_header.shell.level block_header.shell.timestamp block_header.shell.fitness

let begin_partial_application
    ~chain_id
    ~ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    block_header =
  begin_application
    ~chain_id
    ~predecessor_context:ancestor_context
    ~predecessor_timestamp
    ~predecessor_fitness
    block_header

let begin_construction
    ~chain_id:_
    ~predecessor_context:ctxt
    ~predecessor_timestamp:_
    ~predecessor_level:level
    ~predecessor_fitness:fitness
    ~predecessor:_
    ~timestamp
    ?protocol_data
    () =
  match protocol_data with
  | None ->
      (* Dummy result. *)
      return { Updater.message = None ; context = ctxt ;
               fitness ; max_operations_ttl = 0 ;
               last_allowed_fork_level = 0l ;
             }
  | Some { command ; _ }->
      Data.Init.check_inited ctxt >>=? fun () ->
      prepare_application ctxt command level timestamp fitness

let apply_operation _vctxt _ =
  failwith "genesis.apply_operation" (* absurd *)

let finalize_block state = return (state, ())

let rpc_services = Services.rpc_services

(* temporary hardcoded key to be removed... *)
let sandbox_param_key = [ "sandbox_parameter" ]
let get_sandbox_param ctxt =
  Context.get ctxt sandbox_param_key >>= function
  | None -> return_none
  | Some bytes ->
      match Data_encoding.Binary.of_bytes Data_encoding.json bytes with
      | None ->
          failwith "Internal error: failed to parse the sandbox parameter."
      | Some json -> return_some json

let init ctxt block_header =
  Data.Init.tag_first_block ctxt >>=? fun ctxt ->
  get_sandbox_param ctxt >>=? fun sandbox_param ->
  begin
    match sandbox_param with
    | None -> return ctxt
    | Some json ->
        Data.Pubkey.may_change_default ctxt json >>= fun ctxt ->
        return ctxt
  end >>=? fun ctxt ->
  return { Updater.message = None ; context = ctxt ;
           fitness = block_header.Block_header.fitness ;
           max_operations_ttl = 0 ;
           last_allowed_fork_level = block_header.level ;
         }
src/proto_genesis/lib_protocol/main.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

(* ❌ Structure item `typext` not handled. *)
type_extension

(* ❌ Structure item `typext` not handled. *)
type_extension





Definition operation_data := unit.

Definition operation_data_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
  Data_encoding.unit.

Definition operation_receipt := unit.

Definition operation_receipt_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
  Data_encoding.unit.

Definition operation_data_and_receipt_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
    (unit * unit) :=
  Data_encoding.conv
    (fun function_parameter =>
      let '(tt, tt) := function_parameter in
      tt)
    (fun function_parameter =>
      let 'tt := function_parameter in
      (tt, tt)) None Data_encoding.unit.

Record operation := {
  shell : Tezos_protocol_environment_genesis__Environment.Operation.shell_header;
  protocol_data : operation_data }.

Definition acceptable_passes {A B : Type} (_op : A) : list B := [].

Definition compare_operations {A B : Type} (function_parameter : A) : B -> Z :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    0.

Definition validation_passes {A : Type} : list A := [].

Record block_header_data := {
  command : Tezos_raw_protocol_genesis.Data.Command.t;
  signature : Tezos_protocol_environment_genesis__Environment.Signature.t }.

Record block_header := {
  shell :
    Tezos_protocol_environment_genesis__Environment.Block_header.shell_header;
  protocol_data : block_header_data }.

Definition block_header_data_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding
    block_header_data :=
  Data_encoding.conv
    (fun function_parameter =>
      let '{| command := command; signature := signature |} :=
        function_parameter in
      (command, signature))
    (fun function_parameter =>
      let '(command, signature) := function_parameter in
      {| command := command; signature := signature |}) None
    Data.Command.signed_encoding.

Definition block_header_metadata := unit.

Definition block_header_metadata_encoding
  : Tezos_protocol_environment_genesis__Environment.Data_encoding.encoding unit :=
  Data_encoding.unit.

Definition max_block_length : Z :=
  op_plus
    (Data_encoding.Binary.length Data.Command.encoding
      (Tezos_raw_protocol_genesis.Data.Command.Activate_testchain
        {|
          protocol :=
            Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.zero);
          fitness := cons (MBytes.create 1) [];
          protocol_parameters := MBytes.create 1;
          delay :=
            (* ❌ Constant of type int64 is converted to int *)
            0 |})) Signature.size.

Definition max_operation_data_length : Z := 0.

Definition check_signature
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (chain_id :
    Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
  (function_parameter : block_header)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult unit) :=
  let '{|
    shell := shell;
      protocol_data := {| command := command; signature := signature |}
      |} := function_parameter in
  let bytes := Data.Command.forge shell command in
  op_gtgteq (Data.Pubkey.get_pubkey ctxt)
    (fun public_key =>
      fail_unless
        (Signature.check
          (Some
            (Tezos_protocol_environment_genesis__Environment.Signature.Block_header
              chain_id)) public_key signature string)
        Tezos_protocol_environment_genesis__Environment.Error_monad.Invalid_signature).

Definition validation_state :=
  Tezos_protocol_environment_genesis__Environment.Updater.validation_result.

Definition current_context (function_parameter : validation_state)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Context.t) :=
  let '{| context := context |} := function_parameter in
  _return context.

Definition protocol_parameters_key : list string :=
  cons "protocol_parameters" % string [].

Definition prepare_application {A : Type}
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (command : Tezos_raw_protocol_genesis.Data.Command.t)
  (level : Tezos_protocol_environment_genesis__Environment.Int32.t)
  (timestamp : Tezos_protocol_environment_genesis__Environment.Time.t)
  (_fitness : A)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  match command with
  |
    Tezos_raw_protocol_genesis.Data.Command.Activate {|
      protocol := hash;
        fitness := fitness;
        protocol_parameters := protocol_parameters
        |} =>
    let message :=
      Some
        (Format.asprintf
          (Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Format
            (Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.String_literal
              "activate " % string
              (Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Alpha
                Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.End_of_format))
            "activate %a" % string)
          Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.pp_short)
          hash) in
    op_gtgteq (Context.set ctxt protocol_parameters_key protocol_parameters)
      (fun ctxt =>
        op_gtgteq (Updater.activate ctxt hash)
          (fun ctxt =>
            _return
              {| Updater.context := ctxt; Updater.fitness := fitness;
                Updater.message := message; Updater.max_operations_ttl := 0;
                Updater.last_allowed_fork_level := level |}))
  |
    Tezos_raw_protocol_genesis.Data.Command.Activate_testchain {|
      protocol := hash;
        fitness := fitness;
        protocol_parameters := protocol_parameters;
        delay := delay
        |} =>
    let message :=
      Some
        (Format.asprintf
          (Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Format
            (Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.String_literal
              "activate testchain " % string
              (Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.Alpha
                Tezos_protocol_environment_genesis__Environment.CamlinternalFormatBasics.End_of_format))
            "activate testchain %a" % string)
          Tezos_protocol_environment_genesis__Environment.Protocol_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.pp_short)
          hash) in
    op_gtgteq (Context.set ctxt protocol_parameters_key protocol_parameters)
      (fun ctxt =>
        let expiration := Time.add timestamp delay in
        op_gtgteq (Updater.fork_test_chain ctxt hash expiration)
          (fun ctxt =>
            _return
              {| Updater.context := ctxt; Updater.fitness := fitness;
                Updater.message := message; Updater.max_operations_ttl := 0;
                Updater.last_allowed_fork_level := level |}))
  end.

Definition begin_application {A B : Type}
  (chain_id :
    Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (function_parameter : A)
  : B ->
    block_header ->
      Tezos_protocol_environment_genesis__Environment.Lwt.t
        (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
          Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  let '_ := function_parameter in
  fun function_parameter =>
    let '_ := function_parameter in
    fun block_header =>
      op_gtgteqquestion (Data.Init.check_inited ctxt)
        (fun function_parameter =>
          let 'tt := function_parameter in
          op_gtgteqquestion (check_signature ctxt chain_id block_header)
            (fun function_parameter =>
              let 'tt := function_parameter in
              prepare_application ctxt (command (protocol_data block_header))
                (level (shell block_header)) (timestamp (shell block_header))
                (fitness (shell block_header)))).

Definition begin_partial_application {A B : Type}
  (chain_id :
    Tezos_protocol_environment_genesis__Environment.Chain_id.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
  (ancestor_context : Tezos_protocol_environment_genesis__Environment.Context.t)
  (predecessor_timestamp : A) (predecessor_fitness : B)
  (block_header : block_header)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  begin_application chain_id ancestor_context predecessor_timestamp
    predecessor_fitness block_header.

Definition begin_construction {A B C : Type} (function_parameter : A)
  : Tezos_protocol_environment_genesis__Environment.Context.t ->
    B ->
      Tezos_protocol_environment_genesis__Environment.Int32.t ->
        Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
          ->
          C ->
            Tezos_protocol_environment_genesis__Environment.Time.t ->
              (option block_header_data) ->
                unit ->
                  Tezos_protocol_environment_genesis__Environment.Lwt.t
                    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
                      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  let '_ := function_parameter in
  fun ctxt =>
    fun function_parameter =>
      let '_ := function_parameter in
      fun level =>
        fun fitness =>
          fun function_parameter =>
            let '_ := function_parameter in
            fun timestamp =>
              fun protocol_data =>
                fun function_parameter =>
                  let 'tt := function_parameter in
                  match protocol_data with
                  | None =>
                    _return
                      {| Updater.context := ctxt; Updater.fitness := fitness;
                        Updater.message := None;
                        Updater.max_operations_ttl := 0;
                        Updater.last_allowed_fork_level :=
                          (* ❌ Constant of type int32 is converted to int *)
                          0 |}
                  | Some {| command := command |} =>
                    op_gtgteqquestion (Data.Init.check_inited ctxt)
                      (fun function_parameter =>
                        let 'tt := function_parameter in
                        prepare_application ctxt command level timestamp fitness)
                  end.

Definition apply_operation {A B C : Type} (_vctxt : A) (function_parameter : B)
  : C :=
  let '_ := function_parameter in
  failwith "genesis.apply_operation" % string.

Definition finalize_block {A : Type} (state : A)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      (A * unit)) := _return (state, tt).

Definition rpc_services
  : Tezos_protocol_environment_genesis__Environment.RPC_directory.t
    Tezos_protocol_environment_genesis__Environment.Updater.rpc_context :=
  Services.rpc_services.

Definition sandbox_param_key : list string :=
  cons "sandbox_parameter" % string [].

Definition get_sandbox_param
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      (option Tezos_protocol_environment_genesis__Environment.Data_encoding.json)) :=
  op_gtgteq (Context.get ctxt sandbox_param_key)
    (fun function_parameter =>
      match function_parameter with
      | None => return_none
      | Some bytes =>
        match Data_encoding.Binary.of_bytes Data_encoding.json string with
        | None =>
          failwith
            "Internal error: failed to parse the sandbox parameter." % string
        | Some json => return_some json
        end
      end).

Definition init
  (ctxt : Tezos_protocol_environment_genesis__Environment.Context.t)
  (block_header :
    Tezos_protocol_environment_genesis__Environment.Block_header.shell_header)
  : Tezos_protocol_environment_genesis__Environment.Lwt.t
    (Tezos_protocol_environment_genesis__Environment.Error_monad.tzresult
      Tezos_protocol_environment_genesis__Environment.Updater.validation_result) :=
  op_gtgteqquestion (Data.Init.tag_first_block ctxt)
    (fun ctxt =>
      op_gtgteqquestion (get_sandbox_param ctxt)
        (fun sandbox_param =>
          op_gtgteqquestion
            match sandbox_param with
            | None => _return ctxt
            | Some json =>
              op_gtgteq (Data.Pubkey.may_change_default ctxt json)
                (fun ctxt => _return ctxt)
            end
            (fun ctxt =>
              _return
                {| Updater.context := ctxt;
                  Updater.fitness := Block_header.fitness block_header;
                  Updater.message := None; Updater.max_operations_ttl := 0;
                  Updater.last_allowed_fork_level := level block_header |}))).

src/proto_genesis/lib_protocol/services.ml 14 errors
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module Forge = struct
  let block custom_root =
    let open Data_encoding in
    RPC_service.post_service
      ~description: "Forge a block"
      ~query: RPC_query.empty
      ~input:
        (merge_objs
           (obj6
              (req "level" int32)
              (req "proto_level" uint8)
              (req "predecessor" Block_hash.encoding)
              (req "timestamp" Time.encoding)
              (req "fitness" Fitness.encoding)
              (req "context" Context_hash.encoding))
           Data.Command.encoding)
      ~output: (obj1 (req "payload" bytes))
      RPC_path.(custom_root / "helpers" / "forge" / "block")
end

let int64_to_bytes i =
  let b = MBytes.create 8 in
  MBytes.set_int64 b 0 i;
  b

let operations_hash =
  Operation_list_list_hash.compute []

let rpc_services : Updater.rpc_context RPC_directory.t =
  let dir = RPC_directory.empty in
  let dir =
    RPC_directory.register
      dir
      (Forge.block RPC_path.open_root)
      (fun _ctxt () ((level, proto_level, predecessor,
                      timestamp, fitness, context), command) ->
        let shell = { Block_header.level ; proto_level ; predecessor ;
                      timestamp ; fitness ; validation_passes = 0 ;
                      operations_hash ; context } in
        let bytes = Data.Command.forge shell command in
        return bytes) in
  dir
src/proto_genesis/lib_protocol/services.ml.v
Require Import OCaml.OCaml.

Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Module Forge.
  Definition block {A B : Type}
    (custom_root :
      Tezos_protocol_environment_genesis__Environment.RPC_path.path A B)
    : Tezos_protocol_environment_genesis__Environment.RPC_service.service
      variant A B unit
      ((int32 * Z *
        Tezos_protocol_environment_genesis__Environment.Block_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t)
        * Tezos_protocol_environment_genesis__Environment.Time.t *
        Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.t)
        *
        Tezos_protocol_environment_genesis__Environment.Context_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.t))
        * Tezos_raw_protocol_genesis.Data.Command.t)
      Tezos_protocol_environment_genesis__Environment.MBytes.t :=
    RPC_service.post_service (Some "Forge a block" % string) RPC_query.empty
      (merge_objs
        (obj6 (req None None "level" % string int32)
          (req None None "proto_level" % string uint8)
          (req None None "predecessor" % string
            Tezos_protocol_environment_genesis__Environment.Block_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding))
          (req None None "timestamp" % string Time.encoding)
          (req None None "fitness" % string
            Tezos_protocol_environment_genesis__Environment.Fitness.(Tezos_protocol_environment_genesis__Environment.T.S.encoding))
          (req None None "context" % string
            Tezos_protocol_environment_genesis__Environment.Context_hash.(Tezos_protocol_environment_genesis__Environment.HASH.S.encoding)))
        Data.Command.encoding) (obj1 (req None None "payload" % string bytes))
      (op_div (op_div (op_div custom_root "helpers" % string) "forge" % string)
        "block" % string).
End Forge.

Definition int64_to_bytes (i : int64)
  : Tezos_protocol_environment_genesis__Environment.MBytes.t :=
  let b := MBytes.create 8 in
  (* ❌ Sequences of instructions are not handled (operator ";") *)
  let _ := MBytes.set_int64 b 0 i in
  b.

Definition operations_hash
  : Tezos_protocol_environment_genesis__Environment.Operation_list_list_hash.(Tezos_protocol_environment_genesis__Environment.MERKLE_TREE.S.t) :=
  Tezos_protocol_environment_genesis__Environment.Operation_list_list_hash.(Tezos_protocol_environment_genesis__Environment.MERKLE_TREE.S.compute)
    [].

Definition rpc_services
  : Tezos_protocol_environment_genesis__Environment.RPC_directory.t
    Tezos_protocol_environment_genesis__Environment.Updater.rpc_context :=
  let dir := RPC_directory.empty in
  let dir :=
    RPC_directory.register dir (Forge.block RPC_path.open_root)
      (fun _ctxt =>
        fun function_parameter =>
          let 'tt := function_parameter in
          fun function_parameter =>
            let
              '((level, proto_level, predecessor, timestamp, fitness, context),
                command) := function_parameter in
            let shell :=
              {| Block_header.level := level;
                Block_header.proto_level := proto_level;
                Block_header.predecessor := predecessor;
                Block_header.timestamp := timestamp;
                Block_header.validation_passes := 0;
                Block_header.operations_hash := operations_hash;
                Block_header.fitness := fitness; Block_header.context := context
                |} in
            let bytes := Data.Command.forge shell command in
            _return string) in
  dir.